From 57cc44f662a0597010f11774bc94ce22d3ef5a3c Mon Sep 17 00:00:00 2001 From: Carson Sievert Date: Tue, 14 May 2019 16:34:00 -0500 Subject: [PATCH] Coordmap info should retain discrete limits (#2410) * ggplot2 input brushes should retain discrete range mapping, and be imposed in brushedPoints(), closes #1433 * simplify logic and reduce required storage * get nearPoints() working as well, cleanup * only remember scale range if ggplot is facet with a free discrete axis * Use the scale limits (before the range) since the former is specified, that's what is actually shown on the plot also, introduce within_brush() helper to consistently handle missing values produced by asNumber() * also use scale limits in older versions of ggplot2 * DRY * discrete_mapping -> discrete_limits; better comments * update test expectation * a couple unit tests * update comment to reflect new coordmap data structure * use unlink() not rm() * add some tests for specifying scale limits and labels * Use get_limits() if available * update news * better name and comment for new asNumber() argument --- NEWS.md | 4 + R/image-interact.R | 31 +++++-- R/render-plot.R | 114 ++++++++++++++++++------- tests/testthat/test-plot-coordmap.R | 125 ++++++++++++++++++++++++++-- 4 files changed, 227 insertions(+), 47 deletions(-) diff --git a/NEWS.md b/NEWS.md index 8d30031c1..dd87f37ac 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,6 +1,10 @@ shiny 1.3.2.9000 ======= +## Changes + +* Resolved ([#1433](https://github.com/rstudio/shiny/issues/1433)): `plotOutput()`'s coordmap info now includes discrete axis limits for **ggplot2** plots. As a result, any **shinytest** tests that contain **ggplot2** plots with discrete axes (that were recorded before this change) will now report differences that can safely be updated. This new coordmap info was added to correctly infer what data points are within an input brush and/or near input click/hover in scenarios where a non-trivial discrete axis scale is involved (e.g., whenever `scale_[x/y]_discrete(limits = ...)` and/or free scales across multiple discrete axes are used). ([#2410](https://github.com/rstudio/shiny/pull/2410)) + ### Improvements * Resolved ([#2402](https://github.com/rstudio/shiny/issues/2402)): An informative warning is now thrown for mis-specified (date) strings in `dateInput()`, `updateDateInput()`, `dateRangeInput()`, and `updateDateRangeInput()`. ([#2403](https://github.com/rstudio/shiny/pull/2403)) diff --git a/R/image-interact.R b/R/image-interact.R index 8e072935a..7b63f45e7 100644 --- a/R/image-interact.R +++ b/R/image-interact.R @@ -88,17 +88,14 @@ brushedPoints <- function(df, brush, xvar = NULL, yvar = NULL, stop("brushedPoints: not able to automatically infer `xvar` from brush") if (!(xvar %in% names(df))) stop("brushedPoints: `xvar` ('", xvar ,"') not in names of input") - # Extract data values from the data frame - x <- asNumber(df[[xvar]]) - keep_rows <- keep_rows & (x >= brush$xmin & x <= brush$xmax) + keep_rows <- keep_rows & within_brush(df[[xvar]], brush, "x") } if (use_y) { if (is.null(yvar)) stop("brushedPoints: not able to automatically infer `yvar` from brush") if (!(yvar %in% names(df))) stop("brushedPoints: `yvar` ('", yvar ,"') not in names of input") - y <- asNumber(df[[yvar]]) - keep_rows <- keep_rows & (y >= brush$ymin & y <= brush$ymax) + keep_rows <- keep_rows & within_brush(df[[yvar]], brush, "y") } # Find which rows are matches for the panel vars (if present) @@ -281,8 +278,8 @@ nearPoints <- function(df, coordinfo, xvar = NULL, yvar = NULL, stop("nearPoints: `yvar` ('", yvar ,"') not in names of input") # Extract data values from the data frame - x <- asNumber(df[[xvar]]) - y <- asNumber(df[[yvar]]) + x <- asNumber(df[[xvar]], coordinfo$domain$discrete_limits$x) + y <- asNumber(df[[yvar]], coordinfo$domain$discrete_limits$y) # Get the coordinates of the point (in img pixel coordinates) point_img <- coordinfo$coords_img @@ -402,11 +399,27 @@ nearPoints <- function(df, coordinfo, xvar = NULL, yvar = NULL, # ..$ y: NULL # $ .nonce : num 0.603 - +# Helper to determine if data values are within the limits of +# an input brush +within_brush <- function(vals, brush, var = "x") { + var <- match.arg(var, c("x", "y")) + vals <- asNumber(vals, brush$domain$discrete_limits[[var]]) + # It's possible for a non-missing data values to not + # map to the axis limits, for example: + # https://github.com/rstudio/shiny/pull/2410#issuecomment-488100881 + !is.na(vals) & + vals >= brush[[paste0(var, "min")]] & + vals <= brush[[paste0(var, "max")]] +} # Coerce various types of variables to numbers. This works for Date, POSIXt, # characters, and factors. Used because the mouse coords are numeric. -asNumber <- function(x) { +# The `levels` argument should be used when mapping this variable to +# a known set of discrete levels, which is needed for ggplot2 since +# it allows you to control ordering and possible values of a discrete +# positional scale (#2410) +asNumber <- function(x, levels = NULL) { + if (length(levels)) return(match(x, levels)) if (is.character(x)) x <- as.factor(x) if (is.factor(x)) x <- as.integer(x) as.numeric(x) diff --git a/R/render-plot.R b/R/render-plot.R index adc5f9509..1d7c23f50 100644 --- a/R/render-plot.R +++ b/R/render-plot.R @@ -353,62 +353,88 @@ custom_print.ggplot <- function(x) { # With a faceted ggplot2 plot, the outer list contains two objects, each of # which represents one panel. In this example, there is one panelvar, but there # can be up to two of them. -# mtc <- mtcars -# mtc$am <- factor(mtc$am) -# p <- print(ggplot(mtc, aes(wt, mpg)) + geom_point() + facet_wrap(~ am)) -# str(getGgplotCoordmap(p, 400, 300, 72)) +# p <- print(ggplot(mpg) + geom_point(aes(fl, cty), alpha = 0.2) + facet_wrap(~drv, scales = "free_x")) +# str(getGgplotCoordmap(p, 500, 400, 72)) # List of 2 -# $ panels:List of 2 +# $ panels:List of 3 # ..$ :List of 8 # .. ..$ panel : num 1 # .. ..$ row : int 1 # .. ..$ col : int 1 # .. ..$ panel_vars:List of 1 -# .. .. ..$ panelvar1: Factor w/ 2 levels "0","1": 1 +# .. .. ..$ panelvar1: chr "4" # .. ..$ log :List of 2 # .. .. ..$ x: NULL # .. .. ..$ y: NULL -# .. ..$ domain :List of 4 -# .. .. ..$ left : num 1.32 -# .. .. ..$ right : num 5.62 -# .. .. ..$ bottom: num 9.22 -# .. .. ..$ top : num 35.1 +# .. ..$ domain :List of 5 +# .. .. ..$ left : num 0.4 +# .. .. ..$ right : num 4.6 +# .. .. ..$ bottom : num 7.7 +# .. .. ..$ top : num 36.3 +# .. .. ..$ discrete_limits:List of 1 +# .. .. .. ..$ x: chr [1:4] "d" "e" "p" "r" # .. ..$ mapping :List of 3 -# .. .. ..$ x : chr "wt" -# .. .. ..$ y : chr "mpg" -# .. .. ..$ panelvar1: chr "am" +# .. .. ..$ x : chr "fl" +# .. .. ..$ y : chr "cty" +# .. .. ..$ panelvar1: chr "drv" # .. ..$ range :List of 4 # .. .. ..$ left : num 33.3 -# .. .. ..$ right : num 191 -# .. .. ..$ bottom: num 328 +# .. .. ..$ right : num 177 +# .. .. ..$ bottom: num 448 # .. .. ..$ top : num 23.1 # ..$ :List of 8 # .. ..$ panel : num 2 # .. ..$ row : int 1 # .. ..$ col : int 2 # .. ..$ panel_vars:List of 1 -# .. .. ..$ panelvar1: Factor w/ 2 levels "0","1": 2 +# .. .. ..$ panelvar1: chr "f" # .. ..$ log :List of 2 # .. .. ..$ x: NULL # .. .. ..$ y: NULL -# .. ..$ domain :List of 4 -# .. .. ..$ left : num 1.32 -# .. .. ..$ right : num 5.62 -# .. .. ..$ bottom: num 9.22 -# .. .. ..$ top : num 35.1 +# .. ..$ domain :List of 5 +# .. .. ..$ left : num 0.4 +# .. .. ..$ right : num 5.6 +# .. .. ..$ bottom : num 7.7 +# .. .. ..$ top : num 36.3 +# .. .. ..$ discrete_limits:List of 1 +# .. .. .. ..$ x: chr [1:5] "c" "d" "e" "p" ... # .. ..$ mapping :List of 3 -# .. .. ..$ x : chr "wt" -# .. .. ..$ y : chr "mpg" -# .. .. ..$ panelvar1: chr "am" +# .. .. ..$ x : chr "fl" +# .. .. ..$ y : chr "cty" +# .. .. ..$ panelvar1: chr "drv" # .. ..$ range :List of 4 -# .. .. ..$ left : num 197 -# .. .. ..$ right : num 355 -# .. .. ..$ bottom: num 328 +# .. .. ..$ left : num 182 +# .. .. ..$ right : num 326 +# .. .. ..$ bottom: num 448 +# .. .. ..$ top : num 23.1 +# ..$ :List of 8 +# .. ..$ panel : num 3 +# .. ..$ row : int 1 +# .. ..$ col : int 3 +# .. ..$ panel_vars:List of 1 +# .. .. ..$ panelvar1: chr "r" +# .. ..$ log :List of 2 +# .. .. ..$ x: NULL +# .. .. ..$ y: NULL +# .. ..$ domain :List of 5 +# .. .. ..$ left : num 0.4 +# .. .. ..$ right : num 3.6 +# .. .. ..$ bottom : num 7.7 +# .. .. ..$ top : num 36.3 +# .. .. ..$ discrete_limits:List of 1 +# .. .. .. ..$ x: chr [1:3] "e" "p" "r" +# .. ..$ mapping :List of 3 +# .. .. ..$ x : chr "fl" +# .. .. ..$ y : chr "cty" +# .. .. ..$ panelvar1: chr "drv" +# .. ..$ range :List of 4 +# .. .. ..$ left : num 331 +# .. .. ..$ right : num 475 +# .. .. ..$ bottom: num 448 # .. .. ..$ top : num 23.1 # $ dims :List of 2 -# ..$ width : num 400 -# ..$ height: num 300 - +# ..$ width : num 500 +# ..$ height: num 400 getCoordmap <- function(x, width, height, res) { if (inherits(x, "ggplot_build_gtable")) { @@ -570,6 +596,9 @@ find_panel_info_api <- function(b) { domain$bottom <- -domain$bottom } + domain <- add_discrete_limits(domain, xscale, "x") + domain <- add_discrete_limits(domain, yscale, "y") + domain } @@ -689,6 +718,9 @@ find_panel_info_non_api <- function(b, ggplot_format) { domain$bottom <- -domain$bottom } + domain <- add_discrete_limits(domain, xscale, "x") + domain <- add_discrete_limits(domain, yscale, "y") + domain } @@ -995,3 +1027,23 @@ find_panel_ranges <- function(g, res) { ) }) } + +# Remember the x/y limits of discrete axes. This info is +# necessary to properly inverse map the numeric (i.e., trained) +# positions back to the data scale, for example: +# https://github.com/rstudio/shiny/pull/2410#issuecomment-487783828 +# https://github.com/rstudio/shiny/pull/2410#issuecomment-488100881 +# +# Eventually, we may want to consider storing the entire ggplot2 +# object server-side and querying information from that object +# as we need it...that's the only way we'll ever be able to +# faithfully brush examples like this: +# https://github.com/rstudio/shiny/issues/2411 +add_discrete_limits <- function(domain, scale, var = "x") { + var <- match.arg(var, c("x", "y")) + if (!is.function(scale$is_discrete) || !is.function(scale$get_limits)) return(domain) + if (scale$is_discrete()) { + domain$discrete_limits[[var]] <- scale$get_limits() + } + domain +} diff --git a/tests/testthat/test-plot-coordmap.R b/tests/testthat/test-plot-coordmap.R index 1584f5c7a..d6731a970 100644 --- a/tests/testthat/test-plot-coordmap.R +++ b/tests/testthat/test-plot-coordmap.R @@ -14,7 +14,7 @@ test_that("ggplot coordmap", { dat <- data.frame(xvar = c(0, 5), yvar = c(10, 20)) tmpfile <- tempfile("test-shiny", fileext = ".png") - on.exit(rm(tmpfile)) + on.exit(unlink(tmpfile)) # Basic scatterplot p <- ggplot(dat, aes(xvar, yvar)) + geom_point() + @@ -75,7 +75,7 @@ test_that("ggplot coordmap with facet_wrap", { g = c("a", "b", "c")) tmpfile <- tempfile("test-shiny", fileext = ".png") - on.exit(rm(tmpfile)) + on.exit(unlink(tmpfile)) # facet_wrap p <- ggplot(dat, aes(xvar, yvar)) + geom_point() + @@ -123,7 +123,7 @@ test_that("ggplot coordmap with facet_grid", { g = c("a", "b", "c")) tmpfile <- tempfile("test-shiny", fileext = ".png") - on.exit(rm(tmpfile)) + on.exit(unlink(tmpfile)) p <- ggplot(dat, aes(xvar, yvar)) + geom_point() + scale_x_continuous(expand = c(0, 0)) + @@ -209,7 +209,7 @@ test_that("ggplot coordmap with 2D facet_grid", { g = c("a", "b"), h = c("i", "j")) tmpfile <- tempfile("test-shiny", fileext = ".png") - on.exit(rm(tmpfile)) + on.exit(unlink(tmpfile)) p <- ggplot(dat, aes(xvar, yvar)) + geom_point() + scale_x_continuous(expand = c(0, 0)) + @@ -259,7 +259,7 @@ test_that("ggplot coordmap with 2D facet_grid", { test_that("ggplot coordmap with various data types", { tmpfile <- tempfile("test-shiny", fileext = ".png") - on.exit(rm(tmpfile)) + on.exit(unlink(tmpfile)) # Factors dat <- expand.grid(xvar = letters[1:3], yvar = LETTERS[1:4]) @@ -271,9 +271,20 @@ test_that("ggplot coordmap with various data types", { dev.off() # Check domain + expectation <- list( + left = 1, + right = 3, + bottom = 1, + top = 4, + discrete_limits = list( + x = letters[1:3], + y = LETTERS[1:4] + ) + ) + expect_equal( sortList(m$panels[[1]]$domain), - sortList(list(left=1, right=3, bottom=1, top=4)) + sortList(expectation) ) # Dates and date-times @@ -302,7 +313,7 @@ test_that("ggplot coordmap with various data types", { test_that("ggplot coordmap with various scales and coords", { tmpfile <- tempfile("test-shiny", fileext = ".png") - on.exit(rm(tmpfile)) + on.exit(unlink(tmpfile)) # Reversed scales dat <- data.frame(xvar = c(0, 5), yvar = c(10, 20)) @@ -357,3 +368,103 @@ test_that("ggplot coordmap with various scales and coords", { sortList(list(left=-1, right=3, bottom=-2, top=4)) ) }) + + +test_that("ggplot coordmap maintains discrete limits", { + tmpfile <- tempfile("test-shiny", fileext = ".png") + on.exit(unlink(tmpfile)) + + # check discrete limits are correct for free x scales + p <- ggplot(mpg) + + geom_point(aes(fl, cty), alpha = 0.2) + + facet_wrap(~drv, scales = "free_x") + png(tmpfile) + m <- getGgplotCoordmap(print(p), 500, 400, 72) + dev.off() + + expect_length(m$panels, 3) + expect_equal( + m$panels[[1]]$domain$discrete_limits, + list(x = c("d", "e", "p", "r")) + ) + expect_equal( + m$panels[[2]]$domain$discrete_limits, + list(x = c("c", "d", "e", "p", "r")) + ) + expect_equal( + m$panels[[3]]$domain$discrete_limits, + list(x = c("e", "p", "r")) + ) + + # same for free y + p2 <- ggplot(mpg) + + geom_point(aes(cty, fl), alpha = 0.2) + + facet_wrap(~drv, scales = "free_y") + png(tmpfile) + m2 <- getGgplotCoordmap(print(p2), 500, 400, 72) + dev.off() + + expect_length(m2$panels, 3) + expect_equal( + m2$panels[[1]]$domain$discrete_limits, + list(y = c("d", "e", "p", "r")) + ) + expect_equal( + m2$panels[[2]]$domain$discrete_limits, + list(y = c("c", "d", "e", "p", "r")) + ) + expect_equal( + m2$panels[[3]]$domain$discrete_limits, + list(y = c("e", "p", "r")) + ) + + # check that specifying x limits is captured + p3 <- ggplot(mpg) + + geom_point(aes(fl, cty), alpha = 0.2) + + scale_x_discrete(limits = c("c", "d", "e")) + + png(tmpfile) + m3 <- getGgplotCoordmap(suppressWarnings(print(p3)), 500, 400, 72) + dev.off() + + expect_length(m3$panels, 1) + expect_equal( + m3$panels[[1]]$domain$discrete_limits, + list(x = c("c", "d", "e")) + ) + + # same for y + p4 <- ggplot(mpg) + + geom_point(aes(cty, fl), alpha = 0.2) + + scale_y_discrete(limits = c("e", "f")) + + png(tmpfile) + m4 <- getGgplotCoordmap(suppressWarnings(print(p4)), 500, 400, 72) + dev.off() + + expect_length(m4$panels, 1) + expect_equal( + m4$panels[[1]]$domain$discrete_limits, + list(y = c("e", "f")) + ) + + # make sure that when labels are specified, where + # still relaying the input data + p5 <- ggplot(mpg) + + geom_point(aes(fl, cty), alpha = 0.2) + + scale_x_discrete( + limits = c("e", "f"), + labels = c("foo", "bar") + ) + + png(tmpfile) + m5 <- getGgplotCoordmap(suppressWarnings(print(p5)), 500, 400, 72) + dev.off() + + expect_length(m5$panels, 1) + expect_equal( + m5$panels[[1]]$domain$discrete_limits, + list(x = c("e", "f")) + ) + +})