Rewrite guide_axis() and rename to draw_axis() (#3349)

paleolimbot · web-flow · commit 0f929a12e96c · 2019-06-04T15:26:26.000-05:00
diff --git a/R/coord-.r b/R/coord-.r
@@ -158,9 +158,9 @@ expand_default <- function(scale, discrete = c(0, 0.6, 0, 0.6), continuous = c(0
 # generated
 render_axis <- function(panel_params, axis, scale, position, theme) {
   if (axis == "primary") {
-    guide_axis(panel_params[[paste0(scale, ".major")]], panel_params[[paste0(scale, ".labels")]], position, theme)
+    draw_axis(panel_params[[paste0(scale, ".major")]], panel_params[[paste0(scale, ".labels")]], position, theme)
   } else if (axis == "secondary" && !is.null(panel_params[[paste0(scale, ".sec.major")]])) {
-    guide_axis(panel_params[[paste0(scale, ".sec.major")]], panel_params[[paste0(scale, ".sec.labels")]], position, theme)
+    draw_axis(panel_params[[paste0(scale, ".sec.major")]], panel_params[[paste0(scale, ".sec.labels")]], position, theme)
   } else {
     zeroGrob()
   }
diff --git a/R/coord-map.r b/R/coord-map.r
@@ -308,8 +308,8 @@ CoordMap <- ggproto("CoordMap", Coord,
     pos <- self$transform(x_intercept, panel_params)
 
     axes <- list(
-      top = guide_axis(pos$x, panel_params$x.labels, "top", theme),
-      bottom = guide_axis(pos$x, panel_params$x.labels, "bottom", theme)
+      top = draw_axis(pos$x, panel_params$x.labels, "top", theme),
+      bottom = draw_axis(pos$x, panel_params$x.labels, "bottom", theme)
     )
     axes[[which(arrange == "secondary")]] <- zeroGrob()
     axes
@@ -332,8 +332,8 @@ CoordMap <- ggproto("CoordMap", Coord,
     pos <- self$transform(x_intercept, panel_params)
 
     axes <- list(
-      left = guide_axis(pos$y, panel_params$y.labels, "left", theme),
-      right = guide_axis(pos$y, panel_params$y.labels, "right", theme)
+      left = draw_axis(pos$y, panel_params$y.labels, "left", theme),
+      right = draw_axis(pos$y, panel_params$y.labels, "right", theme)
     )
     axes[[which(arrange == "secondary")]] <- zeroGrob()
     axes
diff --git a/R/coord-polar.r b/R/coord-polar.r
@@ -190,7 +190,7 @@ CoordPolar <- ggproto("CoordPolar", Coord,
   render_axis_h = function(panel_params, theme) {
     list(
       top = zeroGrob(),
-      bottom = guide_axis(NA, "", "bottom", theme)
+      bottom = draw_axis(NA, "", "bottom", theme)
     )
   },
 
diff --git a/R/coord-sf.R b/R/coord-sf.R
@@ -243,10 +243,10 @@ CoordSf <- ggproto("CoordSf", CoordCartesian,
     tick_labels <- c(ticks1$degree_label, ticks2$degree_label)
 
     if (length(tick_positions) > 0) {
-      top <- guide_axis(
+      top <- draw_axis(
         tick_positions,
         tick_labels,
-        position = "top",
+        axis_position = "top",
         theme = theme
       )
     } else {
@@ -279,10 +279,10 @@ CoordSf <- ggproto("CoordSf", CoordCartesian,
     tick_labels <- c(ticks1$degree_label, ticks2$degree_label)
 
     if (length(tick_positions) > 0) {
-      bottom <- guide_axis(
+      bottom <- draw_axis(
         tick_positions,
         tick_labels,
-        position = "bottom",
+        axis_position = "bottom",
         theme = theme
       )
     } else {
@@ -321,10 +321,10 @@ CoordSf <- ggproto("CoordSf", CoordCartesian,
     tick_labels <- c(ticks1$degree_label, ticks2$degree_label)
 
     if (length(tick_positions) > 0) {
-      right <- guide_axis(
+      right <- draw_axis(
         tick_positions,
         tick_labels,
-        position = "right",
+        axis_position = "right",
         theme = theme
       )
     } else {
@@ -357,10 +357,10 @@ CoordSf <- ggproto("CoordSf", CoordCartesian,
     tick_labels <- c(ticks1$degree_label, ticks2$degree_label)
 
     if (length(tick_positions) > 0) {
-      left <- guide_axis(
+      left <- draw_axis(
         tick_positions,
         tick_labels,
-        position = "left",
+        axis_position = "left",
         theme = theme
       )
     } else {
diff --git a/R/guides-axis.r b/R/guides-axis.r
@@ -1,146 +1,115 @@
-# Grob for axes
-#
-# @param position of ticks
-# @param labels at ticks
-# @param position of axis (top, bottom, left or right)
-# @param range of data values
-guide_axis <- function(at, labels, position = "right", theme) {
-  line <- switch(position,
-    top =    element_render(theme, "axis.line.x.top", c(0, 1), c(0, 0), id.lengths = 2),
-    bottom = element_render(theme, "axis.line.x.bottom", c(0, 1), c(1, 1), id.lengths = 2),
-    right =  element_render(theme, "axis.line.y.right", c(0, 0), c(0, 1), id.lengths = 2),
-    left =   element_render(theme, "axis.line.y.left", c(1, 1), c(0, 1), id.lengths = 2)
-  )
-  position <- match.arg(position, c("top", "bottom", "right", "left"))
-
-  zero <- unit(0, "npc")
-  one <- unit(1, "npc")
-
-  if (length(at) == 0) {
-    vertical <- position %in% c("left", "right")
-    return(absoluteGrob(
-      gList(line),
-      width = if (vertical) zero else one,
-      height = if (vertical) one else zero
-    ))
-  }
 
-  at <- unit(at, "native")
+#' Grob for axes
+#'
+#' @param break_position position of ticks
+#' @param break_labels labels at ticks
+#' @param axis_position position of axis (top, bottom, left or right)
+#' @param theme A [theme()] object
+#'
+#' @noRd
+#'
+draw_axis <- function(break_positions, break_labels, axis_position, theme) {
 
-  theme$axis.ticks.length.x.bottom <- with(
-    theme,
-    axis.ticks.length.x.bottom %||%
-      axis.ticks.length.x %||%
-      axis.ticks.length
-  )
-  theme$axis.ticks.length.x.top <- with(
-    theme,
-    axis.ticks.length.x.top %||%
-      axis.ticks.length.x %||%
-      axis.ticks.length
-  )
-  theme$axis.ticks.length.y.left <- with(
-    theme,
-    axis.ticks.length.y.left %||%
-      axis.ticks.length.y %||%
-      axis.ticks.length
-  )
-  theme$axis.ticks.length.y.right <- with(
-    theme,
-    axis.ticks.length.y.right %||%
-      axis.ticks.length.y %||%
-      axis.ticks.length
-  )
+  axis_position <- match.arg(axis_position, c("top", "bottom", "right", "left"))
+  aesthetic <- if (axis_position %in% c("top", "bottom")) "x" else "y"
 
-  label_render <- switch(position,
-    top = "axis.text.x.top", bottom = "axis.text.x.bottom",
-    left = "axis.text.y.left", right = "axis.text.y.right"
-  )
+  # resolve elements
+  line_element_name <- paste0("axis.line.", aesthetic, ".", axis_position)
+  tick_element_name <- paste0("axis.ticks.", aesthetic, ".", axis_position)
+  tick_length_element_name <- paste0("axis.ticks.length.", aesthetic, ".", axis_position)
+  label_element_name <- paste0("axis.text.", aesthetic, ".", axis_position)
 
-  label_x <- switch(position,
-    top = ,
-    bottom = at,
-    right = theme$axis.ticks.length.y.right,
-    left = one - theme$axis.ticks.length.y.left
-  )
-  label_y <- switch(position,
-    top = theme$axis.ticks.length.x.top,
-    bottom = one - theme$axis.ticks.length.x.bottom,
-    right = ,
-    left = at
+  line_element <- calc_element(line_element_name, theme)
+  tick_element <- calc_element(tick_element_name, theme)
+  tick_length <- calc_element(tick_length_element_name, theme)
+  label_element <- calc_element(label_element_name, theme)
+
+  # conditionally set parameters that depend on axis orientation
+  is_vertical <- axis_position %in% c("left",  "right")
+
+  position_dim <- if (is_vertical) "y" else "x"
+  non_position_dim <- if (is_vertical) "x" else "y"
+  position_size <- if (is_vertical) "height" else "width"
+  non_position_size <- if (is_vertical) "width" else "height"
+  label_margin_name <- if (is_vertical) "margin_x" else "margin_y"
+  gtable_element <- if (is_vertical) gtable_row else gtable_col
+  measure_gtable <- if (is_vertical) gtable_width else gtable_height
+  measure_labels <- if (is_vertical) grobWidth else grobHeight
+
+  # conditionally set parameters that depend on which side of the panel
+  # the axis is on
+  is_second <- axis_position %in% c("right", "top")
+
+  tick_direction <- if (is_second) 1 else -1
+  non_position_panel <- if (is_second) unit(0, "npc") else unit(1, "npc")
+  tick_coordinate_order <- if (is_second) c(2, 1) else c(1, 2)
+
+  # conditionally set the gtable ordering
+  labels_first_gtable <- axis_position %in% c("left", "top") # refers to position in gtable
+
+  table_order <- if (labels_first_gtable) c("labels", "ticks") else c("ticks", "labels")
+
+  # set common parameters
+  n_breaks <- length(break_positions)
+  opposite_positions <- c("top" = "bottom", "bottom" = "top", "right" = "left", "left" = "right")
+  axis_position_opposite <- unname(opposite_positions[axis_position])
+
+  # draw elements
+  line_grob <- exec(
+    element_grob, line_element,
+    !!position_dim := unit(c(0, 1), "npc"),
+    !!non_position_dim := unit.c(non_position_panel, non_position_panel)
   )
 
-  if (is.list(labels)) {
-    if (any(sapply(labels, is.language))) {
-      labels <- do.call(expression, labels)
-    } else {
-      labels <- unlist(labels)
-    }
+  if (n_breaks == 0) {
+    return(
+      absoluteGrob(
+        gList(line_grob),
+        width = grobWidth(line_grob),
+        height = grobHeight(line_grob)
+      )
+    )
   }
 
-  labels <- switch(position,
-    top = ,
-    bottom = element_render(theme, label_render, labels, x = label_x, margin_y = TRUE),
-    right = ,
-    left =  element_render(theme, label_render, labels, y = label_y, margin_x = TRUE))
-
-
-
-  nticks <- length(at)
-
-  ticks <- switch(position,
-    top = element_render(theme, "axis.ticks.x.top",
-      x          = rep(at, each = 2),
-      y          = rep(unit.c(zero, theme$axis.ticks.length.x.top), nticks),
-      id.lengths = rep(2, nticks)),
-    bottom = element_render(theme, "axis.ticks.x.bottom",
-      x          = rep(at, each = 2),
-      y          = rep(unit.c(one - theme$axis.ticks.length.x.bottom, one), nticks),
-      id.lengths = rep(2, nticks)),
-    right = element_render(theme, "axis.ticks.y.right",
-      x          = rep(unit.c(zero, theme$axis.ticks.length.y.right), nticks),
-      y          = rep(at, each = 2),
-      id.lengths = rep(2, nticks)),
-    left = element_render(theme, "axis.ticks.y.left",
-      x          = rep(unit.c(one - theme$axis.ticks.length.y.left, one), nticks),
-      y          = rep(at, each = 2),
-      id.lengths = rep(2, nticks))
+  labels_grob <- exec(
+    element_grob, label_element,
+    !!position_dim := unit(break_positions, "native"),
+    !!label_margin_name := TRUE,
+    label = break_labels
   )
 
-  # Create the gtable for the ticks + labels
-  gt <- switch(position,
-    top    = gtable_col("axis",
-      grobs   = list(labels, ticks),
-      width   = one,
-      heights = unit.c(grobHeight(labels), theme$axis.ticks.length.x.top)
-    ),
-    bottom = gtable_col("axis",
-      grobs   = list(ticks, labels),
-      width   = one,
-      heights = unit.c(theme$axis.ticks.length.x.bottom, grobHeight(labels))
+  ticks_grob <- exec(
+    element_grob, tick_element,
+    !!position_dim := rep(unit(break_positions, "native"), each = 2),
+    !!non_position_dim := rep(
+      unit.c(non_position_panel + (tick_direction * tick_length), non_position_panel)[tick_coordinate_order],
+      times = n_breaks
     ),
-    right  = gtable_row("axis",
-      grobs   = list(ticks, labels),
-      widths  = unit.c(theme$axis.ticks.length.y.right, grobWidth(labels)),
-      height  = one
-    ),
-    left   = gtable_row("axis",
-      grobs   = list(labels, ticks),
-      widths  = unit.c(grobWidth(labels), theme$axis.ticks.length.y.left),
-      height  = one
-    )
+    id.lengths = rep(2, times = n_breaks)
+  )
+
+  # create gtable
+  table_order_int <- match(table_order, c("labels", "ticks"))
+  non_position_sizes <- paste0(non_position_size, "s")
+
+  gt <- exec(
+    gtable_element,
+    name = "axis",
+    grobs = list(labels_grob, ticks_grob)[table_order_int],
+    !!non_position_sizes := unit.c(measure_labels(labels_grob), tick_length)[table_order_int],
+    !!position_size := unit(1, "npc")
   )
 
-  # Viewport for justifying the axis grob
-  justvp <- switch(position,
-    top    = viewport(y = 0, just = "bottom", height = gtable_height(gt)),
-    bottom = viewport(y = 1, just = "top",    height = gtable_height(gt)),
-    right  = viewport(x = 0, just = "left",   width  = gtable_width(gt)),
-    left   = viewport(x = 1, just = "right",  width  = gtable_width(gt))
+  # create viewport
+  justvp <- exec(
+    viewport,
+    !!non_position_dim := non_position_panel,
+    !!non_position_size := measure_gtable(gt),
+    just = axis_position_opposite
   )
 
   absoluteGrob(
-    gList(line, gt),
+    gList(line_grob, gt),
     width = gtable_width(gt),
     height = gtable_height(gt),
     vp = justvp
diff --git a/R/theme.r b/R/theme.r
@@ -612,21 +612,38 @@ merge_element.element <- function(new, old) {
   new
 }
 
-# Combine the properties of two elements
-#
-# @param e1 An element object
-# @param e2 An element object which e1 inherits from
+#' Combine the properties of two elements
+#'
+#' @param e1 An element object
+#' @param e2 An element object from which e1 inherits
+#'
+#' @noRd
+#'
 combine_elements <- function(e1, e2) {
 
   # If e2 is NULL, nothing to inherit
-  if (is.null(e2) || inherits(e1, "element_blank"))  return(e1)
+  if (is.null(e2) || inherits(e1, "element_blank")) {
+    return(e1)
+  }
+
   # If e1 is NULL inherit everything from e2
-  if (is.null(e1)) return(e2)
+  if (is.null(e1)) {
+    return(e2)
+  }
+
+  # If neither of e1 or e2 are element_* objects, return e1
+  if (!inherits(e1, "element") && !inherits(e2, "element")) {
+    return(e1)
+  }
+
   # If e2 is element_blank, and e1 inherits blank inherit everything from e2,
   # otherwise ignore e2
   if (inherits(e2, "element_blank")) {
-    if (e1$inherit.blank) return(e2)
-    else return(e1)
+    if (e1$inherit.blank) {
+      return(e2)
+    } else {
+      return(e1)
+    }
   }
 
   # If e1 has any NULL properties, inherit them from e2
diff --git a/tests/testthat/test-theme.r b/tests/testthat/test-theme.r
@@ -213,6 +213,12 @@ test_that("elements can be merged", {
   )
 })
 
+test_that("theme elements that don't inherit from element can be combined", {
+  expect_identical(combine_elements(1, NULL), 1)
+  expect_identical(combine_elements(NULL, 1), 1)
+  expect_identical(combine_elements(1, 0), 1)
+})
+
 test_that("complete plot themes shouldn't inherit from default", {
   default_theme <- theme_gray() + theme(axis.text.x = element_text(colour = "red"))
   base <- qplot(1, 1)

Original file line number	Diff line number	Diff line change
`@@ -190,7 +190,7 @@ CoordPolar <- ggproto("CoordPolar", Coord,`
`190`	`190`	`render_axis_h = function(panel_params, theme) {`
`191`	`191`	`list(`
`192`	`192`	`top = zeroGrob(),`
`193`		`- bottom = guide_axis(NA, "", "bottom", theme)`
	`193`	`+ bottom = draw_axis(NA, "", "bottom", theme)`
`194`	`194`	`)`
`195`	`195`	`},`
`196`	`196`