Commit c11d612e authored by houyun's avatar houyun
Browse files

guide_child

parent 708bf08a

NAMESPACE

+15 −0
Original line number Diff line number Diff line
@@ -38,6 +38,9 @@ S3method(ggplot_add,geom_panel_grid) 
S3method(ggplot_add,magic_text)

S3method(ggplot_add,secondary_axis)

S3method(ggplot_build,gggplot)

S3method(guide_gengrob,guide_child)

S3method(guide_train,guide_child)

S3method(guide_transform,guide_child)

S3method(length,marker)

S3method(makeContent,markerGrob)

S3method(marker,"magick-image")
@@ -112,6 +115,7 @@ export(geom_shaping) 
export(geom_square)

export(get_order)

export(grid.doughnut)

export(guide_axis_child)

export(hyplot)

export(is_grouped_matrix_data)

export(is_matrix_data)
@@ -182,6 +186,9 @@ importFrom(ggplot2,ggplotGrob) 
importFrom(ggplot2,ggplot_add)

importFrom(ggplot2,ggplot_build)

importFrom(ggplot2,ggproto)

importFrom(ggplot2,guide_gengrob)

importFrom(ggplot2,guide_train)

importFrom(ggplot2,guide_transform)

importFrom(ggplot2,guides)

importFrom(ggplot2,is.ggplot)

importFrom(ggplot2,layer)
@@ -194,25 +201,32 @@ importFrom(grDevices,dev.cur) 
importFrom(grDevices,dev.off)

importFrom(grDevices,dev.set)

importFrom(grDevices,dev.size)

importFrom(grid,gList)

importFrom(grid,gTree)

importFrom(grid,get.gpar)

importFrom(grid,gpar)

importFrom(grid,grid.draw)

importFrom(grid,grobHeight)

importFrom(grid,grobTree)

importFrom(grid,grobWidth)

importFrom(grid,is.grob)

importFrom(grid,is.unit)

importFrom(grid,makeContent)

importFrom(grid,polygonGrob)

importFrom(grid,rasterGrob)

importFrom(grid,unit)

importFrom(grid,unit.c)

importFrom(grid,viewport)

importFrom(gtable,gtable)

importFrom(gtable,gtable_add_col_space)

importFrom(gtable,gtable_add_cols)

importFrom(gtable,gtable_add_grob)

importFrom(gtable,gtable_add_row_space)

importFrom(gtable,gtable_add_rows)

importFrom(gtable,gtable_col)

importFrom(gtable,gtable_height)

importFrom(gtable,gtable_row)

importFrom(gtable,gtable_width)

importFrom(igraph,V)

importFrom(igraph,as.igraph)

importFrom(igraph,graph_from_data_frame)
@@ -223,6 +237,7 @@ importFrom(purrr,map_dbl) 
importFrom(purrr,pmap)

importFrom(purrr,pmap_dfr)

importFrom(purrr,walk2)

importFrom(rlang,":=")

importFrom(rlang,eval_tidy)

importFrom(rlang,set_names)

importFrom(scales,alpha)

R/experimental-fun.R

+258 −0
Original line number Diff line number Diff line 
## STOLEN: ggh4x::guide_dendro

#' @title Children axis guide

#' @description This function can be used to add children axis on a ggplot.

#' @inheritParams ggplot2::guide_axis

#' @param child a tibble of child axis information, see examples.

#' @param only_child if TRUE, will remove main axis elements.

#' @param child_size size of child axis label.

#' @rdname axis_child

#' @export

guide_axis_child <- function(title = waiver(),

                             check.overlap = FALSE,

                             angle = NULL,

                             n.dodge = 1,

                             order = 0,

                             position = waiver(),

                             child = NULL,

                             only_child = FALSE,

                             child_size = 7) {



  structure(

    list(title = title,

         check.overlap = check.overlap,

         angle = angle,

         n.dodge = n.dodge,

         order = order,

         position = position,

         child = child,

         only_child = only_child,

         child_size = child_size,

         available_aes = c("x", "y"),

         name = "axis"),

    class = c("guide", "guide_child", "axis")

  )

}



#' @method guide_train guide_child

#' @importFrom ggplot2 guide_train

#' @export

guide_train.guide_child <- function(guide, scale, aesthetic = NULL) {

  guide <- NextMethod()

  if (empty(guide$child)) {

    return(guide)

  }

  if (scale$is_discrete()) {

    id <- guide$child$label %in% guide$key$.label & (!duplicated(guide$child$label))

    guide$child <- guide$child[id, , drop = FALSE]

    guide$is_discrete <- TRUE

  } else {

    guide$is_discrete <- FALSE

  }

  guide

}



#' @method guide_transform guide_child

