diff --git a/NEWS.md b/NEWS.md index 793a9dd82f..084f0b0a66 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,7 @@ # ggplot2 (development version) +* Improve the support for `guide_axis()` on `coord_trans()` (@yutannihilation, #3959) + * `geom_density()` and `stat_density()` now support `bounds` argument to estimate density with boundary correction (@echasnovski, #4013). diff --git a/R/coord-.r b/R/coord-.r index 9c46e8a549..6cd2c5fc0c 100644 --- a/R/coord-.r +++ b/R/coord-.r @@ -59,7 +59,33 @@ Coord <- ggproto("Coord", aspect = function(ranges) NULL, - labels = function(labels, panel_params) labels, + labels = function(self, labels, panel_params) { + # If panel params contains guides information, use it. + # Otherwise use the labels as is, for backward-compatibility + if (is.null(panel_params$guide)) { + return(labels) + } + + positions_x <- c("top", "bottom") + positions_y <- c("left", "right") + + list( + x = lapply(c(1, 2), function(i) { + panel_guide_label( + panel_params$guides, + position = positions_x[[i]], + default_label = labels$x[[i]] + ) + }), + y = lapply(c(1, 2), function(i) { + panel_guide_label( + panel_params$guides, + position = positions_y[[i]], + default_label = labels$y[[i]] + ) + }) + ) + }, render_fg = function(panel_params, theme) element_render(theme, "panel.border"), @@ -92,10 +118,59 @@ Coord <- ggproto("Coord", }, setup_panel_guides = function(self, panel_params, guides, params = list()) { + aesthetics <- c("x", "y", "x.sec", "y.sec") + names(aesthetics) <- aesthetics + + # If the panel_params doesn't contain the scale, do not use a guide for that aesthetic + idx <- vapply(aesthetics, function(aesthetic) { + scale <- panel_params[[aesthetic]] + !is.null(scale) && inherits(scale, "ViewScale") + }, logical(1L)) + aesthetics <- aesthetics[idx] + + # resolve the specified guide from the scale and/or guides + guides <- lapply(aesthetics, function(aesthetic) { + resolve_guide( + aesthetic, + panel_params[[aesthetic]], + guides, + default = guide_axis(), + null = guide_none() + ) + }) + + # resolve the guide definition as a "guide" S3 + guides <- lapply(guides, validate_guide) + + # if there is a "position" specification in the scale, pass this on to the guide + # ideally, this should be specified in the guide + guides <- lapply(aesthetics, function(aesthetic) { + guide <- guides[[aesthetic]] + scale <- panel_params[[aesthetic]] + # position could be NULL here for an empty scale + guide$position <- guide$position %|W|% scale$position + guide + }) + + panel_params$guides <- guides panel_params }, train_panel_guides = function(self, panel_params, layers, default_mapping, params = list()) { + aesthetics <- c("x", "y", "x.sec", "y.sec") + names(aesthetics) <- aesthetics + # If the panel_params doesn't contain the scale, there's no guide for the aesthetic + aesthetics <- intersect(aesthetics, names(panel_params$guides)) + + panel_params$guides <- lapply(aesthetics, function(aesthetic) { + axis <- substr(aesthetic, 1, 1) + guide <- panel_params$guides[[aesthetic]] + guide <- guide_train(guide, panel_params[[aesthetic]]) + guide <- guide_transform(guide, self, panel_params) + guide <- guide_geom(guide, layers, default_mapping) + guide + }) + panel_params }, diff --git a/R/coord-cartesian-.r b/R/coord-cartesian-.r index d36a49674a..d4d3181b90 100644 --- a/R/coord-cartesian-.r +++ b/R/coord-cartesian-.r @@ -103,75 +103,6 @@ CoordCartesian <- ggproto("CoordCartesian", Coord, ) }, - setup_panel_guides = function(self, panel_params, guides, params = list()) { - aesthetics <- c("x", "y", "x.sec", "y.sec") - names(aesthetics) <- aesthetics - - # resolve the specified guide from the scale and/or guides - guides <- lapply(aesthetics, function(aesthetic) { - resolve_guide( - aesthetic, - panel_params[[aesthetic]], - guides, - default = guide_axis(), - null = guide_none() - ) - }) - - # resolve the guide definition as a "guide" S3 - guides <- lapply(guides, validate_guide) - - # if there is an "position" specification in the scale, pass this on to the guide - # ideally, this should be specified in the guide - guides <- lapply(aesthetics, function(aesthetic) { - guide <- guides[[aesthetic]] - scale <- panel_params[[aesthetic]] - # position could be NULL here for an empty scale - guide$position <- guide$position %|W|% scale$position - guide - }) - - panel_params$guides <- guides - panel_params - }, - - train_panel_guides = function(self, panel_params, layers, default_mapping, params = list()) { - aesthetics <- c("x", "y", "x.sec", "y.sec") - names(aesthetics) <- aesthetics - - panel_params$guides <- lapply(aesthetics, function(aesthetic) { - axis <- substr(aesthetic, 1, 1) - guide <- panel_params$guides[[aesthetic]] - guide <- guide_train(guide, panel_params[[aesthetic]]) - guide <- guide_transform(guide, self, panel_params) - guide <- guide_geom(guide, layers, default_mapping) - guide - }) - - panel_params - }, - - labels = function(self, labels, panel_params) { - positions_x <- c("top", "bottom") - positions_y <- c("left", "right") - - list( - x = lapply(c(1, 2), function(i) { - panel_guide_label( - panel_params$guides, - position = positions_x[[i]], - default_label = labels$x[[i]] - ) - }), - y = lapply(c(1, 2), function(i) { - panel_guide_label( - panel_params$guides, - position = positions_y[[i]], - default_label = labels$y[[i]]) - }) - ) - }, - render_bg = function(panel_params, theme) { guide_grid( theme, @@ -206,7 +137,6 @@ view_scales_from_scale <- function(scale, coord_limits = NULL, expand = TRUE) { view_scales <- list( view_scale_primary(scale, limits, continuous_range), sec = view_scale_secondary(scale, limits, continuous_range), - arrange = scale$axis_order(), range = continuous_range ) names(view_scales) <- c(aesthetic, paste0(aesthetic, ".", names(view_scales)[-1])) @@ -215,7 +145,7 @@ view_scales_from_scale <- function(scale, coord_limits = NULL, expand = TRUE) { } panel_guide_label <- function(guides, position, default_label) { - guide <- guide_for_position(guides, position) %||% guide_none(title = NULL) + guide <- guide_for_position(guides, position) %||% guide_none(title = waiver()) guide$title %|W|% default_label } diff --git a/R/coord-transform.r b/R/coord-transform.r index 9c3af8c85d..9cab70b5c7 100644 --- a/R/coord-transform.r +++ b/R/coord-transform.r @@ -125,8 +125,18 @@ CoordTrans <- ggproto("CoordTrans", Coord, }, transform = function(self, data, panel_params) { - trans_x <- function(data) transform_value(self$trans$x, data, panel_params$x.range) - trans_y <- function(data) transform_value(self$trans$y, data, panel_params$y.range) + # trans_x() and trans_y() needs to keep Inf values because this can be called + # in guide_transform.axis() + trans_x <- function(data) { + idx <- !is.infinite(data) + data[idx] <- transform_value(self$trans$x, data[idx], panel_params$x.range) + data + } + trans_y <- function(data) { + idx <- !is.infinite(data) + data[idx] <- transform_value(self$trans$y, data[idx], panel_params$y.range) + data + } new_data <- transform_position(data, trans_x, trans_y) @@ -138,8 +148,8 @@ CoordTrans <- ggproto("CoordTrans", Coord, setup_panel_params = function(self, scale_x, scale_y, params = list()) { c( - train_trans(scale_x, self$limits$x, self$trans$x, "x", self$expand), - train_trans(scale_y, self$limits$y, self$trans$y, "y", self$expand) + view_scales_from_scale_with_coord_trans(scale_x, self$limits$x, self$trans$x, self$expand), + view_scales_from_scale_with_coord_trans(scale_y, self$limits$y, self$trans$y, self$expand) ) }, @@ -154,20 +164,16 @@ CoordTrans <- ggproto("CoordTrans", Coord, }, render_axis_h = function(panel_params, theme) { - arrange <- panel_params$x.arrange %||% c("secondary", "primary") - list( - top = render_axis(panel_params, arrange[1], "x", "top", theme), - bottom = render_axis(panel_params, arrange[2], "x", "bottom", theme) + top = panel_guides_grob(panel_params$guides, position = "top", theme = theme), + bottom = panel_guides_grob(panel_params$guides, position = "bottom", theme = theme) ) }, render_axis_v = function(panel_params, theme) { - arrange <- panel_params$y.arrange %||% c("primary", "secondary") - list( - left = render_axis(panel_params, arrange[1], "y", "left", theme), - right = render_axis(panel_params, arrange[2], "y", "right", theme) + left = panel_guides_grob(panel_params$guides, position = "left", theme = theme), + right = panel_guides_grob(panel_params$guides, position = "right", theme = theme) ) } ) @@ -178,14 +184,16 @@ transform_value <- function(trans, value, range) { rescale(trans$transform(value), 0:1, range) } -train_trans <- function(scale, coord_limits, trans, name, expand = TRUE) { +# TODO: can we merge this with view_scales_from_scale()? +view_scales_from_scale_with_coord_trans <- function(scale, coord_limits, trans, expand = TRUE) { expansion <- default_expansion(scale, expand = expand) scale_trans <- scale$trans %||% identity_trans() coord_limits <- coord_limits %||% scale_trans$inverse(c(NA, NA)) + scale_limits <- scale$get_limits() if (scale$is_discrete()) { continuous_ranges <- expand_limits_discrete_trans( - scale$get_limits(), + scale_limits, expansion, coord_limits, trans, @@ -195,7 +203,7 @@ train_trans <- function(scale, coord_limits, trans, name, expand = TRUE) { # transform user-specified limits to scale transformed space coord_limits <- scale$trans$transform(coord_limits) continuous_ranges <- expand_limits_continuous_trans( - scale$get_limits(), + scale_limits, expansion, coord_limits, trans @@ -216,6 +224,10 @@ train_trans <- function(scale, coord_limits, trans, name, expand = TRUE) { out$sec.minor_source <- transform_value(trans, out$sec.minor_source, out$range) out <- list( + # Note that a ViewScale requires a limit and a range that are before the + # Coord's transformation, so we pass `continuous_range`, not `continuous_range_coord`. + view_scale_primary(scale, scale_limits, continuous_ranges$continuous_range), + sec = view_scale_secondary(scale, scale_limits, continuous_ranges$continuous_range), range = out$range, labels = out$labels, major = out$major_source, @@ -224,7 +236,9 @@ train_trans <- function(scale, coord_limits, trans, name, expand = TRUE) { sec.major = out$sec.major_source, sec.minor = out$sec.minor_source ) - names(out) <- paste(name, names(out), sep = ".") + + aesthetic <- scale$aesthetics[1] + names(out) <- c(aesthetic, paste(aesthetic, names(out)[-1], sep = ".")) out } diff --git a/tests/testthat/_snaps/guides/guide-titles-with-coord-trans.svg b/tests/testthat/_snaps/guides/guide-titles-with-coord-trans.svg new file mode 100644 index 0000000000..78de62f91c --- /dev/null +++ b/tests/testthat/_snaps/guides/guide-titles-with-coord-trans.svg @@ -0,0 +1,80 @@ + + + + + + + + + + + + + + + + + + + + + + + + + +0.950 +0.975 +1.000 +1.025 +1.050 + + + + + +0.950 +0.975 +1.000 +1.025 +1.050 + + + + + + + + + + +0.950 +0.975 +1.000 +1.025 +1.050 + + + + + +0.950 +0.975 +1.000 +1.025 +1.050 +x (secondary) +x (primary) +y (primary) +y (secondary) +guide titles with coord_trans() + + diff --git a/tests/testthat/test-guides.R b/tests/testthat/test-guides.R index 4138e848b5..1b1c43de5d 100644 --- a/tests/testthat/test-guides.R +++ b/tests/testthat/test-guides.R @@ -373,6 +373,24 @@ test_that("guides have the final say in x and y", { expect_doppelganger("position guide titles", plot) }) +test_that("Axis titles won't be blown away by coord_*()", { + df <- data_frame(x = 1, y = 1) + plot <- ggplot(df, aes(x, y)) + + geom_point() + + guides( + x = guide_axis(title = "x (primary)"), + y = guide_axis(title = "y (primary)"), + x.sec = guide_axis(title = "x (secondary)"), + y.sec = guide_axis(title = "y (secondary)") + ) + + expect_doppelganger("guide titles with coord_trans()", plot + coord_trans()) + # TODO + # expect_doppelganger("guide titles with coord_polar()", plot + coord_polar()) + # TODO + # expect_doppelganger("guide titles with coord_sf()", plot + coord_sf()) +}) + test_that("guides are positioned correctly", { df <- data_frame(x = 1, y = 1, z = factor("a"))