diff --git a/NAMESPACE b/NAMESPACE index 2500034b..cbf04c7e 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -10,6 +10,7 @@ S3method(apply_scale_defaults,scale_numeric) S3method(apply_scale_defaults,scale_ordinal) S3method(as.character,prop_band) S3method(as.character,prop_constant) +S3method(as.character,prop_group) S3method(as.character,prop_reactive) S3method(as.character,prop_variable) S3method(as.data.frame,singular) @@ -94,6 +95,7 @@ S3method(new_prop,band) S3method(new_prop,call) S3method(new_prop,default) S3method(new_prop,formula) +S3method(new_prop,groupwise) S3method(new_prop,name) S3method(new_prop,prop) S3method(new_prop,reactive) @@ -112,19 +114,23 @@ S3method(print,singular) S3method(print,template) S3method(prop_domain,prop_band) S3method(prop_domain,prop_constant) +S3method(prop_domain,prop_group) S3method(prop_domain,prop_reactive) S3method(prop_domain,prop_variable) S3method(prop_label,prop_band) S3method(prop_label,prop_constant) +S3method(prop_label,prop_group) S3method(prop_label,prop_reactive) S3method(prop_label,prop_variable) S3method(prop_type,data.frame) S3method(prop_value,prop_band) S3method(prop_value,prop_constant) +S3method(prop_value,prop_group) S3method(prop_value,prop_reactive) S3method(prop_value,prop_variable) S3method(prop_vega,prop_band) S3method(prop_vega,prop_constant) +S3method(prop_vega,prop_group) S3method(prop_vega,prop_reactive) S3method(prop_vega,prop_variable) S3method(remove_missing,data.frame) @@ -216,6 +222,7 @@ export(group_by_.ggvis) export(group_by_.reactive) export(groups.ggvis) export(groups.reactive) +export(groupwise) export(handle_brush) export(handle_click) export(handle_hover) @@ -245,6 +252,7 @@ export(is.prop_variable) export(is.scaled_value) export(knit_print.ggvis) export(layer_arcs) +export(layer_axial_lines) export(layer_bars) export(layer_boxplots) export(layer_densities) diff --git a/R/ggvis.R b/R/ggvis.R index b8b359a4..7ace2f0b 100644 --- a/R/ggvis.R +++ b/R/ggvis.R @@ -290,6 +290,14 @@ register_scales_from_props <- function(vis, props) { label <- NULL } + if (is.prop_group(prop) && prop_is_scaled(prop)) { + vis <- add_scale( + vis, + ggvis_scale(property = propname_to_scale(prop$property), + name = prop$scale, label = label) + ) + return(vis) + } if (is.prop_band(prop)) { # band() requires points = FALSE vis <- add_scale( diff --git a/R/layer_axial.R b/R/layer_axial.R new file mode 100644 index 00000000..5d19e99e --- /dev/null +++ b/R/layer_axial.R @@ -0,0 +1,63 @@ +#' Draw vertical or horizontal lines +#' +#' This adds axial lines to the plot, that is, lines that are parallel +#' to the axes. For each \code{x}, a vertical line spanning the +#' plot is created. Each \code{y} will result in a vertical line. +#' @inheritParams marks +#' @export +#' @examples +#' # In this example we will represent graphically the means of the +#' # mixture components of the faithful dataset. +#' # First we compute the means of each component: +#' library("dplyr") +#' means <- faithful %>% +#' mutate(left = eruptions < 3) %>% +#' group_by(left) %>% +#' summarise(values = mean(eruptions)) +#' +#' # Now we draw vertical lines corresponding to those means, plus an +#' # horizontal line 100 pixel from the top of the plot +#' ggvis(faithful) %>% +#' layer_histograms(~eruptions) %>% +#' layer_axial_lines(data = means, +#' x = ~values, y := 100, +#' stroke := "red", strokeWidth := 4 +#' ) +layer_axial_lines <- function(vis, ..., data = NULL) { + props <- props(..., env = parent.frame()) + props_names <- trim_prop_event(names(props)) + + is_x <- "x" == props_names + is_y <- "y" == props_names + + if ("x2" %in% props_names || "y2" %in% props_names) { + stop("Cannot have x2 or y2 property", call. = FALSE) + } + if (sum(is_x) > 1 || sum(is_y) > 1) { + stop("Cannot have more than one event for x and y", call. = FALSE) + } + + if (any(is_x)) { + x2_prop <- props[[which(is_x)]] + x2_prop$property <- "x2" + x2_prop_name <- paste0("x2.", x2_prop$event) + v_props <- props[!is_y] + v_props[[x2_prop_name]] <- x2_prop + v_props$y <- prop("y", 0) + v_props$y2 <- prop("y2", groupwise("height")) + vis <- add_mark(vis, "rule", v_props, data, deparse2(substitute(data))) + } + + if (any(is_y)) { + y2_prop <- props[[which(is_y)]] + y2_prop$property <- "y2" + y2_prop_name <- paste0("y2.", y2_prop$event) + h_props <- props[!is_x] + h_props[[y2_prop_name]] <- y2_prop + h_props$x <- prop("x", 0) + h_props$x2 <- prop("x2", groupwise("width")) + vis <- add_mark(vis, "rule", h_props, data, deparse2(substitute(data))) + } + + vis +} diff --git a/R/marks.R b/R/marks.R index cec5c539..264bdfcd 100644 --- a/R/marks.R +++ b/R/marks.R @@ -113,6 +113,7 @@ valid_props <- list( image = c(common_valid_props, "x2", "y2", "width", "height", "url", "align", "baseline"), line = c(common_valid_props, "interpolate", "tension"), + rule = c(common_valid_props, "x2", "y2", "width", "height"), rect = c(common_valid_props, "x2", "y2", "width", "height"), symbol = c(common_valid_props, "size", "shape"), text = c(common_valid_props, "text", "align", "baseline", "dx", "dy", "angle", @@ -144,6 +145,7 @@ default_props <- function(type) { arc = props(fill := "#333333"), area = props(fill := "#333333"), line = props(stroke := "#000000"), + rule = props(stroke := "#000000"), image = props(fill := "#000000"), rect = props(stroke := "#000000", fill := "#333333"), symbol = props(fill := "#000000", size := 50), diff --git a/R/prop_group.R b/R/prop_group.R new file mode 100644 index 00000000..91926d1b --- /dev/null +++ b/R/prop_group.R @@ -0,0 +1,94 @@ +#' Groupwise property +#' +#' \code{groupwise()} is used to refer to properties of the plot or +#' subvisualisation, typically the height or the width. +#' @param prop Name of the group property. Typically "height" or "width". +#' @param offset,mult Additive and multiplicate offsets. +#' @export +#' @examples +#' # In the following example, we draw a rectangle running vertically +#' # across the plot by referring to its total height +#' ggvis(faithful) %>% +#' layer_histograms(~eruptions) %>% +#' emit_rects(props( +#' x = ~mean(eruptions), width := 40, +#' y := 0, y2 := groupwise("height"), +#' fill := "red" +#' )) +#' +#' # The mult factor is useful to draw elements at fixed fractions +#' # of the plot: +#' ggvis(mtcars, ~mpg) %>% +#' layer_histograms() %>% +#' layer_axial_lines(y := groupwise("height", mult = 0.5), +#' stroke := "red", strokeWidth := 4) +#' +#' # Combining mult and offset makes it is easy to place elements where +#' # you want them +#' ggvis(faithful) %>% +#' layer_histograms(~eruptions) %>% +#' emit_rects(props( +#' x := 30, x2 := groupwise("width", -15, 0.5), +#' y := 30, y2 := groupwise("height", -30), +#' fill := "red" +#' )) %>% +#' emit_rects(props( +#' x := groupwise("width", 15, 0.5), x2 := groupwise("width", -30), +#' y := groupwise("height", -30), y2 := 30, +#' fill := "blue" +#' )) +groupwise <- function(prop, offset = NULL, mult = NULL) { + structure( + list(group_prop = prop, offset = offset, mult = mult), + class = c("groupwise") + ) +} + +#' @export +new_prop.groupwise <- function(x, property, scale, offset, mult, env, event, + label) { + structure( + list( + property = property, + scale = decide_scale(scale %||% FALSE, property), + offset = x$offset, + mult = x$mult, + event = event, + env = NULL, + group_prop = x$group_prop + ), + class = c("prop_group", "prop") + ) +} + +#' @export +as.character.prop_group <- function(x, ...) "" + +#' @rdname groupwise +#' @param x object to test for group-ness +is.prop_group <- function(x) inherits(x, "prop_group") + +#' @export +prop_value.prop_group <- function(x, data) { + NULL +} + +#' @export +prop_label.prop_group <- function(x) { + "" +} + +#' @export +prop_domain.prop_group <- function(x, data) { + NULL +} + +#' @export +prop_vega.prop_group <- function(x, default_scale) { + compact(list( + scale = x$scale, + mult = x$mult, + offset = x$offset, + group = x$group_prop + )) +} diff --git a/R/vega.R b/R/vega.R index f0b1861d..3339f4e1 100644 --- a/R/vega.R +++ b/R/vega.R @@ -145,6 +145,12 @@ as.vega.mark <- function(mark, in_group = FALSE) { } } + # Don't include reference to data when no prop needs it + is_variable <- vapply(mark$props, is.prop_variable, logical(1)) + if (!any(is_variable)) { + m$from <- NULL + } + if (!is.null(key)) { m$key <- paste0("data.", safe_vega_var(prop_label(key))) } diff --git a/man/groupwise.Rd b/man/groupwise.Rd new file mode 100644 index 00000000..5489c418 --- /dev/null +++ b/man/groupwise.Rd @@ -0,0 +1,56 @@ +% Generated by roxygen2 (4.1.0): do not edit by hand +% Please edit documentation in R/prop_group.R +\name{groupwise} +\alias{groupwise} +\alias{is.prop_group} +\title{Groupwise property} +\usage{ +groupwise(prop, offset = NULL, mult = NULL) + +is.prop_group(x) +} +\arguments{ +\item{prop}{Name of the group property. Typically "height" or "width".} + +\item{offset,mult}{Additive and multiplicate offsets.} + +\item{x}{object to test for group-ness} +} +\description{ +\code{groupwise()} is used to refer to properties of the plot or +subvisualisation, typically the height or the width. +} +\examples{ +# In the following example, we draw a rectangle running vertically +# across the plot by referring to its total height +ggvis(faithful) \%>\% + layer_histograms(~eruptions) \%>\% + emit_rects(props( + x = ~mean(eruptions), width := 40, + y := 0, y2 := groupwise("height"), + fill := "red" + )) + +# The mult factor is useful to draw elements at fixed fractions +# of the plot: +ggvis(mtcars, ~mpg) \%>\% + layer_histograms() \%>\% + layer_axial_lines(y := groupwise("height", mult = 0.5), + stroke := "red", strokeWidth := 4) + +# Combining mult and offset makes it is easy to place elements where +# you want them +ggvis(faithful) \%>\% + layer_histograms(~eruptions) \%>\% + emit_rects(props( + x := 30, x2 := groupwise("width", -15, 0.5), + y := 30, y2 := groupwise("height", -30), + fill := "red" + )) \%>\% + emit_rects(props( + x := groupwise("width", 15, 0.5), x2 := groupwise("width", -30), + y := groupwise("height", -30), y2 := 30, + fill := "blue" + )) +} + diff --git a/man/layer_axial_lines.Rd b/man/layer_axial_lines.Rd new file mode 100644 index 00000000..cd803f7b --- /dev/null +++ b/man/layer_axial_lines.Rd @@ -0,0 +1,42 @@ +% Generated by roxygen2 (4.1.0): do not edit by hand +% Please edit documentation in R/layer_axial.R +\name{layer_axial_lines} +\alias{layer_axial_lines} +\title{Draw vertical or horizontal lines} +\usage{ +layer_axial_lines(vis, ..., data = NULL) +} +\arguments{ +\item{vis}{Visualisation to modify} + +\item{...}{A \code{\link{props}} object, named according to the +properties listed below.} + +\item{data}{An optional dataset, if you want to override the usual data +inheritance for this mark.} +} +\description{ +This adds axial lines to the plot, that is, lines that are parallel +to the axes. For each \code{x}, a vertical line spanning the +plot is created. Each \code{y} will result in a vertical line. +} +\examples{ +# In this example we will represent graphically the means of the +# mixture components of the faithful dataset. +# First we compute the means of each component: +library("dplyr") +means <- faithful \%>\% + mutate(left = eruptions < 3) \%>\% + group_by(left) \%>\% + summarise(values = mean(eruptions)) + +# Now we draw vertical lines corresponding to those means, plus an +# horizontal line 100 pixel from the top of the plot +ggvis(faithful) \%>\% + layer_histograms(~eruptions) \%>\% + layer_axial_lines(data = means, + x = ~values, y := 100, + stroke := "red", strokeWidth := 4 + ) +} + diff --git a/tests/testthat/test-props.r b/tests/testthat/test-props.r index 7011a640..42c6a288 100644 --- a/tests/testthat/test-props.r +++ b/tests/testthat/test-props.r @@ -312,3 +312,20 @@ test_that("band() is created properly", { expect_error(prop("x", band())) expect_error(props(x = band())) }) + +test_that("groupwise() is created properly", { + # Group property is correctly set + expect_identical(prop("y", groupwise("height"))$group_prop, "height") + + # Automatic setting of scale, event + test_prop(prop("y", groupwise("height")), "y", NULL, NULL, "update") + + # Explicit settings of scale, event + test_prop(prop("x", groupwise("height"), scale = "x"), "x", NULL, "x") + test_prop(prop("x", groupwise("height"), event = "enter"), "x", NULL, NULL, "enter") + test_prop(prop("x", groupwise("height"), scale = "foo"), "x", NULL, "foo") + + # Create with props() + test_prop(props("y" = groupwise("width"))$y.update, "y", NULL, "y", "update") + test_prop(props(y.enter = groupwise("width"))$y.enter, "y", NULL, "y", "enter") +})