params.R

#' Get a parameter
#'
#' Accessor function for getting parameter values.
#'
#' @param object object to get parameter from.
#' @param name name of the parameter to get.
#'
#' @return The extracted parameter value
#'
#' @examples
#' \dontrun{
#' params <- newParams()
#' getParam(object = params,name = "nGenes")
#' }
#' @rdname getParam
#' @export
setGeneric("getParam", function(object, name) {standardGeneric("getParam")})

#' Set a parameter
#'
#' Accessor function for setting parameter values.
#'
#' @param object object to set parameter in.
#' @param name name of the parameter to set.
#' @param value value to set the paramter to.
#'
#' @return Object with new parameter value.
#'
#' @examples
#' \dontrun{
#' params <- newParams()
#' params <- setParam(object = params,name = "nPatients",value = 250)
#' }
#' @rdname setParam
#' @importFrom methods new rbind2 slot slot<- slotNames validObject
#' @export
setGeneric("setParam",
           function(object, name, value) {
             standardGeneric("setParam")
           })

#' The Params virtual class
#'
#' Virtual S4 class that stores all parameters needed for the simulation of gene expression data.
#'
#' @section Parameters:
#' The Params class defines the following parameters:
#' \describe{
#'     \item{\code{nGenes}}{A list containing the numbers of genes to simulate for
#'     each scenario and modality.}
#'     \item{\code{means}}{A list containing the parameter range for the mean for
#'     each scenario and modality.}
#'     \item{\code{foldChanges}}{A list containing the parameter range for the log2
#'     foldChanges between distributions for multimodal genes. Has to contain one
#'     entry less than the modality that is simulated.}
#'     \item{\code{sd}}{The parameters mu and lambda for the generation of the
#'     standard deviation of each distribution via an Inverse Gaussian distribution.}
#'     \item{\code{gamma}}{The shape and rate parameter  for generating the gamma
#'     distributions.}
#'     \item{\code{proportions}}{Parameters for the allowed proportions of
#'     multimodal distributions.}
#'     \item{\code{nPatients}}{The number of patients to simulate and how
#'     many columns the simulated gene expression should have per gene.}
#'     \item{\code{seed}}{Seed to use for generating random numbers.}
#' }
#'
#' @name Params
#' @rdname Params
#' @aliases Params-class
#' @exportClass Params
setClass("Params",
         slots = c(nGenes ="list",
                   means = "list",
                   foldChanges = "list",
                   sd = "list",
                   gamma = "list",
                   proportions = "vector",
                   nPatients = "numeric",
                   seed = "numeric"),
         prototype = prototype(nGenes = list("1"= 700, "2" = list("gauss"=150,"gamma"=150)),
                               means = list("1"=c(2,4),"2" = c(2,4)),
                               foldChanges = list("1" = c(2,4),"2" = list("gauss"= c(2,4),"gamma" = c(3,5))),
                               sd = list("mu"= 0.61,"lambda"=2.21),
                               gamma = list("shape" = 2, "rate" = 2),
                               proportions = c(10,20,30,40,50,60,70,80,90),
                               nPatients = 200,
                               seed = sample(1:1e6, 1)))

#' @rdname getParam
setMethod("getParam", "Params", function(object, name) {
  methods::slot(object, name)
})

#' @rdname setParam
setMethod("setParam", "Params", function(object, name, value) {
  checkmate::assertString(name)
  methods::slot(object, name) <- value
  methods::validObject(object)
  return(object)
})

setMethod("show", "Params", function(object) {

  pp <- list("Global:" = c("nGenes" = "nGenes",
                           "Means" = "means",
                           "FoldChanges" = "foldChanges",
                           "sd" ="sd",
                           "Gamma" ="gamma",
                           "Proportions" =  "proportions",
                           "nPatients" = "nPatients",
                           "Seed" = "seed"))

  cat("A Params object of class", class(object), "\n")
  cat("Parameters can be Default' or 'NOT DEFAULT'.", "\n\n")
  showPP(object, pp)
  cat(length(methods::slotNames(object)) - 8, "additional parameters", "\n\n")
})

