Commit 80339ad4 authored by houyun's avatar houyun
Browse files

clean: mv axis function to a separate file

parent 16d1bd9b

R/axis.R

+248 −0
Original line number Diff line number Diff line
@@ -65,3 +65,251 @@ ggplot_add.secondary_axis <- function(object, plot, object_name) { 
  ggplot_add(object, plot, object_name)

}



## 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 theme a ggplot theme object for child axis.

#' @rdname axis_child

#' @author Hou Yun

#' @export

guide_axis_child <- function(title = waiver(),

                             check.overlap = FALSE,

                             angle = NULL,

                             n.dodge = 1,

                             order = 0,

                             position = waiver(),

                             child = NULL,

                             only_child = FALSE,

                             theme = NULL) {



  structure(

    list(title = title,

         check.overlap = check.overlap,

         angle = angle,

         n.dodge = n.dodge,

         order = order,

         position = position,

         child = child,

         only_child = only_child,

         theme = theme,

         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 = as.character(labels),

                                        .label = as.character(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

## TODO: clean and remove unused code

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 + guide$theme

  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)

  }

  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), grid::unit(2, "mm"), grobWidth(child_grobs))

    } else {

      unit.c(grobWidth(child_grobs), grid::unit(2, "mm"), 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, 3))

    } else {

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

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

    }

  } else {

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

      unit.c(grobHeight(main_grobs), grid::unit(2, "mm"), grobHeight(child_grobs))

    } else {

      unit.c(grobHeight(child_grobs), grid::unit(2, "mm"), 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, 3), l = c(1, 1))

    } else {

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

                            t = c(3, 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)

}

R/experimental-fun.R

+0 −248
Original line number Diff line number Diff line
@@ -594,254 +594,6 @@ is_binary <- function(x) { 
  is.factor(x) || is.character(x) || is.logical(x)

}



## 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 theme a ggplot theme object for child axis.

#' @rdname axis_child

#' @author Hou Yun

#' @export

guide_axis_child <- function(title = waiver(),

                             check.overlap = FALSE,

                             angle = NULL,

                             n.dodge = 1,

                             order = 0,

                             position = waiver(),

                             child = NULL,

                             only_child = FALSE,

                             theme = NULL) {



  structure(

    list(title = title,

         check.overlap = check.overlap,

         angle = angle,

         n.dodge = n.dodge,

         order = order,

         position = position,

         child = child,

         only_child = only_child,

         theme = theme,

         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 = as.character(labels),

                                        .label = as.character(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 + guide$theme

  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)

  }

  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), grid::unit(2, "mm"), grobWidth(child_grobs))

    } else {

      unit.c(grobWidth(child_grobs), grid::unit(2, "mm"), 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, 3))

    } else {

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

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

    }

  } else {

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

      unit.c(grobHeight(main_grobs), grid::unit(2, "mm"), grobHeight(child_grobs))

    } else {

      unit.c(grobHeight(child_grobs), grid::unit(2, "mm"), 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, 3), l = c(1, 1))

    } else {

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

                            t = c(3, 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

+1 −1
Original line number Diff line number Diff line 
% Generated by roxygen2: do not edit by hand

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

% Please edit documentation in R/axis.R

\name{guide_axis_child}

\alias{guide_axis_child}

\title{Children axis guide}

CRA Git | Maintained and supported by SUSTech CRA and CCSE