Updates to better support dendrograms

R/layers2traces.R

@@ -100,6 +100,7 @@ layers2traces <- function(data, prestats_data, layout, p) {
  d <- datz[[i]]
  # variables that produce multiple traces and deserve their own legend entries
  split_legend <- paste0(names(discreteScales), "_plotlyDomain")
+ show_legend <- paste0(names(Filter(function(x) x$guide != "none", discreteScales)), "_plotlyDomain")
  # add variable that produce multiple traces, but do _not_ deserve entries
  split_by <- c(split_legend, "PANEL", "frame", split_on(d))
  # ensure the factor level orders (which determines traces order)
@@ -120,7 +121,7 @@ layers2traces <- function(data, prestats_data, layout, p) {
  trs <- Map(function(x, y) { x$set <- attr(y, "set"); x}, trs, dl)
  # if we need a legend, set name/legendgroup/showlegend
  # note: this allows us to control multiple traces from one legend entry
- if (any(split_legend %in% names(d))) {
+ if (any(show_legend %in% names(d))) {
  nms <- strsplit(names(trs), separator, fixed = TRUE)
  nms <- vapply(nms, function(x) {
  y <- unique(x[seq_along(split_legend)])
@@ -254,11 +255,26 @@ to_basic.GeomSegment <- function(data, prestats_data, layout, params, p, ...) {
 to_basic.GeomRect <- function(data, prestats_data, layout, params, p, ...) {
  data$group <- seq_len(nrow(data))
  others <- data[!names(data) %in% c("xmin", "ymin", "xmax", "ymax", "y", "x")]
+ if (inherits(p$coordinates, "CoordFlip")) {
+ x_min <- layout$y_min
+ x_max <- layout$y_max
+ y_min <- layout$x_min
+ y_max <- layout$x_max
+ } else {
+ x_min <- layout$x_min
+ x_max <- layout$x_max
+ y_min <- layout$y_min
+ y_max <- layout$y_max
+ }
  dat <- with(data, {
- rbind(cbind(x = xmin, y = ymin, others),
- cbind(x = xmin, y = ymax, others),
- cbind(x = xmax, y = ymax, others),
- cbind(x = xmax, y = ymin, others))
+ rbind(cbind(x = ifelse(xmin == -Inf, x_min, xmin),
+ y = ifelse(ymin == -Inf, y_min, ymin), others),
+ cbind(x = ifelse(xmin == -Inf, x_min, xmin),
+ y = ifelse(ymax == Inf, y_max, ymax), others),
+ cbind(x = ifelse(xmax == Inf, x_max, xmax),
+ y = ifelse(ymax == Inf, y_max, ymax), others),
+ cbind(x = ifelse(xmax == Inf, x_max, xmax),
+ y = ifelse(ymin == -Inf, y_min, ymin), others))
  })
  prefix_class(dat, c("GeomPolygon", "GeomRect"))
 }
@@ -603,10 +619,15 @@ geom2trace.GeomBoxplot <- function(data, params, p) {
 
 #' @export
 geom2trace.GeomText <- function(data, params, p) {
+ text <- as.character(data[["label"]])
+ i_ind <- grepl("italic", data[["fontface"]])
+ text[i_ind] <- paste0("<i>", text[i_ind], "</i>")
+ b_ind <- grepl("bold", data[["fontface"]])
+ text[b_ind] <- paste0("<b>", text[b_ind], "</b>")
  compact(list(
  x = data[["x"]],
  y = data[["y"]],
- text = data[["label"]],
+ text = text,
  key = data[["key"]],
  frame = data[["frame"]],
  ids = data[["ids"]],
@@ -618,6 +639,14 @@ geom2trace.GeomText <- function(data, params, p) {
  aes2plotly(data, params, "alpha")
  )
  ),
+ textposition = paste0(
+ ifelse(data[["vjust"]] < 0.5, "top ",
+ ifelse(data[["vjust"]] > 0.5, "bottom ", "")
+ ),
+ ifelse(data[["hjust"]] < 0.5, "right",
+ ifelse(data[["vjust"]] > 0.5, "left", "center")
+ )
+ ),
  type = "scatter",
  mode = "text",
  hoveron = hover_on(data)

tests/testthat/test-ggplot-rect.R

@@ -139,3 +139,36 @@ test_that('Specifying alpha in hex color code works', {
  expect_match(info$data[[1]]$fillcolor, "rgba\\(0,0,0,0\\.0[6]+")
 })
 
+p1 = ggplot(data.frame(x = 1, y = 1)) +
+ geom_point(aes(x = x, y = y)) +
+ geom_rect(xmin = 0.9, xmax = 1.1, ymin = -Inf, ymax = Inf)
+p2 = ggplot(data.frame(x = 1, y = 1)) +
+ geom_point(aes(x = x, y = y)) +
+ geom_rect(ymin = 0.9, ymax = 1.1, xmin = -Inf, xmax = Inf) +
+ coord_flip()
+info1 <- save_outputs(p1, "rect-vert-inf")
+info2 <- save_outputs(p2, "rect-vert-flip-inf")
+
+test_that("rect vertical inf is translated correctly", {
+ expect_identical(info1$data[[2]]$x, c(0.9, 0.9, 1.1, 1.1, 0.9))
+ expect_identical(info1$data[[2]]$y, c(0.5, 1.5, 1.5, 0.5, 0.5))
+ expect_identical(info2$data[[2]]$x, c(0.9, 1.1, 1.1, 0.9, 0.9))
+ expect_identical(info2$data[[2]]$y, c(0.5, 0.5, 1.5, 1.5, 0.5))
+})
+
+p3 = ggplot(data.frame(x = 1, y = 1)) +
+ geom_point(aes(x = x, y = y)) +
+ geom_rect(ymin = 0.9, ymax = 1.1, xmin = -Inf, xmax = Inf)
+p4 = ggplot(data.frame(x = 1, y = 1)) +
+ geom_point(aes(x = x, y = y)) +
+ geom_rect(xmin = 0.9, xmax = 1.1, ymin = -Inf, ymax = Inf) +
+ coord_flip()
+info3 <- save_outputs(p3, "rect-hor-inf")
+info4 <- save_outputs(p4, "rect-hor-flip-inf")
+
+test_that("rect horizontal inf is translated correctly", {
+ expect_identical(info4$data[[2]]$y, c(0.9, 0.9, 1.1, 1.1, 0.9))
+ expect_identical(info4$data[[2]]$x, c(0.5, 1.5, 1.5, 0.5, 0.5))
+ expect_identical(info3$data[[2]]$y, c(0.9, 1.1, 1.1, 0.9, 0.9))
+ expect_identical(info3$data[[2]]$x, c(0.5, 0.5, 1.5, 1.5, 0.5))
+})

tests/testthat/test-ggplot-text.R

@@ -42,3 +42,28 @@ test_that("geom_text splits along colour", {
  # Right colour for each trace
  expect_true(L$data[[1]]$textfont$color != L$data[[2]]$textfont$color)
 })
+
+gg1 = ggplot(data.frame(x = seq(5, 25, 5), y = 60)) +
+ geom_point(aes(x = x, y = y)) +
+ geom_text(x = 5, y = 60, label = "nothing") +
+ geom_text(x = 10, y = 60, label = "bold", fontface = "bold", hjust = 0, vjust = 0) +
+ geom_text(x = 15, y = 60, label = "italic", fontface = "italic", hjust = 1, vjust = 1) +
+ geom_text(x = 20, y = 60, label = "bold italic", fontface = "bold.italic", hjust = 0, vjust = 1) +
+ geom_text(x = 25, y = 60, label = "plain", fontface = "plain", hjust = 1, vjust = 0)
+info1 <- save_outputs(gg1, "text-fontjust")
+
+test_that("fontface is translated correctly", {
+ expect_identical(info1$data[[2]]$text, rep("nothing", 5))
+ expect_identical(info1$data[[3]]$text, rep("<b>bold</b>", 5))
+ expect_identical(info1$data[[4]]$text, rep("<i>italic</i>", 5))
+ expect_identical(info1$data[[5]]$text, rep("<b><i>bold italic</i></b>", 5))
+ expect_identical(info1$data[[6]]$text, rep("plain", 5))
+})
+
+test_that("hjust/vjust is translated correctly", {
+ expect_identical(info1$data[[2]]$textposition, rep("center", 5))
+ expect_identical(info1$data[[3]]$textposition, rep("top right", 5))
+ expect_identical(info1$data[[4]]$textposition, rep("bottom left", 5))
+ expect_identical(info1$data[[5]]$textposition, rep("bottom right", 5))
+ expect_identical(info1$data[[6]]$textposition, rep("top center", 5))
+})