Merge pull request #90 from RGLab/multirangegate

MultiRangeGate support

DESCRIPTION

@@ -13,7 +13,7 @@ Description: With the dedicated fortify method implemented for flowSet,
 VignetteBuilder: knitr
 Depends:
     methods,
-    ggplot2(>= 3.3.0),
+    ggplot2(>= 3.4.2),
     flowCore(>= 1.41.5),
     ncdfFlow(>= 2.17.1),
     flowWorkspace(>= 3.33.1)
@@ -48,6 +48,7 @@ Collate:
     'fortify_fs.R'
     'geom_gate.R'
     'geom_hvline.R'
+    'geom_multi_range.R'
     'geom_overlay.R'
     'geom_stats.R'
     'getFlowFrame.R'
@@ -67,5 +68,5 @@ Collate:
     'stat_position.R'
     'transform_gate.R'
     'utility.R'
-RoxygenNote: 7.1.2
+RoxygenNote: 7.2.1
 Roxygen: list(markdown=TRUE)

NAMESPACE

@@ -19,6 +19,7 @@ S3method(fortify,ellipsoidGate)
 S3method(fortify,filterList)
 S3method(fortify,flowFrame)
 S3method(fortify,flowSet)
+S3method(fortify,multiRangeGate)
 S3method(fortify,ncdfFlowList)
 S3method(fortify,polygonGate)
 S3method(fortify,rectangleGate)
@@ -84,6 +85,7 @@ export(fortify_fs)
 export(gate_null)
 export(geom_gate)
 export(geom_hvline)
+export(geom_multi_range)
 export(geom_overlay)
 export(geom_stats)
 export(getFlowFrame)
@@ -145,4 +147,5 @@ importFrom(plyr,empty)
 importFrom(plyr,eval.quoted)
 importFrom(plyr,name_rows)
 importFrom(rlang,"!!!")
+importFrom(rlang,list2)
 importFrom(rlang,quo_name)

R/fortify.R