#' @importFrom ggplot2 guide_transform

#' @importFrom rlang :=

#' @importFrom grid unit.c gList

#' @importFrom gtable gtable gtable_height gtable_width

#' @export

guide_transform.guide_child <- function(guide, coord, panel_params) {

  if (is.null(guide$position) || nrow(guide$key) == 0) {

    return(guide)

  }

  key <- guide$key

  child <- guide$child

  aesthetics <- names(guide$key)[!grepl("^\\.", names(guide$key))]

  other_aesthetic <- setdiff(c("x", "y"), aesthetics)

  override_value <- if (guide$position %in% c("bottom", "left")) -Inf else Inf

  guide$key[[other_aesthetic]] <- override_value

  guide$key <- coord$transform(guide$key, panel_params)



  if (empty(child)) {

    return(guide)

  }



  ch <- tibble(!!aesthetics := numeric(0),

               .value = character(0),

               .label = character(0))



  if (isTRUE(guide$is_discrete)) {

    key[[aesthetics]] <- unclass(key[[aesthetics]])

    id <- match(child$label, key$.label)

    child[[aesthetics]] <- key[[aesthetics]][id]



    for (row in split(child, seq_len(nrow(child)))) {

      limits <- unlist(row$limits)

      breaks <- unlist(row$breaks)

      if (is.factor(breaks)) {

        breaks <- levels(breaks)

      }

      if (is.character(breaks)) {

        labels <- breaks

        breaks <- seq_along(breaks)

      } else {

        if (all(is.na(breaks))) {

          breaks <- pretty_in_range(limits)

        }

        labels <- breaks

      }



      pos <- scales::rescale(breaks, c(-0.5, 0.5), limits)

      ch <- dplyr::bind_rows(ch, tibble(!!aesthetics := pos + row[[aesthetics]],

                                        .value = labels,

                                        .label = labels))

    }

  } else {

    MIN <- if (aesthetics == "x") panel_params$x.range[1] else panel_params$y.range[1]

    MAX <- if (aesthetics == "x") panel_params$x.range[2] else panel_params$y.range[2]

    child$from <- ifelse(child$from < MIN, MIN, child$from)

    child$to <- ifelse(child$to > MAX, MAX, child$to)

    child <- child[child$from < child$to, , drop = FALSE]

    if (empty(child)) {

      return(guide)

    }



    for (row in split(child, seq_len(nrow(child)))) {

      limits <- unlist(row$limits)

      breaks <- unlist(row$breaks)

      if (is.factor(breaks)) {

        breaks <- levels(breaks)

      }

      if (is.character(breaks)) {

        labels <- breaks

        breaks <- seq_along(breaks)

      } else {

        if (all(is.na(breaks))) {

          breaks <- pretty_in_range(limits)

        }

        labels <- breaks

      }



      pos <- scales::rescale(breaks, c(row$from, row$to), limits)

      ch <- dplyr::bind_rows(ch, tibble(!!aesthetics := pos,

                                        .value = breaks,

                                        .label = labels))

    }

  }

  ch[[other_aesthetic]] <- override_value

  guide$child <- coord$transform(ch, panel_params)

  guide

}



#' @noRd

pretty_in_range <- function(x) {

  rng <- range(x, na.rm = TRUE)

  x <- pretty(x)

  x[x > rng[1] & x < rng[2]]

}



#' @method guide_gengrob guide_child

#' @importFrom ggplot2 guide_gengrob

#' @export

