diff --git a/R/coord-.r b/R/coord-.r index 47e0f0175c..d29bd420e7 100644 --- 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 index d28f7c9711..ce2bf0889f 100644 --- 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 index d200759886..85c0668e9c 100644 --- 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 index 056510733a..20b0d35b79 100644 --- 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 index c1aae75693..ba2b98f507 100644 --- 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 index f9d461f1da..2fa96b4c8a 100644 --- 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 index 68fb73b0bd..32a77f3f80 100644 --- 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)