R/ZINBParams-methods.R

In Oshlack/splatter: Simple Simulation of Single-cell RNA Sequencing Data

#' @rdname newParams
#' @importFrom methods new
#' @export
newZINBParams <- function(...) {
    if (!requireNamespace("zinbwave", quietly = TRUE)) {
        stop("The ZINB-WaVE simulation requires the 'zinbwave' package.")
    }

    params <- new("ZINBParams")
    default.model <- zinbwave::zinbModel()

    params <- setParams(params, model = default.model)
    params <- setParams(params, ...)

    return(params)
}

setValidity("ZINBParams", function(object) {
    v <- getParams(object, slotNames(object))

    checks <- c(
        nGenes = checkmate::checkInt(v$nGenes, lower = 1),
        nCells = checkmate::checkInt(v$nCells, lower = 1),
        seed = checkmate::checkInt(v$seed, lower = 0),
        model = checkmate::checkClass(v$model, "ZinbModel"),
        model_valid = validObject(v$model, test = TRUE)
    )

    if (all(checks == TRUE)) {
        valid <- TRUE
    } else {
        valid <- checks[checks != TRUE]
        valid <- paste(names(valid), valid, sep = ": ")
    }

    return(valid)
})

#' @rdname setParam
setMethod("setParam", "ZINBParams", function(object, name, value) {
    checkmate::assertString(name)

    if (name %in% c("nGenes", "nCells")) {
        stop(name, " cannot be set directly, set model instead")
    }

    if (name == "model") {
        checkmate::assertClass(value, "ZinbModel")
        object <- setParamUnchecked(
            object, "nGenes",
            as.numeric(zinbwave::nFeatures(value))
        )
        object <- setParamUnchecked(
            object, "nCells",
            as.numeric(zinbwave::nSamples(value))
        )
    }

    object <- callNextMethod()

    return(object)
})

setMethod("show", "ZINBParams", function(object) {
    pp <- list(
        "Design:" = c(
            "(Samples)" = "X",
            "(Genes)" = "V"
        ),
        "Offsets:" = c(
            "(Mu)" = "O_mu",
            "(Pi)" = "O_pi"
        ),
        "Indices:" = c(
            "(Sample Mu)" = "which_X_mu",
            "(Gene Mu)" = "which_V_mu",
            "(Sample Pi)" = "which_X_pi",
            "(Gene Pi)" = "which_V_pi"
        ),
        "Intercepts:" = c(
            "(Sample Mu)" = "X_mu_intercept",
            "(Gene Mu)" = "V_mu_intercept",
            "(Sample Pi)" = "X_pi_intercept",
            "(Gene Pi)" = "V_pi_intercept"
        ),
        "Latent factors:" = c("(W)" = "W"),
        "Coefficients:" = c(
            "(Sample Mu)" = "beta_mu",
            "(Gene Mu)" = "gamma_mu",
            "(Latent Mu)" = "alpha_mu",
            "(Sample Pi)" = "beta_pi",
            "(Gene Pi)" = "gamma_pi",
            "(Latent Pi)" = "alpha_pi"
        ),
        "Regularisation:" = c(
            "(Sample Mu)" = "epsilon_beta_mu",
            "(Gene Mu)" = "epsilon_gamma_mu",
            "(Sample Pi)" = "epsilon_beta_pi",
            "(Gene Pi)" = "epsilon_gamma_pi",
            "(Latent)" = "epsilon_W",
            "(Latent coeffs)" = "epsilon_alpha",
            "(Zeta)" = "epsilon_zeta",
            "(Logit)" = "epsilon_min_logit"
        )
    )

    callNextMethod()

    model <- getParam(object, "model")
    default <- zinbwave::zinbModel()
    not.default <- !identical(model, default)
    cat(crayon::bold("Model:"), "\n")
    msg <- paste(
        "ZinbModel with", zinbwave::nFeatures(model), "features,",
        zinbwave::nSamples(model), "samples,",
        zinbwave::nFactors(model), "latent factors and",
        zinbwave::nParams(model), "parameters"
    )
    if (not.default) {
        msg <- crayon::bold(crayon::green(msg))
    }
    cat(msg, "\n\n")


    cat(crayon::bold("Parameters of the ZinbModel"), "\n\n")
    for (category in names(pp)) {
        parameters <- pp[[category]]
        values <- lapply(parameters, function(x) {
            slot(model, x)
        })
        short.values <- vapply(values, function(x) {
            if ("matrix" %in% class(x)) {
                if (nrow(x) == 1) {
                    paste0(paste(head(x[1, ], n = 4), collapse = ", "), ",...")
                } else if (ncol(x) == 1) {
                    paste0(paste(head(x[, 1], n = 4), collapse = ", "), ",...")
                } else {
                    paste(nrow(x), "x", ncol(x), "matrix")
                }
            } else if (length(x) > 4) {
                paste0(paste(head(x, n = 4), collapse = ", "), ",...")
            } else {
                paste(x, collapse = ", ")
            }
        }, c(Value = "None"))
        values <- vapply(values, paste, c(Value = "None"), collapse = ", ")
        default.values <- lapply(parameters, function(x) {
            slot(default, x)
        })
        default.values <- vapply(default.values, paste, c(Value = "None"),
            collapse = ", "
        )
        not.default <- values != default.values
        cat(crayon::bold(c("Model", category)), "\n")
        showValues(short.values, not.default)
        cat("\n")
    }
})