guide_gengrob.guide_child <- function(guide, theme) {

  if (empty(guide$child)) {

    guide <- NextMethod()

    return(guide)

  }



  draw_axis <- utils::getFromNamespace("draw_axis", "ggplot2")

  axis_position <- match.arg(guide$position, c("top", "bottom", "right", "left"))

  aesthetic <- if (axis_position %in% c("bottom", "top")) "x" else "y"



  ## child theme not equal theme

  child_theme <- theme

  line_element_name <- paste0("axis.line.", aesthetic, ".", axis_position)

  tick_element_name <- paste0("axis.ticks.", aesthetic, ".", axis_position)

  label_element_name <- paste0("axis.text.", aesthetic, ".", axis_position)



  child_label_element <- ggplot2::calc_element(label_element_name, child_theme)

  child_label_element <- child_label_element %||% ggplot2::element_text()

  child_label_element$size <- guide$child_size

  child_theme[[label_element_name]] <- child_label_element

  child_grobs <- draw_axis(break_positions = guide$child[[aesthetic]],

                           break_labels = guide$child$.label,

                           axis_position = guide$position,

                           theme = child_theme,

                           check.overlap = guide$check.overlap,

                           angle = guide$angle,

                           n.dodge = guide$n.dodge)

  if (isTRUE(guide$only_child)) {

    return(child_grobs)

  }



  theme[[tick_element_name]] <- ggplot2::element_blank()

  theme[[line_element_name]] <- ggplot2::element_blank()

  main_grobs <- draw_axis(break_positions = guide$key[[aesthetic]],

                          break_labels = guide$key$.label,

                          axis_position = guide$position,

                          theme = theme,

                          check.overlap = guide$check.overlap,

                          angle = guide$angle,

                          n.dodge = guide$n.dodge)





  ## unit main and child axis

  if (axis_position %in% c("left", "right")) {

    width <- if (axis_position == "left") {

      unit.c(grobWidth(main_grobs), grobWidth(child_grobs))

    } else {

      unit.c(grobWidth(child_grobs), grobWidth(main_grobs))

    }

    height <- unit(1, "null")

    gt <- gtable(widths = width, heights = height)

    if (axis_position == "left") {

      gt <- gtable_add_grob(gt, grobs = list(main_grobs, child_grobs),

                            t = c(1, 1), l = c(1, 2))

    } else {

      gt <- gtable_add_grob(gt, grobs = list(main_grobs, child_grobs),

                            t = c(1, 1), l = c(2, 1))

    }

  } else {

    height <- if (axis_position == "top") {

      unit.c(grobHeight(main_grobs), grobHeight(child_grobs))

    } else {

      unit.c(grobHeight(child_grobs), grobHeight(main_grobs))

    }

    width <- unit(1, "null")

    gt <- gtable(widths = width, heights = height)

    if (axis_position == "top") {

      gt <- gtable_add_grob(gt, grobs = list(main_grobs, child_grobs),

                            t = c(1, 2), l = c(1, 1))

    } else {

      gt <- gtable_add_grob(gt, grobs = list(main_grobs, child_grobs),

                            t = c(2, 1), l = c(1, 1))

    }

  }

  gTree(children = gList(gt), width = gtable_width(gt), height = gtable_height(gt),

        cl = "absoluteGrob")

}



#' @importFrom grid grobHeight

#' @noRd

grobHeight.absoluteGrob <- function(x) {

  grobs <- x$children

  hl <- lapply(grobs, function(g) {

    if (inherits(g, "gtable")) {

      gtable::gtable_height(g)

    } else {

      grid::grobHeight(g)

    }

  })

  Reduce("sum", hl)

}



#' @importFrom grid grobWidth

#' @noRd

grobWidth.absoluteGrob <- function(x) {

  grobs <- x$children

  wl <- lapply(grobs, function(g) {

    if (inherits(g, "gtable")) {

      gtable::gtable_width(g)

    } else {

      grid::grobWidth(g)

    }

  })

  Reduce("sum", wl)

}



#' @title Draw ggplot on ggplot

#' @description This function convert a ggplot object to marker, and then draw it

#' on plot.

man/axis_child.Rd

0 → 100644
+50 −0
Original line number Diff line number Diff line 
% Generated by roxygen2: do not edit by hand

% Please edit documentation in R/experimental-fun.R

\name{guide_axis_child}

\alias{guide_axis_child}

\title{Children axis guide}

\usage{

guide_axis_child(

  title = waiver(),

  check.overlap = FALSE,

  angle = NULL,

  n.dodge = 1,

  order = 0,

  position = waiver(),

  child = NULL,

  only_child = FALSE,

  child_size = 7

)

}

\arguments{

\item{title}{A character string or expression indicating a title of guide.

If \code{NULL}, the title is not shown. By default

(\code{\link[ggplot2:waiver]{waiver()}}), the name of the scale object or the name

specified in \code{\link[ggplot2:labs]{labs()}} is used for the title.}



\item{check.overlap}{silently remove overlapping labels,

(recursively) prioritizing the first, last, and middle labels.}



\item{angle}{Compared to setting the angle in \code{\link[ggplot2:theme]{theme()}} / \code{\link[ggplot2:element]{element_text()}},

this also uses some heuristics to automatically pick the \code{hjust} and \code{vjust} that

you probably want.}



\item{n.dodge}{The number of rows (for vertical axes) or columns (for

horizontal axes) that should be used to render the labels. This is

useful for displaying labels that would otherwise overlap.}



\item{order}{Used to determine the order of the guides (left-to-right,

top-to-bottom), if more than one  guide must be drawn at the same location.}



\item{position}{Where this guide should be drawn: one of top, bottom,

left, or right.}



\item{child}{a tibble of child axis information, see examples.}



\item{only_child}{if TRUE, will remove main axis elements.}



\item{child_size}{size of child axis label.}

}

\description{

This function can be used to add children axis on a ggplot.

}

CRA Git | Maintained and supported by SUSTech CRA and CCSE