#' New Params
#'
#' Create a new Params object.
#'
#' @param ... additional parameters passed to \code{\link{setParams}}.
#'
#' @return New Params object.
#' @examples
#' \dontrun{
#' params <- newParams()
#' params <- newParams("nGenes"=list("1"=10,"2"=list("gauss"=10,"gamma"=10)),
#' "proportions"=c(30,70))
#' params <- newParams(
#' nGenes=list("1"=c(70),"2"=list(gauss = 15, gamma = 15),
#' "3"=list(gauss = 15, gamma = 15)),
#' means=list("1"= c(2, 4),"2"= c(2, 4),"3"= c(2, 4)),
#' foldChanges = list("1"=NA,"2"= list(gauss = c(2, 4), gamma = c(2, 4)),
#' "3"= list(gauss = list(c(2, 4), c(2, 4)), gamma = list(c(2, 4), c(2, 4)))))
#' }
#' @rdname newParams
#' @export
newParams <- function(...) {

  params <- methods::new("Params")
  params <- setParams(params, ...)

  return(params)
}

#' Get parameters
#'
#' Get multiple parameter values from a Params object.
#'
#' @param params Params object to get values from.
#' @param names vector of names of the parameters to get.
#'
#' @return List with the values of the selected parameters.
#' @examples
#' \dontrun{
#' params <- newParams()
#' getParams(params = params,names = c("nGenes","foldChanges","proportions","means"))
#' }
#' @export
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)
}

#' Set parameters
#'
#' Set multiple parameters in a Params object.
#'
#' @param params Params object to set parameters in.
#' @param update list of parameters to set where \code{names(update)} are the
#'        names of the parameters to set and the items in the list are values.
#' @param ... additional parameters to set. These are combined with any
#'        parameters specified in \code{update}.
#'
#' @details
#' Each parameter is set by a call to \code{\link{setParam}}. If the same
#' parameter is specified multiple times it will be set multiple times.
#' Parameters can be specified using a list via \code{update} (useful when
#' collecting parameter values in some way) or individually (useful when setting
#' them manually), see examples.
#'
#' @return Params object with updated values.
#' @examples
#' \dontrun{
#' params <- newParams()
#' params
#' # Set individually
#' params <- params <- setParams(params,proportions = c(80,20),
#' foldChanges = list("1"=c(2,4),"2"= list("gauss"=c(2,5),"gamma"=c(3,5))))
#' params
#' # Set via update list
#' params <- setParams(params,update = list("nGenes"=list("1"=10,
#' "2"=list("gauss"=20,"gamma"=10)),"means"=list("1"=c(1,3),"2"=c(2,4)),
#' "nPatients"=700))
#' params
#' }
#' @export
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)
}

#' Show pretty print
#'
#' Function used for pretty printing Params object.
#'
#' @param params object to show.
#' @param pp list specifying how the object should be displayed.
#'
#' @return Print params object to console
#'
#' @importFrom utils head
showPP <- function(params, pp) {

  checkmate::assertClass(params, classes = "Params")
  checkmate::assertList(pp, types = "character", min.len = 1)

  default <- methods::new(class(params))
  for (category in names(pp)) {
    parameters <- pp[[category]]
    values <- getParams(params, parameters)
    short.values <- sapply(values, function(x) {
      if (length(x) > 10) {
        paste0(paste(head(x, n = 4), collapse = ", "), ",...")
      } else {
        paste(x, collapse = ", ")
      }
    })
    values <- sapply(values, paste, collapse = ", ")
    default.values <- getParams(default, parameters)
    default.values <- sapply(default.values, paste, collapse = ", ")
    not.default <- values != default.values
    names(short.values)[not.default] <- toupper(names(values[not.default]))
    cat(category, "\n")
    print(noquote(short.values), print.gap = 2)
    cat("\n")
  }
}