Add underBrush() function

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'

NAMESPACE

@@ -174,6 +174,7 @@ export(textInput)
 export(textOutput)
 export(titlePanel)
 export(uiOutput)
+export(underBrush)
 export(updateCheckboxGroupInput)
 export(updateCheckboxInput)
 export(updateDateInput)

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,

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]
+}
+

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,

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.
+}
+