Merge pull request satijalab#341 from satijalab/feat/CellSelectorGadget

Turn CellSelector into a Shiny Gadget

DESCRIPTION

@@ -2,7 +2,7 @@ Package: Seurat
 Version: 3.1.5.9015
 Date: 2020-07-09
 Title: Tools for Single Cell Genomics
-Description: A toolkit for quality control, analysis, and exploration of single cell RNA sequencing data. 'Seurat' aims to enable users to identify and interpret sources of heterogeneity from single cell transcriptomic measurements, and to integrate diverse types of single cell data. See Satija R, Farrell J, Gennert D, et al (2015) <doi:10.1038/nbt.3192>, Macosko E, Basu A, Satija R, et al (2015) <doi:10.1016/j.cell.2015.05.002>, and Stuart T, Butler A, et al (2019) <doi:10.1016/j.cell.2019.05.031> for more details. Please note:  SDMTools is available is available from the CRAN archives with install.packages(<"https://cran.rstudio.com//src/contrib/Archive/SDMTools/SDMTools_1.1-221.2.tar.gz">, repos = NULL); it is not in the standard repositories.
+Description: A toolkit for quality control, analysis, and exploration of single cell RNA sequencing data. 'Seurat' aims to enable users to identify and interpret sources of heterogeneity from single cell transcriptomic measurements, and to integrate diverse types of single cell data. See Satija R, Farrell J, Gennert D, et al (2015) <doi:10.1038/nbt.3192>, Macosko E, Basu A, Satija R, et al (2015) <doi:10.1016/j.cell.2015.05.002>, and Stuart T, Butler A, et al (2019) <doi:10.1016/j.cell.2019.05.031> for more details.
 Authors@R: c(
   person(given = 'Rahul', family = 'Satija', email = '[email protected]', role = 'aut', comment = c(ORCID = '0000-0001-9448-8833')),
   person(given = 'Andrew', family = 'Butler', email = '[email protected]', role = 'aut', comment = c(ORCID = '0000-0003-3608-0463')),
@@ -42,6 +42,7 @@ Imports:
     lmtest,
     MASS,
     Matrix (>= 1.2-14),
+    miniUI,
     patchwork,
     pbapply,
     plotly,
@@ -57,6 +58,7 @@ Imports:
     Rtsne,
     scales,
     sctransform (>= 0.2.0),
+    shiny,
     stats,
     tools,
     utils,
@@ -83,7 +85,6 @@ RoxygenNote: 7.1.1
 Encoding: UTF-8
 Suggests:
     loomR,
-    SDMTools,
     testthat,
     hdf5r,
     S4Vectors,

NAMESPACE

@@ -487,6 +487,10 @@ importFrom(methods,setOldClass)
 importFrom(methods,signature)
 importFrom(methods,slot)
 importFrom(methods,slotNames)
+importFrom(miniUI,gadgetTitleBar)
+importFrom(miniUI,miniContentPanel)
+importFrom(miniUI,miniPage)
+importFrom(miniUI,miniTitleBarButton)
 importFrom(patchwork,wrap_plots)
 importFrom(pbapply,pbapply)
 importFrom(pbapply,pblapply)
@@ -511,6 +515,15 @@ importFrom(sctransform,correct_counts)
 importFrom(sctransform,get_residual_var)
 importFrom(sctransform,get_residuals)
 importFrom(sctransform,vst)
+importFrom(shiny,brushOpts)
+importFrom(shiny,brushedPoints)
+importFrom(shiny,fillRow)
+importFrom(shiny,observeEvent)
+importFrom(shiny,plotOutput)
+importFrom(shiny,reactiveValues)
+importFrom(shiny,renderPlot)
+importFrom(shiny,runGadget)
+importFrom(shiny,stopApp)
 importFrom(stats,aggregate)
 importFrom(stats,anova)
 importFrom(stats,approxfun)

NEWS.md

@@ -17,7 +17,10 @@ object inheriting from the Assay class
 - Efficiency improvements in anchor scoring (`ScoreAnchors`)
 - Fix bug in `FindClusters()` when the last node has no edges 
 - Default to weighted = TRUE when constructing igraph objects in `RunLeiden`. Remove corresponding weights parameter from `FindClusters()`.
-- Fix handling of keys in `FeatureScatter()` 
+- Fix handling of keys in `FeatureScatter()`
+- Change `CellSelector` to use Shiny gadgets instead of SDMTools
+- Mark `PointLocator` as defunct
+- Remove `SDMTools`
 
 ## [3.1.5] - 2020-04-14
 ### Added

R/visualization.R

@@ -2488,26 +2488,28 @@ BlueAndRed <- function(k = 50) {
   return(CustomPalette(low = "#313695" , high = "#A50026", mid = "#FFFFBF", k = k))
 }
 
-#' Cell selector
+#' Cell Selector
 #'
 #' Select points on a scatterplot and get information about them
 #'
 #' @param plot A ggplot2 plot
-#' @param object An optional Seurat object; if passes, will return an object with
-#' the identities of selected cells set to \code{ident}
+#' @param object An optional Seurat object; if passes, will return an object
+#' with the identities of selected cells set to \code{ident}
 #' @param ident An optional new identity class to assign the selected cells
-#' @param ... Extra parameters, such as dark.theme, recolor, or smooth for using a dark theme,
-#' recoloring based on selected cells, or using a smooth scatterplot, respectively
+#' @param ... Ignored
 #'
-#' @return If \code{object} is \code{NULL}, the names of the points selected; otherwise,
-#' a Seurat object with the selected cells identity classes set to \code{ident}
+#' @return If \code{object} is \code{NULL}, the names of the points selected;
+#' otherwise, a Seurat object with the selected cells identity classes set to
+#' \code{ident}
+#'
+#' @importFrom miniUI miniPage gadgetTitleBar miniTitleBarButton
+#' miniContentPanel
+#' @importFrom shiny fillRow plotOutput brushOpts reactiveValues observeEvent
+#' stopApp brushedPoints renderPlot runGadget
 #'
-#' @importFrom ggplot2 ggplot_build
 #' @export
 #'
-# @aliases FeatureLocator
-#' @seealso \code{\link[graphics]{locator}} \code{\link[ggplot2]{ggplot_build}}
-#' \code{\link[SDMTools]{pnt.in.poly}} \code{\link{DimPlot}} \code{\link{FeaturePlot}}
+#' @seealso \code{\link{DimPlot}} \code{\link{FeaturePlot}}
 #'
 #' @examples
 #' \dontrun{
@@ -2520,17 +2522,100 @@ BlueAndRed <- function(k = 50) {
 #' }
 #'
 CellSelector <- function(plot, object = NULL, ident = 'SelectedCells', ...) {
-  located <- PointLocator(plot = plot, ...)
-  data <- ggplot_build(plot = plot)$plot$data
-  selected <- rownames(x = data[as.numeric(x = rownames(x = located)), ])
-  if (inherits(x = object, what = 'Seurat')) {
-    if (!all(selected %in% Cells(x = object))) {
-      stop("Cannot find selected cells in the Seurat object, please be sure you pass the same object used to generate the plot", call. = FALSE)
+  # Set up the gadget UI
+  ui <- miniPage(
+    gadgetTitleBar(
+      title = "Cell Selector",
+      left = miniTitleBarButton(inputId = "reset", label = "Reset")
+    ),
+    miniContentPanel(
+      fillRow(
+        plotOutput(
+          outputId = "plot",
+          height = '100%',
+          brush = brushOpts(
+            id = 'brush',
+            delay = 100,
+            delayType = 'debounce',
+            clip = TRUE,
+            resetOnNew = FALSE
+          )
+        )
+      ),
+    )
+  )
+  # Get some plot information
+  if (inherits(x = plot, what = 'patchwork')) {
+    if (length(x = plot$patches$plots)) {
+      warning(
+        "Multiple plots passed, using last plot",
+        call. = FALSE,
+        immediate. = TRUE
+      )
     }
-    Idents(object = object, cells = selected) <- ident
-    return(object)
+    class(x = plot) <- grep(
+      pattern = 'patchwork',
+      x = class(x = plot),
+      value = TRUE,
+      invert = TRUE
+    )
   }
-  return(selected)
+  xy.aes <- GetXYAesthetics(plot = plot)
+  dark.theme <- !is.null(x = plot$theme$plot.background$fill) &&
+    plot$theme$plot.background$fill == 'black'
+  plot.data <- GGpointToBase(plot = plot, do.plot = FALSE)
+  plot.data$selected_ <- FALSE
+  rownames(x = plot.data) <- rownames(x = plot$data)
+  # Server function
+  server <- function(input, output, session) {
+    plot.env <- reactiveValues(data = plot.data)
+    # Event handlers
+    observeEvent(
+      eventExpr = input$done,
+      handlerExpr = {
+        PlotBuild(data = plot.env$data, dark.theme = dark.theme)
+        selected <- rownames(x = plot.data)[plot.env$data$selected_]
+        if (inherits(x = object, what = 'Seurat')) {
+          if (!all(selected %in% Cells(x = object))) {
+            stop("Cannot find the selected cells in the Seurat object, please be sure you pass the same object used to generate the plot")
+          }
+          Idents(object = object, cells = selected) <- ident
+          selected <- object
+        }
+        stopApp(returnValue = selected)
+      }
+    )
+    observeEvent(
+      eventExpr = input$reset,
+      handlerExpr = {
+        plot.env$data <- plot.data
+        session$resetBrush(brushId = 'brush')
+      }
+    )
+    observeEvent(
+      eventExpr = input$brush,
+      handlerExpr = {
+        plot.env$data <- brushedPoints(
+          df = plot.data,
+          brush = input$brush,
+          xvar = xy.aes$x,
+          yvar = xy.aes$y,
+          allRows = TRUE
+        )
+        plot.env$data$color <- ifelse(
+          test = plot.env$data$selected_,
+          yes = '#DE2D26',
+          no = '#C3C3C3'
+        )
+      }
+    )
+    # Render the plot
+    output$plot <- renderPlot(expr = PlotBuild(
+      data = plot.env$data,
+      dark.theme = dark.theme
+    ))
+  }
+  return(runGadget(app = ui, server = server))
 }
 
 #' Move outliers towards center on dimension reduction plot
@@ -3956,6 +4041,34 @@ GGpointToBase <- function(plot, do.plot = TRUE, ...) {
   return(plot.data)
 }
 
+# Get colour aesththics from a plot for a certain geom
+#
+# @param plot A ggplot2 object
+# @param geom Geom class to filter to
+# @param plot.first Use plot-wide colour aesthetics before geom-specific aesthetics
+#
+# @return A named list with values 'colour' for the colour aesthetic
+#
+GetColourAesthetics <- function(plot, geom = 'GeomPoint', plot.first = TRUE) {
+  geoms <- sapply(
+    X = plot$layers,
+    FUN = function(layer) {
+      return(class(x = layer$geom)[1])
+    }
+  )
+  geoms <- which(x = geoms == geom)
+  if (!length(x = geoms)) {
+    stop("Cannot find a geom of class ", geom)
+  }
+  geoms <- min(geoms)
+  if (plot.first) {
+    colour <- as.character(x = plot$mapping$colour %||% plot$layers[[geoms]]$mapping$colour)[2]
+  } else {
+    colour <- as.character(x = plot$layers[[geoms]]$mapping$colour %||% plot$mapping$colour)[2]
+  }
+  return(list(colour = colour))
+}
+
 # Get X and Y aesthetics from a plot for a certain geom
 #
 # @param plot A ggplot2 object
@@ -4225,30 +4338,31 @@ PlotBuild <- function(data, dark.theme = FALSE, smooth = FALSE, ...) {
 # @importFrom SDMTools pnt.in.poly
 #
 PointLocator <- function(plot, recolor = TRUE, dark.theme = FALSE, ...) {
-  #   Convert the ggplot object to a data.frame
-  PackageCheck('SDMTools')
-  plot.data <- GGpointToBase(plot = plot, dark.theme = dark.theme, ...)
-  npoints <- nrow(x = plot.data)
-  cat("Click around the cluster of points you wish to select\n")
-  cat("ie. select the vertecies of a shape around the cluster you\n")
-  cat("are interested in. Press <Esc> when finished (right click for R-terminal users)\n\n")
-  polygon <- locator(n = npoints, type = 'l')
-  polygon <- data.frame(polygon)
-  #   pnt.in.poly returns a data.frame of points
-  points.all <- SDMTools::pnt.in.poly(
-    pnts = plot.data[, c(1, 2)],
-    poly.pnts = polygon
-  )
-  #   Find the located points
-  points.located <- points.all[which(x = points.all$pip == 1), ]
-  #   If we're recoloring, do the recolor
-  if (recolor) {
-    no <- ifelse(test = dark.theme, yes = 'white', no = '#C3C3C3')
-    points.all$color <- ifelse(test = points.all$pip == 1, yes = '#DE2D26', no = no)
-    plot.data$color <- points.all$color
-    PlotBuild(data = plot.data, dark.theme = dark.theme, ...)
-  }
-  return(points.located[, c(1, 2)])
+  .Defunct(new = "CellSelector")
+  # #   Convert the ggplot object to a data.frame
+  # PackageCheck('SDMTools')
+  # plot.data <- GGpointToBase(plot = plot, dark.theme = dark.theme, ...)
+  # npoints <- nrow(x = plot.data)
+  # cat("Click around the cluster of points you wish to select\n")
+  # cat("ie. select the vertecies of a shape around the cluster you\n")
+  # cat("are interested in. Press <Esc> when finished (right click for R-terminal users)\n\n")
+  # polygon <- locator(n = npoints, type = 'l')
+  # polygon <- data.frame(polygon)
+  # #   pnt.in.poly returns a data.frame of points
+  # points.all <- SDMTools::pnt.in.poly(
+  #   pnts = plot.data[, c(1, 2)],
+  #   poly.pnts = polygon
+  # )
+  # #   Find the located points
+  # points.located <- points.all[which(x = points.all$pip == 1), ]
+  # #   If we're recoloring, do the recolor
+  # if (recolor) {
+  #   no <- ifelse(test = dark.theme, yes = 'white', no = '#C3C3C3')
+  #   points.all$color <- ifelse(test = points.all$pip == 1, yes = '#DE2D26', no = no)
+  #   plot.data$color <- points.all$color
+  #   PlotBuild(data = plot.data, dark.theme = dark.theme, ...)
+  # }
+  # return(points.located[, c(1, 2)])
 }
 
 # Create quantile segments for quantiles on violin plots in ggplot2