diff --git a/R/ggplotly.R b/R/ggplotly.R index f1d606c15c..aed5744528 100644 --- a/R/ggplotly.R +++ b/R/ggplotly.R @@ -300,8 +300,10 @@ gg2list <- function(p, width = NULL, height = NULL, if (!is.null(scale_y()) && scale_y()$is_discrete()) d$y_plotlyDomain <- d$y d }) + data <- layout$map_position(data) + # build a mapping between group and key # if there are multiple keys within a group, the key is a list-column reComputeGroup <- function(x, layer = NULL) { @@ -316,7 +318,6 @@ gg2list <- function(p, width = NULL, height = NULL, } x } - nestedKeys <- Map(function(x, y, z) { key <- y[[crosstalk_key()]] if (is.null(key) || inherits(z[["stat"]], "StatIdentity")) return(NULL) @@ -565,7 +566,6 @@ gg2list <- function(p, width = NULL, height = NULL, axisLine <- theme_el("axis.line") panelGrid <- theme_el("panel.grid.major") stripText <- theme_el("strip.text") - axisName <- lay[, paste0(xy, "axis")] anchor <- lay[, paste0(xy, "anchor")] rng <- layout$panel_params[[i]] @@ -581,12 +581,16 @@ gg2list <- function(p, width = NULL, height = NULL, axisTitleText <- sc$name %||% plot$labels[[xy]] %||% "" if (is_blank(axisTitle)) axisTitleText <- "" # https://plot.ly/r/reference/#layout-xaxis + + default_axis <- switch(xy, "x" = "bottom", "y" = "left") + axisObj <- list( type = "linear", autorange = FALSE, tickmode = "array", range = rng[[paste0(xy, ".range")]], ticktext = rng[[paste0(xy, ".labels")]], + side = scales$get_scales(xy)$position %||% default_axis, # TODO: implement minor grid lines with another axis object # and _always_ hide ticks/text? tickvals = rng[[paste0(xy, ".major")]], @@ -609,7 +613,25 @@ gg2list <- function(p, width = NULL, height = NULL, title = faced(axisTitleText, axisTitle$face), titlefont = text2font(axisTitle) ) + + non_default_side <- isTRUE(scales$get_scales(xy)[["position"]] != default_axis) + ## Move axis and change anchor if necessary + if (has_facet(plot) & non_default_side) { + if (xy == "x") { + ## Facet labels are always on top, so add tick length to move past them + axisObj[["ticklen"]] <- axisObj[["ticklen"]] + + (unitConvert(stripText, "pixels", type) * 3) + + axisObj[["anchor"]] <- "y" + } else if (xy == "y" && nCols > 1) { + axisObj[["anchor"]] <- paste0("x", nCols) + axisTitle[["angle"]] <- 270 + } + } + + + # convert dates to milliseconds (86400000 = 24 * 60 * 60 * 1000) # ensure dates/datetimes are put on the same millisecond scale # hopefully scale_name doesn't go away -- https://github.com/hadley/ggplot2/issues/1312 if (any(c("date", "datetime") %in% sc$scale_name)) { @@ -639,7 +661,11 @@ gg2list <- function(p, width = NULL, height = NULL, # do some stuff that should be done once for the entire plot if (i == 1) { axisTickText <- axisObj$ticktext[which.max(nchar(axisObj$ticktext))] - side <- if (xy == "x") "b" else "l" + if (non_default_side) { + side <- if (xy == "x") "t" else "r" + } else { + side <- if (xy == "x") "b" else "l" + } # account for axis ticks, ticks text, and titles in plot margins # (apparently ggplot2 doesn't support axis.title/axis.text margins) gglayout$margin[[side]] <- gglayout$margin[[side]] + axisObj$ticklen + @@ -654,26 +680,40 @@ gg2list <- function(p, width = NULL, height = NULL, bbox(axisTickText, axisText$angle, axisTextSize)[[type]] - bbox(axisTitleText, axisTitle$angle, axisTitleSize)[[type]] / 2 - unitConvert(theme$axis.ticks.length, "npc", type)) + ## Need extra room for striptext + if (xy == "x" & non_default_side) { + offset <- offset - (unitConvert(stripText, "npc", type) * 4) + } } # add space for exterior facet strips in `layout.margin` - if (has_facet(plot)) { stripSize <- unitConvert(stripText, "pixels", type) + ## Increasing padding when non-standard side, especially for strip + padding_amount <- stripSize + ## 4 is a magic number to ensure annotation is onscreen... + if (non_default_side) padding_amount <- (stripSize * 4) if (xy == "x") { - gglayout$margin$t <- gglayout$margin$t + stripSize + gglayout$margin$t <- gglayout$margin$t + padding_amount } - if (xy == "y" && inherits(plot$facet, "FacetGrid")) { - gglayout$margin$r <- gglayout$margin$r + stripSize + if (xy == "y" && (inherits(plot$facet, "FacetGrid") | non_default_side)) { + gglayout$margin$r <- gglayout$margin$r + padding_amount } # facets have multiple axis objects, but only one title for the plot, # so we empty the titles and try to draw the title as an annotation if (nchar(axisTitleText) > 0) { + + ## If axis is moved, need to move axis title as well + if (non_default_side) { + axisTitleLocation <- (1 - offset) + } else axisTitleLocation <- offset + + x <- if (xy == "x") 0.5 else axisTitleLocation + y <- if (xy == "x") axisTitleLocation else 0.5 + # npc is on a 0-1 scale of the _entire_ device, # but these units _should_ be wrt to the plotting region # multiplying the offset by 2 seems to work, but this is a terrible hack - x <- if (xy == "x") 0.5 else offset - y <- if (xy == "x") offset else 0.5 gglayout$annotations <- c( gglayout$annotations, make_label( @@ -912,10 +952,10 @@ gg2list <- function(p, width = NULL, height = NULL, } # If a trace isn't named, it shouldn't have additional hoverinfo traces <- lapply(compact(traces), function(x) { x$name <- x$name %||% ""; x }) - + gglayout$width <- width gglayout$height <- height - + l <- list( data = setNames(traces, NULL), layout = compact(gglayout), diff --git a/tests/testthat/test-ggplot-axis.R b/tests/testthat/test-ggplot-axis.R new file mode 100644 index 0000000000..f994cb69fe --- /dev/null +++ b/tests/testthat/test-ggplot-axis.R @@ -0,0 +1,79 @@ +context("Axis moving") + +expect_traces <- function(gg, n.traces, name){ + stopifnot(is.numeric(n.traces)) + L <- save_outputs(gg, paste0("axis-", name)) + all.traces <- L$data + no.data <- sapply(all.traces, function(tr) { + is.null(tr[["x"]]) && is.null(tr[["y"]]) + }) + has.data <- all.traces[!no.data] + expect_equal(length(has.data), n.traces) + list(data = has.data, layout = L$layout) +} + +p <- ggplot(mtcars, aes(x=mpg, y=wt)) + + geom_point() + +test_that("Axis position moves to top", { + p <- p + scale_x_continuous(position="top") + + info <- save_outputs(p, "axis_move_top") + expect_equal(length(info$data), 1) + expect_identical(info$layout$xaxis$side, "top") +}) + +test_that("Axis position moves to right", { + p <- p + scale_y_continuous(position="right") + + info <- save_outputs(p, "axis_move_right") + expect_equal(length(info$data), 1) + expect_identical(info$layout$yaxis$side, "right") +}) + +test_that("Axis position moves to top (facets)", { + p <- p + scale_x_continuous(position="top") + facet_wrap(~carb) + + info <- save_outputs(p, "axis_move_top_facet") + expect_equal(length(info$data), 6) + expect_equal(info$layout$xaxis$anchor, "y") + expect_identical(info$layout$xaxis$side, "top") +}) + +test_that("Axis position moves to top (facets)", { + p <- p + scale_y_continuous(position="right") + facet_wrap(~carb) + + info <- save_outputs(p, "axis_move_right_facet") + + expect_equal(length(info$data), 6) + + expect_equal(info$layout$yaxis$anchor, "x3") + expect_identical(info$layout$yaxis$side, "right") +}) + +test_that("Axis positions stay at bottom and left", { + info <- save_outputs(p, "axis_stay") + + expect_equal(length(info$data), 1) + + expect_identical(info$layout$xaxis$side, "bottom") + expect_identical(info$layout$yaxis$side, "left") + + expect_equal(info$layout$xaxis$anchor, "y") + expect_equal(info$layout$yaxis$anchor, "x") +}) + + +test_that("Axis positions stay at bottom and left (facet)", { + p <- p + facet_wrap(~carb) + info <- save_outputs(p, "axis_stay_facet") + + expect_equal(length(info$data), 6) + + expect_identical(info$layout$xaxis$side, "bottom") + expect_identical(info$layout$yaxis$side, "left") + + expect_equal(info$layout$xaxis$anchor, "y2") + expect_equal(info$layout$yaxis$anchor, "x") +}) +