Add S4 SimpleParams class

DESCRIPTION

 Package: splatter
 Type: Package
 Title: Simple Simulation of Single-cell RNA Sequencing Data
-Version: 0.6.0
-Date: 2016-10-12
+Version: 0.6.1
+Date: 2016-10-13
 Author: Luke Zappia
 Authors@R: as.person(c(
     "Luke Zappia <luke.zappia@mcri.edu.au> [aut, cre]",
@@ -24,7 +24,8 @@ Imports:
     stats,
     locfit,
     akima,
-    Biobase
+    Biobase,
+    checkmate
 Suggests:
     testthat
 biocViews: SingleCell, RNASeq, Transcriptomics, GeneExpression, Sequencing,

R/AllClasses.R

+setClass("Params",
+         contains = "VIRTUAL",
+         slots = c(nGenes = "numeric",
+                   nCells = "numeric",
+                   seed = "numeric"),
+         prototype = prototype(nGenes = 10000, nCells = 100,
+                               seed = sample(1:1e6, 1)))
+
+setClass("SimpleParams",
+         contains = "Params",
+         slots = c(mean.shape = "numeric",
+                   mean.rate = "numeric",
+                   count.disp = "numeric"),
+         prototype = prototype(mean.shape = 0.4, mean.rate = 0.3,
+                               count.disp = 0.1))
\ No newline at end of file

R/AllGenerics.R

+setGeneric("getParam", function(object, name) {standardGeneric("getParam")})
+
+setGeneric("setParam",
+           function(object, name, value) {standardGeneric("setParam")})
+
+setGeneric("expandParams", function(object) {standardGeneric("expandParams")})
\ No newline at end of file

R/Params-methods.R

+setMethod("getParam", "Params", function(object, name) {slot(object, name)})
+
+setMethod("setParam", "Params", function(object, name, value) {
+    checkmate::assertString(name)
+    slot(object, name) <- value
+    validObject(object)
+    return(object)
+})
+
+setMethod("show", "Params", function(object) {
+
+    pp <- list("Global:" = c("(Genes)" = "nGenes",
+                             "(Cells)" = "nCells",
+                             "[Seed]"  = "seed"))
+
+    cat("A Params object of class", class(object), "\n")
+    cat("Parameters can be (estimatable) or [not estimatable],",
+        "'Default' or 'NOT DEFAULT'", "\n\n")
+    showPP(object, pp)
+    cat(length(slotNames(object)) - 3, "additional parameters", "\n\n")
+})
\ No newline at end of file

R/SimpleParams-methods.R

+newSimpleParams <- function(...) {
+
+    params <- new("SimpleParams")
+    params <- setParams(params, ...)
+
+    return(params)
+}
+
+setValidity("SimpleParams", function(object) {
+
+    v <- getParams(object, c("nGenes", "nCells", "mean.shape", "mean.rate",
+                             "count.disp", "seed"))
+
+    checks <- c(nGenes = checkmate::checkInt(v$nGenes, lower = 1),
+                nCells = checkmate::checkInt(v$nCells, lower = 1),
+                mean.rate = checkmate::checkNumber(v$mean.rate, lower = 0),
+                mean.shape = checkmate::checkNumber(v$mean.shape, lower = 0),
+                count.disp = checkmate::checkNumber(v$count.disp, lower = 0),
+                seed = checkmate::checkInt(v$seed, lower = 0))
+
+    if (all(checks == TRUE)) {
+        valid <- TRUE
+    } else {
+        valid <- checks[checks != TRUE]
+        valid <- paste(names(valid), valid, sep = ": ")
+    }
+
+    return(valid)
+})
+
+setMethod("show", "SimpleParams", function(object) {
+
+    pp <- list("Mean:"   = c("(Rate)"       = "mean.rate",
+                             "(Shape)"      = "mean.shape"),
+               "Counts:" = c("(Dispersion)" = "count.disp"))
+
+    callNextMethod()
+    showPP(object, pp)
+})

R/params-functions.R

+getParams <- function(params, names) {
+
+    checkmate::assertClass(params, classes = "Params")
+    checkmate::assertCharacter(names, min.len = 1, any.missing = FALSE)
+
+    sapply(names, getParam, object = params, simplify = FALSE)
+}
+
+setParams <- function(params, update = NULL, ...) {
+
+    checkmate::assertClass(params, classes = "Params")
+    checkmate::assertList(update, null.ok = TRUE)
+
+    update <- c(update, list(...))
+
+    if (length(update) > 0) {
+        for (name in names(update)) {
+            value <- update[[name]]
+            params <- setParam(params, name, value)
+        }
+    }
+
+    return(params)
+}
+
+showPP <- function(params, pp) {
+
+    checkmate::assertClass(params, classes = "Params")
+    checkmate::assertList(pp, types = "character", min.len = 1)
+
+    default <- new(class(params))
+    for (category in names(pp)) {
+        parameters <- pp[[category]]
+        values <- getParams(params, parameters)
+        values <- sapply(values, paste, collapse = ", ")
+        default.values <- getParams(default, parameters)
+        default.values <- sapply(default.values, paste, collapse = ", ")
+        not.default <- values != default.values
+        names(values)[not.default] <- toupper(names(values[not.default]))
+        cat(category, "\n")
+        print(noquote(values), print.gap = 2)
+        cat("\n")
+    }
+}
+
+# mergeParams <- function(params1, params2) {
+#
+#     if (class(params1) != class(params2)) {
+#         stop("params1 and params2 must be of the same Params class")
+#     }
+#
+#     default <- new(class(params1))
+#
+#     update <- list()
+#     for (parameter in slotNames(params1)) {
+#         value1 <- getParam(params1, parameter)
+#         default.value <- getParam(default, parameter)
+#         if (value1 == default.value) {
+#             value2 <- getParam(params2, parameter)
+#             update[[parameter]] <- value2
+#         } else {
+#             update[[parameter]] <- value1
+#         }
+#     }
+#
+#     merged <- setParams(default, update)
+#
+#     return(merged)
+# }
\ No newline at end of file

R/params.R

@@ -209,7 +209,7 @@ print.splatParams <- function(x, ...) {
 #' params <- setParams(params, mean.rate = 1, lib.loc = 12)
 #' params
 #' @export
-setParams <- function(params, ...) {
+setParamsS3 <- function(params, ...) {
 
     update <- list(...)
 
@@ -269,7 +269,7 @@ setParams <- function(params, ...) {
 #' params <- setParams(params, groupCells = c(100, 200))
 #' getParams(params, c("nGenes", "mean.rate", "groupCells"))
 #' @export
-getParams <- function(params, names) {
+getParamsS3 <- function(params, names) {
 
     if (length(names) == 0) {
         return(NULL)
@@ -443,7 +443,7 @@ checkParams <- function(params) {
 #' params <- mergeParams(params, defaultParams())
 #' params
 #' @export
-mergeParams <- function(params1, params2) {
+mergeParamsS3 <- function(params1, params2) {
 
     for (i in 1:length(params1)) {
         for (j in 1:length(params1[[i]])) {