Add support for alternative axis sides in ggplotly

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),

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")
+})
+