mirror of
https://github.com/rstudio/shiny.git
synced 2026-04-07 03:00:20 -04:00
Send variable mappings in coordmap
This commit is contained in:
Winston Chang
@@ -156,8 +156,12 @@ getPrevPlotCoordmap <- function(width, height) {
|
||||
log = list(
|
||||
x = if (par('xlog')) 10 else NULL,
|
||||
y = if (par('ylog')) 10 else NULL
|
||||
))
|
||||
)
|
||||
),
|
||||
# We can't extract the original variable names from a base graphic.
|
||||
# `mapping` is an empty _named_ list, so that it is converted to an object
|
||||
# (not an array) in JSON.
|
||||
mapping = list(x = NULL)[0]
|
||||
))
|
||||
}
|
||||
|
||||
# Print a ggplot object and return a coordmap for it.
|
||||
@@ -219,7 +223,8 @@ getGgplotCoordmap <- function(p, pixelratio) {
|
||||
scale_x = scale_x,
|
||||
scale_y = scale_x,
|
||||
log = check_log_scales(b, scale_x, scale_y),
|
||||
domain = find_panel_domain(b, l$PANEL, scale_x, scale_y)
|
||||
domain = find_panel_domain(b, l$PANEL, scale_x, scale_y),
|
||||
mapping = find_mappings(b)
|
||||
)
|
||||
})
|
||||
}
|
||||
@@ -297,6 +302,41 @@ getGgplotCoordmap <- function(p, pixelratio) {
|
||||
)
|
||||
}
|
||||
|
||||
# Given a built ggplot object, return a named list of variables mapped to x
|
||||
# and y. This function will be called for each panel, but in practice the
|
||||
# result is always the same across panels, so we'll cache the result.
|
||||
mappings_cache <- NULL
|
||||
find_mappings <- function(b) {
|
||||
if (!is.null(mappings_cache))
|
||||
return(mappings_cache)
|
||||
|
||||
mappings <- lapply(b$plot$mapping, as.character)
|
||||
|
||||
# If x or y mapping is missing, look in each layer for mappings and return
|
||||
# the first one.
|
||||
missing_mappings <- setdiff(c("x", "y"), names(mappings))
|
||||
if (length(missing_mappings) != 0) {
|
||||
# Grab mappings for each layer
|
||||
layer_mappings <- lapply(b$plot$layers, function(layer) {
|
||||
lapply(layer$mapping, as.character)
|
||||
})
|
||||
|
||||
# Get just the first x or y value in the combined list of plot and layer
|
||||
# mappings.
|
||||
mappings <- c(list(mappings), layer_mappings)
|
||||
mappings <- Reduce(x = mappings, init = list(x = NULL, y = NULL),
|
||||
function(init, m) {
|
||||
if (is.null(init$x) && !is.null(m$x)) init$x <- m$x
|
||||
if (is.null(init$y) && !is.null(m$y)) init$y <- m$y
|
||||
init
|
||||
}
|
||||
)
|
||||
}
|
||||
|
||||
mappings_cache <<- mappings
|
||||
mappings
|
||||
}
|
||||
|
||||
# Given a gtable object, return the x and y ranges (in pixel dimensions)
|
||||
find_panel_ranges <- function(g, pixelratio) {
|
||||
# Given a vector of unit objects, return logical vector indicating which ones
|
||||
|
||||
267
inst/tests/test-plot-coordmap.R
Normal file
267
inst/tests/test-plot-coordmap.R
Normal file
@@ -0,0 +1,267 @@
|
||||
context("plot-coordmap")
|
||||
library(ggplot2)
|
||||
|
||||
# Sort a list by the names of its keys
|
||||
sortList <- function(x) {
|
||||
x[sort(names(x))]
|
||||
}
|
||||
|
||||
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))
|
||||
|
||||
# Basic scatterplot
|
||||
p <- ggplot(dat, aes(xvar, yvar)) + geom_point() +
|
||||
scale_x_continuous(expand = c(0, 0)) +
|
||||
scale_y_continuous(expand = c(0, 0))
|
||||
png(tmpfile)
|
||||
m <- getGgplotCoordmap(p, 1)
|
||||
dev.off()
|
||||
# Check mapping vars
|
||||
expect_equal(m[[1]]$mapping, list(x = "xvar", y = "yvar"))
|
||||
# Check domain
|
||||
expect_equal(
|
||||
sortList(m[[1]]$domain),
|
||||
sortList(list(left=0, right=5, bottom=10, top=20))
|
||||
)
|
||||
|
||||
|
||||
# Scatterplot where aes() is declared in geom
|
||||
p <- ggplot(dat, aes(xvar)) + geom_point(aes(y=yvar))
|
||||
png(tmpfile)
|
||||
m <- getGgplotCoordmap(p, 1)
|
||||
dev.off()
|
||||
# Check mapping vars
|
||||
expect_equal(m[[1]]$mapping, list(x = "xvar", y = "yvar"))
|
||||
|
||||
|
||||
# Scatterplot where aes() is declared in plot and in geom
|
||||
p <- ggplot(dat, aes(xvar, yvar)) + geom_point(aes(y=xvar))
|
||||
png(tmpfile)
|
||||
m <- getGgplotCoordmap(p, 1)
|
||||
dev.off()
|
||||
# Check mapping vars
|
||||
expect_equal(m[[1]]$mapping, list(x = "xvar", y = "yvar"))
|
||||
|
||||
|
||||
# Plot with computed variable (histogram)
|
||||
p <- ggplot(dat, aes(xvar)) + geom_histogram(binwidth=1)
|
||||
png(tmpfile)
|
||||
m <- getGgplotCoordmap(p, 1)
|
||||
dev.off()
|
||||
# Check mapping vars - no value for y
|
||||
expect_equal(m[[1]]$mapping, list(x = "xvar", y = NULL))
|
||||
})
|
||||
|
||||
|
||||
test_that("ggplot coordmap with facet_wrap", {
|
||||
dat <- data.frame(xvar = c(0, 5, 10), yvar = c(10, 20, 30),
|
||||
g = c("a", "b", "c"))
|
||||
|
||||
tmpfile <- tempfile("test-shiny", fileext = ".png")
|
||||
on.exit(rm(tmpfile))
|
||||
|
||||
# facet_wrap
|
||||
p <- ggplot(dat, aes(xvar, yvar)) + geom_point() +
|
||||
scale_x_continuous(expand = c(0, 0)) +
|
||||
scale_y_continuous(expand = c(0, 0)) +
|
||||
facet_wrap(~ g, ncol = 2)
|
||||
png(tmpfile)
|
||||
m <- getGgplotCoordmap(p, 1)
|
||||
dev.off()
|
||||
|
||||
# Should have 3 panels
|
||||
expect_equal(length(m), 3)
|
||||
expect_equal(m[[1]]$panel, 1)
|
||||
expect_equal(m[[1]]$row, 1)
|
||||
expect_equal(m[[1]]$col, 1)
|
||||
expect_equal(m[[2]]$panel, 2)
|
||||
expect_equal(m[[2]]$row, 1)
|
||||
expect_equal(m[[2]]$col, 2)
|
||||
expect_equal(m[[3]]$panel, 3)
|
||||
expect_equal(m[[3]]$row, 2)
|
||||
expect_equal(m[[3]]$col, 1)
|
||||
|
||||
# Check mapping vars
|
||||
expect_equal(m[[1]]$mapping, list(x = "xvar", y = "yvar"))
|
||||
expect_equal(m[[1]]$mapping, m[[2]]$mapping)
|
||||
expect_equal(m[[2]]$mapping, m[[3]]$mapping)
|
||||
# Check domain
|
||||
expect_equal(
|
||||
sortList(m[[1]]$domain),
|
||||
sortList(list(left=0, right=10, bottom=10, top=30))
|
||||
)
|
||||
expect_equal(sortList(m[[1]]$domain), sortList(m[[2]]$domain))
|
||||
expect_equal(sortList(m[[2]]$domain), sortList(m[[3]]$domain))
|
||||
|
||||
# Check panel vars
|
||||
factor_vals <- dat$g
|
||||
expect_equal(m[[1]]$vars, list(list(name = "g", value = factor_vals[1])))
|
||||
expect_equal(m[[2]]$vars, list(list(name = "g", value = factor_vals[2])))
|
||||
expect_equal(m[[3]]$vars, list(list(name = "g", value = factor_vals[3])))
|
||||
})
|
||||
|
||||
|
||||
test_that("ggplot coordmap with facet_grid", {
|
||||
dat <- data.frame(xvar = c(0, 5, 10), yvar = c(10, 20, 30),
|
||||
g = c("a", "b", "c"))
|
||||
|
||||
tmpfile <- tempfile("test-shiny", fileext = ".png")
|
||||
on.exit(rm(tmpfile))
|
||||
|
||||
p <- ggplot(dat, aes(xvar, yvar)) + geom_point() +
|
||||
scale_x_continuous(expand = c(0, 0)) +
|
||||
scale_y_continuous(expand = c(0, 0))
|
||||
|
||||
# facet_grid horizontal
|
||||
p1 <- p + facet_grid(. ~ g)
|
||||
png(tmpfile)
|
||||
m <- getGgplotCoordmap(p1, 1)
|
||||
dev.off()
|
||||
|
||||
# Should have 3 panels
|
||||
expect_equal(length(m), 3)
|
||||
expect_equal(m[[1]]$panel, 1)
|
||||
expect_equal(m[[1]]$row, 1)
|
||||
expect_equal(m[[1]]$col, 1)
|
||||
expect_equal(m[[2]]$panel, 2)
|
||||
expect_equal(m[[2]]$row, 1)
|
||||
expect_equal(m[[2]]$col, 2)
|
||||
expect_equal(m[[3]]$panel, 3)
|
||||
expect_equal(m[[3]]$row, 1)
|
||||
expect_equal(m[[3]]$col, 3)
|
||||
|
||||
# Check mapping vars
|
||||
expect_equal(m[[1]]$mapping, list(x = "xvar", y = "yvar"))
|
||||
expect_equal(m[[1]]$mapping, m[[2]]$mapping)
|
||||
expect_equal(m[[2]]$mapping, m[[3]]$mapping)
|
||||
# Check domain
|
||||
expect_equal(
|
||||
sortList(m[[1]]$domain),
|
||||
sortList(list(left=0, right=10, bottom=10, top=30))
|
||||
)
|
||||
expect_equal(sortList(m[[1]]$domain), sortList(m[[2]]$domain))
|
||||
expect_equal(sortList(m[[2]]$domain), sortList(m[[3]]$domain))
|
||||
|
||||
# Check panel vars
|
||||
factor_vals <- dat$g
|
||||
expect_equal(m[[1]]$vars, list(list(name = "g", value = factor_vals[1])))
|
||||
expect_equal(m[[2]]$vars, list(list(name = "g", value = factor_vals[2])))
|
||||
expect_equal(m[[3]]$vars, list(list(name = "g", value = factor_vals[3])))
|
||||
|
||||
|
||||
# facet_grid vertical
|
||||
p1 <- p + facet_grid(g ~ .)
|
||||
png(tmpfile)
|
||||
m <- getGgplotCoordmap(p1, 1)
|
||||
dev.off()
|
||||
|
||||
# Should have 3 panels
|
||||
expect_equal(length(m), 3)
|
||||
expect_equal(m[[1]]$panel, 1)
|
||||
expect_equal(m[[1]]$row, 1)
|
||||
expect_equal(m[[1]]$col, 1)
|
||||
expect_equal(m[[2]]$panel, 2)
|
||||
expect_equal(m[[2]]$row, 2)
|
||||
expect_equal(m[[2]]$col, 1)
|
||||
expect_equal(m[[3]]$panel, 3)
|
||||
expect_equal(m[[3]]$row, 3)
|
||||
expect_equal(m[[3]]$col, 1)
|
||||
|
||||
# Check mapping vars
|
||||
expect_equal(m[[1]]$mapping, list(x = "xvar", y = "yvar"))
|
||||
expect_equal(m[[1]]$mapping, m[[2]]$mapping)
|
||||
expect_equal(m[[2]]$mapping, m[[3]]$mapping)
|
||||
# Check domain
|
||||
expect_equal(
|
||||
sortList(m[[1]]$domain),
|
||||
sortList(list(left=0, right=10, bottom=10, top=30))
|
||||
)
|
||||
expect_equal(sortList(m[[1]]$domain), sortList(m[[2]]$domain))
|
||||
expect_equal(sortList(m[[2]]$domain), sortList(m[[3]]$domain))
|
||||
|
||||
# Check panel vars
|
||||
factor_vals <- dat$g
|
||||
expect_equal(m[[1]]$vars, list(list(name = "g", value = factor_vals[1])))
|
||||
expect_equal(m[[2]]$vars, list(list(name = "g", value = factor_vals[2])))
|
||||
expect_equal(m[[3]]$vars, list(list(name = "g", value = factor_vals[3])))
|
||||
})
|
||||
|
||||
|
||||
test_that("ggplot coordmap with 2D facet_grid", {
|
||||
dat <- data.frame(xvar = c(0, 5, 10, 15), yvar = c(10, 20, 30, 40),
|
||||
g = c("a", "b"), h = c("i", "j"))
|
||||
|
||||
tmpfile <- tempfile("test-shiny", fileext = ".png")
|
||||
on.exit(rm(tmpfile))
|
||||
|
||||
p <- ggplot(dat, aes(xvar, yvar)) + geom_point() +
|
||||
scale_x_continuous(expand = c(0, 0)) +
|
||||
scale_y_continuous(expand = c(0, 0))
|
||||
|
||||
p1 <- p + facet_grid(g ~ h)
|
||||
png(tmpfile)
|
||||
m <- getGgplotCoordmap(p1, 1)
|
||||
dev.off()
|
||||
|
||||
# Should have 4 panels
|
||||
expect_equal(length(m), 4)
|
||||
expect_equal(m[[1]]$panel, 1)
|
||||
expect_equal(m[[1]]$row, 1)
|
||||
expect_equal(m[[1]]$col, 1)
|
||||
expect_equal(m[[2]]$panel, 2)
|
||||
expect_equal(m[[2]]$row, 1)
|
||||
expect_equal(m[[2]]$col, 2)
|
||||
expect_equal(m[[3]]$panel, 3)
|
||||
expect_equal(m[[3]]$row, 2)
|
||||
expect_equal(m[[3]]$col, 1)
|
||||
expect_equal(m[[4]]$panel, 4)
|
||||
expect_equal(m[[4]]$row, 2)
|
||||
expect_equal(m[[4]]$col, 2)
|
||||
|
||||
# Check mapping vars
|
||||
expect_equal(m[[1]]$mapping, list(x = "xvar", y = "yvar"))
|
||||
expect_equal(m[[1]]$mapping, m[[2]]$mapping)
|
||||
expect_equal(m[[2]]$mapping, m[[3]]$mapping)
|
||||
expect_equal(m[[4]]$mapping, m[[4]]$mapping)
|
||||
# Check domain
|
||||
expect_equal(
|
||||
sortList(m[[1]]$domain),
|
||||
sortList(list(left=0, right=15, bottom=10, top=40))
|
||||
)
|
||||
expect_equal(sortList(m[[1]]$domain), sortList(m[[2]]$domain))
|
||||
expect_equal(sortList(m[[2]]$domain), sortList(m[[3]]$domain))
|
||||
expect_equal(sortList(m[[3]]$domain), sortList(m[[4]]$domain))
|
||||
|
||||
# Check panel vars
|
||||
expect_equal(
|
||||
m[[1]]$vars,
|
||||
list(
|
||||
list(name = "h", value = dat$h[1]),
|
||||
list(name = "g", value = dat$g[1])
|
||||
)
|
||||
)
|
||||
expect_equal(
|
||||
m[[2]]$vars,
|
||||
list(
|
||||
list(name = "h", value = dat$h[2]),
|
||||
list(name = "g", value = dat$g[1])
|
||||
)
|
||||
)
|
||||
expect_equal(
|
||||
m[[3]]$vars,
|
||||
list(
|
||||
list(name = "h", value = dat$h[1]),
|
||||
list(name = "g", value = dat$g[2])
|
||||
)
|
||||
)
|
||||
expect_equal(
|
||||
m[[4]]$vars,
|
||||
list(
|
||||
list(name = "h", value = dat$h[2]),
|
||||
list(name = "g", value = dat$g[2])
|
||||
)
|
||||
)
|
||||
})
|
||||
@@ -268,7 +268,11 @@ imageutils.initCoordmap = function($el, coordmap) {
|
||||
bottom: el.clientHeight - 1
|
||||
};
|
||||
|
||||
coordmap[0] = { domain: bounds, range: bounds };
|
||||
coordmap[0] = {
|
||||
domain: bounds,
|
||||
range: bounds,
|
||||
mapping: {}
|
||||
};
|
||||
}
|
||||
|
||||
// Add scaling functions to each panel
|
||||
@@ -417,6 +421,9 @@ imageutils.initCoordmap = function($el, coordmap) {
|
||||
}
|
||||
}
|
||||
|
||||
// Add variable name mappings
|
||||
coords.mapping = panel.mapping;
|
||||
|
||||
coords[".nonce"] = Math.random();
|
||||
exports.onInputChange(inputId, coords);
|
||||
};
|
||||
@@ -589,17 +596,20 @@ imageutils.createBrushHandler = function(inputId, $el, opts, coordmap) {
|
||||
return;
|
||||
}
|
||||
|
||||
var panel_vars = brush.getPanel().vars;
|
||||
var panel = brush.getPanel();
|
||||
|
||||
// Add the panel (facet) variables, if present
|
||||
if (panel_vars) {
|
||||
if (panel.vars) {
|
||||
var v;
|
||||
for (var i=0; i<panel_vars.length; i++) {
|
||||
v = panel_vars[i];
|
||||
for (var i=0; i<panel.vars.length; i++) {
|
||||
v = panel.vars[i];
|
||||
coords[v.name] = v.value;
|
||||
}
|
||||
}
|
||||
|
||||
// Add variable name mappings
|
||||
coords.mapping = panel.mapping;
|
||||
|
||||
// Send data to server
|
||||
exports.onInputChange(inputId, coords);
|
||||
}
|
||||
|
||||
Reference in New Issue
Block a user