@@ -141,14 +141,37 @@ fortify.GatingSet <- function(model, ...){
 #' pg <- polygonGate(filterId="nonDebris", .gate= sqrcut)
 #' fortify(pg) 
 fortify.polygonGate <- function(model, data = NULL, nPoints = NULL, ...){
-
   vertices <- model@boundaries
   chnls <- colnames(vertices)
   new.vertices <- rbind(vertices, vertices[1,])#make sure geom_path will enclose the polygon by ending with the starting point
   dt <- as.data.table(new.vertices)
   setnames(dt, chnls)
   dt
 }
+#' Convert a multiRangeGate to a data.table useful for ggplot
+#' 
+#' It converts the boundaries slot into a data.table
+#' 
+#' 
+#' @param model multiRangeGate
+#' @param data Not used
+#' @param nPoints not used
+#' @param ... not used.
+#' 
+#' @export
+#' @return data.table
+#' @examples 
+#' mrq = multiRangeGate(ranges = list(min=c(100, 350), max=c(250, 400)))
+#' fortify(mrq)
+fortify.multiRangeGate<- function(model, data = NULL, ...){
+  vertices <- model@ranges
+  # Convert to 1D vector
+  channel = parameters(model)
+  vertices =unlist(mapply(function(x, y)c(x, y),vertices[["min"]], vertices[["max"]], SIMPLIFY=FALSE))
+  dt <- as.data.table(vertices)
+  setnames(dt, channel)
+  dt
+}
 
 #' Convert a ellipsoidGate to a data.table useful for ggplot
 #' 

R/geom_gate.R

@@ -140,6 +140,12 @@ geom_gate_impl.rectangleGate <- function(data, mapping = NULL, fill = NA, colour
 }
 
 
+geom_gate_impl.multiRangeGate<- function(data, mapping = NULL, fill = NA, colour = "red", alpha= 0.5,nPoints = 100, ...){
+  geom_multi_range(data=data,fill=fill,colour=colour,alpha=alpha, ...)
+}
+
+
+
 geom_gate_impl.ellipsoidGate <- function(data, ...){
 
   geom_gate_impl.polygonGate(data, ...)

R/geom_multi_range.R

@@ -0,0 +1,122 @@
+#' Draw multi-ranges as multiple rectangles on 1D or 2D plot
+#'
+#' This geom is based on the source code of ' \code{\link{geom_rect}}
+#'
+#' The goal is to determine the line to be either vertial or horizontal based on the data provided in 
+#' this layer. Also convert input 1D intervals to geom_rect acceptable shapes
+#'
+#' @section Aesthetics:
+#' \Sexpr[results=rd,stage=build]{ggplot2:::rd_aesthetics("geom", "vline")}
+#'
+#' @param mapping The aesthetic mapping, usually constructed with
+#'    \code{\link{aes}} or \code{\link{aes_string}}. Only needs to be set
+#'    at the layer level if you are overriding the plot defaults.
+#' @param data A layer specific dataset - only needed if you want to override
+#'    the plot defaults.
+#' @param position The position adjustment to use for overlapping points
+#'    on this layer
+#' @param ... other arguments passed on to \code{\link{layer}}. This can
+#'   include aesthetics whose values you want to set, not map. See
+#'   \code{\link{layer}} for more details.
+#' @param show.legend should a legend be drawn? (defaults to \code{FALSE})
+#' @export
+#' @importFrom rlang list2
+#' @return a geom_rect layer
+geom_multi_range <- function(mapping = NULL, data = NULL,
+                      stat = "identity", position = "identity",
+                      ...,
+                      linejoin = "mitre",
+                      na.rm = FALSE,
+                      show.legend = NA,
+                      inherit.aes = TRUE) {
+ obj = layer(
+    data = data,
+    mapping = mapping,
+    stat = stat,
+    geom = GeomMultiRange,
+    position = position,
+    show.legend = show.legend,
+    inherit.aes = inherit.aes,
+    params = list2(
+      linejoin = linejoin,
+      na.rm = na.rm,
+      ...
+    )
+  )
+
+  obj$compute_aesthetics <- .my_compute_aesthetics
+  obj
+}
+
+
+
+
+
+GeomMultiRange<- ggproto("GeomMultiRange", Geom,
+  default_aes = aes(colour = NA, fill = "grey35", linewidth = 0.5, linetype = 1,
+    alpha = NA),
+
+
+  draw_panel = function(self, data, panel_params, coord, lineend = "butt", linejoin = "mitre") {
+    data <- ggplot2:::check_linewidth(data, ggplot2:::snake_class(self))
+
+    # determien whether x or y 
+    if("x"%in% colnames(data)){
+      axis.used <- "x"
+      axis.missing <- "y"
+    }else{
+      axis.used <- "y"
+      axis.missing <- "x"
+    }    
+    # convert range gate to rect format, that is "xmin", "xmax", "ymin", "ymax"
+    multi_intervals=data[[axis.used]]
+    num_breaks=length(multi_intervals)
+    start=multi_intervals[seq(1, num_breaks, 2)]
+    end=multi_intervals[seq(2, num_breaks, 2)]
+    data[[axis.used]] <- NULL
+    panel_data = data[1,]
+    data = data.frame(start=start,end=end)
+    names(data) <-c(paste0(axis.used,"min"),paste0(axis.used,"max"))
+    data[[paste0(axis.missing,"min")]] <--Inf
+    data[[paste0(axis.missing,"max")]] <-Inf
+    rownames(panel_data) <- NULL
+    data=cbind(data, panel_data)
+
+    if (!coord$is_linear()) {
+      aesthetics <- setdiff(
+        names(data), c("x", "y", "xmin", "xmax", "ymin", "ymax")
+      )
+      index <- rep(seq_len(nrow(data)), each = 4)
+
+      new <- data[index, aesthetics, drop = FALSE]
+      new$x <- ggplot2:::vec_interleave(data$xmin, data$xmax, data$xmax, data$xmin)
+      new$y <- ggplot2:::vec_interleave(data$ymax, data$ymax, data$ymin, data$ymin)
+      new$group <- index
+
+      ggname("geom_rect", GeomPolygon$draw_panel(
+        new, panel_params, coord, lineend = lineend, linejoin = linejoin
+      ))
+    } else {
+      coords <- coord$transform(data, panel_params)
+      ggplot2:::ggname("geom_rect", grid::rectGrob(
+        coords$xmin, coords$ymax,
+        width = coords$xmax - coords$xmin,
+        height = coords$ymax - coords$ymin,
+        default.units = "native",
+        just = c("left", "top"),
+        gp = grid::gpar(
+          col = coords$colour,
+          fill = alpha(coords$fill, coords$alpha),
+          lwd = coords$linewidth * .pt,
+          lty = coords$linetype,
+          linejoin = linejoin,
+          lineend = lineend
+        )
+      ))
+    }
+  },
+
+  draw_key = draw_key_polygon,
+
+  rename_size = TRUE
+)

R/ggcyto_flowSet.R

@@ -230,7 +230,6 @@ add_ggcyto <- function(e1, e2, e2name){
     }else{
       thisCall <- quote(geom_point(data = fs.overlay))  
     }
-
     thisCall <- as.call(c(as.list(thisCall), e2[["overlay_params"]]))
     e2.new <- eval(thisCall)
     attr(e2.new, "is.recorded") <- TRUE
@@ -410,7 +409,15 @@ is.geom_gate_filterList <- function(layer){
       polygonGate(df)  
 
   }else if (nDim == 1){
-    rectangleGate(df)
+    num_breaks = nrow(df)
+    if ( num_breaks > 2) {
+      multi_intervals = df[, 1]
+      start=multi_intervals[seq(1, num_breaks, 2)]
+      end=multi_intervals[seq(2, num_breaks, 2)]
+      multiRangeGate(ranges = list(min=start, max=end))
+    } else {
+      rectangleGate(df)
+    }
   }else
     stop("invalid dimension number!")