Add support for alternative axis sides in ggplotly

R/ggplotly.R

@@ -280,8 +280,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) {
@@ -296,7 +298,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)
@@ -543,7 +544,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]]
@@ -559,12 +559,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")]],
@@ -587,6 +591,26 @@ gg2list <- function(p, width = NULL, height = NULL,
         title = axisTitleText,
         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)) {
+        if (non_default_side) {
+          if (xy == "x") {
+            ## Facet labels are always on top, I hope???
+            axisObj[["ticklen"]] <- axisObj[["ticklen"]] + 
+              (unitConvert(stripText, "pixels", type) * 2.5)
+            if (nRows > 1) {
+              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)
       # this way both dates/datetimes are on same scale
       # hopefully scale_name doesn't go away -- https://github.com/hadley/ggplot2/issues/1312
@@ -627,26 +651,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(
@@ -883,10 +921,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,81 @@
+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()
+
+# p3 <- p + facet_wrap(~carb)
+
+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")
+})
+