From f9f28448abbdec06a033f4bebdafc1060859545d Mon Sep 17 00:00:00 2001 From: Carson Sievert Date: Mon, 8 Apr 2019 17:41:54 -0500 Subject: [PATCH 1/6] respect outlier.* params in geom_boxplot() --- R/layers2traces.R | 41 ++++++++++++++++++++++++++++------------- 1 file changed, 28 insertions(+), 13 deletions(-) diff --git a/R/layers2traces.R b/R/layers2traces.R index fba34f75c9..eff74e67c4 100644 --- a/R/layers2traces.R +++ b/R/layers2traces.R @@ -777,7 +777,7 @@ geom2trace.GeomPolygon <- function(data, params, p) { #' @export geom2trace.GeomBoxplot <- function(data, params, p) { - compact(list( + trace <- compact(list( x = data[["x"]], y = data[["y"]], hoverinfo = "y", @@ -790,22 +790,38 @@ geom2trace.GeomBoxplot <- function(data, params, p) { aes2plotly(data, params, "fill"), aes2plotly(data, params, "alpha") ), - # marker styling must inherit from GeomPoint$default_aes - # https://github.com/hadley/ggplot2/blob/ab42c2ca81458b0cf78e3ba47ed5db21f4d0fc30/NEWS#L73-L77 - marker = list( - opacity = GeomPoint$default_aes$alpha, - outliercolor = toRGB(GeomPoint$default_aes$colour), - line = list( - width = mm2pixels(GeomPoint$default_aes$stroke), - color = toRGB(GeomPoint$default_aes$colour) - ), - size = mm2pixels(GeomPoint$default_aes$size) - ), line = list( color = aes2plotly(data, params, "colour"), width = aes2plotly(data, params, "size") ) )) + + # handle special `outlier.shape=NA` case + if (is.na(params$outlier.shape)) { + params$outlier.alpha <- 0 + } + + # redefine aes meaning using outlier params + data$alpha <- params$outlier.alpha %||% data$alpha + data$fill <- params$outlier.fill %||% data$fill + data$shape <- params$outlier.shape %||% data$shape + data$stroke <- params$outlier.stroke %||% data$stroke + data$colour <- params$outlier.colour %||% data$colour + data$size <- params$outlier.size %||% data$size + + trace$marker <- list( + opacity = aes2plotly(data, params, "alpha"), + # I don't think this is relevant if line.color is defined? + color = aes2plotly(data, params, "fill"), + symbol = aes2plotly(data, params, "shape"), + line = list( + width = aes2plotly(data, params, "stroke"), + color = aes2plotly(data, params, "colour") + ), + size = aes2plotly(data, params, "size") + ) + + trace } @@ -1007,7 +1023,6 @@ aes2plotly <- function(data, params, aes = "size") { # https://github.com/ropensci/plotly/pull/1481 if ("default_aes" %in% names(geom_obj)) geom_obj$default_aes else NULL } - vals <- uniq(data[[aes]]) %||% params[[aes]] %||% defaults[[aes]] %||% NA converter <- switch( aes, From 62a9792965c3fd16d528023e11cc55e29a037c1e Mon Sep 17 00:00:00 2001 From: Carson Sievert Date: Mon, 8 Apr 2019 17:47:43 -0500 Subject: [PATCH 2/6] respect notch/notchwidth --- R/layers2traces.R | 2 ++ 1 file changed, 2 insertions(+) diff --git a/R/layers2traces.R b/R/layers2traces.R index eff74e67c4..19bdae76a7 100644 --- a/R/layers2traces.R +++ b/R/layers2traces.R @@ -786,6 +786,8 @@ geom2trace.GeomBoxplot <- function(data, params, p) { frame = data[["frame"]], ids = data[["ids"]], type = "box", + notched = params[["notch"]], + notchwidth = params[["notchwidth"]], fillcolor = toRGB( aes2plotly(data, params, "fill"), aes2plotly(data, params, "alpha") From 8b096b9733574876a0b527b7fe23c6833a03b7dc Mon Sep 17 00:00:00 2001 From: Carson Sievert Date: Tue, 9 Apr 2019 14:48:40 -0500 Subject: [PATCH 3/6] Translate geom_boxplot() using polygons instead of plotly.js traces --- R/layers2traces.R | 113 +++++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 106 insertions(+), 7 deletions(-) diff --git a/R/layers2traces.R b/R/layers2traces.R index 19bdae76a7..c669333056 100644 --- a/R/layers2traces.R +++ b/R/layers2traces.R @@ -190,14 +190,113 @@ to_basic.GeomViolin <- function(data, prestats_data, layout, params, p, ...) { #' @export to_basic.GeomBoxplot <- function(data, prestats_data, layout, params, p, ...) { - aez <- names(GeomBoxplot$default_aes) - for (i in aez) { - prestats_data[[i]] <- NULL + # Code adapted from GeomBoxplot$draw_group() + data$fill <- scales::alpha(data$fill, data$alpha) + data$hovertext <- NULL + whiskers <- dplyr::bind_rows( + dplyr::mutate(data, xend = x, y = upper, yend = ymax), + dplyr::mutate(data, xend = x, y = lower, yend = ymin) + ) + box <- dplyr::mutate( + data, + ymin = lower, + y = middle, + ymax = upper, + ynotchlower = ifelse(params$notch, notchlower, NA), + ynotchupper = ifelse(params$notch, notchupper, NA), + notchwidth = params$notchwidth + ) + + outliers <- if (length(data$outliers) && !is.na(params$outlier.shape)) { + tidyr::unnest(data) %>% + dplyr::mutate( + y = outliers, + # TODO: respect tooltip + hovertext = paste("x:", x, "y:", y), + colour = params$outlier.colour %||% colour, + fill = params$outlier.fill %||% fill, + shape = params$outlier.shape %||% shape, + size = params$outlier.size %||% size, + stroke = params$outlier.stroke %||% stroke, + alpha = params$outlier.alpha %||% alpha + ) } - vars <- c("PANEL", "group", "key", aez, grep("_plotlyDomain$", names(data), value = T)) - prefix_class( - merge(prestats_data, data[names(data) %in% vars], by = c("PANEL", "group"), sort = FALSE), - "GeomBoxplot" + + # If boxplot has notches, it needs to drawn as a polygon (instead of a crossbar/rect) + # This code is adapted from GeomCrossbar$draw_panel() + if (params$notch) { + # TODO: where does fatten come from? + fatten <- 2.5 + middle <- transform( + box, x = xmin, xend = xmax, yend = y, + size = size * fatten, alpha = NA + ) + if (box$ynotchlower < box$ymin || box$ynotchupper > box$ymax) + message("notch went outside hinges. Try setting notch=FALSE.") + notchindent <- (1 - box$notchwidth) * (box$xmax - box$xmin)/2 + middle$x <- middle$x + notchindent + middle$xend <- middle$xend - notchindent + box <- data.frame( + x = c( + box$xmin, + box$xmin, + box$xmin + notchindent, + box$xmin, + box$xmin, + box$xmax, + box$xmax, + box$xmax - notchindent, + box$xmax, + box$xmax, + box$xmin + ), y = c( + box$ymax, + box$ynotchupper, + box$y, + box$ynotchlower, + box$ymin, + box$ymin, + box$ynotchlower, + box$y, + box$ynotchupper, + box$ymax, + box$ymax + ), + alpha = box$alpha, + colour = box$colour, + size = box$size, + linetype = box$linetype, + fill = box$fill, + group = seq_len(nrow(box)), + stringsAsFactors = FALSE + ) + } + + # place an invisible marker at the boxplot middle + # for some sensible hovertext + hover_pts <- data %>% + dplyr::mutate( + # TODO: + # (1) respect tooltip argument + # (2) include varwidth and/or notch information? + hovertext = paste( + paste("Max:", ymax), + paste("Upper:", upper), + paste("Middle:", middle), + paste("Lower:", lower), + paste("Min:", ymin), + sep = br() + ), + alpha = 0 + ) %>% + dplyr::select(x, y = middle, hovertext, alpha, colour) + + # to_basic.GeomCrossbar() returns list of 2 data frames + c( + if (params$notch) list(prefix_class(box, "GeomPolygon")) else to_basic.GeomCrossbar(box, params = params), + list(to_basic.GeomSegment(whiskers)), + list(prefix_class(hover_pts, "GeomPoint")), + if (length(outliers)) list(prefix_class(outliers, "GeomPoint")) ) } From 515498e6056de5798345dc80443d0b59a3d3e3a0 Mon Sep 17 00:00:00 2001 From: Carson Sievert Date: Tue, 9 Apr 2019 16:30:59 -0500 Subject: [PATCH 4/6] get notches working --- R/layers2traces.R | 95 ++++++++++++++++++++--------------------------- 1 file changed, 41 insertions(+), 54 deletions(-) diff --git a/R/layers2traces.R b/R/layers2traces.R index c669333056..000628117b 100644 --- a/R/layers2traces.R +++ b/R/layers2traces.R @@ -206,7 +206,6 @@ to_basic.GeomBoxplot <- function(data, prestats_data, layout, params, p, ...) { ynotchupper = ifelse(params$notch, notchupper, NA), notchwidth = params$notchwidth ) - outliers <- if (length(data$outliers) && !is.na(params$outlier.shape)) { tidyr::unnest(data) %>% dplyr::mutate( @@ -221,57 +220,6 @@ to_basic.GeomBoxplot <- function(data, prestats_data, layout, params, p, ...) { alpha = params$outlier.alpha %||% alpha ) } - - # If boxplot has notches, it needs to drawn as a polygon (instead of a crossbar/rect) - # This code is adapted from GeomCrossbar$draw_panel() - if (params$notch) { - # TODO: where does fatten come from? - fatten <- 2.5 - middle <- transform( - box, x = xmin, xend = xmax, yend = y, - size = size * fatten, alpha = NA - ) - if (box$ynotchlower < box$ymin || box$ynotchupper > box$ymax) - message("notch went outside hinges. Try setting notch=FALSE.") - notchindent <- (1 - box$notchwidth) * (box$xmax - box$xmin)/2 - middle$x <- middle$x + notchindent - middle$xend <- middle$xend - notchindent - box <- data.frame( - x = c( - box$xmin, - box$xmin, - box$xmin + notchindent, - box$xmin, - box$xmin, - box$xmax, - box$xmax, - box$xmax - notchindent, - box$xmax, - box$xmax, - box$xmin - ), y = c( - box$ymax, - box$ynotchupper, - box$y, - box$ynotchlower, - box$ymin, - box$ymin, - box$ynotchlower, - box$y, - box$ynotchupper, - box$ymax, - box$ymax - ), - alpha = box$alpha, - colour = box$colour, - size = box$size, - linetype = box$linetype, - fill = box$fill, - group = seq_len(nrow(box)), - stringsAsFactors = FALSE - ) - } - # place an invisible marker at the boxplot middle # for some sensible hovertext hover_pts <- data %>% @@ -291,9 +239,48 @@ to_basic.GeomBoxplot <- function(data, prestats_data, layout, params, p, ...) { ) %>% dplyr::select(x, y = middle, hovertext, alpha, colour) - # to_basic.GeomCrossbar() returns list of 2 data frames + # If boxplot has notches, it needs to drawn as a polygon (instead of a crossbar/rect) + # This code is adapted from GeomCrossbar$draw_panel() + box_dat <- if (!params$notch) { + to_basic.GeomCrossbar(box, params = params) + } else { + # fatten is a parameter to GeomCrossbar$draw_panel() and is always 2 when called from GeomBoxplot$draw_panel() + fatten <- 2 + middle <- transform( + box, x = xmin, xend = xmax, yend = y, + size = size * fatten, alpha = NA + ) + if (box$ynotchlower < box$ymin || box$ynotchupper > box$ymax) + message("notch went outside hinges. Try setting notch=FALSE.") + notchindent <- (1 - box$notchwidth) * (box$xmax - box$xmin)/2 + middle$x <- middle$x + notchindent + middle$xend <- middle$xend - notchindent + + box$notchindent <- notchindent + boxes <- split(box, seq_len(nrow(box))) + box <- dplyr::bind_rows(lapply(boxes, function(b) { + dplyr::bind_rows( + dplyr::mutate(b, x = xmin, y = ymax), + dplyr::mutate(b, x = xmin, y = notchupper), + dplyr::mutate(b, x = xmin + notchindent, y = middle), + dplyr::mutate(b, x = xmin, y = notchlower), + dplyr::mutate(b, x = xmin, y = ymin), + dplyr::mutate(b, x = xmax, y = ymin), + dplyr::mutate(b, x = xmax, y = notchlower), + dplyr::mutate(b, x = xmax - notchindent, y = middle), + dplyr::mutate(b, x = xmax, y = notchupper), + dplyr::mutate(b, x = xmax, y = ymax) + ) + })) + + list( + prefix_class(box, "GeomPolygon"), + to_basic.GeomSegment(middle) + ) + } + # box_dat is list of 2 data frames c( - if (params$notch) list(prefix_class(box, "GeomPolygon")) else to_basic.GeomCrossbar(box, params = params), + box_dat, list(to_basic.GeomSegment(whiskers)), list(prefix_class(hover_pts, "GeomPoint")), if (length(outliers)) list(prefix_class(outliers, "GeomPoint")) From b0aa59649bea8d421e6d8e7ea8ec9b8bc171d0b2 Mon Sep 17 00:00:00 2001 From: Carson Sievert Date: Wed, 10 Apr 2019 14:37:44 -0500 Subject: [PATCH 5/6] format hovertext & include PANEL in tooltip data --- R/layers2traces.R | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/R/layers2traces.R b/R/layers2traces.R index 000628117b..bcec8e4bac 100644 --- a/R/layers2traces.R +++ b/R/layers2traces.R @@ -226,18 +226,18 @@ to_basic.GeomBoxplot <- function(data, prestats_data, layout, params, p, ...) { dplyr::mutate( # TODO: # (1) respect tooltip argument - # (2) include varwidth and/or notch information? + # (2) include varwidth and/or notch information, if relevant hovertext = paste( - paste("Max:", ymax), - paste("Upper:", upper), - paste("Middle:", middle), - paste("Lower:", lower), - paste("Min:", ymin), + paste("Max:", format(ymax)), + paste("Upper:", format(upper)), + paste("Middle:", format(middle)), + paste("Lower:", format(lower)), + paste("Min:", format(ymin)), sep = br() ), alpha = 0 ) %>% - dplyr::select(x, y = middle, hovertext, alpha, colour) + dplyr::select(PANEL, x, y = middle, hovertext, alpha, fill) # If boxplot has notches, it needs to drawn as a polygon (instead of a crossbar/rect) # This code is adapted from GeomCrossbar$draw_panel() From 59bee4c2b35f9c067d439938b8013b5bd0a4c9c8 Mon Sep 17 00:00:00 2001 From: Carson Sievert Date: Fri, 24 May 2019 14:23:54 -0500 Subject: [PATCH 6/6] Introduce geom_boxplot2() which maps to box traces --- NAMESPACE | 3 +++ R/geom_boxplot2.R | 25 +++++++++++++++++++++ R/layers2traces.R | 53 +++++++++++++++++++++++++++++++++++++++++++- man/geom_boxplot2.Rd | 28 +++++++++++++++++++++++ 4 files changed, 108 insertions(+), 1 deletion(-) create mode 100644 R/geom_boxplot2.R create mode 100644 man/geom_boxplot2.Rd diff --git a/NAMESPACE b/NAMESPACE index dd80145f23..fd85b88383 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -12,6 +12,7 @@ S3method(fortify,SharedData) S3method(geom2trace,GeomBar) S3method(geom2trace,GeomBlank) S3method(geom2trace,GeomBoxplot) +S3method(geom2trace,GeomBoxplot2) S3method(geom2trace,GeomErrorbar) S3method(geom2trace,GeomErrorbarh) S3method(geom2trace,GeomPath) @@ -48,6 +49,7 @@ S3method(to_basic,GeomAbline) S3method(to_basic,GeomAnnotationMap) S3method(to_basic,GeomArea) S3method(to_basic,GeomBoxplot) +S3method(to_basic,GeomBoxplot2) S3method(to_basic,GeomCol) S3method(to_basic,GeomContour) S3method(to_basic,GeomCrossbar) @@ -134,6 +136,7 @@ export(export) export(filter) export(filter_) export(geom2trace) +export(geom_boxplot2) export(get_figure) export(gg2list) export(ggplotly) diff --git a/R/geom_boxplot2.R b/R/geom_boxplot2.R new file mode 100644 index 0000000000..46a3f00dc2 --- /dev/null +++ b/R/geom_boxplot2.R @@ -0,0 +1,25 @@ +#' Attempt to convert `geom_boxplot()` to a plotly.js box trace +#' +#' There are two ways to create boxplot via [ggplotly()]: with either +#' this function or [ggplot2::geom_boxplot()]. This function uses +#' the [box](https://plot.ly/r/reference/#box) trace type whereas the +#' latter uses a combination of [scatter](https://plot.ly/r/reference/#scatter) +#' traces to render the visualization. This implies that, this +#' function lets plotly.js compute boxplot summaries and positional +#' dodging, whereas the latter uses the actual ggplot2 boxplot +#' definition(s). +#' +#' @param ... arguments passed along to [ggplot2::geom_boxplot()] +#' +#' @export +#' @examples +#' +#' subplot( +#' ggplot(diamonds) + geom_boxplot(aes(y = price)), +#' ggplot(diamonds) + geom_boxplot2(aes(y = price)) +#' ) +geom_boxplot2 <- function(...) { + ggproto_box <- ggplot2::geom_boxplot(...) + ggproto_box$plotlyGeomBoxplot2 <- TRUE + ggproto_box +} diff --git a/R/layers2traces.R b/R/layers2traces.R index bcec8e4bac..858a344f3f 100644 --- a/R/layers2traces.R +++ b/R/layers2traces.R @@ -1,7 +1,12 @@ # layer -> trace conversion layers2traces <- function(data, prestats_data, layout, p) { # Attach a "geom class" to each layer of data for method dispatch - data <- Map(function(x, y) prefix_class(x, class(y$geom)[1]), data, p$layers) + data <- Map(function(x, y) { + cl <- class(y$geom)[1] + # is this layer coming from plotly::geom_boxplot2()? + cl <- if (isTRUE(y$plotlyGeomBoxplot2)) "GeomBoxplot2" else cl + prefix_class(x, cl) + }, data, p$layers) # Extract parameters (and "hovertext aesthetics") in each layer params <- Map(function(x, y) { @@ -287,6 +292,19 @@ to_basic.GeomBoxplot <- function(data, prestats_data, layout, params, p, ...) { ) } +#' @export +to_basic.GeomBoxplot2 <- function(data, prestats_data, layout, params, p, ...) { + aez <- names(GeomBoxplot$default_aes) + for (i in aez) { + prestats_data[[i]] <- NULL + } + vars <- c("PANEL", "group", "key", aez, grep("_plotlyDomain$", names(data), value = T)) + prefix_class( + merge(prestats_data, data[names(data) %in% vars], by = c("PANEL", "group"), sort = FALSE), + "GeomBoxplot" + ) +} + #' @export to_basic.GeomSmooth <- function(data, prestats_data, layout, params, p, ...) { if (nrow(data) == 0) { @@ -861,6 +879,39 @@ geom2trace.GeomPolygon <- function(data, params, p) { compact(L) } +#' @export +geom2trace.GeomBoxplot2 <- function(data, params, p) { + compact(list( + x = data[["x"]], + y = data[["y"]], + hoverinfo = "y", + key = data[["key"]], + customdata = data[["customdata"]], + frame = data[["frame"]], + ids = data[["ids"]], + type = "box", + fillcolor = toRGB( + aes2plotly(data, params, "fill"), + aes2plotly(data, params, "alpha") + ), + # marker styling must inherit from GeomPoint$default_aes + # https://github.com/hadley/ggplot2/blob/ab42c2ca81458b0cf78e3ba47ed5db21f4d0fc30/NEWS#L73-L77 + marker = list( + opacity = GeomPoint$default_aes$alpha, + outliercolor = toRGB(GeomPoint$default_aes$colour), + line = list( + width = mm2pixels(GeomPoint$default_aes$stroke), + color = toRGB(GeomPoint$default_aes$colour) + ), + size = mm2pixels(GeomPoint$default_aes$size) + ), + line = list( + color = aes2plotly(data, params, "colour"), + width = aes2plotly(data, params, "size") + ) + )) +} + #' @export geom2trace.GeomBoxplot <- function(data, params, p) { trace <- compact(list( diff --git a/man/geom_boxplot2.Rd b/man/geom_boxplot2.Rd new file mode 100644 index 0000000000..0ce1b6e311 --- /dev/null +++ b/man/geom_boxplot2.Rd @@ -0,0 +1,28 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/geom_boxplot2.R +\name{geom_boxplot2} +\alias{geom_boxplot2} +\title{Attempt to convert \code{geom_boxplot()} to a plotly.js box trace} +\usage{ +geom_boxplot2(...) +} +\arguments{ +\item{...}{arguments passed along to \code{\link[ggplot2:geom_boxplot]{ggplot2::geom_boxplot()}}} +} +\description{ +There are two ways to create boxplot via \code{\link[=ggplotly]{ggplotly()}}: with either +this function or \code{\link[ggplot2:geom_boxplot]{ggplot2::geom_boxplot()}}. This function uses +the \href{https://plot.ly/r/reference/#box}{box} trace type whereas the +latter uses a combination of \href{https://plot.ly/r/reference/#scatter}{scatter} +traces to render the visualization. This implies that, this +function lets plotly.js compute boxplot summaries and positional +dodging, whereas the latter uses the actual ggplot2 boxplot +definition(s). +} +\examples{ + +subplot( + ggplot(diamonds) + geom_boxplot(aes(y = price)), + ggplot(diamonds) + geom_boxplot2(aes(y = price)) +) +}