From eae2b408988f6486cab8fc9747fdb2801e54e919 Mon Sep 17 00:00:00 2001 From: Winston Chang Date: Wed, 29 Apr 2015 11:45:24 -0500 Subject: [PATCH] Add nearPoints() function --- NAMESPACE | 1 + R/bootstrap.R | 30 ++++-- R/image-interact.R | 197 ++++++++++++++++++++++++++++++++++ man/imageOutput.Rd | 30 ++++-- man/nearPoints.Rd | 74 +++++++++++++ srcjs/output_binding_image.js | 10 ++ 6 files changed, 326 insertions(+), 16 deletions(-) create mode 100644 man/nearPoints.Rd diff --git a/NAMESPACE b/NAMESPACE index b3cd9ec8f..e3cec20b5 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -102,6 +102,7 @@ export(maskReactiveContext) export(navbarMenu) export(navbarPage) export(navlistPanel) +export(nearPoints) export(need) export(numericInput) export(observe) diff --git a/R/bootstrap.R b/R/bootstrap.R index 0877871c2..cac368537 100644 --- a/R/bootstrap.R +++ b/R/bootstrap.R @@ -1805,18 +1805,21 @@ verbatimTextOutput <- function(outputId) { #' click = "plot_click", # Equiv, to click=clickOpts(id="plot_click") #' hover = hoverOpts(id = "plot_hover", delayType = "throttle"), #' brush = brushOpts(id = "plot_brush") -#' ) +#' ), +#' h4("Clicked points"), +#' tableOutput("plot_clickedpoints"), +#' h4("Brushed points"), +#' tableOutput("plot_brushedpoints") #' ), -#' column(width = 3, +#' column(width = 4, #' verbatimTextOutput("plot_clickinfo"), #' verbatimTextOutput("plot_hoverinfo") #' ), -#' column(width = 3, +#' column(width = 4, #' wellPanel(actionButton("newplot", "New plot")), #' verbatimTextOutput("plot_brushinfo") #' ) -#' ), -#' tableOutput("plot_brushedpoints") +#' ) #' ), #' server = function(input, output, session) { #' data <- reactive({ @@ -1840,8 +1843,19 @@ verbatimTextOutput <- function(outputId) { #' cat("Brush (debounced):\n") #' str(input$plot_brush) #' }) +#' output$plot_clickedpoints <- renderTable({ +#' # For base graphics, we need to specify columns, though for ggplot2, +#' # it's usually not necessary. +#' res <- nearPoints(data(), input$plot_click, "speed", "dist") +#' if (nrow(res) == 0) +#' return() +#' res +#' }) #' output$plot_brushedpoints <- renderTable({ -#' selectBrush(input$plot_brush, data(), "speed", "dist") +#' res <- selectBrush(data(), input$plot_brush, "speed", "dist") +#' if (nrow(res) == 0) +#' return() +#' res #' }) #' } #' ) @@ -1863,11 +1877,11 @@ verbatimTextOutput <- function(outputId) { #' brush = brushOpts(id = "image_brush") #' ) #' ), -#' column(width = 3, +#' column(width = 4, #' verbatimTextOutput("image_clickinfo"), #' verbatimTextOutput("image_hoverinfo") #' ), -#' column(width = 3, +#' column(width = 4, #' wellPanel(actionButton("newimage", "New image")), #' verbatimTextOutput("image_brushinfo") #' ) diff --git a/R/image-interact.R b/R/image-interact.R index c5d4e226f..342cff1ed 100644 --- a/R/image-interact.R +++ b/R/image-interact.R @@ -106,3 +106,200 @@ selectBrush <- function(df, brush, xvar = NULL, yvar = NULL, df[keep_rows, , drop = FALSE] } +#' Find rows of data that are near a click/hover/double-click +#' +#' This function returns rows from a data frame which are near a click, hover, +#' or double-click, when used with \code{\link{plotOutput}}. The rows will be +#' sorted by their distance to the mouse event. +#' +#' The \code{xvar}, \code{yvar}, \code{panelvar1}, and \code{panelvar2} +#' arguments specify which columns in the data correspond to the x variable, y +#' variable, and panel variables of the plot. For example, if your plot is +#' \code{plot(x=cars$speed, y=cars$dist)}, and your click variable is named +#' \code{"cars_click"}, then you would use \code{nearPoints(cars, +#' input$cars_brush, "speed", "dist")}. +#' +#' @inheritParams selectBrush +#' @param threshold A maxmimum distance to the click point; rows in the data +#' frame where the distance to the click is less than \code{threshold} will be +#' returned. +#' @param maxrows Maximum number of rows to return. If NULL (the default), +#' return all rows that are within the threshold distance. +#' @param addDist If TRUE, add a column named \code{_dist} that contains the +#' distance from the coordinate to the point, in pixels. +#' +#' @seealso \code{\link{plotOutput}} for more examples. +#' +#' @examples +#' \dontrun{ +#' # Note that in practice, these examples would need to go in reactives +#' # or observers. +#' +#' # This would select all points within 5 pixels of the click +#' nearPoints(mtcars, input$plot_click) +#' +#' # Select just the nearest point within 10 pixels of the click +#' nearPoints(mtcars, input$plot_click, threshold = 10, maxrows = 1) +#' +#' } +#' @export +nearPoints <- function(df, coordinfo, xvar = NULL, yvar = NULL, + panelvar1 = NULL, panelvar2 = NULL, + threshold = 5, maxrows = NULL, addDist = FALSE) { + if (is.null(coordinfo)) { + return(df[0, , drop = FALSE]) + } + + vars <- findCoordmapVars(coordinfo, xvar, yvar, panelvar1, panelvar2) + + # Extract data values from the data frame + x <- asNumber(df[[vars$xvar]]) + y <- asNumber(df[[vars$yvar]]) + + # Get the pixel coordinates of the point + coordPx <- scaleCoords(coordinfo$x, coordinfo$y, coordinfo) + + # Get pixel coordinates of data points + dataPx <- scaleCoords(x, y, coordinfo) + + # Distances of data points to coordPx + dists <- sqrt((dataPx$x - coordPx$x) ^ 2 + (dataPx$y - coordPx$y) ^ 2) + + keep_rows <- (dists <= threshold) + + # Find which rows are matches for the panel vars (if present) + if (!is.null(vars$panelvar1)) + keep_rows <- keep_rows & panelMatch(coordinfo$panelvar1, df[[vars$panelvar1]]) + if (!is.null(vars$panelvar2)) + keep_rows <- keep_rows & panelMatch(coordinfo$panelvar2, df[[vars$panelvar2]]) + + if (addDist) + df$`_dist` <- dists + + df <- df[keep_rows, , drop = FALSE] + + # Sort by distance + dists <- dists[keep_rows] + df <- df[order(dists), , drop = FALSE] + + # Keep max number of rows + if (!is.null(maxrows) && nrow(df) > maxrows) { + df <- df[seq_len(maxrows), , drop = FALSE] + } + + df +} + + +findCoordmapVars <- function(coordmap, xvar = NULL, yvar = NULL, + panelvar1 = NULL, panelvar2 = NULL) { + + # Try to extract vars from coordmap. object + if (is.null(xvar)) xvar <- coordmap$mapping$x + if (is.null(yvar)) yvar <- coordmap$mapping$y + if (is.null(panelvar1)) panelvar1 <- coordmap$mapping$panelvar1 + if (is.null(panelvar2)) panelvar2 <- coordmap$mapping$panelvar2 + + if (is.null(xvar)) + stop("findCoordmapVars: not able to automatically infer `xvar` from coordmap.") + if (is.null(yvar)) + stop("findCoordmapVars: not able to automatically infer `yvar` from coordmap.") + + list( + xvar = xvar, + yvar = yvar, + panelvar1 = panelvar1, + panelvar2 = panelvar2 + ) +} + +# Coerce characters and factors to integers. Used because the mouse coords +# are numeric. +asNumber <- function(x) { + if (is.character(x)) x <- as.factor(x) + if (is.factor(x)) x <- as.integer(x) + x +} + +# Given +panelMatch <- function(search_value, x) { + # search_value is always a character; may need to coerce to number to match + # x, because the faceting var might be numeric. + if (is.numeric(x)) search_value <- as.numeric(match_value) + + x == search_value +} + +# ---------------------------------------------------------------------------- +# Scaling functions +# These functions have direct analogs in Javascript code, except these are +# vectorized for x and y. + +# Map a value x from a domain to a range. If clip is true, clip it to the +# range. +mapLinear <- function(x, domainMin, domainMax, rangeMin, rangeMax, clip = TRUE) { + factor <- (rangeMax - rangeMin) / (domainMax - domainMin) + val <- x - domainMin + newval <- (val * factor) + rangeMin + + if (clip) { + maxval <- max(rangeMax, rangeMin) + minval <- min(rangeMax, rangeMin) + newval[newval > maxval] <- maxval + newval[newval < minval] <- minval + } + newval +} + +# Scale val from domain to range. If logbase is present, use log scaling. +scale1D <- function(val, domainMin, domainMax, rangeMin, rangeMax, + logbase = NULL, clip = TRUE) { + if (!is.null(logbase)) + val <- log(val, logbase) + mapLinear(val, domainMin, domainMax, rangeMin, rangeMax, clip) +} + +# Inverse scale val, from range to domain. If logbase is present, use inverse +# log (power) transformation. +scaleInv1D <- function(val, domainMin, domainMax, rangeMin, rangeMax, + logbase = NULL, clip = TRUE) { + res <- mapLinear(val, rangeMin, rangeMax, domainMin, domainMax, clip) + if (!is.null(logbase)) + res <- logbase ^ res + res +} + +# Scale x and y coordinates from domain to range, using information in +# scaleinfo. scaleinfo must contain items $domain, $range, and $log. The +# scaleinfo object corresponds to one element from the coordmap object generated +# by getPrevPlotCoordmap or getGgplotCoordmap; it is the scaling information for +# one panel in a plot. +scaleCoords <- function(x, y, scaleinfo) { + if (is.null(scaleinfo)) + return(NULL) + + domain <- scaleinfo$domain + range <- scaleinfo$range + log <- scaleinfo$log + + list( + x = scale1D(x, domain$left, domain$right, range$left, range$right, log$x), + y = scale1D(y, domain$bottom, domain$top, range$bottom, range$top, log$y) + ) +} + +# Inverse scale x and y coordinates from range to domain, using information in +# scaleinfo. +scaleInvCoords <- function(x, y, scaleinfo) { + if (is.null(scaleinfo)) + return(NULL) + + domain <- scaleinfo$domain + range <- scaleinfo$range + log <- scaleinfo$log + + list( + x = scaleInv1D(x, domain$left, domain$right, range$left, range$right, log$x), + y = scaleInv1D(y, domain$bottom, domain$top, range$bottom, range$top, log$y) + ) +} diff --git a/man/imageOutput.Rd b/man/imageOutput.Rd index e221d9a55..4675e9d01 100644 --- a/man/imageOutput.Rd +++ b/man/imageOutput.Rd @@ -138,18 +138,21 @@ shinyApp( click = "plot_click", # Equiv, to click=clickOpts(id="plot_click") hover = hoverOpts(id = "plot_hover", delayType = "throttle"), brush = brushOpts(id = "plot_brush") - ) + ), + h4("Clicked points"), + tableOutput("plot_clickedpoints"), + h4("Brushed points"), + tableOutput("plot_brushedpoints") ), - column(width = 3, + column(width = 4, verbatimTextOutput("plot_clickinfo"), verbatimTextOutput("plot_hoverinfo") ), - column(width = 3, + column(width = 4, wellPanel(actionButton("newplot", "New plot")), verbatimTextOutput("plot_brushinfo") ) - ), - tableOutput("plot_brushedpoints") + ) ), server = function(input, output, session) { data <- reactive({ @@ -173,8 +176,19 @@ shinyApp( cat("Brush (debounced):\\n") str(input$plot_brush) }) + output$plot_clickedpoints <- renderTable({ + # For base graphics, we need to specify columns, though for ggplot2, + # it's usually not necessary. + res <- nearPoints(data(), input$plot_click, "speed", "dist") + if (nrow(res) == 0) + return() + res + }) output$plot_brushedpoints <- renderTable({ - selectBrush(input$plot_brush, data(), "speed", "dist") + res <- selectBrush(data(), input$plot_brush, "speed", "dist") + if (nrow(res) == 0) + return() + res }) } ) @@ -196,11 +210,11 @@ shinyApp( brush = brushOpts(id = "image_brush") ) ), - column(width = 3, + column(width = 4, verbatimTextOutput("image_clickinfo"), verbatimTextOutput("image_hoverinfo") ), - column(width = 3, + column(width = 4, wellPanel(actionButton("newimage", "New image")), verbatimTextOutput("image_brushinfo") ) diff --git a/man/nearPoints.Rd b/man/nearPoints.Rd new file mode 100644 index 000000000..15e8b4c46 --- /dev/null +++ b/man/nearPoints.Rd @@ -0,0 +1,74 @@ +% Generated by roxygen2 (4.1.0): do not edit by hand +% Please edit documentation in R/image-interact.R +\name{nearPoints} +\alias{nearPoints} +\title{Find rows of data that are near a click/hover/double-click} +\usage{ +nearPoints(df, coordinfo, xvar = NULL, yvar = NULL, panelvar1 = NULL, + panelvar2 = NULL, threshold = 5, maxrows = NULL, addDist = FALSE) +} +\arguments{ +\item{df}{A data frame from which to select rows.} + +\item{xvar}{A string with the name of the variable on the x axis. This must +also be the name of a column in \code{df}. If absent, then +\code{selectBrush} will try to infer the variable from the brush (only +works for ggplot2).} + +\item{yvar}{A string with the name of the variable on the y axis. This must +also be the name of a column in \code{df}. If absent, then +\code{selectBrush} will try to infer the variable from the brush (only +works for ggplot2).} + +\item{panelvar1}{Each of these is a string with the name of a panel + variable. For example, if with ggplot2, you facet on a variable called + \code{cyl}, then you can use \code{"cyl"} here. However, specifying the + panel variable should not be necessary with ggplot2; Shiny should be able + to auto-detect the panel variable.} + +\item{panelvar2}{Each of these is a string with the name of a panel + variable. For example, if with ggplot2, you facet on a variable called + \code{cyl}, then you can use \code{"cyl"} here. However, specifying the + panel variable should not be necessary with ggplot2; Shiny should be able + to auto-detect the panel variable.} + +\item{threshold}{A maxmimum distance to the click point; rows in the data +frame where the distance to the click is less than \code{threshold} will be +returned.} + +\item{maxrows}{Maximum number of rows to return. If NULL (the default), +return all rows that are within the threshold distance.} + +\item{addDist}{If TRUE, add a column named \code{_dist} that contains the + distance from the coordinate to the point, in pixels.} +} +\description{ +This function returns rows from a data frame which are near a click, hover, +or double-click, when used with \code{\link{plotOutput}}. The rows will be +sorted by their distance to the mouse event. +} +\details{ +The \code{xvar}, \code{yvar}, \code{panelvar1}, and \code{panelvar2} +arguments specify which columns in the data correspond to the x variable, y +variable, and panel variables of the plot. For example, if your plot is +\code{plot(x=cars$speed, y=cars$dist)}, and your click variable is named +\code{"cars_click"}, then you would use \code{nearPoints(cars, +input$cars_brush, "speed", "dist")}. +} +\examples{ +\dontrun{ +# Note that in practice, these examples would need to go in reactives +# or observers. + +# This would select all points within 5 pixels of the click +nearPoints(mtcars, input$plot_click) + +# Select just the nearest point within 10 pixels of the click +nearPoints(mtcars, input$plot_click, threshold = 10, maxrows = 1) + +} +} +\seealso{ +\code{\link{plotOutput}} for more examples. +} + diff --git a/srcjs/output_binding_image.js b/srcjs/output_binding_image.js index 3bf8997ca..fb312813e 100644 --- a/srcjs/output_binding_image.js +++ b/srcjs/output_binding_image.js @@ -418,6 +418,11 @@ imageutils.initCoordmap = function($el, coordmap) { // Add variable name mappings coords.mapping = panel.mapping; + // Add scaling information + coords.domain = panel.domain; + coords.range = panel.range; + coords.log = panel.log; + coords[".nonce"] = Math.random(); exports.onInputChange(inputId, coords); }; @@ -598,6 +603,11 @@ imageutils.createBrushHandler = function(inputId, $el, opts, coordmap) { // Add variable name mappings coords.mapping = panel.mapping; + // Add scaling information + coords.domain = panel.domain; + coords.range = panel.range; + coords.log = panel.log; + // Send data to server exports.onInputChange(inputId, coords); }