diff --git a/DESCRIPTION b/DESCRIPTION index 94d656588d..721c5e9cc6 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -94,6 +94,7 @@ Collate: 'html-deps.R' 'htmltools.R' 'image-interact-opts.R' + 'image-interact.R' 'imageutils.R' 'jqueryui.R' 'middleware-shiny.R' diff --git a/NAMESPACE b/NAMESPACE index b88da084b6..0466d014d9 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -174,6 +174,7 @@ export(textInput) export(textOutput) export(titlePanel) export(uiOutput) +export(underBrush) export(updateCheckboxGroupInput) export(updateCheckboxInput) export(updateDateInput) diff --git a/R/bootstrap.R b/R/bootstrap.R index 62eb0a0cea..92723e5d0a 100644 --- a/R/bootstrap.R +++ b/R/bootstrap.R @@ -1804,7 +1804,7 @@ verbatimTextOutput <- function(outputId) { #' plotOutput("plot", height=300, #' click = "plot_click", # Equiv, to click=clickOpts(id="plot_click") #' hover = hoverOpts(id = "plot_hover", delayType = "throttle"), -#' brush = brushOpts(id = "plot_brush", fill = "red") +#' brush = brushOpts(id = "plot_brush") #' ) #' ), #' column(width = 3, @@ -1815,14 +1815,18 @@ verbatimTextOutput <- function(outputId) { #' wellPanel(actionButton("newplot", "New plot")), #' verbatimTextOutput("plot_brushinfo") #' ) -#' ) +#' ), +#' tableOutput("plot_brushedpoints") #' ), #' server = function(input, output, session) { -#' output$plot <- renderPlot({ +#' data <- reactive({ #' input$newplot -#' # Add a little noise to the cars data -#' cars2 <- cars + rnorm(nrow(cars)) -#' plot(cars2) +#' # Add a little noise to the cars data so the points move +#' cars + rnorm(nrow(cars)) +#' }) +#' output$plot <- renderPlot({ +#' d <- data() +#' plot(d$speed, d$dist) #' }) #' output$plot_clickinfo <- renderPrint({ #' cat("Click:\n") @@ -1836,6 +1840,9 @@ verbatimTextOutput <- function(outputId) { #' cat("Brush (debounced):\n") #' str(input$plot_brush) #' }) +#' output$plot_brushedpoints <- renderTable({ +#' underBrush(input$plot_brush, data(), "speed", "dist") +#' }) #' } #' ) #' @@ -1853,7 +1860,7 @@ verbatimTextOutput <- function(outputId) { #' delay = 500, #' delayType = "throttle" #' ), -#' brush = brushOpts(id = "image_brush", fill = "red") +#' brush = brushOpts(id = "image_brush") #' ) #' ), #' column(width = 3, diff --git a/R/image-interact.R b/R/image-interact.R new file mode 100644 index 0000000000..95744b8a1e --- /dev/null +++ b/R/image-interact.R @@ -0,0 +1,57 @@ +#' Find points that are under a brush +#' +#' This function returns rows from a data frame which are under a brush used +#' with \code{\link{plotOutput}}. +#' +#' If a specified x or y column is a factor, then it will be coerced to an +#' integer vector. If it is a character vector, then it will be coerced to a +#' factor and then integer vector. This means that the brush will be considered +#' to cover a given character/factor value when it covers the center value. +#' +#' @param brush The data from a brush, such as \code{input$plot_brush}. +#' @param df A data frame from which to select rows. +#' @param 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}. +#' @param 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}. +#' +#' @seealso \code{\link{plotOutput}} for example usage. +#' @export +underBrush <- function(brush, df, xvar, yvar) { + if (is.null(brush)) { + return(df[0, , drop = FALSE]) + } + + x <- df[[xvar]] + y <- df[[yvar]] + + if (is.character(x)) x <- as.factor(x) + if (is.factor(x)) x <- as.integer(x) + + if (is.character(y)) x <- as.factor(y) + if (is.factor(y)) x <- as.integer(y) + + # Panel vars, if present + panel_names <- setdiff(names(brush), c("xmin", "xmax", "ymin", "ymax")) + + # Find which rows are matches for the pnael vars + keep_rows <- rep.int(TRUE, nrow(df)) + lapply(panel_names, function(varname) { + brush_value <- brush[varname] + col_vals <- df[[varname]] + + # brush_value is always a character; may need to coerce to number + if (is.numeric(col_vals)) + brush_value <- as.numeric(brush_value) + + keep_rows <<- keep_rows & (brush_value == col_vals) + }) + + # Filter out x and y values + keep_rows <- keep_rows & + x >= brush$xmin & x <= brush$xmax & + y >= brush$ymin & y <= brush$ymax + + df[keep_rows, , drop = FALSE] +} + diff --git a/man/imageOutput.Rd b/man/imageOutput.Rd index 742b617bb1..9fd6a90e56 100644 --- a/man/imageOutput.Rd +++ b/man/imageOutput.Rd @@ -137,7 +137,7 @@ shinyApp( plotOutput("plot", height=300, click = "plot_click", # Equiv, to click=clickOpts(id="plot_click") hover = hoverOpts(id = "plot_hover", delayType = "throttle"), - brush = brushOpts(id = "plot_brush", fill = "red") + brush = brushOpts(id = "plot_brush") ) ), column(width = 3, @@ -148,14 +148,18 @@ shinyApp( wellPanel(actionButton("newplot", "New plot")), verbatimTextOutput("plot_brushinfo") ) - ) + ), + tableOutput("plot_brushedpoints") ), server = function(input, output, session) { - output$plot <- renderPlot({ + data <- reactive({ input$newplot - # Add a little noise to the cars data - cars2 <- cars + rnorm(nrow(cars)) - plot(cars2) + # Add a little noise to the cars data so the points move + cars + rnorm(nrow(cars)) + }) + output$plot <- renderPlot({ + d <- data() + plot(d$speed, d$dist) }) output$plot_clickinfo <- renderPrint({ cat("Click:\\n") @@ -169,6 +173,9 @@ shinyApp( cat("Brush (debounced):\\n") str(input$plot_brush) }) + output$plot_brushedpoints <- renderTable({ + underBrush(input$plot_brush, data(), "speed", "dist") + }) } ) @@ -186,7 +193,7 @@ shinyApp( delay = 500, delayType = "throttle" ), - brush = brushOpts(id = "image_brush", fill = "red") + brush = brushOpts(id = "image_brush") ) ), column(width = 3, diff --git a/man/underBrush.Rd b/man/underBrush.Rd new file mode 100644 index 0000000000..c9013c619b --- /dev/null +++ b/man/underBrush.Rd @@ -0,0 +1,33 @@ +% Generated by roxygen2 (4.1.0): do not edit by hand +% Please edit documentation in R/image-interact.R +\name{underBrush} +\alias{underBrush} +\title{Find points that are under a brush} +\usage{ +underBrush(brush, df, xvar, yvar) +} +\arguments{ +\item{brush}{The data from a brush, such as \code{input$plot_brush}.} + +\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}.} + +\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}.} +} +\description{ +This function returns rows from a data frame which are under a brush used +with \code{\link{plotOutput}}. +} +\details{ +If a specified x or y column is a factor, then it will be coerced to an +integer vector. If it is a character vector, then it will be coerced to a +factor and then integer vector. This means that the brush will be considered +to cover a given character/factor value when it covers the center value. +} +\seealso{ +\code{\link{plotOutput}} for example usage. +} +