From e036aaa49beeeecec3ee61b16cb3ef882e6936fc Mon Sep 17 00:00:00 2001 From: Yichen Wang Date: Sun, 3 Mar 2024 19:52:18 -0500 Subject: [PATCH] Continue update logging to CLI form --- NAMESPACE | 2 +- R/ATAC.R | 6 - R/DEG_marker.R | 47 ++-- R/DoubletFinder.R | 27 ++- R/GSEA.R | 40 ++-- R/classConversion.R | 6 +- R/classes.R | 15 +- R/clustering.R | 8 +- R/dotplot.R | 5 +- R/embedding.R | 10 +- R/factorMarker.R | 34 ++- R/generics.R | 2 +- R/ggplotting.R | 17 +- R/h5Utility.R | 53 ++-- R/heatmap.R | 11 +- R/import.R | 148 ++++++------ R/integration.R | 13 +- R/liger-methods.R | 360 ++++++++++++++++------------ R/ligerCommand_relates.R | 10 +- R/ligerDataset-methods.R | 44 ++-- R/preprocess.R | 38 ++- R/subsetObject.R | 139 +++++++---- R/util.R | 131 +++++----- R/visualization.R | 64 ++--- man/liger-class.Rd | 39 +-- man/plotVolcano.Rd | 4 + man/sub-liger.Rd | 32 +++ man/subsetLiger.Rd | 4 +- man/subsetLigerDataset.Rd | 6 +- tests/testthat/test_downstream.R | 10 +- tests/testthat/test_object.R | 32 +-- tests/testthat/test_preprocessing.R | 4 +- tests/testthat/test_subset.R | 18 +- tests/testthat/test_visualization.R | 2 +- 34 files changed, 773 insertions(+), 608 deletions(-) create mode 100644 man/sub-liger.Rd diff --git a/NAMESPACE b/NAMESPACE index 4f9b714..84bd3aa 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,5 +1,6 @@ # Generated by roxygen2: do not edit by hand +S3method("[",liger) S3method("[",ligerDataset) S3method("[[",liger) S3method(.DollarNames,liger) @@ -189,7 +190,6 @@ exportClasses(ligerRNADataset) exportClasses(ligerSpatialDataset) exportMethods("$") exportMethods("$<-") -exportMethods("[") exportMethods("cellMeta<-") exportMethods("coordinate<-") exportMethods("dataset<-") diff --git a/R/ATAC.R b/R/ATAC.R index 77ba674..b3867a3 100644 --- a/R/ATAC.R +++ b/R/ATAC.R @@ -50,12 +50,6 @@ imputeKNN <- function( knn_k = nNeighbors ) { .deprecateArgs(list(knn_k = "nNeighbors"), defunct = "scale") - # if (!requireNamespace("FNN", quietly = TRUE)) { - # stop("Package \"foreach\" needed for this function to work. ", - # "Please install it by command:\n", - # "install.packages('FNN')", - # call. = FALSE) - # } if (is.null(getMatrix(object, "H.norm"))) cli::cli_abort( "Aligned factor loading has to be available for imputation. diff --git a/R/DEG_marker.R b/R/DEG_marker.R index 69978df..2916215 100644 --- a/R/DEG_marker.R +++ b/R/DEG_marker.R @@ -96,7 +96,7 @@ runPairwiseDEG <- function( groups <- list(group1Idx, group2Idx) names(groups) <- c(group1Name, group2Name) } else { - stop("Please see `?runPairwiseDEG` for usage.") + cli::cli_abort("Please see {.code ?runPairwiseDEG} for usage.") } result <- .runDEG(object, groups = groups, method = method, usePeak = usePeak, useReplicate = useReplicate, @@ -161,7 +161,7 @@ runMarkerDEG <- function( allCellIdx <- seq(ncol(object))[object$dataset %in% useDatasets] conditionBy <- conditionBy %||% object@uns$defaultCluster if (is.null(conditionBy)) { - stop("No `conditionBy` given or default cluster not set.") + cli::cli_abort("No {.var conditionBy} given or default cluster not set.") } conditionBy <- .fetchCellMetaVar( object, conditionBy, cellIdx = allCellIdx, @@ -241,6 +241,8 @@ runWilcoxon <- function( ) { method <- match.arg(method) allCellIdx <- unlist(groups) + if (length(allCellIdx) == 0) + cli::cli_abort(c(x = "No cell selected")) allCellBC <- colnames(object)[allCellIdx] datasetInvolve <- levels(object$dataset[allCellIdx, drop = TRUE]) var <- factor(rep(names(groups), lengths(groups)), levels = names(groups)) @@ -258,8 +260,10 @@ runWilcoxon <- function( mat <- Reduce(cbind, dataList) mat <- mat[, allCellBC, drop = FALSE] if (method == "wilcoxon") { + cliID <- cli::cli_process_start("Running Wilcoxon rank-sum test") mat <- log1p(1e10*mat) result <- wilcoxauc(mat, var) + cli::cli_process_done(id = cliID) } else if (method == "pseudoBulk") { if (is.null(useReplicate)) { replicateAnn <- setupPseudoRep(var, nRep = nPsdRep, @@ -292,18 +296,20 @@ runWilcoxon <- function( .DE.checkDataAvail <- function(object, useDatasets, method, usePeak) { if (isH5Liger(object, useDatasets)) { # nocov start - stop("HDF5 based datasets detected but is not supported. \n", - "Try `object.sub <- downsample(object, useSlot = ", - "'normData')` to create ANOTHER object with in memory data.") + cli::cli_abort( + c("HDF5 based datasets detected but is not supported. ", + "i" = "Try {.code object.sub <- downsample(object, useSlot = 'normData')} to create another object with in memory data") + ) } # nocov end if (method == "wilcoxon") { slot <- ifelse(usePeak, "normPeak", "normData") } else if (method == "pseudoBulk") { if (!requireNamespace("DESeq2", quietly = TRUE)) # nocov start - stop("Package \"DESeq2\" needed for this function to work. ", - "Please install it by command:\n", - "BiocManager::install('DESeq2')", - call. = FALSE) # nocov end + cli::cli_abort( + "Package {.pkg DESeq2} is needed for this function to work. + Please install it by command: + {.code BiocManager::install('DESeq2')}" + ) # nocov end slot <- ifelse(usePeak, "rawPeak", "rawData") } allAvail <- all(sapply(useDatasets, function(d) { @@ -311,8 +317,10 @@ runWilcoxon <- function( !is.null(methods::slot(ld, slot)) })) if (!allAvail) - stop(slot, " not all available for involved datasets. [method = \"", - method, "\", usePeak = ", usePeak, "]") + cli::cli_abort( + c("{.field {slot}} not all available for involved datasets: {.val {useDatasets}}", + "i" = "{.code method = '{method}'}; {.code usePeak = {usePeak}}") + ) return(slot) } @@ -345,9 +353,10 @@ makePseudoBulk <- function(mat, replicateAnn, minCellPerRep, verbose = TRUE) { subrep <- replicateAnn[replicateAnn$groups == gr,] splitLabel <- interaction(subrep, drop = TRUE) if (nlevels(splitLabel) < 2) { - stop("Too few replicates label for condition \"", gr, "\". ", - "Cannot not create pseudo-bulks. Please use ", - "consider creating pseudo-replicates or use wilcoxon instead.") + cli::cli_abort( + c("Too few replicates for condition {.val {gr}}. Cannot create pseudo-bulks.", + "i" = "Please consider creating pseudo-replicates or using {.code method = 'wilcoxon'} instead.") + ) } } splitLabel <- interaction(replicateAnn, drop = TRUE) @@ -360,10 +369,9 @@ makePseudoBulk <- function(mat, replicateAnn, minCellPerRep, verbose = TRUE) { mat <- mat[, idx, drop = FALSE] replicateAnn <- replicateAnn[idx, , drop = FALSE] if (verbose) { - .log("Ignoring replicates with too few cells: ", - paste0(ignored, collapse = ", ")) - .log("Replicate size:") - .log(paste0(levels(splitLabel), ": ", table(splitLabel), collapse = ", "), level = 2) + if (length(ignored) > 0) cli::cli_alert_warning("Ignoring replicates with too few cells: {.val {ignored}}") + cli::cli_alert_info("Replicate sizes:") + print(table(splitLabel)) } pseudoBulks <- colAggregateSums_sparse(mat, as.integer(splitLabel) - 1, nlevels(splitLabel)) @@ -375,7 +383,7 @@ makePseudoBulk <- function(mat, replicateAnn, minCellPerRep, verbose = TRUE) { .callDESeq2 <- function(pseudoBulks, groups, verbose = getOption("ligerVerbose")) { # DESeq2 workflow - if (isTRUE(verbose)) .log("Calling DESeq2 Wald test") + if (isTRUE(verbose)) cliID <- cli::cli_process_start("Calling DESeq2 Wald test") ## NOTE: DESeq2 wishes that the contrast/control group is the first level ## whereas we required it as the second in upstream input. So we need to ## reverse it here. @@ -396,6 +404,7 @@ makePseudoBulk <- function(mat, replicateAnn, minCellPerRep, verbose = TRUE) { res$group <- levels(groups)[2] res <- res[, c(7, 8, 2, 5, 6)] colnames(res) <- c("feature", "group", "logFC", "pval", "padj") + if (isTRUE(verbose)) cli::cli_process_done(id = cliID) return(res) } diff --git a/R/DoubletFinder.R b/R/DoubletFinder.R index fa2e2f3..1dc4c3d 100644 --- a/R/DoubletFinder.R +++ b/R/DoubletFinder.R @@ -41,27 +41,29 @@ runDoubletFinder <- function( ... ) { if (!requireNamespace("DoubletFinder", quietly = TRUE)) { # nocov start - stop("DoubletFinder need to be installed. Please run:\n", - "remotes::install_github('chris-mcginnis-ucsf/DoubletFinder')") + cli::cli_abort( + "Package {.pkg DoubletFinder} is needed for this function to work. + Please install it by command: + {.code remotes::install_github('DoubletFinder')}") } if (!requireNamespace("Seurat", quietly = TRUE)) { - stop("Seurat need to be installed. Please run:\n", - "install.packages(\"Seurat\")") + cli::cli_abort( + "Package {.pkg Seurat} is needed for this function to work. + Please install it by command: + {.code install.packages('Seurat')}") } # nocov end useDatasets <- .checkUseDatasets(object, useDatasets = useDatasets) - nNeighbors <- .checkArgLen(nNeighbors, length(useDatasets), repN = TRUE) - if (!is.null(nExp)) { - nExp <- .checkArgLen(nExp, length(useDatasets), repN = TRUE) - } else { - nExp <- sapply(useDatasets, function(d) { + nNeighbors <- .checkArgLen(nNeighbors, length(useDatasets), repN = TRUE, class = "numeric") + nExp <- .checkArgLen(nExp, length(useDatasets), repN = TRUE, class = "numeric") + if (is.null(nExp)) + nExp <- sapply(useDatasets, function(d) round(0.15 * ncol(dataset(object, d))) - }) - } + ) object <- recordCommand(object, ..., dependencies = c("Seurat", "DoubletFinder")) for (i in seq_along(useDatasets)) { d <- useDatasets[i] - if (isTRUE(verbose)) .log("Running DoubletFinder on dataset: ", d) + if (isTRUE(verbose)) cliID <- cli::cli_process_start("Running DoubletFinder on dataset {.val {d}}") seu <- Seurat::CreateSeuratObject(rawData(object, d)) %>% Seurat::NormalizeData(verbose = FALSE) %>% Seurat::FindVariableFeatures(verbose = FALSE) %>% @@ -74,6 +76,7 @@ runDoubletFinder <- function( DFCol <- grep(pattern = "DF.classifications", colnames(seuMeta)) cellMeta(object, "DoubletFinder_pANN", useDatasets = d) <- seuMeta[,pANNCol] cellMeta(object, "DoubletFinder_classification", useDatasets = d) <- seuMeta[,DFCol] + if (isTRUE(verbose)) cli::cli_process_done(id = cliID) } return(object) } diff --git a/R/GSEA.R b/R/GSEA.R index 04c0bcc..dc6a089 100644 --- a/R/GSEA.R +++ b/R/GSEA.R @@ -32,22 +32,22 @@ runGSEA <- function( custom_gene_sets = customGenesets ) { if (!requireNamespace("org.Hs.eg.db", quietly = TRUE)) # nocov start - stop("Package \"org.Hs.eg.db\" needed for this function to work. ", - "Please install it by command:\n", - "BiocManager::install('org.Hs.eg.db')", - call. = FALSE) + cli::cli_abort( + "Package {.pkg org.Hs.eg.db} is needed for this function to work. + Please install it by command: + {.code BiocManager::install('org.Hs.eg.db')}") if (!requireNamespace("reactome.db", quietly = TRUE)) - stop("Package \"reactome.db\" needed for this function to work. ", - "Please install it by command:\n", - "BiocManager::install('reactome.db')", - call. = FALSE) + cli::cli_abort( + "Package {.pkg reactome.db} is needed for this function to work. + Please install it by command: + {.code BiocManager::install('reactome.db')}") if (!requireNamespace("fgsea", quietly = TRUE)) - stop("Package \"fgsea\" needed for this function to work. ", - "Please install it by command:\n", - "BiocManager::install('fgsea')", - call. = FALSE) # nocov end + cli::cli_abort( + "Package {.pkg fgsea} is needed for this function to work. + Please install it by command: + {.code BiocManager::install('fgsea')}") # nocov end .deprecateArgs(list(gene_sets = "genesets", mat_w = "useW", @@ -164,14 +164,14 @@ runGOEnrich <- function( ... ) { if (!requireNamespace("gprofiler2", quietly = TRUE)) # nocov start - stop("Package \"gprofiler2\" needed for this function to work. ", - "Please install it by command:\n", - "install.packages('gprofiler2')", - call. = FALSE) # nocov end + cli::cli_abort( + "Package {.pkg gprofiler2} is needed for this function to work. + Please install it by command: + {.code install.packages('gprofiler2')}") # nocov end + group <- group %||% unique(result$group) if (any(!group %in% result$group)) { - stop("Selected groups not available `result$group`: ", - paste(group[!group %in% result$group], collapse = ", ")) + cli::cli_abort("Selected groups not available in {.code result$group}: {.val {group[!group %in% result$group]}}") } bg <- NULL domain_scope <- "annotated" # gprofiler2 default @@ -190,9 +190,9 @@ runGOEnrich <- function( ordered_query <- FALSE if (!is.null(orderBy)) { ordered_query <- TRUE - if (length(orderBy) > 1) stop("Only one `orderBy` metric allowed") + if (length(orderBy) > 1) cli::cli_abort("Only one {.code orderBy} metric allowed") if (!orderBy %in% c("logFC", "pval", "padj")) { - stop("`orderBy` should be one of 'logFC', 'pval' or 'padj'.") + cli::cli_abort("{.code orderBy} should be one of {.val logFC}, {.val pval} or {.val padj}.") } if (orderBy == "logFC") { resultUp <- resultUp[order(resultUp$logFC, decreasing = TRUE),] diff --git a/R/classConversion.R b/R/classConversion.R index bd38c25..3a0747a 100644 --- a/R/classConversion.R +++ b/R/classConversion.R @@ -18,7 +18,7 @@ as.liger.dgCMatrix <- function( datasetVar <- droplevels(datasetVar) rawDataList <- splitRmMiss(object, datasetVar) - modal <- .checkArgLen(modal, length(rawDataList)) + modal <- .checkArgLen(modal, length(rawDataList), class = "character") createLiger(rawData = rawDataList, modal = modal, ...) } @@ -61,7 +61,7 @@ as.liger.SingleCellExperiment <- function( if (!is.factor(datasetVar)) datasetVar <- factor(datasetVar) datasetVar <- droplevels(datasetVar) raw <- splitRmMiss(raw, datasetVar) - modal <- .checkArgLen(modal, length(raw)) + modal <- .checkArgLen(modal, length(raw), class = "character") lig <- createLiger(raw, modal = modal, ...) colDataCopy <- SummarizedExperiment::colData(object) for (cdn in colnames(colDataCopy)) { @@ -119,7 +119,7 @@ as.liger.Seurat <- function( } datasetVar <- datasetVar %||% "Seurat" - modal <- .checkArgLen(modal, length(raw)) + modal <- .checkArgLen(modal, length(raw), class = "character") lig <- createLiger(raw, modal = modal, ...) colnames(object) <- colnames(lig) for (cdn in colnames(object[[]])) { diff --git a/R/classes.R b/R/classes.R index 720859f..d1f473f 100644 --- a/R/classes.R +++ b/R/classes.R @@ -420,29 +420,28 @@ ligerSpatialDataset <- setClass( .checkCoords <- function(ld, value) { if (is.null(rownames(value))) { - warning("No rownames with given spatial coordinate, ", - "assuming they match with the cells.") + cli::cli_alert_warning("No rownames with given spatial coordinate. Assuming they match with the cells.") rownames(value) <- colnames(ld) } if (is.null(colnames(value))) { if (ncol(value) <= 3) { colnames(value) <- c("x", "y", "z")[seq(ncol(value))] } else { - stop("More than 3 dimensions for the coordinates but no ", - "colnames are given.") + cli::cli_abort("More than 3 dimensions for the coordinates but no colnames are given.") } - warning("No colnames with given spatial coordinate, ", - "setting to ", paste0(colnames(value), collapse = ", ")) + cli::cli_alert_warning( + "No colnames with given spatial coordinate. Setting to {.val {colnames(value)}}" + ) } full <- matrix(NA, nrow = ncol(ld), ncol = ncol(value), dimnames = list(colnames(ld), colnames(value))) cellIsec <- intersect(rownames(value), colnames(ld)) full[cellIsec, colnames(value)] <- value[cellIsec,] if (any(is.na(full))) { - warning("NA generated for missing cells.") + cli::cli_alert_warning("NA generated for missing cells.") } if (any(!rownames(value) %in% rownames(full))) { - warning("Cells in given coordinate not found in the dataset.") + cli::cli_alert_warning("Cells in given coordinate not found in the dataset.") } return(full) } diff --git a/R/clustering.R b/R/clustering.R index ac7cdc3..5b15358 100644 --- a/R/clustering.R +++ b/R/clustering.R @@ -82,7 +82,7 @@ runCluster <- function( if (!is.null(useDims)) H <- H[, useDims, drop = FALSE] if (isTRUE(verbose)) - cli::cli_alert_info("{method} clustering on {type} cell factor loadings...") + cli::cli_process_start("{method} clustering on {type} cell factor loadings...") knn <- RANN::nn2(H, k = nNeighbors, eps = eps) snn <- ComputeSNN(knn$nn.idx, prune = prune) if (!is.null(seed)) set.seed(seed) @@ -124,10 +124,10 @@ runCluster <- function( verbose = verbose) cellMeta(object, clusterName, check = FALSE) <- clusts if (isTRUE(verbose)) - cli::cli_alert_success("Found {nlevels(clusts)} clusters.") + cli::cli_process_done(msg_done = "{method} clustering on {type} cell factor loadings ... Found {nlevels(clusts)} clusters.") object@uns$defaultCluster <- object@uns$defaultCluster %||% clusterName if (isTRUE(verbose)) - cli::cli_alert_info("cellMeta variable {.val {clusterName}} is now set as default.") + cli::cli_alert_info("cellMeta variable {.field {clusterName}} is now set as default.") return(object) } @@ -291,7 +291,7 @@ mapCellMeta <- function( object <- recordCommand(object, ...) from <- cellMeta(object, from) if (!is.factor(from)) - cli::cli_abort("{.code from} must be a {.cls factor}.") + cli::cli_abort("{.var from} must be a {.cls factor}.") mapping <- list(...) fromCats <- names(mapping) notFound <- fromCats[!fromCats %in% levels(from)] diff --git a/R/dotplot.R b/R/dotplot.R index 0d7c13c..569098d 100644 --- a/R/dotplot.R +++ b/R/dotplot.R @@ -290,7 +290,10 @@ plotClusterFactorDot <- function( ) if (length(viridisOption) != 1 || !viridisOption %in% viridisAvail) - stop("`viridisOption` has to be one value from the available choices.") + cli::cli_abort( + c("{.var viridisOption} has to be one value from the available choices: ", + "{.val {viridisAvail}}") + ) ## Font-size specification # Broadcast one-param setting to each diff --git a/R/embedding.R b/R/embedding.R index 0bbdae5..7d42dd6 100644 --- a/R/embedding.R +++ b/R/embedding.R @@ -73,14 +73,17 @@ runUMAP <- function( useRaw <- Hsearch$useRaw type <- ifelse(useRaw, "unnormalized", "quantile normalized") if (isTRUE(verbose)) - cli::cli_alert_info("Generating UMAP on {type} cell factor loadings...") + cli::cli_process_start("Generating UMAP on {type} cell factor loadings...") if (!is.null(useDims)) H <- H[, useDims, drop = FALSE] umap <- uwot::umap(H, n_components = as.integer(nDims), metric = distance, n_neighbors = as.integer(nNeighbors), min_dist = minDist) + if (isTRUE(verbose)) cli::cli_process_done() dimRed(object, dimredName) <- umap + if (isTRUE(verbose)) + cli::cli_alert_info("cellMeta variable {.field {dimredName}} is now set as default.") return(object) } @@ -163,7 +166,7 @@ runTSNE <- function( useRaw <- Hsearch$useRaw type <- ifelse(useRaw, "unnormalized", "quantile normalized") if (isTRUE(verbose)) - cli::cli_alert_info("Generating TSNE ({method}) on {type} cell factor loadings...") + cli::cli_process_start("Generating TSNE ({method}) on {type} cell factor loadings...") if (!is.null(useDims)) H <- H[, useDims, drop = FALSE] if (method == "Rtsne") { set.seed(seed) @@ -182,8 +185,11 @@ runTSNE <- function( theta = theta, perplexity = perplexity) } + if (isTRUE(verbose)) cli::cli_process_done() dimRed(object, dimredName) <- tsne object@uns$TSNE <- list(method = method) + if (isTRUE(verbose)) + cli::cli_alert_info("cellMeta variable {.field {dimredName}} is now set as default.") return(object) } diff --git a/R/factorMarker.R b/R/factorMarker.R index 41299fc..8ae4fc7 100644 --- a/R/factorMarker.R +++ b/R/factorMarker.R @@ -66,7 +66,7 @@ getFactorMarkers <- function( dataset1 <- .checkUseDatasets(object, useDatasets = dataset1) dataset2 <- .checkUseDatasets(object, useDatasets = dataset2) if (any(isH5Liger(object, dataset = c(dataset1, dataset2)))) - stop("Please use in-memory liger object for this analysis.`") + cli::cli_abort("Please use in-memory {.cls liger} object for this analysis") if (is.null(nGenes)) { nGenes <- length(varFeatures(object)) } @@ -78,11 +78,13 @@ getFactorMarkers <- function( } useFactors <- which(abs(datasetSpecificity) <= factorShareThresh) if (length(useFactors) == 0) { - stop("No factor passed the dataset specificity threshold, ", - "please try a larger `factorShareThresh`.") + cli::cli_abort( + c("No factor passed the dataset specificity threshold", + i = "please try a larger {.var factorShareThresh}.") + ) } if (length(useFactors) == 1 && isTRUE(verbose)) { - warning("Only 1 factor passed the dataset specificity threshold.") + cli::cli_alert_warning("Only 1 factor passed the dataset specificity threshold.") } H <- getMatrix(object, "H", dataset = c(dataset1, dataset2)) @@ -101,10 +103,16 @@ getFactorMarkers <- function( W_matrices <- list() vargene <- varFeatures(object) if (isTRUE(verbose)) { - .log("Performing wilcoxon test between datasets \"", dataset1, - "\" and \"", dataset2, "\", \nbasing on factor loading.") - if (!isTRUE(printGenes)) - pb <- utils::txtProgressBar(0, length(useFactors), style = 3) + if (isTRUE(printGenes)) { + cli::cli_alert_info( + "Performing wilcoxon test between {.val {dataset1}} and {.val {dataset2}} basing on factor loading." + ) + } else { + cli::cli_progress_bar( + name = "Testing between {.val {dataset1}} and {.val {dataset2}}", + total = length(useFactors), type = "iter", clear = FALSE + ) + } } for (j in seq_along(useFactors)) { i <- useFactors[j] @@ -116,8 +124,7 @@ getFactorMarkers <- function( # if not max factor for any cell in either dataset if (sum(labels[[dataset1]] == i) <= 1 || sum(labels[[dataset2]] == i) <= 1) { - warning("Factor ", i, " did not appear as max in ", - "any cell in either dataset", immediate. = TRUE) + cli::cli_alert_warning("Factor {i} did not appear as max in any cell in either dataset") next } @@ -164,15 +171,16 @@ getFactorMarkers <- function( if (isTRUE(verbose)) { if (isTRUE(printGenes)) { - .log("Factor ", i) - message("Dataset 1:\n", + cli::cli_h2("Factor {i}") + cat("Dataset 1:\n", paste(topGenesV1, collapse = ", "), "\nShared:\n", paste(topGenesW, collapse = ", "), "\nDataset 2\n", paste(topGenesV2, collapse = ", "), "\n") } else { - utils::setTxtProgressBar(pb, j) + cli::cli_progress_update(set = j) + # utils::setTxtProgressBar(pb, j) } } diff --git a/R/generics.R b/R/generics.R index f0d8d4a..5bc866b 100644 --- a/R/generics.R +++ b/R/generics.R @@ -242,7 +242,7 @@ setGeneric( #' @rdname liger-class setGeneric( "cellMeta<-", - function(x, columns = NULL, useDatasets = NULL, cellIdx = NULL, check = FALSE, value) { + function(x, columns = NULL, useDatasets = NULL, cellIdx = NULL, inplace = FALSE, check = FALSE, value) { standardGeneric("cellMeta<-") } ) diff --git a/R/ggplotting.R b/R/ggplotting.R index 3bf6c7e..1cfdb6a 100644 --- a/R/ggplotting.R +++ b/R/ggplotting.R @@ -143,13 +143,13 @@ plotCellScatter <- function( } plotList <- list() - titles <- .checkArgLen(titles, n = length(plotDFList), .stop = FALSE) + titles <- .checkArgLen(titles, n = length(plotDFList), class = "ANY", .stop = FALSE) for (i in seq_along(plotDFList)) { - .log("Plotting feature: ", names(plotDFList)[i], ", on ", - nrow(plotDFList[[i]]), " cells...") + cliID <- cli::cli_process_start("Plotting feature {.val {names(plotDFList)[i]}} on {.val {nrow(plotDFList[[i]])}} cells") plotList[[i]] <- .ggScatter(plotDF = plotDFList[[i]], x = x, y = y, colorBy = colorByParam[[i]], shapeBy = shapeBy, title = titles[i], ...) + cli::cli_process_done(cliID) } names(plotList) <- names(plotDFList) @@ -450,7 +450,7 @@ plotCellViolin <- function( names(yParam) <- names(plotDFList) } plotList <- list() - titles <- .checkArgLen(titles, n = length(plotDFList), .stop = FALSE) + titles <- .checkArgLen(titles, n = length(plotDFList), class = "ANY", .stop = FALSE) for (i in seq_along(plotDFList)) { plotList[[i]] <- .ggCellViolin(plotDF = plotDFList[[i]], y = yParam[[i]], groupBy = groupBy, @@ -799,11 +799,14 @@ plotCellViolin <- function( } if (isTRUE(plotly)) { - if (requireNamespace("plotly", quietly = FALSE)) { + if (requireNamespace("plotly", quietly = TRUE)) { plot <- plotly::ggplotly(plot) } else { - warning('Run `install.packages("plotly")` to enable web based ', - "interactive browsing. Returning original ggplot.") + cli::cli_alert_danger( + "Package {.pkg plotly} is needed for interactive browsing." + ) + cli::cli_alert_info("Please run {.code install.packages('plotly')} to enable it.") + cli::cli_alert_info("Returning the original {.cls ggplot}.") } } return(plot) diff --git a/R/h5Utility.R b/R/h5Utility.R index 7f38a99..e2a8d86 100644 --- a/R/h5Utility.R +++ b/R/h5Utility.R @@ -56,8 +56,12 @@ H5Apply <- function( colptr <- h5file[[h5meta$indptrName]] rowind <- h5file[[h5meta$indicesName]] data <- h5file[[h5meta[[useData]]]] - if (isTRUE(verbose)) pb <- utils::txtProgressBar(0, numChunks, style = 3) + if (isTRUE(verbose)) + cliID <- cli::cli_progress_bar(name = "HDF5 chunk processing", type = "iter", + total = numChunks, clear = FALSE) + # pb <- utils::txtProgressBar(0, numChunks, style = 3) for (i in seq(numChunks)) { + Sys.sleep(0.1) start <- (i - 1)*chunkSize + 1 end <- if (i*chunkSize > ncol(object)) ncol(object) else i*chunkSize colptrStart <- start @@ -78,7 +82,8 @@ H5Apply <- function( init <- do.call(FUN, c(list(chunk, nnzStart:nnzEnd, start:end, init), fun.args)) - if (isTRUE(verbose)) utils::setTxtProgressBar(pb, i) + # if (isTRUE(verbose)) utils::setTxtProgressBar(pb, i) + if (isTRUE(verbose)) cli::cli_progress_update(id = cliID, set = i) } # Break a new line otherwise next message comes right after the "%" sign. if (isTRUE(verbose)) cat("\n") @@ -182,7 +187,7 @@ safeH5Create <- function(object, #' lig <- restoreH5Liger(lig) restoreH5Liger <- function(object, filePath = NULL) { if (!inherits(object, "liger") && !inherits(object, "ligerDataset")) { - stop("Please specify a liger or ligerDataset object to restore.") + cli::cli_abort("Please specify a {.cls liger} or {.cls ligerDataset} object to restore.") } if (inherits(object, "ligerDataset")) { if (isTRUE(methods::validObject(object, test = TRUE))) { @@ -191,13 +196,12 @@ restoreH5Liger <- function(object, filePath = NULL) { h5.meta <- h5fileInfo(object) if (is.null(filePath)) filePath <- h5.meta$filename if (is.null(filePath)) { - stop("No filename identified") + cli::cli_abort("No filename identified.") } if (!file.exists(filePath)) { - stop("HDF5 file path does not exist:\n", - filePath) + cli::cli_abort("HDF5 file path does not exist: {.file {filePath}}") } - .log("filename identified: ", filePath) + cliID <- cli::cli_process_start("Restoring HDF5 link from: {.file {filePath}}") h5file <- hdf5r::H5File$new(filePath, mode = "r+") h5.meta$filename <- h5file$filename pathChecks <- unlist(lapply(h5.meta[4:10], function(x) { @@ -207,18 +211,23 @@ restoreH5Liger <- function(object, filePath = NULL) { if (any(!pathChecks)) { info.name <- names(pathChecks)[!pathChecks] paths <- unlist(h5.meta[info.name]) - errorMsg <- paste(paste0('HDF5 info "', info.name, - '" not found at path: "', paths, '"'), - collapse = "\n ") - stop(errorMsg) + errMsg_cli <- paste0("HDF5 info {.val ", info.name, "} not found at path: {.val ", paths, "}") + lapply(errMsg_cli, cli::cli_alert_danger) + cli::cli_abort( + "Cannot restore this dataset." + ) + # errorMsg <- paste(paste0('HDF5 info "', info.name, + # '" not found at path: "', paths, '"'), + # collapse = "\n ") + # stop(errorMsg) } barcodes <- h5file[[h5.meta$barcodesName]] if (identical(barcodes, colnames(object))) { - stop("Barcodes in the HDF5 file do not match to object.") + cli::cli_abort("Barcodes in the HDF5 file do not match to object.") } features <- h5file[[h5.meta$genesName]] if (identical(features, rownames(object))) { - stop("Features in the HDF5 file do not match to object.") + cli::cli_abort("Features in the HDF5 file do not match to object.") } # All checks passed! h5.meta$H5File <- h5file @@ -230,25 +239,27 @@ restoreH5Liger <- function(object, filePath = NULL) { scaleData(object, check = FALSE) <- h5file[[h5.meta$scaleData]] } methods::validObject(object) + cli::cli_process_done(id = cliID) } else { # Working for liger object if (!is.null(filePath)) { if (!is.list(filePath) || is.null(names(filePath))) - stop("`filePath` has to be a named list for liger object.") + cli::cli_abort( + "{.var filePath} has to be named list of {.cls liger} objects." + ) } for (d in names(object)) { if (isH5Liger(object, d)) { path <- NULL if (d %in% names(filePath)) { - if (!hdf5r::is.h5file(filePath[[d]])) - warning("Path for dataset \"", d, - "\" is not an HDF5 file: ", - filePath[[d]]) - else path <- filePath[[d]] + if (!hdf5r::is.h5file(filePath[[d]])) { + cli::cli_alert_danger("Path for dataset {.val {d}} is not an HDF5 file: {.file {filePath[[d]]}}") + } else path <- filePath[[d]] } - .log("Restoring dataset \"", d, "\"") + cliID <- cli::cli_process_start("Restoring dataset {.val {d}}") datasets(object, check = FALSE)[[d]] <- restoreH5Liger(dataset(object, d), filePath[[d]]) + cli::cli_process_done(id = cliID) } } } @@ -270,7 +281,7 @@ restoreOnlineLiger <- function(object, file.path = NULL) { .inspectH5Path <- function(path) { if (length(path) != 1 || !is.character(path)) { - stop("`path` has to be a single character.") + cli::cli_abort("{.var path} has to be a single {.cls character}.") } path <- trimws(path, whitespace = "/") path <- strsplit(path, "/")[[1]] diff --git a/R/heatmap.R b/R/heatmap.R index c746eb2..b016f24 100644 --- a/R/heatmap.R +++ b/R/heatmap.R @@ -225,7 +225,10 @@ plotFactorHeatmap <- function( ) if (length(viridisOption) != 1 || !viridisOption %in% viridisAvail) - stop("`viridisOption` has to be one value from the available choices.") + cli::cli_abort( + c("{.var viridisOption} has to be one value from the available choices: ", + "{.val {viridisAvail}}") + ) ## Font-size specification # Broadcast one-param setting to each @@ -391,9 +394,9 @@ plotFactorHeatmap <- function( if (var %in% names(colList)) { df[[var]] <- droplevels(df[[var]]) if (any(!levels(df[[var]]) %in% names(colList[[var]]))) { - stop("Given customized annotation color must have ", - "names matching to all available levels in the ", - "annotation.") + cli::cli_abort( + "Given customized annotation color must have names matching to all available levels in the annotation." + ) } annCol[[var]] <- colList[[var]][levels(df[[var]])] } else { diff --git a/R/import.R b/R/import.R index 571aa61..84d9631 100644 --- a/R/import.R +++ b/R/import.R @@ -83,12 +83,12 @@ createLiger <- function( indices.name = "indicesName", indptr.name = "indptrName", genes.name = "genesName", barcodes.name = "barcodesName")) - if (!is.list(rawData)) stop("`rawData` has to be a named list.") + if (!is.list(rawData)) cli::cli_abort("{.var rawData} has to be a named list.") nData <- length(rawData) if (missing(modal) || is.null(modal)) modal <- "default" modal <- tolower(modal) - modal <- .checkArgLen(modal, nData, repN = TRUE) + modal <- .checkArgLen(modal, nData, repN = TRUE, class = "character") # TODO handle h5 specific argument for hybrid of H5 and in memory stuff. datasets <- list() @@ -188,9 +188,8 @@ createLigerDataset <- function( args <- as.list(environment()) additional <- list(...) # Necessary initialization of slots - if (is.null(rawData) && is.null(normData) && is.null(scaleData)) { - stop("At least one type of expression data (rawData, normData or ", - "scaleData) has to be provided") + if (is.null(rawData) && is.null(normData)) { + cli::cli_abort("At least one of {.field rawData} or {.field normData} has to be provided.") } # Look for proper colnames and rownames cn <- NULL @@ -291,8 +290,7 @@ createH5LigerDataset <- function( genesName <- "raw.var" genes <- h5file[[genesName]][] } else { - stop("Specified `formatType` '", formatType, - "' is not supported for now.") + cli::cli_abort("Specified {.var formatType} ({.val {formatType}}) is not supported for now.") } } else { barcodes <- h5file[[barcodesName]][] @@ -373,22 +371,23 @@ readLiger <- function( h5FilePath = NULL, update = TRUE) { obj <- readRDS(filename) - if (!inherits(obj, "liger")) - stop("Object is not of class \"liger\".") + if (!inherits(obj, "liger")) # nocov start + cli::cli_abort("Object is not of class {.cls liger}.") # nocov end ver <- obj@version if (ver >= package_version("1.99.0")) { if (isH5Liger(obj)) obj <- restoreH5Liger(obj) return(obj) } - .log("Older version (", ver, ") of liger object detected.") + cli::cli_alert_info("Older version ({.val {ver}}) of {.cls liger} object detected.") if (isTRUE(update)) { - .log("Updating the object structure to make it compatible ", - "with current version (", utils::packageVersion("rliger2"), ")") + cli::cli_alert_info( + "Updating the object structure to make it compatible with current version {.val {utils::packageVersion('rliger2')}}" + ) return(convertOldLiger(obj, dimredName = dimredName, clusterName = clusterName, h5FilePath = h5FilePath)) } else { - .log("`update = FALSE` specified. Returning the original object.") + cli::cli_alert_info("{.code update = FALSE} specified. Returning the original object.") return(obj) } } @@ -451,12 +450,15 @@ importPBMC <- function( for (i in seq(nrow(info))) { f <- info$filename[i] if (file.exists(f) && isFALSE(overwrite)) { - warning("File already exists, skipped. set `overwrite = TRUE` ", - "to force downloading: ", f) + cli::cli_alert_warning( + "Skipping file already exists at: {.file {f}}. " + ) + cli::cli_alert_info("Set {.code overwrite = TRUE} to forcing download.") doDownload[i] <- FALSE next } - if (isTRUE(verbose)) .log("Downloading from ", info$url[i], " to ", f) + if (isTRUE(verbose)) + cli::cli_alert_info("Downloading from {.url {info$url[i]}} to {.file {f}}") } if (sum(doDownload) > 0) { utils::download.file(info$url[doDownload], @@ -500,12 +502,15 @@ importBMMC <- function( for (i in seq(nrow(info))) { f <- info$filename[i] if (file.exists(f) && isFALSE(overwrite)) { - warning("File already exists, skipped. set `overwrite = TRUE` ", - "to force downloading: ", f) + cli::cli_alert_warning( + "Skipping file already exists at: {.file {f}}. " + ) + cli::cli_alert_info("Set {.code overwrite = TRUE} to forcing download.") doDownload[i] <- FALSE next } - if (isTRUE(verbose)) .log("Downloading from ", info$url[i], " to ", f) + if (isTRUE(verbose)) + cli::cli_alert_info("Downloading from {.url {info$url[i]}} to {.file {f}}") } if (sum(doDownload) > 0) { utils::download.file(info$url[doDownload], @@ -548,12 +553,15 @@ importCGE <- function( for (i in seq(nrow(info))) { f <- info$filename[i] if (file.exists(f) && isFALSE(overwrite)) { - warning("File already exists, skipped. set `overwrite = TRUE` ", - "to force downloading: ", f) + cli::cli_alert_warning( + "Skipping file already exists at: {.file {f}}. " + ) + cli::cli_alert_info("Set {.code overwrite = TRUE} to forcing download.") doDownload[i] <- FALSE next } - if (isTRUE(verbose)) .log("Downloading from ", info$url[i], " to ", f) + if (isTRUE(verbose)) + cli::cli_alert_info("Downloading from {.url {info$url[i]}} to {.file {f}}") } if (sum(doDownload) > 0) { utils::download.file(info$url[doDownload], @@ -708,34 +716,38 @@ read10X <- function( if (is.null(reference)) { if (length(refsExist) == 1) { reference <- refsExist - .log("Using reference: ", reference) + cli::cli_alert_info("Using referece {.val {reference}}") } else { - stop("Multiple references found, please select one ", - "from: ", paste0(refsExist, collapse = ", ")) + cli::cli_abort( + "Multiple references found, please select one from: {.val {refsExist}}" + ) } } else if (length(reference) == 1) { if (!reference %in% refsExist) { - stop("Specified reference not found, please select ", - "one from: ", paste0(refsExist, collapse = ", ")) + cli::cli_abort( + "Specified reference not found, please select one from: {.val {refsExist}}" + ) } } else { - stop("Multiple reference specified but only one allowed.") + cli::cli_abort("Multiple reference specified but only one allowed.") } path <- file.path(path, reference) } names(path) <- dirSampleNames - .log("Found the following sample folders with possible sub-folder ", - "structure: \n", paste0(dirSampleNames, collapse = ", ")) + cli::cli_alert_info( + c("Found the following sample folders with possible sub-folder structure: ", + "{.val {dirSampleNames}}") + ) } # else mtxDirs } # else mtxDirs allData <- list() - sampleNames <- .checkArgLen(sampleNames, length(path), repN = FALSE) + sampleNames <- .checkArgLen(sampleNames, length(path), repN = FALSE, class = "character") if (is.null(sampleNames) && !is.null(names(path))) { sampleNames <- names(path) } else { if (any(duplicated(sampleNames))) { - stop("Cannot set duplicated sample names.") + cli::cli_abort("Cannot set duplicated sample names.") } } @@ -743,14 +755,13 @@ read10X <- function( if (isTRUE(verbose)) { name <- sampleNames[i] if (is.null(name)) name <- paste0("sample ", i) - .log("Reading from ", name, "...") + cliID <- cli::cli_process_start("Reading from {.val {name}}") } if (is.list(path)) run <- path[[i]] else run <- path[i] if (!dir.exists(run)) { - stop("Directory provided does not exist: ", - normalizePath(run, mustWork = FALSE)) + cli::cli_abort("Directory provided does not exist: {.file {normalizePath(run, mustWork = FALSE)}}") } barcode.loc <- file.path(run, 'barcodes.tsv') gene.loc <- file.path(run, 'genes.tsv') @@ -764,15 +775,13 @@ read10X <- function( matrix.loc <- addgz(matrix.loc) } if (!file.exists(barcode.loc)) { - stop("Barcode file missing. Expecting ", basename(barcode.loc)) + cli::cli_abort("Barcode file is missing. Expecting {.file {barcode.loc}}") } if (!isOldVer && !file.exists(features.loc) ) { - stop("Gene name or features file missing. Expecting ", - basename(features.loc)) + cli::cli_abort("Gene name or features file is missing. Expecting {.file {features.loc}}") } if (!file.exists(matrix.loc)) { - stop("Expression matrix file missing. Expecting ", - basename(matrix.loc)) + cli::cli_abort("Expression matrix file is missing. Expecting {.file {matrix.loc}}") } data <- read10XFiles(matrixPath = matrix.loc, barcodesPath = barcode.loc, featuresPath = ifelse(isOldVer, gene.loc, features.loc), @@ -780,6 +789,7 @@ read10X <- function( cellCol = cellCol) if (isOldVer) names(data) <- "Gene Expression" allData[[i]] <- data + if (isTRUE(verbose)) cli::cli_process_done(id = cliID) } if (!is.null(sampleNames)) names(allData) <- sampleNames if (isTRUE(returnList)) return(allData) @@ -858,23 +868,25 @@ read10XATAC <- function( # Now paths are sample/outs/*_peak_bc_matrix/ path <- file.path(outsPaths, subdir) if (!dir.exists(path)) { - stop("Cannot find folder '", path, "', not standard ", - "`cellranger-", pipeline, "` output. ", - "Please try with the other `pipeline`.") + cli::cli_abort( + c("Cannot find folder {.file {path}}, not standard {.code cellranger-{pipeline}} output. ", + "i" = "Please try with the other {.code pipeline}.") + ) } names(path) <- dirSampleNames - .log("Found the following sample folders with possible sub-folder ", - "structure: \n", paste0(dirSampleNames, collapse = ", ")) + cli::cli_alert_info( + "Found the following sample folders with possible sub-folder structure: {.val {dirSampleNames}}" + ) } # else mtxDirs } # else mtxDirs allData <- list() - sampleNames <- .checkArgLen(sampleNames, length(path), repN = FALSE) + sampleNames <- .checkArgLen(sampleNames, length(path), repN = FALSE, class = "character") if (is.null(sampleNames) && !is.null(names(path))) { sampleNames <- names(path) } else { if (any(duplicated(sampleNames))) { - stop("Cannot set duplicated sample names.") + cli::cli_abort("Cannot set duplicated sample names.") } } @@ -882,14 +894,13 @@ read10XATAC <- function( if (isTRUE(verbose)) { name <- sampleNames[i] if (is.null(name)) name <- paste0("sample ", i) - .log("Reading from ", name, "...") + cliID <- cli::cli_process_start("Reading from {.val {name}}") } if (is.list(path)) run <- path[[i]] else run <- path[i] if (!dir.exists(run)) { - stop("Directory provided does not exist: ", - normalizePath(run, mustWork = FALSE)) + cli::cli_abort("Directory provided does not exist: {.file {normalizePath(run, mustWork = FALSE)}}") } barcode.loc <- switch(pipeline, arc = "barcodes.tsv.gz", @@ -904,15 +915,13 @@ read10XATAC <- function( ) if (!file.exists(barcode.loc)) { - stop("Barcode file missing. Expecting ", basename(barcode.loc)) + cli::cli_abort("Barcode file is missing. Expecting {.file {barcode.loc}}") } if (!file.exists(feature.loc) ) { - stop("Peak or feature file missing. Expecting ", - basename(feature.loc)) + cli::cli_abort("Peak or feature file is missing. Expecting {.file {feature.loc}}") } if (!file.exists(matrix.loc)) { - stop("Expression matrix file missing. Expecting ", - basename(matrix.loc)) + cli::cli_abort("Expression matrix file is missing. Expecting {.file {matrix.loc}}") } data <- read10XFiles(matrixPath = matrix.loc, barcodesPath = barcode.loc, @@ -921,16 +930,18 @@ read10XATAC <- function( geneCol = geneCol, cellCol = cellCol, isATAC = pipeline == "atac") if (pipeline == "arc" && !arcFeatureType %in% names(data)) { - stop("No ATAC data retrieved from cellranger-arc pipeline. ", - "Please see if the following available feature types match ", - "with need and select one for `arcFeatureType`: ", - paste0(names(data), collapse = ", ")) + cli::cli_abort( + c("No ATAC data retrieved from cellranger-arc pipeline. ", + "Please see if the following available feature types match ", + "with need and select one for `arcFeatureType`: {.val {names(data)}}") + ) } data <- switch(pipeline, arc = data[[arcFeatureType]], atac = data[[1]] ) allData[[i]] <- data + cli::cli_process_done(id = cliID) } if (!is.null(sampleNames)) names(allData) <- sampleNames if (isTRUE(returnList)) return(allData) @@ -984,16 +995,14 @@ read10XFiles <- function( "-", feature.names[, 3]) } else { if (ncol(feature.names) < geneCol) { - stop("`geneCol` was set to ", geneCol, " but feature.tsv.gz ", - "(or genes.tsv) only has ", ncol(feature.names), " columns.", - " Try setting `geneCol` to a value <= ", - ncol(feature.names), ".") + cli::cli_abort( + c("{.var geneCol} was set to {.val {geneCol}} but {.file feature.tsv.gz} (or {.file genes.tsv}) only has {ncol(fetures.names)} columns.", + "i" = "Try setting {.var geneCol} to a value <= {ncol(feature.names)}.") + ) } if (any(is.na(feature.names[, geneCol]))) { - warning( - "Some features names are NA. Replacing NA names with ID from the ", - "opposite column requested", - call. = FALSE, immediate. = TRUE + cli::cli_alert_warning( + "Some feature names are NA. Replacing NA names with ID from the opposite column requested" ) na.features <- which(is.na(feature.names[, geneCol])) replacement.column <- ifelse(geneCol == 2, 1, 2) @@ -1009,8 +1018,9 @@ read10XFiles <- function( data_types <- factor(feature.names$V3) lvls <- levels(data_types) if (length(lvls) > 1) { - .log("10X data contains more than one type and is being ", - "returned as a list containing matrices of each type.") + cli::cli_alert_warning( + "10X data contains more than one type and is being returned as a list containing matrices of each type." + ) } expr_name <- "Gene Expression" # Return Gene Expression first diff --git a/R/integration.R b/R/integration.R index 376b6fa..41130fd 100644 --- a/R/integration.R +++ b/R/integration.R @@ -388,7 +388,7 @@ runINMF.Seurat <- function( bestSeed <- seed for (i in seq(nRandomStarts)) { if (isTRUE(verbose) && nRandomStarts > 1) { - cli::cli_alert_info("Replicate run {i}/{nRandomStarts}") + cli::cli_alert_info("Replicate run [{i}/{nRandomStarts}]") } set.seed(seed = seed + i - 1) out <- RcppPlanc::inmf(objectList = object, k = k, lambda = lambda, @@ -701,7 +701,7 @@ runOnlineINMF.liger <- function( newNames <- names(newDatasets) if (any(newNames %in% names(object))) { - cli::cli_abort("Names of {.code newDatasets} overlap with existing datasets.") + cli::cli_abort("Names of {.var newDatasets} overlap with existing datasets.") } if (is.list(newDatasets)) { # A list of raw data @@ -716,14 +716,14 @@ runOnlineINMF.liger <- function( ld <- createH5LigerDataset(newDatasets[[i]]) dataset(object, names(newDatasets[i])) <- ld } else { - cli::cli_abort("Cannot interpret `newDatasets` element {i}") + cli::cli_abort("Cannot interpret {.var newDatasets} element {i}") } } } else if (inherits(newDatasets, "liger")) { # A liger object with all new datasets object <- c(object, newDatasets) } else { - cli::cli_abort("{.code newDatasets} must be either a named list or a liger object") + cli::cli_abort("{.var newDatasets} must be either a named list or a {.cls liger} object") } object <- normalize(object, useDatasets = newNames) @@ -1180,6 +1180,7 @@ runUINMF.liger <- function( bestRes <- NULL bestSeed <- NULL for (i in seq(nRandomStarts)) { + cli::cli_alert_info("Replicate start [{i}/{nRandomStarts}]") seed <- seed + i - 1 set.seed(seed) res <- RcppPlanc::uinmf(object, unsharedList, k = k, lambda = lambda, @@ -1359,7 +1360,7 @@ quantileNorm.Seurat <- function( resName <- paste0(reduction, "Norm") reduction <- object[[reduction]] if (!inherits(reduction, "DimReduc")) { - cli::cli_abort("Specified {.code reduction} does not points to a {.cls DimReduc}.") + cli::cli_abort("Specified {.var reduction} does not points to a {.cls DimReduc}.") } # Retrieve some information. Might have better ways instead of using `@` ## Due to proper formatting in Seurat object, Hconcat is already cell x k @@ -1414,7 +1415,7 @@ quantileNorm.Seurat <- function( if (length(reference) != length(object) || sum(reference) != 1) cli::cli_abort("Should specify one existing dataset as reference.") } else { - cli::cli_abort("Unable to understand {.code reference}. See {.code ?quantileNorm}.") + cli::cli_abort("Unable to understand {.var reference}. See {.code ?quantileNorm}.") } useDims <- useDims %||% seq_len(nrow(object[[1]])) # Transposing all H to cell x k diff --git a/R/liger-methods.R b/R/liger-methods.R index b35d66d..bb11127 100644 --- a/R/liger-methods.R +++ b/R/liger-methods.R @@ -30,10 +30,6 @@ is.newLiger <- function(object) { #' \code{NULL} uses all cells. #' @param as.data.frame Logical, whether to apply #' \code{\link[base]{as.data.frame}} on the subscription. Default \code{FALSE}. -#' @param i,j Feature and cell index for \code{`[`} method. For \code{`[[`} -#' method, use a single variable name with \code{i} while \code{j} is not -#' applicable. -#' @param drop Not applicable. #' @param slot Name of slot to retrieve matrix from. Options shown in Usage. #' @param returnList Logical, whether to force return a list even when only one #' dataset-specific matrix (i.e. expression matrices, H, V or U) is requested. @@ -115,6 +111,16 @@ setMethod( #' with \code{NULL} as the first element and valid cell identifiers as the #' second element. For \code{colnames<-} method, the character vector of cell #' identifiers. \code{rownames<-} method is not applicable. +#' @section Subsetting: +#' For more detail of subsetting a \code{liger} object or a +#' \linkS4class{ligerDataset} object, please check out \code{\link{subsetLiger}} +#' and \code{\link{subsetLigerDataset}}. Here, we set the S4 method +#' "single-bracket" \code{[} as a quick wrapper to subset a \code{liger} object. +#' Note that \code{j} serves as cell subscriptor which can be any valid index +#' refering the collection of all cells (i.e. \code{rownames(cellMeta(obj))}). +#' While \code{i}, the feature subscriptor can only be character vector because +#' the features for each dataset can vary. \code{...} arugments are passed to +#' \code{subsetLiger} so that advanced options are allowed. #' @rdname liger-class #' @export setMethod("dim", "liger", function(x) { @@ -145,39 +151,47 @@ setReplaceMethod("dimnames", c("liger", "list"), function(x, value) { #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% # Subsetting #### #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -#' @section Subsetting: -#' For more detail of subsetting a \code{liger} object or a -#' \linkS4class{ligerDataset} object, please check out \code{\link{subsetLiger}} -#' and \code{\link{subsetLigerDataset}}. Here, we set the S4 method -#' "single-bracket" \code{[} as a quick wrapper to subset a \code{liger} object. -#' Note that \code{j} serves as cell subscriptor which can be any valid index -#' refering the collection of all cells (i.e. \code{rownames(cellMeta(obj))}). -#' While \code{i}, the feature subscriptor can only be character vector because -#' the features for each dataset can vary. \code{...} arugments are passed to -#' \code{subsetLiger} so that advanced options are allowed. -#' @export -#' @rdname liger-class -setMethod( - "[", - signature(x = "liger", i = "character", j = "missing"), - function(x, i, j, ...) subsetLiger(x, featureIdx = i, cellIdx = NULL, ...) -) - -#' @export -#' @rdname liger-class -setMethod( - "[", - signature(x = "liger", i = "missing", j = "index"), - function(x, i, j, ...) subsetLiger(x, featureIdx = NULL, cellIdx = j, ...) -) -#' @export -#' @rdname liger-class -setMethod( - "[", - signature(x = "liger", i = "character", j = "index"), - function(x, i, j, ...) subsetLiger(x, featureIdx = i, cellIdx = j, ...) -) +#' Subset liger with brackets +#' @name sub-liger +#' @param x A \linkS4class{liger} object +#' @param i Feature subscriptor, passed to \code{featureIdx} of +#' \code{\link{subsetLiger}}. +#' @param j Cell subscriptor, passed to \code{cellIdx} of +#' \code{\link{subsetLiger}}. +#' @param ... Additional arguments passed to \code{\link{subsetLiger}}. +#' @export +#' @return Subset of \code{x} with specified features and cells. +#' @seealso \code{\link{subsetLiger}} +#' @method [ liger +#' @examples +#' pbmcPlot[varFeatures(pbmcPlot)[1:10], 1:10] +`[.liger` <- function(x, i, j, ...) { + if (missing(i)) i <- NULL + if (missing(j)) j <- NULL + subsetLiger(x, featureIdx = i, cellIdx = j, ...) +} +# setMethod( +# "[", +# signature(x = "liger", i = "character", j = "missing"), +# function(x, i, j, ...) subsetLiger(x, featureIdx = i, cellIdx = NULL, ...) +# ) +# +# #' @export +# #' @rdname liger-class +# setMethod( +# "[", +# signature(x = "liger", i = "missing", j = "index"), +# function(x, i, j, ...) subsetLiger(x, featureIdx = NULL, cellIdx = j, ...) +# ) +# +# #' @export +# #' @rdname liger-class +# setMethod( +# "[", +# signature(x = "liger", i = "character", j = "index"), +# function(x, i, j, ...) subsetLiger(x, featureIdx = i, cellIdx = j, ...) +# ) #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% # Datasets #### @@ -217,8 +231,7 @@ setMethod("dataset", signature(x = "liger", dataset = "character_OR_NULL"), if (is.null(dataset)) return(datasets(x)[[1]]) else { if (!dataset %in% names(x)) { - stop('Specified dataset name "', dataset, - '" not found in liger object.') + cli::cli_abort("Specified dataset name {.val {dataset}} not found in {.cls liger} object") } return(datasets(x)[[dataset]]) } @@ -330,7 +343,7 @@ setReplaceMethod("dataset", signature(x = "liger", dataset = "character", x@cellMeta <- cm # x@W is genes x k, no need to worry if (!is.null(x@H.norm)) { - message("Filling in NAs to H.norm matrix") + cli::cli_alert_info("Finning in NAs to H.norm matrix") H.normNew <- matrix( NA, ncol(value), ncol(x@H.norm), dimnames = list(colnames(value), NULL)) @@ -366,22 +379,24 @@ setReplaceMethod("dataset", signature(x = "liger", dataset = "character", #' @export #' @rdname liger-class -setReplaceMethod("dataset", signature(x = "liger", dataset = "character", - type = "missing", qc = "ANY", - value = "NULL"), - function(x, dataset, type = NULL, qc = TRUE, value) { - if (!dataset %in% names(x)) { - warning("Specified dataset name not found in ", - "liger object. Nothing would happen.") - } else { - idxToRemove <- x$dataset == dataset - x@datasets[[dataset]] <- NULL - x@cellMeta <- x@cellMeta[!idxToRemove, , drop = FALSE] - x@H.norm <- x@H.norm[!idxToRemove, , drop = FALSE] - x@cellMeta$dataset <- droplevels(x@cellMeta$dataset) - } - x - }) +setReplaceMethod( + "dataset", + signature(x = "liger", dataset = "character", type = "missing", qc = "ANY", + value = "NULL"), + function(x, dataset, type = NULL, qc = TRUE, value) { + if (!dataset %in% names(x)) { + cli::cli_alert_warning( + "Specified dataset name {.val {dataset}} not found in {.cls liger} object. Nothing would happen.") + } else { + idxToRemove <- x$dataset == dataset + x@datasets[[dataset]] <- NULL + x@cellMeta <- x@cellMeta[!idxToRemove, , drop = FALSE] + x@H.norm <- x@H.norm[!idxToRemove, , drop = FALSE] + x@cellMeta$dataset <- droplevels(x@cellMeta$dataset) + } + x + } +) #' @rdname liger-class #' @export @@ -434,8 +449,8 @@ setMethod("length", signature(x = "liger"), function(x) { if (!is.null(columns)) { notFound <- !columns %in% colnames(res) if (any(notFound)) { - warning("Specified variables from cellMeta not found: ", - .nfstr(columns, colnames(res))) + cli::cli_alert_danger( + "Specified variables from cellMeta not found: {.val {columns[notFound]}}") columns <- columns[!notFound] } res <- res[, columns, ...] @@ -451,7 +466,7 @@ setMethod("length", signature(x = "liger"), function(x) { cellIdx <- .idxCheck(object, idx = cellIdx, orient = "cell") if (is.vector(res) || is.factor(res)) res <- res[cellIdx] else if (!is.null(dim(res))) res <- res[cellIdx, , ...] - else stop("Result before idx subscription corrupted") + else cli::cli_abort("Result before idx subscription corrupted") } return(res) } @@ -512,26 +527,64 @@ setReplaceMethod( #' @export #' @rdname liger-class +#' @param inplace For \code{cellMeta<-} method, when \code{columns} is for +#' existing variable and \code{useDatasets} or \code{cellIdx} indicate partial +#' insertion to the object, whether to by default (\code{TRUE}) in-place insert +#' \code{value} into the variable for selected cells or to replace the whole +#' variable with non-selected part left as NA. setReplaceMethod( "cellMeta", signature(x = "liger", columns = "character"), - function(x, columns = NULL, useDatasets = NULL, cellIdx = NULL, check = FALSE, value) { + function(x, columns = NULL, useDatasets = NULL, cellIdx = NULL, + inplace = TRUE, check = FALSE, value) { + # 1 - check cell selection if (is.null(cellIdx) && !is.null(useDatasets)) { if (!is.character(useDatasets)) useDatasets <- names(x)[useDatasets] cellIdx <- which(x@cellMeta$dataset %in% useDatasets) } else { cellIdx <- .idxCheck(x, cellIdx, "cell") } + if (length(cellIdx) == 0) + cli::cli_abort("No cell selected with either {.val cellIdx} or {.var useDatasets}.") + + # 2 - check value matching or length/dimension + barcodes <- colnames(x)[cellIdx] if (is.null(dim(value))) { # Vector/factor like - value <- .checkArgLen(value, n = length(cellIdx)) - } - # if (is.null(dim(value)) && length(value) != length(cellIdx)) { - # stop("Length of value does not match with cell index.") - # } - if (!is.null(dim(value)) && nrow(value) != length(cellIdx)) { - stop("nrow of value does not match with cell index.") + if (is.null(names(value))) { + # No name matching, require exact length + value <- .checkArgLen(value, n = length(cellIdx), class = c("vector", "factor")) + } else { + if (!all(barcodes %in% names(value))) { + cli::cli_abort( + c("{.code names(value)} do not contain all cells selected. ", + "These are not involved: ", + "{.val {barcodes[!barcodes %in% names(value)]}}") + ) + } + value <- value[barcodes] + } + } else { + # matrix like + if (is.null(rownames(value))) { + # no rowname matching, require extact nrow + if (nrow(value) != length(cellIdx)) { + cli::cli_abort( + "{.code nrow(value)} ({nrow(value)}) does not match with cells selected ({length(cellIdx)}).") + } + } else { + if (!all(barcodes %in% rownames(value))) { + cli::cli_abort( + c("{.code rownames(value)} do not contain all cells selected. ", + "These are not involved: ", + "{.val {barcodes[!barcodes %in% rownames(value)]}}") + ) + } + value <- value[barcodes, , drop = FALSE] + } } + + # 3 - Insert value if (length(cellIdx) == ncol(x)) { x@cellMeta[[columns]] <- value } else if (length(cellIdx) < ncol(x)) { @@ -549,59 +602,48 @@ setReplaceMethod( } else { x@cellMeta[[columns]][cellIdx] <- value } - if (!is.null(names(value))) { - if (!identical(colnames(x)[cellIdx], names(value))) { - warning("Names of inserted values do not ", - "match to cell IDs at specified index ", - "of the object. Forced to store using ", - "object colnames.") - } - } } else { # matrix like - x@cellMeta[[columns]] <- matrix(NA, ncol(x), ncol(value)) + x@cellMeta[[columns]] <- matrix( + NA, ncol(x), ncol(value), + dimnames = list(colnames(x), colnames(value)) + ) x@cellMeta[[columns]][cellIdx,] <- value - if (!is.null(colnames(value))) { - colnames(x@cellMeta[[columns]]) <- colnames(value) - } - if (!is.null(rownames(value))) { - if (!identical(rownames(value), colnames(x)[cellIdx])) { - warning("Rownames of inserted values do not match ", - "to cell IDs at specified index of the ", - "object. Forced to store using object ", - "colnames.") - } - } } } else { - if (is.null(dim(value)) && is.null(dim(x@cellMeta[[columns]]))) { - # Both are 1D - if (is.factor(value) && is.factor(x@cellMeta[[columns]])) { - charVar <- as.character(x@cellMeta[[columns]]) - charVar[cellIdx] <- as.character(value) - x@cellMeta[[columns]] <- - factor( - charVar, - levels = unique(c(levels(x@cellMeta[[columns]]), - levels(value))) - ) + if (isTRUE(inplace)) { + # Modifying existing variable + if (is.null(dim(value)) && is.null(dim(x@cellMeta[[columns]]))) { + # Both are 1-D + if (is.factor(value) && is.factor(x@cellMeta[[columns]])) { + charVar <- as.character(x@cellMeta[[columns]]) + charVar[cellIdx] <- as.character(value) + x@cellMeta[[columns]] <- + factor( + charVar, + levels = unique(c(levels(x@cellMeta[[columns]]), + levels(value))) + ) + } else { + x@cellMeta[[columns]][cellIdx] <- value + } + } else if (!is.null(dim(value)) && !is.null(dim(x@cellMeta[[columns]]))) { + # Both are dimensional + if (ncol(value) != ncol(x@cellMeta[[columns]])) { + cli::cli_abort("Cannot insert value to a variable of different dimensionality") + } + x@cellMeta[[columns]][cellIdx,] <- value } else { - x@cellMeta[[columns]][cellIdx] <- value - } - } else if (!is.null(dim(value)) && !is.null(dim(x@cellMeta[[columns]]))) { - # Both are dimensional - if (ncol(value) != ncol(x@cellMeta[[columns]])) { - stop("Cannot insert value to a variable of different ", - "dimensionality") + cli::cli_abort("Cannot insert value to a variable of different dimensionality") } - x@cellMeta[[columns]][cellIdx,] <- value } else { - stop("Cannot insert value to a variable of different ", - "dimensionality") + x@cellMeta[[columns]] <- NULL + # Remove and go to "Add new variable" case above + cellMeta(x, columns = columns, cellIdx = cellIdx, check = check) <- value } } } else { - stop("`cellIdx` pointing to more cells than available") + cli::cli_abort("{.var cellIdx} pointing to more cells than available") } if (isTRUE(check)) methods::validObject(x) x @@ -628,9 +670,9 @@ setReplaceMethod( signature(x = "liger", dataset = "ANY", check = "ANY", value = "matrixLike_OR_NULL"), function(x, dataset = NULL, check = TRUE, value) { dataset <- .checkUseDatasets(x, dataset) - if (length(dataset) != 1) stop("Need to specify one dataset to insert.") + if (length(dataset) != 1) cli::cli_abort("Need to specify one dataset to insert.") if (isH5Liger(x, dataset)) - stop("Cannot replace slot with in-memory data for H5 based object.") + cli::cli_abort("Cannot replace slot with in-memory data for H5 based object.") x@datasets[[dataset]]@rawData <- value if (isTRUE(check)) methods::validObject(x) x @@ -644,9 +686,9 @@ setReplaceMethod( signature(x = "liger", dataset = "ANY", check = "ANY", value = "H5D"), function(x, dataset = NULL, check = TRUE, value) { dataset <- .checkUseDatasets(x, dataset) - if (length(dataset) != 1) stop("Need to specify one dataset to insert.") + if (length(dataset) != 1) cli::cli_abort("Need to specify one dataset to insert.") if (!isH5Liger(x, dataset)) - stop("Cannot replace slot with on-disk data for in-memory object.") + cli::cli_abort("Cannot replace slot with on-disk data for in-memory object.") x@datasets[[dataset]]@rawData <- value if (isTRUE(check)) methods::validObject(x@datasets[[dataset]]) if (isTRUE(check)) methods::validObject(x) @@ -673,9 +715,9 @@ setReplaceMethod( signature(x = "liger", dataset = "ANY", check = "ANY", value = "matrixLike_OR_NULL"), function(x, dataset = NULL, check = TRUE, value) { dataset <- .checkUseDatasets(x, dataset) - if (length(dataset) != 1) stop("Need to specify one dataset to insert.") + if (length(dataset) != 1) cli::cli_abort("Need to specify one dataset to insert.") if (isH5Liger(x, dataset)) - stop("Cannot replace slot with in-memory data for H5 based object.") + cli::cli_abort("Cannot replace slot with in-memory data for H5 based object.") x@datasets[[dataset]]@normData <- value if (isTRUE(check)) methods::validObject(x) x @@ -689,9 +731,9 @@ setReplaceMethod( signature(x = "liger", dataset = "ANY", check = "ANY", value = "H5D"), function(x, dataset = NULL, check = TRUE, value) { dataset <- .checkUseDatasets(x, dataset) - if (length(dataset) != 1) stop("Need to specify one dataset to insert.") + if (length(dataset) != 1) cli::cli_abort("Need to specify one dataset to insert.") if (!isH5Liger(x, dataset)) - stop("Cannot replace slot with on-disk data for in-memory object.") + cli::cli_abort("Cannot replace slot with on-disk data for in-memory object.") x@datasets[[dataset]]@normData <- value if (isTRUE(check)) methods::validObject(x) x @@ -720,9 +762,9 @@ setReplaceMethod( signature(x = "liger", dataset = "ANY", check = "ANY", value = "matrixLike_OR_NULL"), function(x, dataset = NULL, check = TRUE, value) { dataset <- .checkUseDatasets(x, dataset) - if (length(dataset) != 1) stop("Need to specify one dataset to insert.") + if (length(dataset) != 1) cli::cli_abort("Need to specify one dataset to insert.") if (isH5Liger(x, dataset)) - stop("Cannot replace slot with in-memory data for H5 based object.") + cli::cli_abort("Cannot replace slot with in-memory data for H5 based object.") x@datasets[[dataset]]@scaleData <- value if (isTRUE(check)) methods::validObject(x) x @@ -736,9 +778,9 @@ setReplaceMethod( signature(x = "liger", dataset = "ANY", check = "ANY", value = "H5D"), function(x, dataset = NULL, check = TRUE, value) { dataset <- .checkUseDatasets(x, dataset) - if (length(dataset) != 1) stop("Need to specify one dataset to insert.") + if (length(dataset) != 1) cli::cli_abort("Need to specify one dataset to insert.") if (!isH5Liger(x, dataset)) - stop("Cannot replace slot with on-disk data for in-memory object.") + cli::cli_abort("Cannot replace slot with on-disk data for in-memory object.") x@datasets[[dataset]]@scaleData <- value if (isTRUE(check)) methods::validObject(x) x @@ -752,9 +794,9 @@ setReplaceMethod( signature(x = "liger", dataset = "ANY", check = "ANY", value = "H5Group"), function(x, dataset = NULL, check = TRUE, value) { dataset <- .checkUseDatasets(x, dataset) - if (length(dataset) != 1) stop("Need to specify one dataset to insert.") + if (length(dataset) != 1) cli::cli_abort("Need to specify one dataset to insert.") if (!isH5Liger(x, dataset)) - stop("Cannot replace slot with on-disk data for in-memory object.") + cli::cli_abort("Cannot replace slot with on-disk data for in-memory object.") x@datasets[[dataset]]@scaleData <- value if (isTRUE(check)) methods::validObject(x) x @@ -790,9 +832,9 @@ setReplaceMethod( signature(x = "liger", dataset = "ANY", check = "ANY", value = "matrixLike_OR_NULL"), function(x, dataset = NULL, check = TRUE, value) { dataset <- .checkUseDatasets(x, dataset) - if (length(dataset) != 1) stop("Need to specify one dataset to insert.") + if (length(dataset) != 1) cli::cli_abort("Need to specify one dataset to insert.") if (isH5Liger(x, dataset)) - stop("Cannot replace slot with in-memory data for H5 based object.") + cli::cli_abort("Cannot replace slot with in-memory data for H5 based object.") x@datasets[[dataset]]@scaleUnsharedData <- value if (isTRUE(check)) methods::validObject(x) x @@ -806,9 +848,9 @@ setReplaceMethod( signature(x = "liger", dataset = "ANY", check = "ANY", value = "H5D"), function(x, dataset = NULL, check = TRUE, value) { dataset <- .checkUseDatasets(x, dataset) - if (length(dataset) != 1) stop("Need to specify one dataset to insert.") + if (length(dataset) != 1) cli::cli_abort("Need to specify one dataset to insert.") if (!isH5Liger(x, dataset)) - stop("Cannot replace slot with on-disk data for in-memory object.") + cli::cli_abort("Cannot replace slot with on-disk data for in-memory object.") x@datasets[[dataset]]@scaleUnsharedData <- value if (isTRUE(check)) methods::validObject(x) x @@ -822,9 +864,9 @@ setReplaceMethod( signature(x = "liger", dataset = "ANY", check = "ANY", value = "H5Group"), function(x, dataset = NULL, check = TRUE, value) { dataset <- .checkUseDatasets(x, dataset) - if (length(dataset) != 1) stop("Need to specify one dataset to insert.") + if (length(dataset) != 1) cli::cli_abort("Need to specify one dataset to insert.") if (!isH5Liger(x, dataset)) - stop("Cannot replace slot with on-disk data for in-memory object.") + cli::cli_abort("Cannot replace slot with on-disk data for in-memory object.") x@datasets[[dataset]]@scaleUnsharedData <- value if (isTRUE(check)) methods::validObject(x) x @@ -976,17 +1018,14 @@ setReplaceMethod( "defaultCluster", signature(x = "liger", value = "character"), function(x, name = NULL, useDatasets = NULL, ..., value) { - useDatasets <- .checkUseDatasets(x, useDatasets) - cellIdx <- x$dataset %in% useDatasets if (length(value) == 1) { # If doing defaultCluster(obj) <- "someName" if (!is.null(name)) { - warning("Cannot have `name` when selecting a name with ", - "`value`.") + cli::cli_alert_danger("Cannot have {.code name} when selecting a variable with {.code value}.") } name <- value if (!name %in% colnames(cellMeta(x))) { - stop("Selected name does not exist in `cellMeta(x)`") + cli::cli_abort("Selected variable does not exist in {.code cellMeta(x)}.") } x@uns$defaultCluster <- name } else { @@ -1007,14 +1046,27 @@ setReplaceMethod( useDatasets <- .checkUseDatasets(x, useDatasets) cellIdx <- x$dataset %in% useDatasets if (length(value) != sum(cellIdx)) { - stop("Length of `value` does not match with the number of cells") + cli::cli_abort("Length of {.code value} does not match with the number of cells.") } if (is.null(name)) { - .log("Storing given cluster labels to cellMeta(x) field: ", - "\"defaultCluster\"") + cli::cli_alert_info( + c("Storing given cluster labels to {.code cellMeta(x)} field: ", + "{.val defaultCluster}.") + ) name <- "defaultCluster" } if (is.null(names(value))) names(value) <- colnames(x)[cellIdx] + else { + if (all(names(value) %in% colnames(x)[cellIdx])) { + value <- value[colnames(x)[cellIdx]] + } else { + cli::cli_abort( + c(x = "Not all {.code names(value)} match with target cells: ", + "{.val {names(value)[!names(value) %in% colnames(x)[cellIdx]]}}", + i = "Please have a check or try {.code unname(value)}.") + ) + } + } cellMeta(x, name, cellIdx) <- value x@uns$defaultCluster <- name return(x) @@ -1048,14 +1100,14 @@ setMethod( if (is.null(name)) { for (i in seq_along(cellMeta(x))) { if (!is.null(dim(cellMeta(x)[[i]]))) { - warning("No default dimRed recorded. Returning the first ", - "matrix like object in cellMeta(object)") + cli::cli_alert_warning( + "No default dimRed recorded. Returning the first matrix alike in {.code cellMeta(object)}.") dimred <- cellMeta(x)[[i]] break } } if (is.null(dimred)) { - stop("No possible dimRed can be found in this liger object.") + cli::cli_abort("No possible dimRed can be found in this {.cls liger} object.") } } else { dimred <- cellMeta(x, name, x$dataset %in% useDatasets) @@ -1077,7 +1129,7 @@ setMethod( useDatasets <- .checkUseDatasets(x, useDatasets) dimred <- cellMeta(x, name, x$dataset %in% useDatasets) if (is.null(dim(dimred))) { - stop("Retrieved data for \"", name, "\" is not a matrix.") + cli::cli_abort("Retrieved data for {.val {name}} is not a matrix.") } dimred <- as.matrix(dimred) rownames(dimred) <- colnames(x)[x$dataset %in% useDatasets] @@ -1131,10 +1183,10 @@ setReplaceMethod( value <- value[1] dimred <- cellMeta(x, value) if (is.null(dim(dimred))) { - stop("Specified variable is not matrix like.") + cli::cli_abort("Specified variable is not a matrix alike.") } if (ncol(dimred) == 0) { - stop("Cannot set unexisting variable as default dimRed.") + cli::cli_abort("Cannot set unexisting variable as default dimRed.") } x@uns$defaultDimRed <- value return(x) @@ -1179,10 +1231,9 @@ setReplaceMethod( all(value %in% rownames(ld)) }), use.names = FALSE) if (!all(checkResult)) { - problem <- names(x)[!checkResult] - warning("Not all variable features passed are ", - "found in datasets: ", - paste(problem, collapse = ", ")) + cli::cli_alert_warning( + "Not all variable features passed are found in datasets: {.val {names(x)[!checkResult]}}" + ) } } x @@ -1215,8 +1266,7 @@ setReplaceMethod( x@datasets[[dataset]]@varUnsharedFeatures <- value if (isTRUE(check)) { if (!all(value %in% rownames(x@datasets[[dataset]]))) { - warning("Not all features passed are found in dataset \"", - dataset, "\".") + cli::cli_alert_warning("Not all features passed are found in dataset {.val {dataset}}.") } } return(x) @@ -1247,7 +1297,7 @@ fortify.liger <- function(model, data, ...) { c.liger <- function(...) { objList <- list(...) if (any(sapply(objList, function(obj) !inherits(obj, "liger")))) - stop("Can only combine `liger` objects with `c(...)` method for now.") + cli::cli_abort("Can only combine {.cls liger} objects with {.fn c} method for now.") objList[[length(objList)]] <- recordCommand(objList[[length(objList)]]) allDatasets <- list() allCellMeta <- NULL @@ -1299,7 +1349,7 @@ setMethod("rawPeak", signature(x = "liger", dataset = "character"), function(x, dataset) { atac <- dataset(x, dataset) if (!inherits(atac, "ligerATACDataset")) { - stop("Specified dataset is not of ligerATACDataset class.") + cli::cli_abort("Specified dataset is not of {.cls ligerATACDataset} class.") } atac@rawPeak }) @@ -1311,7 +1361,7 @@ setReplaceMethod( signature(x = "liger", dataset = "character"), function(x, dataset, check = TRUE, value) { if (!inherits(dataset(x, dataset), "ligerATACDataset")) - stop("Specified dataset is not of `ligerATACDataset` class.") + cli::cli_abort("Specified dataset is not of {.cls ligerATACDataset} class.") x@datasets[[dataset]]@rawPeak <- value if (isTRUE(check)) methods::validObject(dataset(x, dataset)) x @@ -1323,7 +1373,7 @@ setMethod("normPeak", signature(x = "liger", dataset = "character"), function(x, dataset) { atac <- dataset(x, dataset) if (!inherits(atac, "ligerATACDataset")) { - stop("Specified dataset is not of ligerATACDataset class.") + cli::cli_abort("Specified dataset is not of {.cls ligerATACDataset} class.") } atac@normPeak }) @@ -1335,7 +1385,7 @@ setReplaceMethod( signature(x = "liger", dataset = "character"), function(x, dataset, check = TRUE, value) { if (!inherits(dataset(x, dataset), "ligerATACDataset")) - stop("Specified dataset is not of `ligerATACDataset` class.") + cli::cli_abort("Specified dataset is not of {.cls ligerATACDataset} class.") x@datasets[[dataset]]@normPeak <- value if (isTRUE(check)) methods::validObject(dataset(x, dataset)) x @@ -1348,7 +1398,7 @@ setMethod("coordinate", signature(x = "liger", dataset = "character"), function(x, dataset) { spatial <- dataset(x, dataset) if (!inherits(spatial, "ligerSpatialDataset")) { - stop("Specified dataset is not of `ligerSpatialDataset` class.") + cli::cli_abort("Specified dataset is not of {.cls ligerSpatialDataset} class.") } spatial@coordinate }) @@ -1360,7 +1410,7 @@ setReplaceMethod( signature(x = "liger", dataset = "character"), function(x, dataset, check = TRUE, value) { if (!inherits(dataset(x, dataset), "ligerSpatialDataset")) - stop("Specified dataset is not of `ligerSpatialDataset` class.") + cli::cli_abort("Specified dataset is not of {.cls ligerSpatialDataset} class.") value <- .checkCoords(ld = dataset(x, dataset), value = value) x@datasets[[dataset]]@coordinate <- value if (isTRUE(check)) methods::validObject(dataset(x, dataset)) diff --git a/R/ligerCommand_relates.R b/R/ligerCommand_relates.R index 74209b3..f79652b 100644 --- a/R/ligerCommand_relates.R +++ b/R/ligerCommand_relates.R @@ -9,8 +9,6 @@ recordCommand <- function( ..., dependencies = NULL ) { - #if (!inherits(object, "liger")) - # stop("Can only record commands for operation on a liger object") # Generate time stamp time <- Sys.time() # Capture the call @@ -145,12 +143,12 @@ setMethod( commandDiff <- function(object, cmd1, cmd2) { cmd1 <- commands(object, cmd1) if (!inherits(cmd1, "ligerCommand")) - stop("`cmd1` matching with multiple command records. ", - "Available options could be viewed with `commands(object)`.") + cli::cli_abort("{.code cmd1} matching with multiple command records. + Availble options could be viewed with {.code commands(object)}.") cmd2 <- commands(object, cmd2) if (!inherits(cmd2, "ligerCommand")) - stop("`cmd2` matching with multiple command records. ", - "Available options could be viewed with `commands(object)`.") + cli::cli_abort("{.code cmd2} matching with multiple command records. + Availble options could be viewed with {.code commands(object)}.") .cmdDiff(cmd1, cmd2) } diff --git a/R/ligerDataset-methods.R b/R/ligerDataset-methods.R index ac7efe0..7ee9d8c 100644 --- a/R/ligerDataset-methods.R +++ b/R/ligerDataset-methods.R @@ -25,10 +25,11 @@ isH5Liger <- function(object, dataset = NULL) { } } else if (inherits(object, "liger")) { dataset <- .checkUseDatasets(object, dataset) + if (length(dataset) == 0) return(FALSE) allCheck <- unlist(lapply(datasets(object)[dataset], isH5Liger)) return(all(allCheck)) } else { - warning("Given object is not of liger or ligerDataset class.") + cli::cli_alert_danger("Given object is not of {.cls liger} or {.cls ligerDataset} class.") return(FALSE) } } @@ -127,8 +128,7 @@ setMethod( ncol(object), "cells\n") if (isH5Liger(object) & !isTRUE(methods::validObject(object, test = TRUE))) { - warning("Link to HDF5 file fails. Please try running ", - "`restoreH5Liger(object)`.") + cli::cli_alert_danger("Link to HDF5 file fails. Please try running {.code restoreH5Liger(object)}.") return() } for (slot in c("rawData", "normData", "scaleData", @@ -293,7 +293,7 @@ setReplaceMethod( signature(x = "ligerDataset", dataset = "ANY", check = "ANY", value = "matrixLike_OR_NULL"), function(x, dataset = NULL, check = TRUE, value) { if (isH5Liger(x)) - stop("Cannot replace slot with in-memory data for H5 based object.") + cli::cli_abort("Cannot replace slot with in-memory data for H5 based object.") x@rawData <- value if (isTRUE(check)) methods::validObject(x) x @@ -307,7 +307,7 @@ setReplaceMethod( signature(x = "ligerDataset", dataset = "ANY", check = "ANY", value = "H5D"), function(x, dataset = NULL, check = TRUE, value) { if (!isH5Liger(x)) - stop("Cannot replace slot with on-disk data for in-memory object.") + cli::cli_abort("Cannot replace slot with on-disk data for in-memory object.") x@rawData <- value if (isTRUE(check)) methods::validObject(x) x @@ -327,7 +327,7 @@ setReplaceMethod( signature(x = "ligerDataset", dataset = "ANY", check = "ANY", value = "matrixLike_OR_NULL"), function(x, dataset = NULL, check = TRUE, value) { if (isH5Liger(x)) - stop("Cannot replace slot with in-memory data for H5 based object.") + cli::cli_abort("Cannot replace slot with in-memory data for H5 based object.") x@normData <- value if (isTRUE(check)) methods::validObject(x) x @@ -341,7 +341,7 @@ setReplaceMethod( signature(x = "ligerDataset", dataset = "ANY", check = "ANY", value = "H5D"), function(x, dataset = NULL, check = TRUE, value) { if (!isH5Liger(x)) - stop("Cannot replace slot with on-disk data for in-memory object.") + cli::cli_abort("Cannot replace slot with on-disk data for in-memory object.") x@normData <- value if (isTRUE(check)) methods::validObject(x) x @@ -360,7 +360,7 @@ setReplaceMethod( signature(x = "ligerDataset", dataset = "ANY", check = "ANY", value = "matrixLike_OR_NULL"), function(x, dataset = NULL, check = TRUE, value) { if (isH5Liger(x)) - stop("Cannot replace slot with in-memory data for H5 based object.") + cli::cli_abort("Cannot replace slot with in-memory data for H5 based object.") x@scaleData <- value if (isTRUE(check)) methods::validObject(x) x @@ -374,7 +374,7 @@ setReplaceMethod( signature(x = "ligerDataset", dataset = "ANY", check = "ANY", value = "H5D"), function(x, dataset = NULL, check = TRUE, value) { if (!isH5Liger(x)) - stop("Cannot replace slot with on-disk data for in-memory object.") + cli::cli_abort("Cannot replace slot with on-disk data for in-memory object.") x@scaleData <- value if (isTRUE(check)) methods::validObject(x) x @@ -388,7 +388,7 @@ setReplaceMethod( signature(x = "ligerDataset", dataset = "ANY", check = "ANY", value = "H5Group"), function(x, dataset = NULL, check = TRUE, value) { if (!isH5Liger(x)) - stop("Cannot replace slot with on-disk data for in-memory object.") + cli::cli_abort("Cannot replace slot with on-disk data for in-memory object.") x@scaleData <- value if (isTRUE(check)) methods::validObject(x) x @@ -407,7 +407,7 @@ setReplaceMethod( signature(x = "ligerDataset", dataset = "missing", check = "ANY", value = "matrixLike_OR_NULL"), function(x, check = TRUE, value) { if (isH5Liger(x)) - stop("Cannot replace slot with in-memory data for H5 based object.") + cli::cli_abort("Cannot replace slot with in-memory data for H5 based object.") x@scaleUnsharedData <- value if (isTRUE(check)) methods::validObject(x) x @@ -421,7 +421,7 @@ setReplaceMethod( signature(x = "ligerDataset", dataset = "missing", check = "ANY", value = "H5D"), function(x, check = TRUE, value) { if (!isH5Liger(x)) - stop("Cannot replace slot with on-disk data for in-memory object.") + cli::cli_abort("Cannot replace slot with on-disk data for in-memory object.") x@scaleUnsharedData <- value if (isTRUE(check)) methods::validObject(x) x @@ -435,7 +435,7 @@ setReplaceMethod( signature(x = "ligerDataset", dataset = "missing", check = "ANY", value = "H5Group"), function(x, check = TRUE, value) { if (!isH5Liger(x)) - stop("Cannot replace slot with on-disk data for in-memory object.") + cli::cli_abort("Cannot replace slot with on-disk data for in-memory object.") x@scaleUnsharedData <- value if (isTRUE(check)) methods::validObject(x) x @@ -472,9 +472,9 @@ setMethod( if (length(info) == 1) result <- x@h5fileInfo[[info]] else { if (any(!info %in% names(x@h5fileInfo))) { - stop("Specified h5file info not found: ", - paste(info[!info %in% names(x@h5fileInfo)], - collapse = ", ")) + cli::cli_abort( + "Specified {.code info} not found: {.val {info[!info %in% names(x@h5fileInfo)]}}" + ) } result <- x@h5fileInfo[info] names(result) <- info @@ -498,13 +498,12 @@ setReplaceMethod( x@h5fileInfo <- value } else { if (!is.character(info) | length(info) != 1) - stop("`info` has to be a single character.") + cli::cli_abort("{.var info} has to be a single character.") if (info %in% c("indicesName", "indptrName", "barcodesName", "genesName", "rawData", "normData", "scaleData")) { if (!getH5File(x)$exists(value)) { - stop("Specified info is invalid, '", info, - "' does not exists in the HDF5 file.") + cli::cli_abort("Specified {.var info} is invalid, {.field info} does not exist in the HDF5 file.") } } x@h5fileInfo[[info]] <- value @@ -562,7 +561,7 @@ setReplaceMethod( x@varUnsharedFeatures <- value if (isTRUE(check)) { if (!all(value %in% rownames(x))) { - warning("Not all features passed are found.") + cli::cli_alert_warning("Not all features passed are found.") } } return(x) @@ -586,7 +585,7 @@ cbind.ligerDataset <- function(x, ..., args <- list(...) isLD <- sapply(args, function(x) inherits(x, "ligerDataset")) if (any(!isLD)) { - warning("Discarding arguments that are not of ligerDataset class") + cli::cli_alert_warning("Discarding arguments that are not of {.cls ligerDataset} class") args <- args[isLD] } if (!missing(x)) args <- c(list(x), args) @@ -595,6 +594,5 @@ cbind.ligerDataset <- function(x, ..., if (all(isH5)) .cbind.ligerDataset.h5(args) else if (!any(isH5)) .cbind.ligerDataset.mem(args) else - stop("Cannot `cbind` a hybrid of H5 ligerDatasets and ", - "in-memory ligerDatasets for now.") + cli::cli_abort("Cannot {.fn cbind} a hybrid of H5 and in-memory {.cls ligerDataset}s for now.") } diff --git a/R/preprocess.R b/R/preprocess.R index bda0225..f2bbc70 100644 --- a/R/preprocess.R +++ b/R/preprocess.R @@ -80,7 +80,7 @@ runGeneralQC <- function( for (d in useDatasets) { ld <- dataset(object, d) if (isTRUE(verbose)) - cli::cli_alert_info("calculating QC for dataset {.val {d}}") + cliID <- cli::cli_process_start("calculating QC for dataset {.val {d}}") if (isH5Liger(ld)) results <- runGeneralQC.h5( ld, @@ -97,6 +97,7 @@ runGeneralQC <- function( object@cellMeta[object$dataset == d, newResultNames] <- results$cell featureMeta(ld, check = FALSE)$nCell <- results$feature datasets(object, check = FALSE)[[d]] <- ld + if (isTRUE(verbose)) cli::cli_process_done(id = cliID) } return(object) @@ -264,10 +265,10 @@ removeMissing <- function( orient <- match.arg(orient) useDatasets <- .checkUseDatasets(object, useDatasets) minCells <- minCells %||% rep(0, length(useDatasets)) - minCells <- .checkArgLen(minCells, length(useDatasets)) + minCells <- .checkArgLen(minCells, length(useDatasets), class = "numeric") names(minCells) <- useDatasets minFeatures <- minFeatures %||% rep(0, length(useDatasets)) - minFeatures <- .checkArgLen(minFeatures, length(useDatasets)) + minFeatures <- .checkArgLen(minFeatures, length(useDatasets), class = "numeric") names(minFeatures) <- useDatasets rmFeature <- ifelse(orient %in% c("both", "feature"), TRUE, FALSE) rmCell <- ifelse(orient %in% c("both", "cell"), TRUE, FALSE) @@ -394,8 +395,8 @@ normalize.dgCMatrix <- function( scaleFactor = NULL, ... ) { - if (!is.null(scaleFactor) && scaleFactor <= 0) { - scaleFactor <- .checkArgLen(scaleFactor, ncol(object), repN = TRUE) + scaleFactor <- .checkArgLen(scaleFactor, ncol(object), repN = TRUE, class = "numeric") + if (!is.null(scaleFactor) && any(scaleFactor <= 0)) { cli::cli_alert_danger("Invalid {.code scaleFactor} given. Setting to {.code NULL}.") scaleFactor <- NULL } @@ -488,13 +489,13 @@ normalize.liger <- function( useDatasets <- .checkUseDatasets(object, useDatasets) object <- recordCommand(object, ..., dependencies = "hdf5r") for (d in useDatasets) { + if (isTRUE(verbose)) cliID <- cli::cli_process_start("Normalizing datasets {.val {d}}") # `d` is the name of each dataset - if (isTRUE(verbose)) - cli::cli_alert_info("Normalizing dataset: {.val {d}}") ld <- dataset(object, d) ld <- normalize(ld, verbose = verbose, ...) datasets(object, check = FALSE)[[d]] <- ld } + if (isTRUE(verbose)) cli::cli_process_done(id = cliID) object } @@ -534,20 +535,16 @@ normalizePeak <- function( useDatasets <- .checkUseDatasets(object, useDatasets, modal = "atac") object <- recordCommand(object, ..., dependencies = "hdf5r") for (d in useDatasets) { + if (isTRUE(verbose)) cliID <- cli::cli_process_start("Normalizing peak of dataset: {.val {d}}") # `d` is the name of each dataset - if (isTRUE(verbose)) - cli::cli_alert_info("Normalizing rawPeak counts in dataset: {.val {d}}") ld <- dataset(object, d) normPeak(ld, check = FALSE) <- normalize(rawPeak(ld), ...) datasets(object, check = FALSE)[[d]] <- ld + if (isTRUE(verbose)) cli::cli_process_done(id = cliID) } object } - - - - ############################### Select Genes ################################### #' Select a subset of informative genes @@ -667,9 +664,9 @@ selectGenes.liger <- function( datasetUnshared <- .checkUseDatasets(object, useUnsharedDatasets) else datasetUnshared <- NULL useDatasets <- union(datasetShared, datasetUnshared) - thresh <- .checkArgLen(thresh, length(datasetShared)) - nGenes <- .checkArgLen(nGenes, length(datasetShared)) - unsharedThresh <- .checkArgLen(unsharedThresh, length(datasetUnshared)) + thresh <- .checkArgLen(thresh, length(datasetShared), class = "numeric") + nGenes <- .checkArgLen(nGenes, length(datasetShared), class = "numeric") + unsharedThresh <- .checkArgLen(unsharedThresh, length(datasetUnshared), class = "numeric") sharedFeature <- Reduce(intersect, lapply(datasets(object), rownames)) selectList <- list() for (d in useDatasets) { @@ -845,7 +842,7 @@ selectGenes.Seurat <- function( featureList <- lapply(matList, rownames) allshared <- Reduce(intersect, featureList) allFeatures <- SeuratObject::Features(object, assay = assay) - thresh <- .checkArgLen(thresh, nlevels(datasetVar)) + thresh <- .checkArgLen(thresh, nlevels(datasetVar), class = "numeric") # Get nUMI metric into list nUMIVar <- paste0("nCount_", assay) @@ -1260,11 +1257,13 @@ scaleNotCenter.liger <- function( useDatasets <- .checkUseDatasets(object, useDatasets) object <- recordCommand(object, ..., dependencies = c("RcppArmadillo", "Rcpp")) + for (d in useDatasets) { - if (isTRUE(verbose)) cli::cli_alert_info("Scaling dataset: {.val {d}}") + if (isTRUE(verbose)) cliID <- cli::cli_process_start("Scaling dataset {.val {d}}") ld <- dataset(object, d) ld <- scaleNotCenter(ld, features = features, verbose = verbose, ...) datasets(object, check = FALSE)[[d]] <- ld + if (isTRUE(verbose)) cli::cli_process_done(id = cliID) } return(object) } @@ -1332,10 +1331,9 @@ scaleNotCenter.Seurat <- function( geneRootMeanSumSq = sqrt(geneSumSq / (nCells - 1)) h5file <- getH5File(ld) # Count the subset nnz first before creating data space - if (isTRUE(verbose)) cli::cli_alert_info("Counting number of non-zero values...") nnz <- 0 nnz <- H5Apply( - ld, useData = "normData", chunkSize = chunk, verbose = verbose, + ld, useData = "normData", chunkSize = chunk, verbose = FALSE, FUN = function(chunk, sparseXIdx, cellIdx, values) { chunk <- chunk[featureIdx, , drop = FALSE] values <- values + length(chunk@x) diff --git a/R/subsetObject.R b/R/subsetObject.R index 9cafc4f..ad09cba 100644 --- a/R/subsetObject.R +++ b/R/subsetObject.R @@ -22,7 +22,7 @@ #' @param chunkSize Integer. Number of maximum number of cells in each chunk, #' Default \code{1000}. #' @param verbose Logical. Whether to show information of the progress. Default -#' \code{getOption("ligerVerbose")} which is \code{TRUE} if users have not set. +#' \code{getOption("ligerVerbose")} or \code{TRUE} if users have not set. #' @param returnObject Logical, whether to return a \linkS4class{liger} object #' for result. Default \code{TRUE}. \code{FALSE} returns a list containing #' requested values. @@ -40,7 +40,7 @@ subsetLiger <- function( cellIdx = NULL, useSlot = NULL, chunkSize = 1000, - verbose = getOption("ligerVerbose"), + verbose = getOption("ligerVerbose", TRUE), newH5 = TRUE, returnObject = TRUE, ... @@ -53,7 +53,8 @@ subsetLiger <- function( return(object) } if (!inherits(object, "liger")) { - warning("`object` is not a liger obejct. Nothing to be done.") + cli::cli_alert_danger("{.var object} is not a {.cls liger} object.") + cli::cli_alert_info("Nothing to be done.") return(object) } # Check subscription parameters #### @@ -65,26 +66,28 @@ subsetLiger <- function( # feature idx need different check from ligerDataset's .idxCheck if (!is.null(featureIdx)) { if (!is.character(featureIdx)) { - stop("Feature subscription from liger object can only take ", - "character vector.") + cli::cli_abort( + "Feature subscription from a {.cls liger} object can only take {.cls character} vector (e.g. gene names)." + ) } genesList <- lapply(datasets(object)[useDatasets], rownames) allGenes <- unique(unlist(genesList, use.names = FALSE)) if (!all(featureIdx %in% allGenes)) { notFound <- featureIdx[!featureIdx %in% allGenes] - warning(length(notFound), " out of ", length(featureIdx), - " given features were not found in the union of all ", - "features of used datasets") + cli::cli_alert_warning( + c("{length(notFound)} out of {length(featureIdx)} given ", + "features were not found in the union of all features of ", + "used datasets: {.val {notFound}}") + ) } featureIdx <- featureIdx[featureIdx %in% allGenes] - if (length(featureIdx) == 0) - stop("No feature can be retrieved") + if (length(featureIdx) == 0) cli::cli_abort("No feature can be retrieved") } # Subset each involved dataset and create new liger object datasets.new <- list() for (d in useDatasets) { - if (isTRUE(verbose)) .log("Subsetting dataset: ", d) + if (isTRUE(verbose)) cli::cli_process_start("Subsetting dataset: {.val {d}}") ld <- dataset(object, d) featureIdxDataset <- featureIdx if (isFALSE(returnObject)) @@ -194,16 +197,19 @@ retrieveCellFeature <- function( value <- data.frame(value, row.names = colnames(ld)) colnames(value) <- feature if (!inherits(ld, "ligerATACDataset")) { - warning("Dataset ", d, " is not of ATAC modality, returning ", - "NAs for cells belonging to this dataset.", - immediate. = TRUE) + cli::cli_alert_warning( + c("Dataset {.val {d}} is not of ATAC modality, returning ", + "NAs for cells belonging to this dataset") + ) return(value) } else { peak <- methods::slot(ld, slot) if (any(!feature %in% rownames(peak))) { nf <- feature[!feature %in% rownames(peak)] - warning("Specified feature not found in dataset ", d, - ", returning NAs.", immediate. = TRUE) + cli::cli_alert_warning( + c("Specified features are not found in dataset ", + "{.val {d}}, returning NAs.") + ) feature <- feature[feature %in% rownames(peak)] } value[,feature] <- peak[feature, ] @@ -247,7 +253,7 @@ retrieveCellFeature <- function( #' @param chunkSize Integer. Number of maximum number of cells in each chunk, #' Default \code{1000}. #' @param verbose Logical. Whether to show information of the progress. Default -#' \code{getOption("ligerVerbose")} which is \code{TRUE} if users have not set. +#' \code{getOption("ligerVerbose")} or \code{TRUE} if users have not set. #' @param returnObject Logical, whether to return a \linkS4class{ligerDataset} #' object for result. Default \code{TRUE}. \code{FALSE} returns a list #' containing requested values. @@ -268,7 +274,7 @@ subsetLigerDataset <- function( filename = NULL, filenameSuffix = NULL, chunkSize = 1000, - verbose = getOption("ligerVerbose"), + verbose = getOption("ligerVerbose", TRUE), returnObject = TRUE, ... ) { @@ -295,13 +301,15 @@ subsetH5LigerDataset <- function( filename = NULL, filenameSuffix = NULL, chunkSize = 1000, - verbose = getOption("ligerVerbose"), + verbose = getOption("ligerVerbose", TRUE), returnObject = TRUE ) { if (isTRUE(newH5)) { if (isFALSE(returnObject)) - warning("Cannot set `returnObject = FALSE` when subsetting", - "H5 based ligerDataset to new H5 file.") + cli::cli_alert_danger( + c("Cannot set {.code returnObject = FALSE} when subsetting H5 based {.cls ligerDataset} to new H5 file.", + "i" = "Will return subset to new object.") + ) if (is.null(filename) && is.null(filenameSuffix)) { oldFN <- h5fileInfo(object, "filename") bn <- basename(oldFN) @@ -323,7 +331,10 @@ subsetH5LigerDataset <- function( useSlot = useSlot, chunkSize = chunkSize, verbose = verbose ) }, error=function(e) { - message('An error occurred during subseting from H5 to H5.') + cli::cli_alert_danger( + "An error occurred during subseting from H5 to H5." + ) + cli::cli_alert_warning("The new H5 file will be removed.") unlink(filename) stop(e) } @@ -345,14 +356,16 @@ subsetH5LigerDatasetToMem <- function( useSlot = NULL, returnObject = TRUE, chunkSize = 1000, - verbose = getOption("ligerVerbose") + verbose = getOption("ligerVerbose", TRUE) ) { if (!inherits(object, "ligerDataset")) { - warning("`object` is not a ligerDataset obejct. Nothing to be done.") + cli::cli_alert_danger("{.var object} is not a {.cls ligerDataset} object.") + cli::cli_alert_info("Nothing to be done.") return(object) } if (!isH5Liger(object)) { - warning("`object` is not HDF5 based. Nothing to be done.") + cli::cli_alert_info("{.var object} is not HDF5 based.") + cli::cli_alert_info("Nothing to be done.") return(object) } modal <- modalOf(object) @@ -364,7 +377,8 @@ subsetH5LigerDatasetToMem <- function( value <- list() # Process rawData #### if ("rawData" %in% slotInvolved & !is.null(rawData(object))) { - if (isTRUE(verbose)) .log("Subsetting `rawData`", level = 2) + if (isTRUE(verbose)) + cli::cli_process_start("... Subsetting {.field rawData}") rawData <- H5Apply( object, init = NULL, useData = "rawData", chunkSize = chunkSize, verbose = verbose, @@ -376,11 +390,13 @@ subsetH5LigerDatasetToMem <- function( rownames(rawData) <- rownames(object)[featureIdx] colnames(rawData) <- colnames(object)[cellIdx] value$rawData <- rawData + if (isTRUE(verbose)) cli::cli_process_done() } # Process normData #### if ("normData" %in% slotInvolved & !is.null(normData(object))) { - if (isTRUE(verbose)) .log("Subsetting `normData`", level = 2) + if (isTRUE(verbose)) + cli::cli_process_start("... Subsetting {.field normData}") normData <- H5Apply( object, init = NULL, useData = "normData", chunkSize = chunkSize, verbose = verbose, @@ -392,6 +408,7 @@ subsetH5LigerDatasetToMem <- function( rownames(normData) <- rownames(object)[featureIdx] colnames(normData) <- colnames(object)[cellIdx] value$normData <- normData + if (isTRUE(verbose)) cli::cli_process_done() } # Process scaled data #### @@ -402,7 +419,8 @@ subsetH5LigerDatasetToMem <- function( secondIdx <- as.numeric(stats::na.omit(match(featureIdx, scaledFeatureIdx))) } if ("scaleData" %in% slotInvolved & !is.null(scaleData(object))) { - if (isTRUE(verbose)) .log("Subsetting `scaleData`", level = 2) + if (isTRUE(verbose)) + cli::cli_process_start("... Subsetting {.field scaleData}") # scaledFeatureIdx <- NULL # if (getH5File(object)$exists("scaleData.featureIdx")) { # scaledFeatureIdx <- getH5File(object)[["scaleData.featureIdx"]][] @@ -463,6 +481,7 @@ subsetH5LigerDatasetToMem <- function( # } # } value$scaleData <- scaleDataSubset + if (isTRUE(verbose)) cli::cli_process_done() } # `NULL[idx1, idx2]` returns `NULL` # V: k x genes @@ -500,15 +519,17 @@ subsetH5LigerDatasetToH5 <- function( filename = NULL, filenameSuffix = NULL, chunkSize = 1000, - verbose = getOption("ligerVerbose") + verbose = getOption("ligerVerbose", TRUE) ) { # Input checks #### if (!inherits(object, "ligerDataset")) { - warning("`object` is not a ligerDataset obejct. Nothing to be done.") + cli::cli_alert_danger("{.var object} is not a {.cls ligerDataset} object.") + cli::cli_alert_info("Nothing to be done.") return(object) } if (!isH5Liger(object)) { - warning("`object` is not HDF5 based. Nothing to be done.") + cli::cli_alert_info("{.var object} is not HDF5 based.") + cli::cli_alert_info("Nothing to be done.") return(object) } modal <- modalOf(object) @@ -522,7 +543,7 @@ subsetH5LigerDatasetToH5 <- function( } else { newH5File <- hdf5r::H5File$new(filename, mode = "w") } - if (isTRUE(verbose)) .log("New H5 file at: ", filename) + if (isTRUE(verbose)) cli::cli_alert_info("New H5 file at: {.file {filename}}") newH5Meta <- h5fileInfo(object) newH5Meta$H5File <- newH5File newH5Meta$filename <- filename @@ -532,6 +553,10 @@ subsetH5LigerDatasetToH5 <- function( newH5File[[newH5Meta$barcodesName]][1:length(cellIdx)] <- colnames(object)[cellIdx] } else { + cli::cli_abort( + c("AnnData (H5AD) format not supported yet.", + "i" = "Please submit an issue on GitHub if this is highly desired.") + ) # TODO: AnnData style barcodes storage. } @@ -542,7 +567,8 @@ subsetH5LigerDatasetToH5 <- function( # Process Raw Data #### if ("rawData" %in% useSlot & !is.null(rawData(object))) { # 1. Create paths to store i, p, x of sparse matrix - if (isTRUE(verbose)) .log("Subsetting `rawData`", level = 2) + if (isTRUE(verbose)) + cli::cli_process_start("... Subsetting {.field rawData}") safeH5Create(newH5File, newH5Meta$indicesName, dims = 1, chunkSize = 4096, dtype = "int") i.h5d <- newH5File[[newH5Meta$indicesName]] @@ -590,10 +616,12 @@ subsetH5LigerDatasetToH5 <- function( return(values) } ) + if (isTRUE(verbose)) cli::cli_process_done() } # Process Normalized Data #### if ("normData" %in% useSlot & !is.null(normData(object))) { - if (isTRUE(verbose)) .log("Subsetting `normData`", level = 2) + if (isTRUE(verbose)) + cli::cli_process_start("... Subsetting {.field normData}") safeH5Create(newH5File, newH5Meta$normData, dims = 1, chunkSize = 4096, dtype = "double") x.h5d <- newH5File[[newH5Meta$normData]] @@ -636,6 +664,7 @@ subsetH5LigerDatasetToH5 <- function( return(values) } ) + if (isTRUE(verbose)) cli::cli_process_done() } # Process Scaled Data #### secondIdx <- NULL @@ -663,8 +692,7 @@ subsetH5LigerDatasetToH5 <- function( if ("scaleData" %in% useSlot & !is.null(scaleData(object))) { scaledFeatureIdxNew <- which(featureIdx %in% scaledFeatureIdx) if (isTRUE(verbose)) - .log(length(secondIdx), - " features used in scaleData were selected. ", level = 3) + cli::cli_process_start("... Subsetting {.field scaleData}") newH5File$create_group(newH5Meta$scaleData) safeH5Create( newH5File, @@ -752,6 +780,12 @@ subsetH5LigerDatasetToH5 <- function( # "feature selection. Unable to subset from H5.") # } # } + if (isTRUE(verbose)) { + cli::cli_process_done() + cli::cli_alert_info( + "...... {length(secondIdx)} features used in {.field scaleData} were selected." + ) + } } newH5File$close() if (!"rawData" %in% useSlot) newH5Meta$rawData <- NULL @@ -788,11 +822,12 @@ subsetH5LigerDatasetToH5 <- function( subsetMemLigerDataset <- function(object, featureIdx = NULL, cellIdx = NULL, useSlot = NULL, returnObject = TRUE) { if (!inherits(object, "ligerDataset")) { - warning("`object` is not a ligerDataset obejct. Nothing to be done.") + cli::cli_alert_danger("{.var object} is not a {.cls ligerDataset} object.") + cli::cli_alert_info("Nothing to be done.") return(object) } if (isH5Liger(object)) { - stop("`object` is HDF5 based. Use `subsetH5LigerDataset()` instead.") + cli::cli_abort("{.var object} is HDF5 based. Use {.fn subsetH5LigerDataset} instead.") } if (is.null(cellIdx) && is.null(featureIdx)) return(object) modal <- modalOf(object) @@ -858,18 +893,18 @@ subsetMemLigerDataset <- function(object, featureIdx = NULL, cellIdx = NULL, else return(subsetData) } -.getOrderedSubsetIdx <- function(allNames, subsetNames) { - # subsetNames must be real subset, but can be in a different order from - # original allNames - - # Label the order of original allNames - idx <- seq_along(allNames) - names(idx) <- allNames - # Subscribe with named vector, so the value (label for original order) get - # ordered by subscription - subsetIdx <- idx[subsetNames] - subsetIdx <- subsetIdx[!is.na(subsetIdx)] - names(subsetIdx) <- NULL - subsetIdx -} +# .getOrderedSubsetIdx <- function(allNames, subsetNames) { +# # subsetNames must be real subset, but can be in a different order from +# # original allNames +# +# # Label the order of original allNames +# idx <- seq_along(allNames) +# names(idx) <- allNames +# # Subscribe with named vector, so the value (label for original order) get +# # ordered by subscription +# subsetIdx <- idx[subsetNames] +# subsetIdx <- subsetIdx[!is.na(subsetIdx)] +# names(subsetIdx) <- NULL +# subsetIdx +# } diff --git a/R/util.R b/R/util.R index bb3bc23..1b1457d 100644 --- a/R/util.R +++ b/R/util.R @@ -9,6 +9,8 @@ message(pref, msg) } +cli_or <- function(x) cli::cli_vec(x, list("vec-last" = " or ")) + .checkObjVersion <- function(object) { if (inherits(object, "liger")) { if (!is.newLiger(object)) @@ -118,6 +120,7 @@ return(FALSE) } }) + passing <- unlist(passing) if (!all(passing)) { cli::cli_abort( "The following selected variables are not considered as @@ -191,8 +194,6 @@ } .checkLDSlot <- function(object, slot) { - if (!inherits(object, "ligerDataset")) - stop("Please use a ligerDataset object.") avail <- c("rawData", "normData", "scaleData") if (is.null(slot)) { slot <- avail @@ -228,26 +229,27 @@ if (type == "V") checklist <- c(1, 1, 1, 0, 0) if (checklist[1]) { if (!is.list(m)) - stop("`", type, ".init` should be a list of matrices") + cli::cli_abort( + "{.var {type}Init} should be a list of {.cls matrix}." + ) if (length(m) != length(nCells)) - stop("Number of matrices in `", type, ".init` should match number", - " of datasets in `object`") + cli::cli_abort( + "Number of matrices in {.var {type}Init} should match number of datasets in {.var object}." + ) isMat <- sapply(m, is.matrix) if (!all(isMat)) { - stop(sum(!isMat), " elements in `", type, ".init` is not a matrix.") + cli::cli_abort("{sum(!isMat)} elements in {.var {type}Init} is not {.cls matrix}.") } isValid <- sapply(seq_along(m), function(i) .checkInit.mat(m[[i]], nCells[i], nGenes, k, checklist)) if (!all(isValid)) - stop("Not all matrices in `", type, - ".init` has valid dimensionality.") + cli::cli_abort("Not all matrices in {.var {type}Init} has valid dimensionality.") } else { if (!is.matrix(m)) - stop("`", type, ".init` should be a matrix") + cli::cli_abort("{.var {type}Init} should be a {.cls matrix}.") if (!.checkInit.mat(m, sum(nCells), nGenes, k, checklist)) - stop("`", type, ".init` does not have valid dimensionality.") + cli::cli_abort("{.var {type}Init} does not have valid dimensionality.") } - m } .checkInit.mat <- function(m, nCells, nGenes, k, checklist) { @@ -262,7 +264,7 @@ checkV = TRUE) { result <- TRUE useDatasets <- .checkUseDatasets(object, useDatasets) - if (is.null(object@W)) stop("W matrix does not exist.") + if (is.null(object@W)) cli::cli_abort("W matrix does not exist.") k <- ncol(object@W) for (d in useDatasets) { @@ -270,32 +272,38 @@ nCells <- ncol(ld) if (isTRUE(checkV)) { if (is.null(ld@V)) { - warning("V matrix does not exist for dataset '", d, "'.") + cli::cli_alert_danger("V matrix does not exist for dataset {.val {d}}.") result <- FALSE } else { if (!identical(dim(ld@V), dim(object@W))) { - warning("Dimensionality of V matrix for dataset '", d, - "' does not match with W matrix.") + cli::cli_alert_danger( + "Dimensionality of V matrix for dataset {.val {d}} does not match with W matrix." + ) result <- FALSE } } } if (is.null(ld@H)) { - warning("H matrix does not exist for dataset '", d, "'.") + cli::cli_alert_danger("H matrix does not exist for dataset {.val {d}}.") result <- FALSE } else { if (!identical(dim(ld@H), c(k, nCells))) { - warning("Dimensionality of H matrix for dataset '", d, - "' is not valid") + cli::cli_alert_danger( + "Dimensionality of H matrix for dataset {.val {d}} is not valid." + ) result <- FALSE } } } if (k != object@uns$factorization$k) - warning("Number of factors does not match with object `k` slot. ") + cli::cli_alert_danger( + "Number of factors does not match with recorded parameter." + ) if (isFALSE(result)) - stop("Cannot detect valid existing factorization result. ", - "Please run factorization first. Check warnings.") + cli::cli_abort( + c(x = "Cannot detect valid existing factorization result. ", + i = "Please run factorization first. Check warnings.") + ) } # !!!MaintainerDeveloperNOTE: @@ -385,19 +393,35 @@ } .checkArgLen <- function(arg, n, repN = TRUE, class = NULL, .stop = TRUE) { + if (is.null(arg)) return(arg) argname <- deparse(substitute(arg)) - if (!is.null(arg)) { - if (length(arg) == 1 && isTRUE(repN)) { - arg <- rep(arg, n) - } - if (length(arg) != n) { - if (isTRUE(.stop)) + if (length(arg) == 1 && isTRUE(repN)) { + arg <- rep(arg, n) + } + if (length(arg) != n) { + classTxt <- ifelse(is.null(class), "", " ") + if (isTRUE(.stop)) + if (!is.null(class)) { cli::cli_abort( - "`{argname}` has to be a vector of length {n}." + c("{.var {argname}} has to be a length {ifelse(repN, paste0('1 or ', n), n)} object of class {.cls {class}}.", + "i" = "length: {length(arg)}; class: {.cls {class(arg)}}") ) - else { + } else { + cli::cli_abort( + c("{.var {argname}} has to be a length {ifelse(repN, paste0('1 or ', n), n)} object.", + "i" = "length: {length(arg)}; class: {.cls {class(arg)}}") + ) + } + else { + if (!is.null(class)) { cli::cli_alert_warning( - "`{argname}` should be a vector of length {n}. Using it anyway." + c("{.var {argname}} has to be a length {ifelse(repN, paste0('1 or ', n), n)} object of class {.cls {class}}.", + i = "Using it anyway.") + ) + } else { + cli::cli_alert_warning( + c("{.var {argname}} has to be a length {ifelse(repN, paste0('1 or ', n), n)} object.", + i = "Using it anyway.") ) } } @@ -405,13 +429,15 @@ if (!is.null(class)) { allClassCheck <- sapply(class, function(x) methods::is(arg, x)) if (!any(allClassCheck)) { + class <- cli::cli_vec(class, list("vec-quote" )) if (isTRUE(.stop)) cli::cli_abort( - "`{argname}` has to be one of the {length(class)} class{?es}: {.val {class}}" + c("{.var {argname}} has to be of class {.cls {class}}", + "i" = "Given class is {.cls {class(arg)}}") ) else { cli::cli_alert_warning( - "`{argname}` has to be one of the {length(class)} class{?es}: {.val {class}}" + c("{.var {argname}} has to be of class {.cls {class}}. Using it anyway.") ) } } @@ -419,16 +445,6 @@ return(arg) } -# Format "not found" string. When we need `need` elements from some source -# `from` format the string of ", " separeted list of not found elements. -.nfstr <- function(need, from) { - nf <- need[!need %in% from] - paste(nf, collapse = ", ") -} - - - - .getSeuratData <- function(object, layer, slot, assay = NULL) { if (!requireNamespace("Seurat", quietly = TRUE)) { cli::cli_abort( @@ -452,7 +468,7 @@ if (utils::packageVersion("SeuratObject") >= package_version("4.9.9")) { layers <- SeuratObject::Layers(object, assay = assay, search = layer) if (length(layers) == 0) { - stop("Layer '", layer, "' not found in object.") + cli::cli_abort("Layer {.val {layer}} not found in object.") } else if (length(layers) == 1) { data <- SeuratObject::LayerData(object, assay = assay, layer = layers) } else { @@ -513,35 +529,6 @@ return(object) } -# plyr::mapvalues -mapvalues <- function(x, from, to, warn_missing = TRUE) { - if (length(from) != length(to)) { - stop("`from` and `to` vectors are not the same length.") - } - if (!is.atomic(x) && !is.null(x)) { - stop("`x` must be an atomic vector or NULL.") - } - - if (is.factor(x)) { - # If x is a factor, call self but operate on the levels - levels(x) <- mapvalues(levels(x), from, to, warn_missing) - return(x) - } - - mapidx <- match(x, from) - mapidxNA <- is.na(mapidx) - - # index of items in `from` that were found in `x` - from_found <- sort(unique(mapidx)) - if (warn_missing && length(from_found) != length(from)) { - message("The following `from` values were not present in `x`: ", - paste(from[!(1:length(from) %in% from_found) ], collapse = ", ")) - } - - x[!mapidxNA] <- to[mapidx[!mapidxNA]] - x -} - .DataFrame.as.data.frame <- function(x) { # Copied from Bioconductor package S4Vectors:::.as.data.frame.DataFrame diff --git a/R/visualization.R b/R/visualization.R index ecd8cdc..37eb8e2 100644 --- a/R/visualization.R +++ b/R/visualization.R @@ -50,7 +50,10 @@ plotClusterDimRed <- function( ...) { useDimRed <- useDimRed %||% object@uns$defaultDimRed if (is.null(useDimRed)) { - stop("No `useDimRed` given or default dimRed not set.") + cli::cli_abort( + c(x = "No {.var useDimRed} given or default dimRed not set.", + i = "Run {.fn runUMAP} or {.fn runTSNE} to create one. Or see {.fn dimRed} and {.fn defaultDimRed}.") + ) } useCluster <- useCluster %||% object@uns$defaultCluster xVar <- paste0(useDimRed, ".1") @@ -68,7 +71,10 @@ plotDatasetDimRed <- function( ...) { useDimRed <- useDimRed %||% object@uns$defaultDimRed if (is.null(useDimRed)) { - stop("No `useDimRed` given or default dimRed not set.") + cli::cli_abort( + c(x = "No {.var useDimRed} given or default dimRed not set.", + i = "Run {.fn runUMAP} or {.fn runTSNE} to create one. Or see {.fn dimRed} and {.fn defaultDimRed}.") + ) } xVar <- paste0(useDimRed, ".1") yVar <- paste0(useDimRed, ".2") @@ -433,8 +439,9 @@ plotProportionDot <- function( class1 <- class1 %||% object@uns$defaultCluster if (length(class1) != 1 || length(class2) != 1) - stop("`class1` and `class2` must be name of one categorical variable ", - "in `cellMeta` slot.") + cli::cli_abort( + "{.var class1} and {.var class2} must be name of one categorical variable in {.code cellMeta(object)}" + ) vars <- .fetchCellMetaVar(object, c(class1, class2), checkCategorical = TRUE) freq <- table(vars) @@ -471,8 +478,7 @@ plotProportionBar <- function( class1 <- class1 %||% object@uns$defaultCluster if (length(class1) != 1 || length(class2) != 1) - stop("`class1` and `class2` must be name of one categorical variable ", - "in `cellMeta` slot.") + cli::cli_abort("{.var class1} and {.var class2} must be name of one categorical variable in {.code cellMeta(object)}") method <- match.arg(method) vars <- .fetchCellMetaVar(object, c(class1, class2), checkCategorical = TRUE) @@ -622,6 +628,9 @@ plotProportionPie <- function( #' passed to \code{\link[EnhancedVolcano]{EnhancedVolcano}}. #' @return ggplot #' @export +#' @examples +#' result <- runMarkerDEG(pbmcPlot) +#' plotVolcano(result, 1) plotVolcano <- function( result, group, @@ -635,7 +644,10 @@ plotVolcano <- function( ... ) { if (!group %in% result$group) { - stop("Selected group does not exist in `result`.") + cli::cli_abort( + c("Selected group does not exist in {.code result$group}", + i = "Available ones: {.val {levels(droplevels(result$group))}}") + ) } result <- result[result$group == group, ] result <- result[order(abs(result$logFC), decreasing = TRUE), ] @@ -705,12 +717,12 @@ plotEnhancedVolcano <- function( group, ... ) { - if (!requireNamespace("EnhancedVolcano", quietly = TRUE)) { - stop("Package \"EnhancedVolcano\" needed for this function to work. ", - "Please install it by command:\n", - "BiocManager::install('EnhancedVolcano')", - call. = FALSE) - } + if (!requireNamespace("EnhancedVolcano", quietly = TRUE)) { # nocov start + cli::cli_abort( + "Package {.pkg EnhancedVolcano} is needed for this function to work. + Please install it by command: + {.code BiocManager::install('EnhancedVolcano')}") + } # nocov end result <- result[result$group == group, ] EnhancedVolcano::EnhancedVolcano( toptable = result, @@ -805,14 +817,12 @@ plotDensityDimRed <- function( } else { # Will return a single ggplot if (length(title) > 1) { - warning("`title` has length greater than 1 while only a single ", - "plot is generated. Using the first value only. ") + cli::cli_alert_warning("{.var title} has length greater than 1 while only a single plot is generated. Using the first value only.") title <- title[1] } drList <- list(dr) } plotList <- list() - #if (length(drList) == 0) stop("No plot could be generated") if (length(drList) == 1) { return(.ggDensity(drList[[1]], dotCoordDF = drList[[1]], title = title, minDensity = minDensity, @@ -1110,11 +1120,11 @@ plotSankey <- function( colorValues = scPalette, mar = c(2, 2, 4, 2) ) { - if (!requireNamespace("sankey", quietly = TRUE)) - stop("Package \"sankey\" needed for this function to work. ", - "Please install it by command:\n", - "install.packages('sankey')", - call. = FALSE) + if (!requireNamespace("sankey", quietly = TRUE)) # nocov start + cli::cli_abort( + "Package {.pkg sankey} is needed for this function to work. + Please install it by command: + {.code install.packages('sankey')}") # nocov end clusterConsensus <- clusterConsensus %||% object@uns$defaultCluster clusterDF <- .fetchCellMetaVar(object, @@ -1122,7 +1132,7 @@ plotSankey <- function( checkCategorical = TRUE, droplevels = TRUE) titles <- titles %||% c(cluster1, clusterConsensus, cluster2) - titles <- .checkArgLen(titles, 3, repN = FALSE) + titles <- .checkArgLen(titles, 3, repN = FALSE, class = "character") # Prepare for networkD3 input: Links, Nodes cluster1Fct <- droplevels(clusterDF[[1]]) clusterCFct <- droplevels(clusterDF[[2]]) @@ -1139,7 +1149,7 @@ plotSankey <- function( if (any(duplicated(c(nodes1, nodesC, nodes2)))) { prefixes <- prefixes %||% c(cluster1, clusterConsensus, cluster2) - prefixes <- .checkArgLen(prefixes, 3, repN = FALSE) + prefixes <- .checkArgLen(prefixes, 3, repN = FALSE, class = "character") nodes1 <- .addPrefix(prefixes[1], nodes1) nodesC <- .addPrefix(prefixes[2], nodesC) nodes2 <- .addPrefix(prefixes[3], nodes2) @@ -1240,7 +1250,7 @@ plotSpatial2D.liger <- function( ...) { dataset <- .checkUseDatasets(object, useDatasets = dataset, modal = "spatial") - .checkArgLen(dataset, 1) + .checkArgLen(dataset, 1, class = "character") ld <- dataset(object, dataset) useCluster <- useCluster %||% defaultCluster(object)[object$dataset == dataset] @@ -1248,7 +1258,7 @@ plotSpatial2D.liger <- function( legendColorTitle <- legendColorTitle %||% useCluster useCluster <- cellMeta(object, useCluster, useDatasets = dataset) } else { - useCluster <- .checkArgLen(useCluster, ncol(ld), repN = FALSE) + useCluster <- .checkArgLen(useCluster, ncol(ld), repN = FALSE, class = "factor") legendColorTitle <- legendColorTitle %||% "Annotation" } plotSpatial2D.ligerSpatialDataset( @@ -1275,11 +1285,11 @@ plotSpatial2D.ligerSpatialDataset <- function( labelText = FALSE, ...) { - .checkArgLen(useCluster, ncol(object)) + .checkArgLen(useCluster, ncol(object), repN = FALSE, class = "factor") legendColorTitle <- legendColorTitle %||% "Annotation" coord <- coordinate(object) - .checkArgLen(useDims, 2) + .checkArgLen(useDims, 2, repN = FALSE, class = "numeric") coord <- coord[, useDims] plotDF <- as.data.frame(coord) colnames(plotDF) <- c("x", "y") diff --git a/man/liger-class.Rd b/man/liger-class.Rd index bf119b4..bbe04b5 100644 --- a/man/liger-class.Rd +++ b/man/liger-class.Rd @@ -26,9 +26,6 @@ \alias{dim,liger-method} \alias{dimnames,liger-method} \alias{dimnames<-,liger,list-method} -\alias{[,liger,character,missing,ANY-method} -\alias{[,liger,missing,index,ANY-method} -\alias{[,liger,character,index,ANY-method} \alias{datasets,liger-method} \alias{datasets<-,liger,logical-method} \alias{datasets<-,liger,missing-method} @@ -103,7 +100,14 @@ cellMeta( ... ) -cellMeta(x, columns = NULL, useDatasets = NULL, cellIdx = NULL, check = FALSE) <- value +cellMeta( + x, + columns = NULL, + useDatasets = NULL, + cellIdx = NULL, + inplace = FALSE, + check = FALSE +) <- value defaultCluster(x, useDatasets = NULL, ...) @@ -135,12 +139,6 @@ commands(x, funcName = NULL, arg = NULL) \S4method{dimnames}{liger,list}(x) <- value -\S4method{[}{liger,character,missing,ANY}(x, i, j, ..., drop = TRUE) - -\S4method{[}{liger,missing,index,ANY}(x, i, j, ..., drop = TRUE) - -\S4method{[}{liger,character,index,ANY}(x, i, j, ..., drop = TRUE) - \S4method{datasets}{liger}(x, check = NULL) \S4method{datasets}{liger,logical}(x, check = TRUE) <- value @@ -194,7 +192,14 @@ commands(x, funcName = NULL, arg = NULL) \S4method{cellMeta}{liger,missing}(x, columns = NULL, useDatasets = NULL, cellIdx = NULL, check = FALSE) <- value -\S4method{cellMeta}{liger,character}(x, columns = NULL, useDatasets = NULL, cellIdx = NULL, check = FALSE) <- value +\S4method{cellMeta}{liger,character}( + x, + columns = NULL, + useDatasets = NULL, + cellIdx = NULL, + inplace = TRUE, + check = FALSE +) <- value \S4method{rawData}{liger}(x, dataset = NULL) @@ -309,17 +314,17 @@ acceptable. Default \code{NULL} works with all datasets.} \item{...}{See detailed sections for explanation.} +\item{inplace}{For \code{cellMeta<-} method, when \code{columns} is for +existing variable and \code{useDatasets} or \code{cellIdx} indicate partial +insertion to the object, whether to by default (\code{TRUE}) in-place insert +\code{value} into the variable for selected cells or to replace the whole +variable with non-selected part left as NA.} + \item{name}{The name of available variables in \code{cellMeta} slot or the name of a new variable to store.} \item{funcName, arg}{See Command records section.} -\item{i, j}{Feature and cell index for \code{`[`} method. For \code{`[[`} -method, use a single variable name with \code{i} while \code{j} is not -applicable.} - -\item{drop}{Not applicable.} - \item{slot}{Name of slot to retrieve matrix from. Options shown in Usage.} \item{returnList}{Logical, whether to force return a list even when only one diff --git a/man/plotVolcano.Rd b/man/plotVolcano.Rd index fdf586f..f5becf3 100644 --- a/man/plotVolcano.Rd +++ b/man/plotVolcano.Rd @@ -59,3 +59,7 @@ most of arguments with other rliger plotting functions. substantial amount of arguments for graphical control. However, that requires the installation of package "EnhancedVolcano". } +\examples{ +result <- runMarkerDEG(pbmcPlot) +plotVolcano(result, 1) +} diff --git a/man/sub-liger.Rd b/man/sub-liger.Rd new file mode 100644 index 0000000..25dbf90 --- /dev/null +++ b/man/sub-liger.Rd @@ -0,0 +1,32 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/liger-methods.R +\name{sub-liger} +\alias{sub-liger} +\alias{[.liger} +\title{Subset liger with brackets} +\usage{ +\method{[}{liger}(x, i, j, ...) +} +\arguments{ +\item{x}{A \linkS4class{liger} object} + +\item{i}{Feature subscriptor, passed to \code{featureIdx} of +\code{\link{subsetLiger}}.} + +\item{j}{Cell subscriptor, passed to \code{cellIdx} of +\code{\link{subsetLiger}}.} + +\item{...}{Additional arguments passed to \code{\link{subsetLiger}}.} +} +\value{ +Subset of \code{x} with specified features and cells. +} +\description{ +Subset liger with brackets +} +\examples{ +pbmcPlot[varFeatures(pbmcPlot)[1:10], 1:10] +} +\seealso{ +\code{\link{subsetLiger}} +} diff --git a/man/subsetLiger.Rd b/man/subsetLiger.Rd index e2b6293..311d4e6 100644 --- a/man/subsetLiger.Rd +++ b/man/subsetLiger.Rd @@ -10,7 +10,7 @@ subsetLiger( cellIdx = NULL, useSlot = NULL, chunkSize = 1000, - verbose = getOption("ligerVerbose"), + verbose = getOption("ligerVerbose", TRUE), newH5 = TRUE, returnObject = TRUE, ... @@ -33,7 +33,7 @@ Missing or \code{NULL} for all cells.} Default \code{1000}.} \item{verbose}{Logical. Whether to show information of the progress. Default -\code{getOption("ligerVerbose")} which is \code{TRUE} if users have not set.} +\code{getOption("ligerVerbose")} or \code{TRUE} if users have not set.} \item{newH5}{Whether to create new H5 files on disk for the subset datasets if involved datasets in the \code{object} is HDF5 based. \code{TRUE} writes a diff --git a/man/subsetLigerDataset.Rd b/man/subsetLigerDataset.Rd index 4fb6528..6380f80 100644 --- a/man/subsetLigerDataset.Rd +++ b/man/subsetLigerDataset.Rd @@ -15,7 +15,7 @@ subsetLigerDataset( filename = NULL, filenameSuffix = NULL, chunkSize = 1000, - verbose = getOption("ligerVerbose"), + verbose = getOption("ligerVerbose", TRUE), returnObject = TRUE, ... ) @@ -29,7 +29,7 @@ subsetH5LigerDataset( filename = NULL, filenameSuffix = NULL, chunkSize = 1000, - verbose = getOption("ligerVerbose"), + verbose = getOption("ligerVerbose", TRUE), returnObject = TRUE ) @@ -71,7 +71,7 @@ for the new files so the new filename looks like Default \code{1000}.} \item{verbose}{Logical. Whether to show information of the progress. Default -\code{getOption("ligerVerbose")} which is \code{TRUE} if users have not set.} +\code{getOption("ligerVerbose")} or \code{TRUE} if users have not set.} \item{returnObject}{Logical, whether to return a \linkS4class{ligerDataset} object for result. Default \code{TRUE}. \code{FALSE} returns a list diff --git a/tests/testthat/test_downstream.R b/tests/testthat/test_downstream.R index e6754e6..31d0969 100644 --- a/tests/testthat/test_downstream.R +++ b/tests/testthat/test_downstream.R @@ -156,10 +156,8 @@ test_that("wilcoxon", { expect_error(getFactorMarkers(pbmc, "ctrl", "stim", factorShareThresh = 0), "No factor passed the dataset specificity threshold") - expect_warning( - expect_message( - res3 <- getFactorMarkers(pbmc, "ctrl", "stim", printGenes = TRUE) - ) + expect_message( + res3 <- getFactorMarkers(pbmc, "ctrl", "stim", printGenes = TRUE) ) expect_is(res3, "list") expect_identical(names(res3), c("ctrl", "shared", "stim", "num_factors_V1", @@ -215,7 +213,7 @@ test_that("pseudo bulk", { groupCtrl = pbmc$dataset == "stim" & pbmc$leiden_cluster == 0, method = "pseudo", useReplicate = "dataset" ), - "Too few replicates label for condition" + "Too few replicates for condition" ) pbmc@datasets$ctrl@rawData <- NULL @@ -225,7 +223,7 @@ test_that("pseudo bulk", { variable1 = "leiden_cluster",　method = "pseudo", useReplicate = "dataset" ), - "rawData not all available for involved datasets" + "not all available for involved datasets" ) }) diff --git a/tests/testthat/test_object.R b/tests/testthat/test_object.R index 5c6d424..ca31f83 100644 --- a/tests/testthat/test_object.R +++ b/tests/testthat/test_object.R @@ -60,7 +60,7 @@ test_that("liger object creation - in memory", { expect_error(createLiger(rawData = "hi"), "`rawData` has to be a named list.") expect_error(createLiger(rawData = rawDataList, modal = letters[1:3]), - "`modal` has to be a vector of length 2") + "`modal` has to be a length 1 or 2 object of class") ldList <- datasets(pbmc) cellmeta <- cellMeta(pbmc) pbmc2 <- createLiger(rawData = ldList, cellMeta = cellmeta, @@ -83,7 +83,7 @@ test_that("liger object creation - on disk", { withNewH5Copy( function(rawList) { expect_error(createLiger(rawList, formatType = "Hello"), - "Specified `formatType` '") + "Specified `formatType`") # Customized paths barcodesName <- "matrix/barcodes" @@ -161,8 +161,8 @@ test_that("liger S3/S4 methods", { expect_is(meta, "DFrame") expect_null(cellMeta(pbmc, NULL)) expect_is(cellMeta(pbmc, "dataset"), "factor") - expect_warning(cellMeta(pbmc, "UMAP.1"), - "Specified variables from cellMeta not found: UMAP.1") + expect_message(cellMeta(pbmc, "UMAP.1"), + "Specified variables from cellMeta not found") expect_is(cellMeta(pbmc, "UMAP.1", cellIdx = 1:500, as.data.frame = TRUE), "numeric") expect_is(pbmc[["nUMI"]], "numeric") @@ -198,7 +198,7 @@ test_that("liger S3/S4 methods", { test_that("ligerDataset (in memory) object creation", { expect_error(createLigerDataset(), - "At least one type of") + "At least one of") ld <- createLigerDataset(rawData = rawDataList[[1]], modal = "atac") expect_is(ld, "ligerATACDataset") @@ -213,8 +213,10 @@ test_that("ligerDataset (in memory) object creation", { pbmc <- scaleNotCenter(pbmc) scaledMat <- scaleData(pbmc, dataset = "ctrl") featuremeta <- featureMeta(dataset(pbmc, "ctrl")) - ld <- createLigerDataset(scaleData = scaledMat, featureMeta = featuremeta) - expect_equal(length(varFeatures(pbmc)), nrow(ld)) + expect_error( + ld <- createLigerDataset(scaleData = scaledMat, featureMeta = featuremeta), + "At least one of " + ) }) #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -227,7 +229,7 @@ test_that("ligerDataset methods", { expect_false(isH5Liger(pbmc)) ctrl <- dataset(pbmc, "ctrl") expect_false(isH5Liger(ctrl)) - expect_warning(isH5Liger("hi"), "Given object is not of liger") + expect_message(isH5Liger("hi"), "Given object is not ") expect_identical(modalOf(ctrl), "default") expect_identical(modalOf(pbmc), c(ctrl = "default", stim = "default")) @@ -274,7 +276,7 @@ test_that("ligerDataset methods", { # ligerATACDataset related expect_error(rawPeak(pbmc, "stim"), - "Specified dataset is not of ligerATACDataset class.") + "Specified dataset is not of ") expect_error(rawPeak(pbmc, "stim") <- rawData(ctrl), "Specified dataset is not of") ctrl <- as.ligerDataset(ctrl, modal = "atac") @@ -282,7 +284,7 @@ test_that("ligerDataset methods", { rawPeak(pbmc, "ctrl") <- rawData(ctrl) expect_error(normPeak(pbmc, "stim"), - "Specified dataset is not of ligerATACDataset class.") + "Specified dataset is not of") expect_error(normPeak(pbmc, "stim") <- normData(stim), "Specified dataset is not of") normPeak(pbmc, "ctrl") <- normData(ctrl) @@ -305,7 +307,7 @@ test_that("ligerDataset methods", { expect_true(validObject(ctrl)) coords <- matrix(rnorm(300*3), 300, 3) - expect_warning(coordinate(ctrl) <- coords, + expect_message(coordinate(ctrl) <- coords, "No rownames with given spatial coordinate") coords <- matrix(rnorm(300*4), 300, 4) rownames(coords) <- colnames(ctrl) @@ -317,7 +319,7 @@ test_that("ligerDataset methods", { colnames(coords) <- c("x", "y") ctrl@coordinate <- coords expect_error(validObject(ctrl), "Inconsistant cell identifiers") - expect_warning(coordinate(ctrl) <- coords, + expect_message(coordinate(ctrl) <- coords, "NA generated for missing cells") # ligerMethDataset related expect_message(ctrl <- as.ligerDataset(ctrl, modal = "meth"), @@ -361,17 +363,17 @@ test_that("H5 ligerDataset methods", { list(indicesName = "matrix/indices", indptrName = "matrix/indptr")) expect_error(h5fileInfo(ctrl, c("indicesName", "hello")), - "Specified h5file info not found: hello") + "Specified `info` not found") expect_error(h5fileInfo(ctrl, info = 1:2) <- "hey", "`info` has to be a single character.") expect_error(h5fileInfo(ctrl, "indicesName") <- "hey", - "Specified info is invalid,") + "Specified `info`") expect_no_error(h5fileInfo(ctrl, "barcodesName") <- "matrix/barcodes") ctrl.h5$close() - expect_warning(show(ctrl), "Link to HDF5 file fails.") + expect_message(show(ctrl), "Link to HDF5 file fails.") } ) }) diff --git a/tests/testthat/test_preprocessing.R b/tests/testthat/test_preprocessing.R index 79695b3..befa2bd 100644 --- a/tests/testthat/test_preprocessing.R +++ b/tests/testthat/test_preprocessing.R @@ -184,8 +184,6 @@ test_that("Normalize - on disk", { context("Select variable genes") test_that("selectGenes", { pbmc <- normalize(pbmc, useDatasets = 1) - expect_error(selectGenes(pbmc, thresh = 1:3), - "`thresh` has to be a vector of length 2") expect_error(selectGenes(pbmc, thresh = 0.1), "Normalized data not available") pbmc <- normalize(pbmc, useDatasets = 2) @@ -217,7 +215,7 @@ test_that("selectGenes", { pbmc <- selectGenesVST(pbmc, useDataset = "ctrl", n = 50) expect_equal(length(varFeatures(pbmc)), 50) - expect_warning(pbmc <- selectGenesVST(pbmc, useDataset = "ctrl", n = 300, + expect_message(pbmc <- selectGenesVST(pbmc, useDataset = "ctrl", n = 300, useShared = FALSE), "Not all variable features passed are found in datasets") expect_equal(length(varFeatures(pbmc)), 266) diff --git a/tests/testthat/test_subset.R b/tests/testthat/test_subset.R index dd30b03..c1b1abf 100644 --- a/tests/testthat/test_subset.R +++ b/tests/testthat/test_subset.R @@ -50,12 +50,12 @@ process <- function(object) { context("subset liger object") test_that("subsetLiger", { - expect_warning(a <- subsetLiger("a"), "`object` is not a liger obejct") + expect_message(a <- subsetLiger("a"), "`object` is not a ") expect_identical(a, "a") skip_if_not(has_RcppPlanc) pbmc <- process(pbmc) expect_error(subsetLiger(pbmc, featureIdx = 1:3), - "Feature subscription from liger object") + "Feature subscription from a") expect_error( expect_warning(subsetLiger(pbmc, featureIdx = c("fakeGene1", "fakeGene2")), @@ -79,7 +79,7 @@ test_that("subsetH5LigerDataset", { expect_false(isH5Liger(ctrlSmall)) path <- dirname(h5fileInfo(ctrl, "filename")) newName <- file.path(path, "ctrltest.h5.small.h5") - expect_warning( + expect_message( subsetLigerDataset(ctrl, featureIdx = 1:10, cellIdx = 1:10, newH5 = TRUE, filename = newName, @@ -88,11 +88,11 @@ test_that("subsetH5LigerDataset", { ) expect_true(file.exists(newName)) unlink(newName) - expect_warning( + expect_message( rliger2:::subsetH5LigerDatasetToMem(letters), - "`object` is not a ligerDataset obejct." + "`object` is not a " ) - expect_warning( + expect_message( rliger2:::subsetH5LigerDatasetToMem(dataset(pbmc, "ctrl")), "`object` is not HDF5 based." ) @@ -101,11 +101,11 @@ test_that("subsetH5LigerDataset", { ) expect_is(valueList, "list") - expect_warning( + expect_message( rliger2:::subsetH5LigerDatasetToH5(letters), - "`object` is not a ligerDataset obejct." + "`object` is not a" ) - expect_warning( + expect_message( rliger2:::subsetH5LigerDatasetToH5(dataset(pbmc, "ctrl")), "`object` is not HDF5 based." ) diff --git a/tests/testthat/test_visualization.R b/tests/testthat/test_visualization.R index 3a9301c..24518c3 100644 --- a/tests/testthat/test_visualization.R +++ b/tests/testthat/test_visualization.R @@ -156,7 +156,7 @@ test_that("Density plot", { expect_gg( expect_no_warning(plotDensityDimRed(pbmcPlot, splitBy = "dataset", title = "one")), - expect_warning(plotDensityDimRed(pbmcPlot, title = letters[1:3], + expect_message(plotDensityDimRed(pbmcPlot, title = letters[1:3], dotRaster = TRUE), "`title` has length greater than") )