Extend transform method to support gate objects

DESCRIPTION

@@ -44,6 +44,7 @@ Collate:
     AllClasses.R
     flowFrame-accessors.R
     flowSet-accessors.R
+    gate-accessors.R
     transform_gate-methods.R
     coerce.R
     logicalFilterResult-accessors.R

R/AllClasses.R

@@ -2495,7 +2495,7 @@ ellipsoidGate <- function(..., .gate, mean, distance=1,
     checkClass(distance, "numeric", 1)
     parms <- prepareInputs(parseDots(list(...)), .gate)
     names(mean) <- sapply(parms$parameters, parameters)
-    new("ellipsoidGate", filterId=filterId, parameters=parms$parameters,
+    new("ellipsoidGate", filterId=filterId, parameters=unname(parms$parameters),
         cov=parms$values, mean=mean, distance=distance)
 }
 
@@ -5224,9 +5224,21 @@ setClass("transformList",
 
 ## constructor
 #' @export
-transformList <- function(from, tfun, to=from,
+transformList <- function(from, tfun, to,
                           transformationId="defaultTransformation")
 {
+    if(missing(from)) {
+      from <- names(tfun)
+      if(is.null(from)) {
+        stop(
+          "channel names must be supplied to 'from' or included ",
+          "as names in 'tfun'!"
+        )
+      }
+    }
+    if(missing(to)) {
+      to <- from
+    }
     from <- unique(from)
     to <- unique(to)
     if(!is.character(from) || !is.character(to) || length(from) != length(to))

R/flowFrame-accessors.R

@@ -826,24 +826,28 @@ setMethod("compensate",
 
 
 
-#' Transform a flowFrame or flowSet
+#' Transform a flowFrame, flowSet or gate object
 #' 
 #' Similar to the base transform method, this will transform the values of
-#' a flowFrame or flowSet object according to the transformations specified
+#' a flowFrame, flowSet or gate object according to the transformations specified
 #' in one of two ways:
-#' 1. a [transformList][flowCore::transformList-class] or list of [transform][flowCore::transform-class] objects
+#' 1. a \code{transformList} or list of \code{transform} objects
 #' 2. named arguments specifying transformations to be applied to channels (see details)
 #' 
 #' @name transform
 #' @aliases transform,flowFrame-method transform,flowSet-method
-#' @param _data a flowFrame or flowSet object
+#'   transform,rectangleGate-method transform,polygonGate-method
+#'   transform,ellipsoidGate-method transform,quadGate-method
+#'   transform,filters-method
+#' @param _data a flowFrame, flowSet or gate object
 #' @param translist a transformList object
 #' @param ... other arguments. e.g. `FL1-H` = myFunc(`FL1-H`)
 #' 
+#' @return A transformed flowFrame, flowSet or gate object.
 #' 
 #' @details To specify the transformations in the second way, the names of these arguments 
 #' should correspond to the new channel names and the values should be functions applied to
-#' channels currently present in the flowFrame or flowSet. There are a few examples below.
+#' channels currently present in the flowFrame, flowSet or gate. There are a few examples below.
 #' 
 #' @examples 
 #' data(GvHD)

R/gate-accessors.R

@@ -0,0 +1,199 @@
+## =============================================================================
+## Gate objects define boundaries for populations
+## =============================================================================
+
+#' @export
+setMethod(
+  "transform",
+  signature = signature(`_data` = "rectangleGate"),
+  definition = function(`_data`,
+                        translist, 
+                        ...) {
+
+    gate <- `_data`
+    if(!(missing(translist))){
+      #check if it is a transformList
+      res <- try(class(translist), silent = TRUE)
+      if(res != "transformList") {
+        err_msg <- attr(res, "condition")[["message"]]
+        err_msg <- paste(
+          err_msg, 
+          "!Please make sure the unnamed argument is a valid 'transformList' object!"
+        )
+        stop(err_msg)
+      } else {
+        params <- unname(parameters(gate))
+        trans_params <- colnames(translist)
+        # transformation required
+        for(param in params) {
+          if(param %in% trans_params) {
+            tfun <- translist@transforms[[param]]@f
+            if(!is.infinite(gate@min[param])) {
+              gate@min[param] <- tfun(gate@min[param])
+            }
+            if(!is.infinite(gate@max[param])) {
+              gate@max[param] <- tfun(gate@max[param])
+            }
+          }
+        }
+        return(gate)
+      }
+      # apply named transformations of form `FSC-H`=asinhTrans(`FSC-H`)     
+    } else {
+      coords <- as.matrix(
+        transform(
+          as.data.frame(
+            rbind(
+              min = gate@min,
+              max = gate@max
+            )
+          ),
+          ...
+        )
+      )
+      gate@min <- unlist(coords[1, , drop = TRUE])
+      gate@max <- unlist(coords[2, , drop = TRUE])
+      return(gate)
+    }
+  }
+)
+
+#' @export
+setMethod(
+  "transform",
+  signature = signature(`_data` = "polygonGate"),
+  definition = function(`_data`,
+                        translist, 
+                        ...) {
+
+    gate <- `_data`
+    if(!(missing(translist))){
+      #check if it is a transformList
+      res <- try(class(translist), silent = TRUE)
+      if(res != "transformList") {
+        err_msg <- attr(res, "condition")[["message"]]
+        err_msg <- paste(
+          err_msg, 
+          "!Please make sure the unnamed argument is a valid 'transformList' object!"
+        )
+        stop(err_msg)
+      } else {
+        params <- unname(parameters(gate))
+        trans_params <- colnames(translist)
+        # transformation required
+        for(param in params) {
+          if(param %in% trans_params) {
+            tfun <- translist@transforms[[param]]@f
+            coords <- gate@boundaries[, param] 
+            coords[!is.infinite(coords)] <- tfun(coords[!is.infinite(coords)])
+            gate@boundaries[, param] <- coords
+          }
+        }
+        return(gate)
+      }
+      # apply named transformations of form `FSC-H`=asinhTrans(`FSC-H`)     
+    } else {
+      gate@boundaries <- as.matrix(
+        transform(
+          as.data.frame(
+            gate@boundaries
+          ),
+          ...
+        )
+      )
+      return(gate)
+    }
+  }
+)
+
+#' @export
+setMethod(
+  "transform",
+  signature = signature(`_data` = "ellipsoidGate"),
+  definition = function(`_data`,
+                        translist, 
+                        ...) {
+
+    # cannot preserve ellipse geometry after transform -> polygonGate
+    gate <- as(`_data`, "polygonGate")
+    gate <- transform(gate, translist = translist, ...)
+    return(gate)
+
+  }
+)
+
+#' @export
+setMethod(
+  "transform",
+  signature = signature(`_data` = "quadGate"),
+  definition = function(`_data`,
+                        translist, 
+                        ...) {
+
+    gate <- `_data`
+    if(!(missing(translist))){
+      #check if it is a transformList
+      res <- try(class(translist), silent = TRUE)
+      if(res != "transformList") {
+        err_msg <- attr(res, "condition")[["message"]]
+        err_msg <- paste(
+          err_msg, 
+          "!Please make sure the unnamed argument is a valid 'transformList' object!"
+        )
+        stop(err_msg)
+      } else {
+        params <- unname(parameters(gate))
+        trans_params <- colnames(translist)
+        # transformation required
+        for(param in params) {
+          if(param %in% trans_params) {
+            tfun <- translist@transforms[[param]]@f
+            if(!is.infinite(gate@boundary[param])) {
+              gate@boundary[param] <- tfun(gate@boundary[param])
+            }
+          }
+        }
+        return(gate)
+      }
+      # apply named transformations of form `FSC-H`=asinhTrans(`FSC-H`)     
+    } else {
+      coords <- as.matrix(
+        transform(
+          as.data.frame(
+            rbind(
+              gate@boundary
+            )
+          ),
+          ...
+        )
+      )
+      gate@boundary <- unlist(coords[1, , drop = TRUE])
+      return(gate)
+    }
+  }
+)
+
+#' @export
+setMethod(
+  "transform",
+  signature = signature(`_data` = "filters"),
+  definition = function(`_data`,
+                        translist, 
+                        ...) {
+
+    # transform each gate in filters list
+    gate <- filters(
+      lapply(
+        unlist(`_data`),
+        function(z) {
+          transform(
+            z,
+            translist = translist,
+            ...
+          )
+        }
+      )
+    )
+    return(gate)
+  }
+)