diff --git a/.github/workflows/check-bioc.yml b/.github/workflows/check-bioc.yml index 36064c1..ba15358 100644 --- a/.github/workflows/check-bioc.yml +++ b/.github/workflows/check-bioc.yml @@ -52,9 +52,9 @@ jobs: fail-fast: false matrix: config: - - { os: ubuntu-latest, r: '4.3', bioc: '3.17', cont: "bioconductor/bioconductor_docker:RELEASE_3_17", rspm: "https://packagemanager.rstudio.com/cran/__linux__/jammy/latest" } - - { os: macOS-latest, r: '4.3', bioc: '3.17'} - - { os: windows-latest, r: '4.3', bioc: '3.17'} + - { os: ubuntu-latest, r: '4.3', bioc: '3.18', cont: "bioconductor/bioconductor_docker:devel", rspm: "https://packagemanager.rstudio.com/cran/__linux__/jammy/latest" } + - { os: macOS-latest, r: '4.3', bioc: '3.18'} + - { os: windows-latest, r: '4.3', bioc: '3.18'} ## Check https://github.com/r-lib/actions/tree/master/examples ## for examples using the http-user-agent env: @@ -105,16 +105,16 @@ jobs: uses: actions/cache@v3 with: path: ${{ env.R_LIBS_USER }} - key: ${{ env.cache-version }}-${{ runner.os }}-biocversion-RELEASE_3_17-r-4.3-${{ hashFiles('.github/depends.Rds') }} - restore-keys: ${{ env.cache-version }}-${{ runner.os }}-biocversion-RELEASE_3_17-r-4.3- + key: ${{ env.cache-version }}-${{ runner.os }}-biocversion-devel-r-4.3-${{ hashFiles('.github/depends.Rds') }} + restore-keys: ${{ env.cache-version }}-${{ runner.os }}-biocversion-devel-r-4.3- - name: Cache R packages on Linux if: "!contains(github.event.head_commit.message, '/nocache') && runner.os == 'Linux' " uses: actions/cache@v3 with: path: /home/runner/work/_temp/Library - key: ${{ env.cache-version }}-${{ runner.os }}-biocversion-RELEASE_3_17-r-4.3-${{ hashFiles('.github/depends.Rds') }} - restore-keys: ${{ env.cache-version }}-${{ runner.os }}-biocversion-RELEASE_3_17-r-4.3- + key: ${{ env.cache-version }}-${{ runner.os }}-biocversion-devel-r-4.3-${{ hashFiles('.github/depends.Rds') }} + restore-keys: ${{ env.cache-version }}-${{ runner.os }}-biocversion-devel-r-4.3- # - name: Install Linux system dependencies # if: runner.os == 'Linux' @@ -202,7 +202,7 @@ jobs: - name: Install pkgdown if: github.ref == 'refs/heads/devel' && env.run_pkgdown == 'true' && runner.os == 'Linux' run: | - remotes::install_cran("pkgdown") + remotes::install_github("r-lib/pkgdown") shell: Rscript {0} - name: Session info @@ -285,7 +285,7 @@ jobs: if: failure() uses: actions/upload-artifact@master with: - name: ${{ runner.os }}-biocversion-RELEASE_3_17-r-4.3-results + name: ${{ runner.os }}-biocversion-devel-r-4.3-results path: check diff --git a/DESCRIPTION b/DESCRIPTION index f5feb7d..dd354b8 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -3,8 +3,9 @@ Package: tidySingleCellExperiment Title: Brings SingleCellExperiment to the Tidyverse Version: 1.11.4 Authors@R: c(person("Stefano", "Mangiola", + comment=c(ORCID="0000-0001-7474-836X"), email="mangiolastefano@gmail.com", - role=c("aut", "cre"))) + role=c("aut", "cre"))) Description: 'tidySingleCellExperiment' is an adapter that abstracts the 'SingleCellExperiment' container in the form of a 'tibble'. This allows *tidy* data manipulation, nesting, and plotting. @@ -61,10 +62,10 @@ VignetteBuilder: RdMacros: lifecycle Biarch: true -biocViews: AssayDomain, Infrastructure, RNASeq, DifferentialExpression, +biocViews: + AssayDomain, Infrastructure, RNASeq, DifferentialExpression, SingleCell, GeneExpression, Normalization, Clustering, QualityControl, Sequencing Encoding: UTF-8 -LazyData: true RoxygenNote: 7.2.3 URL: https://github.com/stemangiola/tidySingleCellExperiment BugReports: https://github.com/stemangiola/tidySingleCellExperiment/issues diff --git a/NAMESPACE b/NAMESPACE index 1b0457c..2f3bf83 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -50,10 +50,15 @@ importFrom(S4Vectors,"metadata<-") importFrom(S4Vectors,DataFrame) importFrom(S4Vectors,metadata) importFrom(SingleCellExperiment,cbind) +importFrom(SingleCellExperiment,reducedDims) +importFrom(SummarizedExperiment,"assays<-") importFrom(SummarizedExperiment,"colData<-") +importFrom(SummarizedExperiment,assay) +importFrom(SummarizedExperiment,assayNames) importFrom(SummarizedExperiment,assays) importFrom(SummarizedExperiment,colData) importFrom(dplyr,add_count) +importFrom(dplyr,any_of) importFrom(dplyr,arrange) importFrom(dplyr,contains) importFrom(dplyr,count) @@ -74,12 +79,10 @@ importFrom(dplyr,rowwise) importFrom(dplyr,sample_frac) importFrom(dplyr,sample_n) importFrom(dplyr,select) -importFrom(dplyr,select_if) importFrom(dplyr,slice) importFrom(dplyr,summarise) importFrom(dplyr,summarize) importFrom(dplyr,vars) -importFrom(ellipsis,check_dots_unnamed) importFrom(ellipsis,check_dots_used) importFrom(fansi,strwrap_ctl) importFrom(ggplot2,aes) @@ -90,6 +93,7 @@ importFrom(magrittr,"%>%") importFrom(magrittr,equals) importFrom(magrittr,set_rownames) importFrom(methods,getMethod) +importFrom(methods,is) importFrom(pillar,align) importFrom(pillar,get_extent) importFrom(pillar,style_subtle) @@ -127,6 +131,7 @@ importFrom(tidyr,extract) importFrom(tidyr,nest) importFrom(tidyr,pivot_longer) importFrom(tidyr,separate) +importFrom(tidyr,spread) importFrom(tidyr,unite) importFrom(tidyr,unnest) importFrom(tidyselect,eval_select) diff --git a/R/attach.R b/R/attach.R index 9a11fc1..e8c69d6 100644 --- a/R/attach.R +++ b/R/attach.R @@ -1,22 +1,23 @@ core <- c("dplyr", "tidyr", "ttservice", "ggplot2") core_unloaded <- function() { - search <- paste0("package:", core) - core[!search %in% search()] + search <- paste0("package:", core) + core[!search %in% search()] } # Attach the package from the same library it was loaded from before. # [source: https://github.com/tidy-biology/tidyverse/issues/171] same_library <- function(pkg) { - loc <- if (pkg %in% loadedNamespaces()) dirname(getNamespaceInfo(pkg, "path")) - library(pkg, lib.loc=loc, character.only=TRUE, warn.conflicts=FALSE) + loc <- if (pkg %in% loadedNamespaces()) + dirname(getNamespaceInfo(pkg, "path")) + library(pkg, lib.loc=loc, character.only=TRUE, warn.conflicts=FALSE) } tidyverse_attach <- function() { - to_load <- core_unloaded() - - suppressPackageStartupMessages( - lapply(to_load, same_library)) - - invisible(to_load) + to_load <- core_unloaded() + + suppressPackageStartupMessages( + lapply(to_load, same_library)) + + invisible(to_load) } diff --git a/R/data.R b/R/data.R index 1fbe637..7696952 100755 --- a/R/data.R +++ b/R/data.R @@ -1,35 +1,41 @@ #' pbmc_small #' -#' PBMC single cell RNA-seq data in SingleCellExperiment format +#' PBMC single cell RNA-seq data in `SingleCellExperiment` format. #' -#' @format A SingleCellExperiment object containing 80 Peripheral Blood -#' Mononuclear Cells (PBMC) from 10x Genomics. Generated by subsampling the PBMC dataset of 2,700 single cells. +#' @format A `SingleCellExperiment` object containing 80 Peripheral Blood +#' Mononuclear Cells (PBMC) from 10x Genomics. Generated by subsampling +#' the PBMC dataset of 2,700 single cells. #' @source \url{https://satijalab.org/seurat/v3.1/pbmc3k_tutorial.html} #' @usage data(pbmc_small) +#' @return `tidySingleCellExperiment` "pbmc_small" #' Cell types of 80 PBMC single cells #' #' A dataset containing the barcodes and cell types of 80 PBMC single cells. #' -#' @format A tibble containing 80 rows and 2 columns. Cells are a subsample of -#' the Peripheral Blood Mononuclear Cells (PBMC) dataset of 2,700 single -#' cell. Cell types were identified with SingleR. +#' @format A tibble containing 80 rows and 2 columns. +#' Cells are a subsample of the Peripheral Blood Mononuclear Cells (PBMC) +#' dataset of 2,700 single cell. Cell types were identified with SingleR. #' \describe{ #' \item{cell}{cell identifier, barcode} #' \item{first.labels}{cell type} #' } #' @source \url{https://satijalab.org/seurat/v3.1/pbmc3k_tutorial.html} #' @usage data(cell_type_df) +#' @return `tibble` "cell_type_df" -#' Intercellular ligand-receptor interactions for 38 ligands from a single cell RNA-seq cluster. +#' Intercellular ligand-receptor interactions for +#' 38 ligands from a single cell RNA-seq cluster. #' -#' A dataset containing ligand-receptor interactions withibn a sample. There are 38 ligands from a single cell cluster versus -#' 35 receptors in 6 other clusters. +#' A dataset containing ligand-receptor interactions within a sample. +#' There are 38 ligands from a single cell cluster versus 35 receptors +#' in 6 other clusters. #' -#' @format A tibble containing 100 rows and 9 columns. Cells are a subsample of -#' the PBMC dataset of 2,700 single cells. Cell interactions were identified with SingleCellSignalR. +#' @format A `tibble` containing 100 rows and 9 columns. +#' Cells are a subsample of the PBMC dataset of 2,700 single cells. +#' Cell interactions were identified with `SingleCellSignalR`. #' \describe{ #' \item{sample}{sample identifier} #' \item{ligand}{cluster and ligand identifier} @@ -43,4 +49,5 @@ #' } #' @source \url{https://satijalab.org/seurat/v3.1/pbmc3k_tutorial.html} #' @usage data(pbmc_small_nested_interactions) +#' @return `tibble` "pbmc_small_nested_interactions" diff --git a/R/dplyr_methods.R b/R/dplyr_methods.R index e9f8512..6910153 100755 --- a/R/dplyr_methods.R +++ b/R/dplyr_methods.R @@ -4,6 +4,7 @@ #' @family single table verbs #' #' @examples +#' data(pbmc_small) #' pbmc_small |> #' arrange(nFeature_RNA) #' @@ -12,13 +13,12 @@ #' @importFrom dplyr pull #' @export arrange.SingleCellExperiment <- function(.data, ..., .by_group=FALSE) { - new_metadata <- - .data %>% - as_tibble() %>% + new_metadata <- + .data |> + as_tibble() |> dplyr::arrange(..., .by_group=.by_group) - + .data[, pull(new_metadata, !!c_(.data)$symbol)] - } #' @name bind_rows @@ -26,6 +26,7 @@ arrange.SingleCellExperiment <- function(.data, ..., .by_group=FALSE) { #' @inherit ttservice::bind_rows #' #' @examples +#' data(pbmc_small) #' tt <- pbmc_small #' bind_rows(tt, tt) #' @@ -40,14 +41,16 @@ arrange.SingleCellExperiment <- function(.data, ..., .by_group=FALSE) { #' @export bind_rows.SingleCellExperiment <- function(..., .id=NULL, add.cell.ids=NULL) { tts <- flatten_if(dots_values(...), is_spliced) - + new_obj <- SingleCellExperiment::cbind(tts[[1]], tts[[2]]) - + # If duplicated cell names - if(new_obj %>% colnames %>% duplicated %>% which %>% length %>% gt(0)) - warning("tidySingleCellExperiment says: you have duplicated cell names, they will be made unique.") + if (new_obj %>% colnames %>% duplicated %>% which %>% length %>% gt(0)) + warning("tidySingleCellExperiment says:", + " you have duplicated cell names;", + " they will be made unique.") colnames(new_obj) <- make.unique(colnames(new_obj), sep="_") - + new_obj } @@ -59,10 +62,10 @@ bind_rows.SingleCellExperiment <- function(..., .id=NULL, add.cell.ids=NULL) { #' @importFrom SummarizedExperiment colData<- bind_cols_ <- function(..., .id=NULL) { tts <- tts <- flatten_if(dots_values(...), is_spliced) - + colData(tts[[1]]) <- bind_cols(colData(tts[[1]]) %>% as.data.frame(), - tts[[2]], .id=.id) %>% DataFrame() - + tts[[2]], .id=.id) %>% DataFrame() + tts[[1]] } @@ -76,22 +79,21 @@ bind_cols.SingleCellExperiment <- bind_cols_ #' @inherit dplyr::distinct #' #' @examples -#' pbmc_small |> -#' distinct(groups) +#' data(pbmc_small) +#' pbmc_small |> distinct(groups) #' #' @importFrom dplyr distinct #' @export distinct.SingleCellExperiment <- function(.data, ..., .keep_all=FALSE) { message(data_frame_returned_message) - - distinct_columns = - (enquos(..., .ignore_empty = "all") %>% map(~ quo_name(.x)) %>% unlist) - - # Deprecation of special column names - if(is_sample_feature_deprecated_used(.data, distinct_columns)){ - .data= ping_old_special_column_into_metadata(.data) - } - + + # Deprecation of special column names + .cols <- enquos(..., .ignore_empty="all") %>% + map(~ quo_name(.x)) %>% unlist() + if (is_sample_feature_deprecated_used(.data, .cols)) { + .data <- ping_old_special_column_into_metadata(.data) + } + .data %>% as_tibble() %>% dplyr::distinct(..., .keep_all=.keep_all) @@ -102,8 +104,8 @@ distinct.SingleCellExperiment <- function(.data, ..., .keep_all=FALSE) { #' @inherit dplyr::filter #' #' @examples -#' pbmc_small |> -#' filter(groups == "g1") +#' data(pbmc_small) +#' pbmc_small |> filter(groups == "g1") #' #' # Learn more in ?dplyr_tidy_eval #' @@ -111,29 +113,29 @@ distinct.SingleCellExperiment <- function(.data, ..., .keep_all=FALSE) { #' @importFrom dplyr filter #' @export filter.SingleCellExperiment <- function(.data, ..., .preserve=FALSE) { - - # Deprecation of special column names - if(is_sample_feature_deprecated_used( - .data, - (enquos(..., .ignore_empty = "all") %>% map(~ quo_name(.x)) %>% unlist) - )){ - .data= ping_old_special_column_into_metadata(.data) - } - - new_meta <- .data %>% - as_tibble() %>% - dplyr::filter(..., .preserve=.preserve) # %>% as_meta_data(.data) - + + # Deprecation of special column names + .cols <- enquos(..., .ignore_empty="all") %>% + map(~ quo_name(.x)) %>% unlist() + if (is_sample_feature_deprecated_used(.data, .cols)) { + .data <- ping_old_special_column_into_metadata(.data) + } + + new_meta <- .data |> + as_tibble() |> + dplyr::filter(..., .preserve=.preserve) + # Try to solve missing colnames - if(colnames(.data) %>% is.null()){ - message("tidySingleCellExperiment says: the input object does not have cell names (colnames(...)). \n Therefore, the cell column in the filtered tibble abstraction will still include an incremental integer vector.") - new_meta = new_meta %>% mutate(!!c_(.data)$symbol := as.integer(!!c_(.data)$symbol)) - + .cell <- c_(.data)$symbol + if (colnames(.data) |> is.null()) { + message("tidySingleCellExperiment says: ", + "the input object does not have cell names (colnames(...)).\n", + "Therefore, the cell column in the filtered tibble abstraction ", + "will still include an incremental integer vector.") + new_meta <- new_meta %>% mutate(!!.cell := as.integer(!!.cell)) } - - - .data[, pull(new_meta, !!c_(.data)$symbol)] - + + .data[, pull(new_meta, !!.cell)] } #' @name group_by @@ -142,23 +144,24 @@ filter.SingleCellExperiment <- function(.data, ..., .preserve=FALSE) { #' @seealso \code{} #' #' @examples -#' pbmc_small |> -#' group_by(groups) +#' data(pbmc_small) +#' pbmc_small |> group_by(groups) #' #' @importFrom dplyr group_by_drop_default #' @importFrom dplyr group_by #' @export -group_by.SingleCellExperiment <- function(.data, ..., .add=FALSE, .drop=group_by_drop_default(.data)) { +group_by.SingleCellExperiment <- function(.data, ..., + .add=FALSE, .drop=group_by_drop_default(.data)) { + message(data_frame_returned_message) - - # Deprecation of special column names - if(is_sample_feature_deprecated_used( - .data, - (enquos(..., .ignore_empty = "all") %>% map(~ quo_name(.x)) %>% unlist) - )){ - .data= ping_old_special_column_into_metadata(.data) - } - + + # Deprecation of special column names + .cols <- enquos(..., .ignore_empty="all") %>% + map(~ quo_name(.x)) %>% unlist() + if (is_sample_feature_deprecated_used(.data, .cols)) { + .data <- ping_old_special_column_into_metadata(.data) + } + .data %>% as_tibble() %>% dplyr::group_by(..., .add=.add, .drop=.drop) @@ -171,23 +174,22 @@ group_by.SingleCellExperiment <- function(.data, ..., .add=FALSE, .drop=group_by #' @family single table verbs #' #' @examples -#' pbmc_small |> -#' summarise(mean(nCount_RNA)) +#' data(pbmc_small) +#' pbmc_small |> summarise(mean(nCount_RNA)) #' #' @importFrom dplyr summarise #' @importFrom purrr map #' @export summarise.SingleCellExperiment <- function(.data, ...) { message(data_frame_returned_message) - - # Deprecation of special column names - if(is_sample_feature_deprecated_used( - .data, - (enquos(..., .ignore_empty = "all") %>% map(~ quo_name(.x)) %>% unlist) - )){ - .data= ping_old_special_column_into_metadata(.data) - } - + + # Deprecation of special column names + .cols <- enquos(..., .ignore_empty="all") %>% + map(~ quo_name(.x)) %>% unlist() + if (is_sample_feature_deprecated_used(.data, .cols)) { + .data <- ping_old_special_column_into_metadata(.data) + } + .data %>% as_tibble() %>% dplyr::summarise(...) @@ -205,8 +207,8 @@ summarize.SingleCellExperiment <- summarise.SingleCellExperiment #' @family single table verbs #' #' @examples -#' pbmc_small |> -#' mutate(nFeature_RNA=1) +#' data(pbmc_small) +#' pbmc_small |> mutate(nFeature_RNA=1) #' #' @importFrom SummarizedExperiment colData #' @importFrom SummarizedExperiment colData<- @@ -215,49 +217,40 @@ summarize.SingleCellExperiment <- summarise.SingleCellExperiment #' @importFrom purrr map #' @export mutate.SingleCellExperiment <- function(.data, ...) { - + # Check that we are not modifying a key column cols <- enquos(...) %>% names() - + # Deprecation of special column names - if(is_sample_feature_deprecated_used( - .data, - (enquos(..., .ignore_empty = "all") %>% map(~ quo_name(.x)) %>% unlist) - )){ - .data= ping_old_special_column_into_metadata(.data) + .cols <- enquos(..., .ignore_empty="all") %>% + map(~ quo_name(.x)) %>% unlist() + if (is_sample_feature_deprecated_used(.data, .cols)) { + .data <- ping_old_special_column_into_metadata(.data) } - - tst <- - intersect( - cols, - get_special_columns(.data) %>% - c(get_needed_columns(.data)) - ) %>% - length() %>% - gt(0) - - if (tst) { - columns = - get_special_columns(.data) %>% - c(get_needed_columns(.data)) %>% - paste(collapse=", ") - stop( - "tidySingleCellExperiment says: you are trying to mutate a column that is view only `", - cols, - "` ", - "(it is not present in the colData). If you want to mutate a view-only column, make a copy (e.g. mutate(new_column = ", - cols[1], - ")) and mutate that one." - ) - + + .view_only_cols <- c( + get_special_columns(.data), + get_needed_columns(.data)) + + .test <- cols |> + intersect(.view_only_cols) |> + length() + + if (.test) { + stop("tidySingleCellExperiment says:", + " you are trying to mutate a column that is view only", + " ", paste(.view_only_cols, collapse=", "), + " (it is not present in the colData).", + " If you want to mutate a view-only column, make a copy", + " (e.g. mutate(new_column=", cols[1], ")) and mutate that one.") } - + colData(.data) <- .data %>% as_tibble() %>% dplyr::mutate(...) %>% as_meta_data(.data) - + .data } @@ -267,8 +260,8 @@ mutate.SingleCellExperiment <- function(.data, ...) { #' @family single table verbs #' #' @examples -#' pbmc_small |> -#' rename(s_score=nFeature_RNA) +#' data(pbmc_small) +#' pbmc_small |> rename(s_score=nFeature_RNA) #' #' @importFrom SummarizedExperiment colData #' @importFrom SummarizedExperiment colData<- @@ -276,42 +269,42 @@ mutate.SingleCellExperiment <- function(.data, ...) { #' @importFrom dplyr rename #' @export rename.SingleCellExperiment <- function(.data, ...) { - + # Check that we are not modifying a key column read_only_columns <- c( get_needed_columns(.data), - get_special_columns(.data) - ) - + get_special_columns(.data)) + # Small df to be more efficient - df <- .data[1,1] |> as_tibble() + df <- .data[1, 1] |> as_tibble() # What columns we are going to create cols_from <- tidyselect::eval_select(expr(c(...)), df) |> names() # What are the columns before renaming - original_columns = df |> colnames() + original_columns <- df |> colnames() - # What the column after renaming would be - new_colums = df |> rename(...) |> colnames() + # What the column after renaming would be + new_colums <- df |> rename(...) |> colnames() # What column you are impacting - changed_columns = original_columns |> setdiff(new_colums) + changed_columns <- original_columns |> setdiff(new_colums) # Check that you are not impacting any read-only columns - if(any(changed_columns %in% read_only_columns)) - stop( - "tidySingleCellExperiment says: you are trying to rename a column that is view only `", - changed_columns, - "` ", - "(it is not present in the colData). If you want to rename a view-only column, make a copy (e.g. mutate(", - cols_from[1], - " = ", - changed_columns[1], - "))." - ) - - colData(.data) <- dplyr::rename(colData(.data) %>% as.data.frame(), ...) %>% DataFrame() + if (any(changed_columns %in% read_only_columns)) { + stop("tidySingleCellExperiment says:", + " you are trying to rename a column that is view only", + " ", paste(changed_columns, collapse=", "), + " (it is not present in the colData).", + " If you want to rename a view-only column, make a copy", + " (e.g., mutate(", cols_from[1], "=", changed_columns[1], ")).") + } + + colData(.data) <- + colData(.data) |> + as.data.frame() |> + dplyr::rename(...) |> + DataFrame() .data } @@ -327,7 +320,7 @@ rename.SingleCellExperiment <- function(.data, ...) { #' @export rowwise.SingleCellExperiment <- function(data, ...) { message(data_frame_returned_message) - + data %>% as_tibble() %>% dplyr::rowwise(...) @@ -338,6 +331,7 @@ rowwise.SingleCellExperiment <- function(data, ...) { #' @inherit dplyr::left_join #' #' @examples +#' data(pbmc_small) #' tt <- pbmc_small #' tt |> left_join(tt |> #' distinct(groups) |> @@ -347,34 +341,28 @@ rowwise.SingleCellExperiment <- function(data, ...) { #' @importFrom dplyr left_join #' @importFrom dplyr count #' @export -left_join.SingleCellExperiment <- function(x, y, by=NULL, copy=FALSE, suffix=c(".x", ".y"), - ...) { - - # Deprecation of special column names - if(is_sample_feature_deprecated_used( x, when(by, !is.null(.) ~ by, ~ colnames(y)))){ - x= ping_old_special_column_into_metadata(x) - } - - x %>% - as_tibble() %>% - dplyr::left_join(y, by=by, copy=copy, suffix=suffix, ...) %>% - when( - - # If duplicated cells returns tibble - dplyr::count(., !!c_(x)$symbol) %>% - filter(n > 1) %>% - nrow() %>% - gt(0) ~ { - message(duplicated_cell_names) - (.) - }, - - # Otherwise return updated tidySingleCellExperiment - ~ { - colData(x) <- (.) %>% as_meta_data(x) - x - } - ) +left_join.SingleCellExperiment <- function(x, y, + by=NULL, copy=FALSE, suffix=c(".x", ".y"), ...) { + + # Deprecation of special column names + .cols <- if (!is.null(by)) by else colnames(y) + if (is_sample_feature_deprecated_used(x, .cols)) { + x <- ping_old_special_column_into_metadata(x) + } + + z <- x |> + as_tibble() |> + dplyr::left_join(y, by=by, copy=copy, suffix=suffix, ...) + + # If duplicated cells returns tibble + if (any(duplicated(z[[c_(x)$name]]))) { + message(duplicated_cell_names) + return(z) + } + + # Otherwise return updated tidySingleCellExperiment + colData(x) <- z |> as_meta_data(x) + return(x) } #' @name inner_join @@ -382,6 +370,7 @@ left_join.SingleCellExperiment <- function(x, y, by=NULL, copy=FALSE, suffix=c(" #' @inherit dplyr::inner_join #' #' @examples +#' data(pbmc_small) #' tt <- pbmc_small #' tt |> inner_join(tt |> #' distinct(groups) |> @@ -392,34 +381,29 @@ left_join.SingleCellExperiment <- function(x, y, by=NULL, copy=FALSE, suffix=c(" #' @importFrom dplyr inner_join #' @importFrom dplyr pull #' @export -inner_join.SingleCellExperiment <- function(x, y, by=NULL, copy=FALSE, suffix=c(".x", ".y"), ...) { - - # Deprecation of special column names - if(is_sample_feature_deprecated_used( x, when(by, !is.null(.) ~ by, ~ colnames(y)))){ - x= ping_old_special_column_into_metadata(x) - } +inner_join.SingleCellExperiment <- function(x, y, + by=NULL, copy=FALSE, suffix=c(".x", ".y"), ...) { - x %>% - as_tibble() %>% - dplyr::inner_join(y, by=by, copy=copy, suffix=suffix, ...) %>% - when( - - # If duplicated cells returns tibble - count(., !!c_(x)$symbol) %>% - filter(n > 1) %>% - nrow() %>% - gt(0) ~ { - message(duplicated_cell_names) - (.) - }, - - # Otherwise return updated tidySingleCellExperiment - ~ { - new_obj <- x[, pull(., c_(x)$name)] - colData(new_obj) <- (.) %>% as_meta_data(new_obj) - new_obj - } - ) + # Deprecation of special column names + .cols <- if (!is.null(by)) by else colnames(y) + if (is_sample_feature_deprecated_used(x, .cols)) { + x <- ping_old_special_column_into_metadata(x) + } + + z <- x |> + as_tibble() |> + dplyr::inner_join(y, by=by, copy=copy, suffix=suffix, ...) + + # If duplicated cells returns tibble + if (any(duplicated(z[[c_(x)$name]]))) { + message(duplicated_cell_names) + return(z) + } + + # Otherwise return updated tidySingleCellExperiment + new_obj <- x[, pull(z, c_(x)$name)] + colData(new_obj) <- z |> as_meta_data(new_obj) + return(new_obj) } #' @name right_join @@ -427,6 +411,7 @@ inner_join.SingleCellExperiment <- function(x, y, by=NULL, copy=FALSE, suffix=c( #' @inherit dplyr::right_join #' #' @examples +#' data(pbmc_small) #' tt <- pbmc_small #' tt |> right_join(tt |> #' distinct(groups) |> @@ -437,35 +422,29 @@ inner_join.SingleCellExperiment <- function(x, y, by=NULL, copy=FALSE, suffix=c( #' @importFrom dplyr right_join #' @importFrom dplyr pull #' @export -right_join.SingleCellExperiment <- function(x, y, by=NULL, copy=FALSE, suffix=c(".x", ".y"), - ...) { - - # Deprecation of special column names - if(is_sample_feature_deprecated_used( x, when(by, !is.null(.) ~ by, ~ colnames(y)))){ - x= ping_old_special_column_into_metadata(x) - } - - x %>% - as_tibble() %>% - dplyr::right_join(y, by=by, copy=copy, suffix=suffix, ...) %>% - when( - - # If duplicated cells returns tibble - count(., !!c_(x)$symbol) %>% - filter(n > 1) %>% - nrow() %>% - gt(0) ~ { - message(duplicated_cell_names) - (.) - }, - - # Otherwise return updated tidySingleCellExperiment - ~ { - new_obj <- x[, pull(., c_(x)$name)] - colData(new_obj) <- (.) %>% as_meta_data(new_obj) - new_obj - } - ) +right_join.SingleCellExperiment <- function(x, y, + by=NULL, copy=FALSE, suffix=c(".x", ".y"), ...) { + + # Deprecation of special column names + .cols <- if (!is.null(by)) by else colnames(y) + if (is_sample_feature_deprecated_used(x, .cols)) { + x <- ping_old_special_column_into_metadata(x) + } + + z <- x |> + as_tibble() |> + dplyr::right_join(y, by=by, copy=copy, suffix=suffix, ...) + + # If duplicated cells returns tibble + if (any(duplicated(z[[c_(x)$name]]))) { + message(duplicated_cell_names) + return(z) + } + + # Otherwise return updated tidySingleCellExperiment + new_obj <- x[, pull(z, c_(x)$name)] + colData(new_obj) <- z |> as_meta_data(new_obj) + return(new_obj) } #' @name full_join @@ -473,41 +452,36 @@ right_join.SingleCellExperiment <- function(x, y, by=NULL, copy=FALSE, suffix=c( #' @inherit dplyr::full_join #' #' @examples +#' data(pbmc_small) #' tt <- pbmc_small #' tt |> full_join(tibble::tibble(groups="g1", other=1:4)) #' #' @importFrom dplyr full_join #' @importFrom dplyr pull #' @export -full_join.SingleCellExperiment <- function(x, y, by=NULL, copy=FALSE, suffix=c(".x", ".y"), - ...) { - - # Deprecation of special column names - if(is_sample_feature_deprecated_used( x, when(by, !is.null(.) ~ by, ~ colnames(y)))){ - x= ping_old_special_column_into_metadata(x) - } - - x %>% - as_tibble() %>% - dplyr::full_join(y, by=by, copy=copy, suffix=suffix, ...) %>% - when( - - # If duplicated cells returns tibble - count(., !!c_(x)$symbol) %>% - filter(n > 1) %>% - nrow() %>% - gt(0) ~ { - message(duplicated_cell_names) - (.) - }, - - # Otherwise return updated tidySingleCellExperiment - ~ { - new_obj <- x[, pull(., c_(x)$name)] - colData(new_obj) <- (.) %>% as_meta_data(x) - new_obj - } - ) +full_join.SingleCellExperiment <- function(x, y, + by=NULL, copy=FALSE, suffix=c(".x", ".y"), ...) { + + # Deprecation of special column names + .cols <- if (!is.null(by)) by else colnames(y) + if (is_sample_feature_deprecated_used(x, .cols)) { + x <- ping_old_special_column_into_metadata(x) + } + + z <- x |> + as_tibble() |> + dplyr::full_join(y, by=by, copy=copy, suffix=suffix, ...) + + # If duplicated cells returns tibble + if (any(duplicated(z[[c_(x)$name]]))) { + message(duplicated_cell_names) + return(z) + } + + # Otherwise return updated tidySingleCellExperiment + new_obj <- x[, pull(z, c_(x)$name)] + colData(new_obj) <- z |> as_meta_data(x) + return(new_obj) } #' @name slice @@ -518,17 +492,19 @@ full_join.SingleCellExperiment <- function(x, y, by=NULL, copy=FALSE, suffix=c(" #' @family single table verbs #' #' @examples +#' data(pbmc_small) #' pbmc_small |> slice(1) #' #' @importFrom SummarizedExperiment colData #' @importFrom dplyr slice #' @export slice.SingleCellExperiment <- function(.data, ..., .by=NULL, .preserve=FALSE) { - new_meta <- dplyr::slice(colData(.data) %>% as.data.frame(), ..., .by=.by, .preserve=.preserve) - new_obj <- .data[, rownames(new_meta)] - # colData(new_obj)=new_meta - - new_obj + new_meta <- .data |> + colData() |> + as.data.frame() |> + dplyr::slice(..., .by=.by, .preserve=.preserve) + + .data[, rownames(new_meta)] } #' @name select @@ -536,73 +512,76 @@ slice.SingleCellExperiment <- function(.data, ..., .by=NULL, .preserve=FALSE) { #' @inherit dplyr::select #' #' @examples +#' data(pbmc_small) #' pbmc_small |> select(cell, orig.ident) #' #' @importFrom SummarizedExperiment colData #' @importFrom dplyr select #' @export select.SingleCellExperiment <- function(.data, ...) { - - # Deprecation of special column names - if(is_sample_feature_deprecated_used( - .data, - (enquos(..., .ignore_empty = "all") %>% map(~ quo_name(.x)) %>% unlist) - )){ - .data= ping_old_special_column_into_metadata(.data) - } - - .data %>% - as_tibble() %>% - select_helper(...) %>% - when( - - # If key columns are missing - (get_needed_columns(.data) %in% colnames(.)) %>% - all() %>% - `!`() ~ { - message("tidySingleCellExperiment says: Key columns are missing. A data frame is returned for independent data analysis.") - (.) - }, - - # If valid SingleCellExperiment meta data - ~ { - colData(.data) <- (.) %>% as_meta_data(.data) - .data - } - ) + + # Deprecation of special column names + .cols <- enquos(..., .ignore_empty="all") %>% + map(~ quo_name(.x)) %>% unlist() + if (is_sample_feature_deprecated_used(.data, .cols)) { + .data <- ping_old_special_column_into_metadata(.data) + } + + new_obj <- .data |> + as_tibble() |> + select_helper(...) + + # If key columns are missing, return tibble + if (!all(get_needed_columns(.data) %in% colnames(new_obj))) { + message( + "tidySingleCellExperiment says: Key columns are missing.", + " A data frame is returned for independent data analysis.") + return(new_obj) + } + + # Otherwise return updated tidySingleCellExperiment + colData(.data) <- new_obj |> as_meta_data(.data) + return(.data) } #' @name sample_n #' @rdname sample_n #' @aliases sample_frac #' @inherit dplyr::sample_n +#' @return `tidySingleCellExperiment` #' #' @examples +#' data(pbmc_small) #' pbmc_small |> sample_n(50) #' pbmc_small |> sample_frac(0.1) #' #' @importFrom SummarizedExperiment colData #' @importFrom dplyr sample_n #' @export -sample_n.SingleCellExperiment <- function(tbl, size, replace=FALSE, - weight=NULL, .env=NULL, ...) { +sample_n.SingleCellExperiment <- function(tbl, size, + replace=FALSE, weight=NULL, .env=NULL, ...) { + lifecycle::signal_superseded("1.0.0", "sample_n()", "slice_sample()") - - new_meta = colData(tbl) %>% + + new_meta <- colData(tbl) %>% as.data.frame() %>% - as_tibble(rownames = c_(tbl)$name) %>% - dplyr::sample_n( size, replace = replace, weight = weight, .env = .env, ...) - - count_cells = new_meta %>% select(!!c_(tbl)$symbol) %>% count(!!c_(tbl)$symbol) - + as_tibble(rownames=c_(tbl)$name) %>% + dplyr::sample_n( size, replace=replace, weight=weight, .env=.env, ...) + + count_cells <- new_meta %>% + select(!!c_(tbl)$symbol) %>% + count(!!c_(tbl)$symbol) + # If repeted cells - if(count_cells$n %>% max() %>% gt(1)){ - message("tidySingleCellExperiment says: When sampling with replacement a data frame is returned for independent data analysis.") + if (count_cells$n %>% max() %>% gt(1)) { + message("tidySingleCellExperiment says:", + " When sampling with replacement a data frame", + " is returned for independent data analysis.") tbl %>% as_tibble() %>% - right_join(new_meta %>% select(!!c_(tbl)$symbol), by = c_(tbl)$name) - } else{ - new_obj = tbl[, new_meta %>% pull(!!c_(tbl)$symbol)] + right_join(new_meta %>% select(!!c_(tbl)$symbol), by=c_(tbl)$name) + } else { + new_obj <- tbl[, new_meta %>% pull(!!c_(tbl)$symbol)] new_obj } } @@ -611,25 +590,30 @@ sample_n.SingleCellExperiment <- function(tbl, size, replace=FALSE, #' @importFrom SummarizedExperiment colData #' @importFrom dplyr sample_frac #' @export -sample_frac.SingleCellExperiment <- function(tbl, size=1, replace=FALSE, - weight=NULL, .env=NULL, ...) { +sample_frac.SingleCellExperiment <- function(tbl, size=1, + replace=FALSE, weight=NULL, .env=NULL, ...) { + lifecycle::signal_superseded("1.0.0", "sample_frac()", "slice_sample()") - - new_meta = colData(tbl) %>% + + new_meta <- colData(tbl) %>% as.data.frame() %>% - as_tibble(rownames = c_(tbl)$name) %>% - dplyr::sample_frac( size, replace = replace, weight = weight, .env = .env, ...) - - count_cells = new_meta %>% select(!!c_(tbl)$symbol) %>% count(!!c_(tbl)$symbol) - - # If repeted cells - if(count_cells$n %>% max() %>% gt(1)){ - message("tidySingleCellExperiment says: When sampling with replacement a data frame is returned for independent data analysis.") + as_tibble(rownames=c_(tbl)$name) %>% + dplyr::sample_frac(size, replace=replace, weight=weight, .env=.env, ...) + + count_cells <- new_meta %>% + select(!!c_(tbl)$symbol) %>% + count(!!c_(tbl)$symbol) + + # If repeated cells + if (count_cells$n %>% max() %>% gt(1)) { + message("tidySingleCellExperiment says:", + " When sampling with replacement a data frame", + " is returned for independent data analysis.") tbl %>% as_tibble() %>% - right_join(new_meta %>% select(!!c_(tbl)$symbol), by = c_(tbl)$name) - } else{ - new_obj = tbl[, new_meta %>% pull(!!c_(tbl)$symbol)] + right_join(new_meta %>% select(!!c_(tbl)$symbol), by=c_(tbl)$name) + } else { + new_obj <- tbl[, new_meta %>% pull(!!c_(tbl)$symbol)] new_obj } } @@ -639,23 +623,27 @@ sample_frac.SingleCellExperiment <- function(tbl, size=1, replace=FALSE, #' @inherit dplyr::count #' #' @examples +#' data(pbmc_small) #' pbmc_small |> count(groups) #' #' @importFrom dplyr count #' @export -count.SingleCellExperiment <- function(x, ..., wt=NULL, sort=FALSE, name=NULL, .drop=group_by_drop_default(x)) { +count.SingleCellExperiment <- function(x, ..., + wt=NULL, sort=FALSE, name=NULL, + .drop=group_by_drop_default(x)) { + message(data_frame_returned_message) - - # Deprecation of special column names - if(is_sample_feature_deprecated_used( - x, - (enquos(..., .ignore_empty = "all") %>% map(~ quo_name(.x)) %>% unlist) - )){ - x= ping_old_special_column_into_metadata(x) - } - - x %>% - as_tibble() %>% + + # Deprecation of special column names + # Deprecation of special column names + .cols <- enquos(..., .ignore_empty="all") %>% + map(~ quo_name(.x)) %>% unlist() + if (is_sample_feature_deprecated_used(x, .cols)) { + x <- ping_old_special_column_into_metadata(x) + } + + x |> + as_tibble() |> dplyr::count(..., wt=!!enquo(wt), sort=sort, name=name, .drop=.drop) } @@ -663,24 +651,22 @@ count.SingleCellExperiment <- function(x, ..., wt=NULL, sort=FALSE, name=NULL, . #' @aliases add_count #' @importFrom dplyr add_count #' @export -add_count.SingleCellExperiment <- function(x, ..., wt = NULL, sort = FALSE, name = NULL) { - - # Deprecation of special column names - if(is_sample_feature_deprecated_used( - x, - (enquos(..., .ignore_empty = "all") %>% map(~ quo_name(.x)) %>% unlist) - )){ - x= ping_old_special_column_into_metadata(x) - } - - colData(x) = - x %>% - as_tibble %>% - dplyr::add_count(..., wt = !!enquo(wt), sort = sort, name = name) %>% - as_meta_data(x) - - x - +add_count.SingleCellExperiment <- function(x, ..., + wt=NULL, sort=FALSE, name=NULL) { + + # Deprecation of special column names + .cols <- enquos(..., .ignore_empty="all") %>% + map(~ quo_name(.x)) %>% unlist() + if (is_sample_feature_deprecated_used(x, .cols)) { + x <- ping_old_special_column_into_metadata(x) + } + + colData(x) <- x |> + as_tibble() |> + dplyr::add_count(..., wt=!!enquo(wt), sort=sort, name=name) |> + as_meta_data(x) + + x } #' @name pull @@ -688,6 +674,7 @@ add_count.SingleCellExperiment <- function(x, ..., wt = NULL, sort = FALSE, name #' @inherit dplyr::pull #' #' @examples +#' data(pbmc_small) #' pbmc_small |> pull(groups) #' #' @importFrom ellipsis check_dots_used @@ -696,15 +683,12 @@ add_count.SingleCellExperiment <- function(x, ..., wt = NULL, sort = FALSE, name pull.SingleCellExperiment <- function(.data, var=-1, name=NULL, ...) { var <- enquo(var) name <- enquo(name) - + # Deprecation of special column names - if(is_sample_feature_deprecated_used( - .data, - quo_name(var) - )){ - .data= ping_old_special_column_into_metadata(.data) + .cols <- quo_name(var) + if (is_sample_feature_deprecated_used(.data, .cols)) { + .data <- ping_old_special_column_into_metadata(.data) } - .data %>% as_tibble() %>% dplyr::pull(var=!!var, name=!!name, ...) diff --git a/R/ggplot2_methods.R b/R/ggplot2_methods.R index be84aaf..6cd2de0 100755 --- a/R/ggplot2_methods.R +++ b/R/ggplot2_methods.R @@ -2,9 +2,11 @@ #' @rdname ggplot #' @inherit ggplot2::ggplot #' @title Create a new \code{ggplot} from a \code{tidySingleCellExperiment} +#' @return `ggplot` #' #' @examples #' library(ggplot2) +#' data(pbmc_small) #' pbmc_small |> #' ggplot(aes(groups, nCount_RNA)) + #' geom_boxplot() @@ -13,16 +15,17 @@ #' @importFrom rlang quo_name #' @importFrom ggplot2 aes ggplot #' @export -ggplot.SingleCellExperiment <- function(data=NULL, mapping=aes(), ..., environment=parent.frame()) { - - # Deprecation of special column names - if(is_sample_feature_deprecated_used( - data, - mapping %>% unlist() %>% map(~ quo_name(.x)) %>% unlist() %>% as.character() - )){ - data= ping_old_special_column_into_metadata(data) - } - +ggplot.SingleCellExperiment <- function(data=NULL, + mapping=aes(), ..., environment=parent.frame()) { + + # Deprecation of special column names + .cols <- mapping %>% + unlist() %>% map(~ quo_name(.x)) %>% + unlist() %>% as.character() + if (is_sample_feature_deprecated_used(data, .cols)) { + data <- ping_old_special_column_into_metadata(data) + } + data %>% as_tibble() %>% ggplot2::ggplot(mapping=mapping) diff --git a/R/methods.R b/R/methods.R index 589cbbe..d4c149d 100755 --- a/R/methods.R +++ b/R/methods.R @@ -1,23 +1,20 @@ #' @importFrom methods getMethod setMethod( - f = "show", - signature = "SingleCellExperiment", - definition = function(object) { - if ( - isTRUE(x = getOption(x = "restore_SingleCellExperiment_show", default = FALSE)) - ) { - f <-getMethod( - f = "show", - signature = "SummarizedExperiment", - where = asNamespace(ns = "SummarizedExperiment") - ) - f(object = object) - - } else { print(object) } + f="show", + signature="SingleCellExperiment", + definition=function(object) { + opt <- getOption("restore_SingleCellExperiment_show", default=FALSE) + if (isTRUE(opt)) { + f <- getMethod( + f="show", + signature="SummarizedExperiment", + where=asNamespace(ns="SummarizedExperiment")) + f(object=object) + } else { print(object) } } ) -setClass("tidySingleCellExperiment", contains = "SingleCellExperiment") +setClass("tidySingleCellExperiment", contains="SingleCellExperiment") #' @name join_features #' @rdname join_features @@ -28,7 +25,7 @@ setClass("tidySingleCellExperiment", contains = "SingleCellExperiment") #' containing information for the specified features. #' #' @examples -#' data("pbmc_small") +#' data(pbmc_small) #' pbmc_small %>% join_features( #' features=c("HLA-DRA", "LYZ")) #' @@ -37,40 +34,34 @@ setClass("tidySingleCellExperiment", contains = "SingleCellExperiment") #' @importFrom dplyr everything #' @importFrom ttservice join_features #' @export -setMethod("join_features", "SingleCellExperiment", function(.data, - features = NULL, - all = FALSE, - exclude_zeros = FALSE, - shape = "long", ...) -{ - # CRAN Note - .cell = NULL - .feature= NULL - - # Shape is long - if (shape == "long") - .data %>% +setMethod("join_features", "SingleCellExperiment", function(.data, + features=NULL, all=FALSE, exclude_zeros=FALSE, shape="long", ...) { + # CRAN Note + .cell <- NULL + .feature <- NULL + + # Shape is long + if (shape == "long") { + .data %>% + left_join( + by=c_(.data)$name, + get_abundance_sc_long( + .data=.data, + features=features, + all=all, + exclude_zeros=exclude_zeros)) %>% + select(!!c_(.data)$symbol, .feature, + contains(".abundance"), everything()) + # Shape if wide + } else { + .data %>% left_join( - get_abundance_sc_long( - .data = .data, - features = features, - all = all, - exclude_zeros = exclude_zeros - ), - by = c_(.data)$name - ) %>% - select(!!c_(.data)$symbol, .feature, contains(".abundance"), everything()) - - # Shape if wide - else - .data %>% left_join(get_abundance_sc_wide( - .data = .data, - features = features, - all = all, ... - ), - by = c_(.data)$name) - - + by=c_(.data)$name, + get_abundance_sc_wide( + .data=.data, + features=features, + all=all, ...)) + } }) #' @name tidy @@ -81,26 +72,26 @@ setMethod("join_features", "SingleCellExperiment", function(.data, #' @return A `tidySingleCellExperiment` object. #' #' @examples -#' tidySingleCellExperiment::pbmc_small +#' data(pbmc_small) +#' pbmc_small #' #' @export tidy <- function(object) { - UseMethod("tidy", object) + UseMethod("tidy", object) } #' @rdname tidy #' @importFrom lifecycle deprecate_warn #' @export tidy.SingleCellExperiment <- function(object) { + + # DEPRECATE + deprecate_warn( + when="1.1.1", + what="tidy()", + details="tidySingleCellExperiment says: tidy() is not needed anymore.") - # DEPRECATE - deprecate_warn( - when = "1.1.1", - what = "tidy()", - details = "tidySingleCellExperiment says: tidy() is not needed anymore." - ) - - object + return(object) } #' @name aggregate_cells @@ -109,7 +100,7 @@ tidy.SingleCellExperiment <- function(object) { #' @aliases aggregate_cells,SingleCellExperiment-method #' #' @examples -#' data("pbmc_small") +#' data(pbmc_small) #' pbmc_small_pseudo_bulk <- pbmc_small |> #' aggregate_cells(c(groups, ident), assays="counts") #' @@ -118,49 +109,48 @@ tidy.SingleCellExperiment <- function(object) { #' @importFrom tibble enframe #' @importFrom Matrix rowSums #' @importFrom ttservice aggregate_cells +#' @importFrom SummarizedExperiment assays assays<- assayNames #' @export -setMethod("aggregate_cells", "SingleCellExperiment", function(.data, - .sample = NULL, - slot = "data", - assays = NULL, - aggregation_function = Matrix::rowSums){ - - # Fix NOTEs - feature = NULL - - .sample = enquo(.sample) - - # Subset only wanted assays - if(!is.null(assays)){ - .data@assays@data = .data@assays@data[assays] - } - - .data %>% +setMethod("aggregate_cells", "SingleCellExperiment", function(.data, + .sample=NULL, slot="data", assays=NULL, + aggregation_function=Matrix::rowSums) { - nest(data = -!!.sample) %>% - mutate(.aggregated_cells = as.integer(map(data, ~ ncol(.x)))) %>% - mutate(data = map(data, ~ - - # loop over assays - map2( - as.list(assays(.x)), names(.x@assays), - - # Get counts - ~ .x %>% - aggregation_function(na.rm = TRUE) %>% - enframe( - name = "feature", - value = sprintf("%s", .y) - ) %>% - mutate(feature = as.character(feature)) - ) %>% - Reduce(function(...) full_join(..., by=c("feature")), .) - - )) %>% - left_join(.data %>% as_tibble() %>% subset(!!.sample), by = quo_names(.sample)) %>% - unnest(data) %>% + # Fix NOTEs + feature <- NULL + .sample <- enquo(.sample) - drop_class("tidySingleCellExperiment_nested") %>% + # Subset only wanted assays + if (!is.null(assays)) { + assays(.data) <- assays(.data)[assays] + } - as_SummarizedExperiment(.sample = !!.sample, .transcript = feature, .abundance = !!as.symbol(names(.data@assays))) + .data %>% + nest(data=-!!.sample) %>% + mutate(.aggregated_cells=as.integer(map(data, ~ ncol(.x)))) %>% + mutate( + data=map(data, ~ { + # Loop over assays + map2(as.list(assays(.x)), assayNames(.x), ~ { + # Get counts + .x %>% + aggregation_function(na.rm=TRUE) %>% + enframe( + name ="feature", + value=sprintf("%s", .y)) %>% + mutate(feature=as.character(feature)) + }) %>% + Reduce(function(...) full_join(..., by="feature"), .) + }) + ) %>% + left_join( + .data %>% + as_tibble() %>% + subset(!!.sample), + by=quo_names(.sample)) %>% + unnest(data) %>% + drop_class("tidySingleCellExperiment_nested") %>% + as_SummarizedExperiment( + .sample=!!.sample, + .transcript=feature, + .abundance=!!as.symbol(names(.data@assays))) }) diff --git a/R/methods_DEPRECATED.R b/R/methods_DEPRECATED.R index 7fd8d6e..85e451d 100644 --- a/R/methods_DEPRECATED.R +++ b/R/methods_DEPRECATED.R @@ -27,39 +27,41 @@ #' #' @export #' -join_transcripts <- function(.data, - transcripts = NULL, - all = FALSE, - exclude_zeros = FALSE, - shape = "long", ...) { - UseMethod("join_transcripts", .data) -} +join_transcripts <- + function(.data, + transcripts=NULL, + all=FALSE, + exclude_zeros=FALSE, + shape="long", ...) + { + UseMethod("join_transcripts", .data) + } #' @export join_transcripts.default <- - function(.data, - transcripts = NULL, - all = FALSE, - exclude_zeros = FALSE, - shape = "long", ...) - { - print("tidySingleCellExperiment says: This function cannot be applied to this object") - } + function(.data, + transcripts=NULL, + all=FALSE, + exclude_zeros=FALSE, + shape="long", ...) + { + print("tidySingleCellExperiment says:", + " This function cannot be applied to this object") + } #' @export join_transcripts.Seurat <- - function(.data, - transcripts = NULL, - all = FALSE, - exclude_zeros = FALSE, - shape = "long", ...) - { - - deprecate_warn("1.1.2", "join_transcripts()", "tidySingleCellExperiment::join_features()") - - - .data %>% - join_features(features = transcripts, - all = all, - exclude_zeros = exclude_zeros, - shape = shape, ...) - - } + function(.data, + transcripts=NULL, + all=FALSE, + exclude_zeros=FALSE, + shape="long", ...) + { + deprecate_warn( + "1.1.2", "join_transcripts()", + "tidySingleCellExperiment::join_features()") + + .data %>% + join_features(features=transcripts, + all=all, + exclude_zeros=exclude_zeros, + shape=shape, ...) + } diff --git a/R/pillar_utilities.R b/R/pillar_utilities.R index b84d179..b57da6f 100644 --- a/R/pillar_utilities.R +++ b/R/pillar_utilities.R @@ -1,26 +1,24 @@ NBSP <- "\U00A0" -pillar___format_comment = function (x, width) +pillar___format_comment <- function(x, width) { - if (length(x) == 0L) { - return(character()) - } - map_chr(x, pillar___wrap, prefix = "# ", width = min(width, cli::console_width())) + if (!length(x)) return(character()) + w <- min(width, cli::console_width()) + map_chr(x, pillar___wrap, prefix="# ", width=w) } #' @importFrom fansi strwrap_ctl -pillar___strwrap2 = function (x, width, indent) +pillar___strwrap2 <- function(x, width, indent) { - fansi::strwrap_ctl(x, width = max(width, 0), indent = indent, - exdent = indent + 2) + fansi::strwrap_ctl(x, width=max(width, 0), indent=indent, exdent=indent+2) } -pillar___wrap = function (..., indent = 0, prefix = "", width) +pillar___wrap <- function(..., indent=0, prefix="", width) { - x <- paste0(..., collapse = "") - wrapped <- pillar___strwrap2(x, width - get_extent(prefix), indent) - wrapped <- paste0(prefix, wrapped) - wrapped <- gsub(NBSP, " ", wrapped) - paste0(wrapped, collapse = "\n") + x <- paste0(..., collapse="") + wrapped <- pillar___strwrap2(x, width-get_extent(prefix), indent) + wrapped <- paste0(prefix, wrapped) + wrapped <- gsub(NBSP, " ", wrapped) + paste0(wrapped, collapse="\n") } diff --git a/R/plotly_methods.R b/R/plotly_methods.R index 2a87055..890cdb8 100755 --- a/R/plotly_methods.R +++ b/R/plotly_methods.R @@ -1,13 +1,15 @@ #' @name plotly #' @rdname plotly #' @inherit plotly::plot_ly +#' @return `plotly` #' #' @examples #' # TODO #' #' @importFrom plotly plot_ly #' @export -plot_ly <- function(data=data.frame(), ..., type=NULL, name=NULL, +plot_ly <- function(data=data.frame(), + ..., type=NULL, name=NULL, color=NULL, colors=NULL, alpha=NULL, stroke=NULL, strokes=NULL, alpha_stroke=1, size=NULL, sizes=c(10, 100), @@ -21,7 +23,8 @@ plot_ly <- function(data=data.frame(), ..., type=NULL, name=NULL, #' @rdname plotly #' @export -plot_ly.default <- function(data=data.frame(), ..., type=NULL, name=NULL, +plot_ly.default <- function(data=data.frame(), + ..., type=NULL, name=NULL, color=NULL, colors=NULL, alpha=NULL, stroke=NULL, strokes=NULL, alpha_stroke=1, size=NULL, sizes=c(10, 100), @@ -31,7 +34,6 @@ plot_ly.default <- function(data=data.frame(), ..., type=NULL, name=NULL, split=NULL, frame=NULL, width=NULL, height=NULL, source="A") { data %>% - # This is a trick to not loop the call drop_class("tbl_df") %>% plotly::plot_ly(..., @@ -43,13 +45,13 @@ plot_ly.default <- function(data=data.frame(), ..., type=NULL, name=NULL, symbol=symbol, symbols=symbols, linetype=linetype, linetypes=linetypes, split=split, frame=frame, - width=width, height=height, source=source - ) + width=width, height=height, source=source) } #' @rdname plotly #' @export -plot_ly.SingleCellExperiment <- function(data=data.frame(), ..., type=NULL, name=NULL, +plot_ly.SingleCellExperiment <- function(data=data.frame(), + ..., type=NULL, name=NULL, color=NULL, colors=NULL, alpha=NULL, stroke=NULL, strokes=NULL, alpha_stroke=1, size=NULL, sizes=c(10, 100), @@ -59,18 +61,16 @@ plot_ly.SingleCellExperiment <- function(data=data.frame(), ..., type=NULL, name split=NULL, frame=NULL, width=NULL, height=NULL, source="A") { data %>% - # This is a trick to not loop the call as_tibble() %>% plot_ly(..., type=type, name=name, color=color, colors=colors, alpha=alpha, stroke=stroke, strokes=strokes, alpha_stroke=alpha_stroke, - size=size, sizes=sizes, + size=size, sizes=sizes, span=span, spans=spans, - symbol=symbol, symbols=symbols, + symbol=symbol, symbols=symbols, linetype=linetype, linetypes=linetypes, split=split, frame=frame, - width=width, height=height, source=source - ) + width=width, height=height, source=source) } diff --git a/R/print_method.R b/R/print_method.R index 14d0ec6..bdef4ae 100755 --- a/R/print_method.R +++ b/R/print_method.R @@ -1,4 +1,5 @@ -# This file is a replacement of the unexported functions in the tibble package, in order to specify "tibble abstraction in the header" +# This file is a replacement of the unexported functions in the tibble +# package, in order to specify "tibble abstraction in the header" #' @name tbl_format_header #' @rdname tbl_format_header @@ -13,62 +14,52 @@ #' @importFrom pillar style_subtle #' @importFrom pillar tbl_format_header #' @export -tbl_format_header.tidySingleCellExperiment <- function(x, setup, ...){ - - number_of_features = x |> attr("number_of_features") - assay_names = x |> attr("assay_names") - - named_header <- setup$tbl_sum - - # Change name - names(named_header) = "A SingleCellExperiment-tibble abstraction" - - if (all(names2(named_header) == "")) { - header <- named_header - } - else { - header <- - paste0( - align(paste0(names2(named_header), ":"), space = NBSP), - " ", - named_header - ) %>% - - # Add further info single-cell - append(sprintf( - "\033[90m Features=%s | Cells=%s | Assays=%s\033[39m", - number_of_features, - nrow(x), - assay_names %>% paste(collapse=", ") - ), after = 1) - } - - style_subtle(pillar___format_comment(header, width = setup$width)) - +tbl_format_header.tidySingleCellExperiment <- function(x, setup, ...) { + + number_of_features <- x |> attr("number_of_features") + assay_names <- x |> attr("assay_names") + + # Change name + named_header <- setup$tbl_sum + names(named_header) <- "A SingleCellExperiment-tibble abstraction" + + if (all(names2(named_header) == "")) { + header <- named_header + } else { + header <- paste0( + align(paste0(names2(named_header), ":"), space=NBSP), + " ", named_header) %>% + # Add further info single-cell + append(sprintf( + "\033[90m Features=%s | Cells=%s | Assays=%s\033[39m", + number_of_features, nrow(x), + paste(assay_names, collapse=", ") + ), after=1) + } + style_subtle(pillar___format_comment(header, width=setup$width)) } #' @name formatting #' @rdname formatting #' @aliases print #' @inherit tibble::formatting +#' @return Prints a message to the console describing +#' the contents of the `tidySingleCellExperiment`. #' #' @examples +#' data(pbmc_small) #' print(pbmc_small) #' #' @importFrom vctrs new_data_frame +#' @importFrom SummarizedExperiment assayNames #' @export -print.SingleCellExperiment <- function(x, ..., n = NULL, width = NULL) {#, n_extra = NULL) { - # TODO: argument 'n_extra' seems to not - # exist anymore; see ?tibble::print.tbl - - x |> - as_tibble(n_dimensions_to_return = 5 ) |> - - new_data_frame(class = c("tidySingleCellExperiment", "tbl")) %>% - add_attr( nrow(x), "number_of_features") %>% - add_attr( assays(x) %>% names , "assay_names") %>% - - print() - - invisible(x) +print.SingleCellExperiment <- function(x, ..., n=NULL, width=NULL) { + x |> + as_tibble(n_dimensions_to_return=5) |> + new_data_frame(class=c("tidySingleCellExperiment", "tbl")) %>% + add_attr(nrow(x), "number_of_features") %>% + add_attr(assayNames(x), "assay_names") %>% + print() + + invisible(x) } diff --git a/R/tibble_methods.R b/R/tibble_methods.R index d981185..9679660 100755 --- a/R/tibble_methods.R +++ b/R/tibble_methods.R @@ -1,8 +1,10 @@ #' @name as_tibble #' @rdname as_tibble #' @inherit tibble::as_tibble +#' @return `tibble` #' #' @examples +#' data(pbmc_small) #' pbmc_small |> as_tibble() #' #' @importFrom tibble as_tibble @@ -12,22 +14,16 @@ as_tibble.SingleCellExperiment <- function(x, ..., .name_repair=c("check_unique", "unique", "universal", "minimal"), rownames=pkgconfig::get_config("tibble::rownames", NULL)) { - colData(x) %>% + df <- colData(x) %>% as.data.frame() %>% - tibble::as_tibble(rownames=c_(x)$name) %>% - - - # Attach reduced dimensions - when( - - # Only if I have reduced dimensions and special datasets - ncol(x@int_colData@listData$reducedDims) > 0 ~ (.) %>% bind_cols( - special_datasets_to_tibble(x, ...) - ), - - # Otherwise skip - ~ (.) - ) + tibble::as_tibble(rownames=c_(x)$name) + # Attach reduced dimensions only if + # there are any and for special datasets + if (length(reducedDims(x))) { + fd <- special_datasets_to_tibble(x, ...) + df <- bind_cols(df, fd) + } + return(df) } #' @name glimpse @@ -35,12 +31,13 @@ as_tibble.SingleCellExperiment <- function(x, ..., #' @inherit pillar::glimpse #' #' @examples +#' data(pbmc_small) #' pbmc_small |> glimpse() #' #' @importFrom tibble glimpse #' @export -glimpse.tidySingleCellExperiment = function(x, width = NULL, ...){ +glimpse.tidySingleCellExperiment <- function(x, width=NULL, ...){ x %>% as_tibble() %>% - tibble::glimpse(width = width, ...) + tibble::glimpse(width=width, ...) } diff --git a/R/tidybulk_utilities.R b/R/tidybulk_utilities.R index c78e899..fff6807 100644 --- a/R/tidybulk_utilities.R +++ b/R/tidybulk_utilities.R @@ -1,10 +1,9 @@ -#' This is a generalisation of ifelse that accepts an object and return an objects +#' This is a generalisation of ifelse that accepts an object and returns an object #' #' @keywords internal #' @noRd #' #' @importFrom purrr as_mapper -#' @importFrom magrittr equals #' #' @param .x A tibble #' @param .p A boolean @@ -12,13 +11,13 @@ #' @param .f2 A function #' #' @return A tibble -ifelse_pipe = function(.x, .p, .f1, .f2 = NULL) { - switch(.p %>% not() %>% sum(1), - as_mapper(.f1)(.x), - if (.f2 %>% is.null %>% not()) - as_mapper(.f2)(.x) - else - .x) +ifelse_pipe <- function(.x, .p, .f1, .f2 = NULL) { + switch( + sum(!.p, 1), + as_mapper(.f1)(.x), + if (!is.null(.f2)) { + as_mapper(.f2)(.x) + } else .x) } #' as_SummarizedExperiment @@ -26,7 +25,9 @@ ifelse_pipe = function(.x, .p, .f1, .f2 = NULL) { #' @keywords internal #' @noRd #' -#' @description as_SummarizedExperiment creates a `SummarizedExperiment` object from a `tbl` or `tidybulk` tbl formatted as | | | | <...> | +#' @description `as_SummarizedExperiment()` creates a `SummarizedExperiment` +#' object from a `tbl` or `tidybulk` tbl formatted as +#' | | | | <...> | #' #' @importFrom rlang enquo #' @importFrom rlang quo_name @@ -40,114 +41,115 @@ ifelse_pipe = function(.x, .p, .f1, .f2 = NULL) { #' @param .abundance The name of the transcript/gene abundance column #' #' @return A `SummarizedExperiment` object -as_SummarizedExperiment = function(.data, - .sample = NULL, - .transcript = NULL, - .abundance = NULL) { - - # Fix NOTES - . = NULL - assay = NULL - - # Get column names - .sample = enquo(.sample) - .transcript = enquo(.transcript) - .abundance = enquo(.abundance) - col_names = get_sample_transcript_counts(.data, .sample, .transcript, .abundance) - .sample = col_names$.sample - .transcript = col_names$.transcript - .abundance = col_names$.abundance - - # If present get the scaled abundance - .abundance_scaled = - .data %>% - ifelse_pipe( - ".abundance_scaled" %in% ((.) %>% get_tt_columns() %>% names) && - # .data %>% get_tt_columns() %$% .abundance_scaled %>% is.null %>% not() && - quo_name((.) %>% get_tt_columns() %$% .abundance_scaled) %in% ((.) %>% colnames), - ~ .x %>% get_tt_columns() %$% .abundance_scaled, - ~ NULL - ) - - # Get which columns are sample wise and which are feature wise - col_direction = get_x_y_annotation_columns(.data, - !!.sample, - !!.transcript, - !!.abundance, - !!.abundance_scaled) - sample_cols = col_direction$horizontal_cols - feature_cols = col_direction$vertical_cols - counts_cols = col_direction$counts_cols - - colData = - .data %>% - select(!!.sample, sample_cols) %>% - distinct() %>% - - # Unite if multiple sample columns - tidyr::unite(!!sample__$name, !!.sample, remove = FALSE, sep = "___") |> +as_SummarizedExperiment <- function(.data, + .sample = NULL, + .transcript = NULL, + .abundance = NULL) { - arrange(!!sample__$symbol) %>% { - S4Vectors::DataFrame( - (.) %>% select(-!!sample__$symbol), - row.names = (.) %>% pull(!!sample__$symbol) - ) - } - - rowData = - .data %>% - select(!!.transcript, feature_cols) %>% - distinct() %>% + # Fix NOTES + . <- NULL + assay <- NULL - # Unite if multiple sample columns - tidyr::unite(!!feature__$name, !!.transcript, remove = FALSE, sep = "___") |> + # Get column names + .sample <- enquo(.sample) + .transcript <- enquo(.transcript) + .abundance <- enquo(.abundance) + col_names <- get_sample_transcript_counts(.data, .sample, .transcript, .abundance) + .sample <- col_names$.sample + .transcript <- col_names$.transcript + .abundance <- col_names$.abundance - arrange(!!feature__$symbol) %>% { - S4Vectors::DataFrame( - (.) %>% select(-!!feature__$symbol), - row.names = (.) %>% pull(!!feature__$symbol) - ) - } - - my_assays = - .data %>% + # If present get the scaled abundance + .abundance_scaled <- + .data %>% + ifelse_pipe( + ".abundance_scaled" %in% ((.) %>% get_tt_columns() %>% names) && + # .data %>% get_tt_columns() %$% .abundance_scaled %>% is.null %>% not() && + quo_name((.) %>% get_tt_columns() %$% .abundance_scaled) %in% ((.) %>% colnames), + ~ .x %>% get_tt_columns() %$% .abundance_scaled, + ~ NULL + ) - # Unite if multiple sample columns - tidyr::unite(!!sample__$name, !!.sample, remove = FALSE, sep = "___") |> + # Get which columns are sample wise and which are feature wise + col_direction <- get_x_y_annotation_columns(.data, + !!.sample, + !!.transcript, + !!.abundance, + !!.abundance_scaled) + sample_cols <- col_direction$horizontal_cols + feature_cols <- col_direction$vertical_cols + counts_cols <- col_direction$counts_cols - # Unite if multiple sample columns - tidyr::unite(!!feature__$name, !!.transcript, remove = FALSE, sep = "___") |> + colData <- + .data %>% + select(!!.sample, sample_cols) %>% + distinct() %>% + + # Unite if multiple sample columns + tidyr::unite(!!sample__$name, !!.sample, remove=FALSE, sep="___") |> + + arrange(!!sample__$symbol) %>% { + S4Vectors::DataFrame( + (.) %>% select(-!!sample__$symbol), + row.names=(.) %>% pull(!!sample__$symbol) + ) + } - select(!!sample__$symbol, - !!feature__$symbol, - !!.abundance, - !!.abundance_scaled, - counts_cols) %>% - distinct() %>% + rowData <- + .data %>% + select(!!.transcript, feature_cols) %>% + distinct() %>% + + # Unite if multiple sample columns + tidyr::unite(!!feature__$name, !!.transcript, remove=FALSE, sep="___") |> + + arrange(!!feature__$symbol) %>% { + S4Vectors::DataFrame( + (.) %>% select(-!!feature__$symbol), + row.names=(.) %>% pull(!!feature__$symbol) + ) + } - pivot_longer( cols=-c(!!feature__$symbol,!!sample__$symbol), names_to="assay", values_to= ".a") %>% - tidyr::nest(`data` = -`assay`) %>% - mutate(`data` = `data` %>% map( - ~ .x %>% - spread(!!sample__$symbol, .a) %>% + my_assays <- + .data %>% + + # Unite if multiple sample columns + tidyr::unite(!!sample__$name, !!.sample, remove=FALSE, sep="___") |> - # arrange sample - select(!!feature__$symbol, rownames(colData)) |> + # Unite if multiple sample columns + tidyr::unite(!!feature__$name, !!.transcript, remove=FALSE, sep="___") |> - # Arrange symbol - arrange(!!feature__$symbol) |> + select(!!sample__$symbol, + !!feature__$symbol, + !!.abundance, + !!.abundance_scaled, + counts_cols) %>% + distinct() %>% - # Convert - as_matrix(rownames = feature__$name) - )) - - # Build the object - SummarizedExperiment::SummarizedExperiment( - assays = my_assays %>% pull(`data`) %>% stats::setNames(my_assays$assay), - rowData = rowData, - colData = colData - ) - + pivot_longer( + cols=-c(!!feature__$symbol,!!sample__$symbol), + names_to="assay", values_to= ".a") %>% + tidyr::nest(`data`=-`assay`) %>% + mutate(`data`=`data` %>% map( + ~ .x %>% + spread(!!sample__$symbol, .a) %>% + + # arrange sample + select(!!feature__$symbol, rownames(colData)) |> + + # Arrange symbol + arrange(!!feature__$symbol) |> + + # Convert + as_matrix(rownames=feature__$name) + )) + + # Build the object + SummarizedExperiment::SummarizedExperiment( + assays=my_assays %>% pull(`data`) %>% stats::setNames(my_assays$assay), + rowData=rowData, + colData=colData + ) } #' Get column names either from user or from attributes @@ -164,38 +166,36 @@ as_SummarizedExperiment = function(.data, #' @param .abundance A character name of the read count column #' #' @return A list of column enquo or error -get_sample_transcript_counts = function(.data, .sample, .transcript, .abundance){ - - if( quo_is_symbolic(.sample) ) .sample = .sample - else if(".sample" %in% (.data %>% get_tt_columns() %>% names)) - .sample = get_tt_columns(.data)$.sample - else stop() - - if( quo_is_symbolic(.transcript) ) .transcript = .transcript - else if(".transcript" %in% (.data %>% get_tt_columns() %>% names)) - .transcript = get_tt_columns(.data)$.transcript - else stop() - - if( quo_is_symbolic(.abundance) ) .abundance = .abundance - else if(".abundance" %in% (.data %>% get_tt_columns() %>% names)) - .abundance = get_tt_columns(.data)$.abundance - else stop() - - list(.sample = .sample, .transcript = .transcript, .abundance = .abundance) - +get_sample_transcript_counts <- function(.data, .sample, .transcript, .abundance) { + + if (quo_is_symbolic(.sample)) .sample <- .sample + else if (".sample" %in% (.data %>% get_tt_columns() %>% names())) + .sample <- get_tt_columns(.data)$.sample + else stop() + + if (quo_is_symbolic(.transcript)) .transcript <- .transcript + else if (".transcript" %in% (.data %>% get_tt_columns() %>% names())) + .transcript <- get_tt_columns(.data)$.transcript + else stop() + + if (quo_is_symbolic(.abundance)) .abundance <- .abundance + else if (".abundance" %in% (.data %>% get_tt_columns() %>% names())) + .abundance <- get_tt_columns(.data)$.abundance + else stop() + + list(.sample=.sample, .transcript=.transcript, .abundance=.abundance) + } -get_tt_columns = function(.data){ - - # Fix NOTES - tt_columns = NULL - - if( - .data %>% attr("internals") %>% is.list() && - "tt_columns" %in% names(.data %>% attr("internals")) - ) #& "internals" %in% (.data %>% attr("internals") %>% names())) - .data %>% attr("internals") %$% tt_columns - else NULL +get_tt_columns <- function(.data) { + + # Fix NOTES + tt_columns <- NULL + + if (.data %>% attr("internals") %>% is.list() && + "tt_columns" %in% names(.data %>% attr("internals"))) { + .data %>% attr("internals") %$% tt_columns + } else NULL } #' get_x_y_annotation_columns @@ -215,103 +215,108 @@ get_tt_columns = function(.data){ #' @description This function recognise what are the sample-wise columns and transcrip-wise columns #' #' @return A list -get_x_y_annotation_columns = function(.data, .horizontal, .vertical, .abundance, .abundance_scaled){ - - # Comply with CRAN NOTES - . = NULL - - # Make col names - .horizontal = enquo(.horizontal) - .vertical = enquo(.vertical) - .abundance = enquo(.abundance) - .abundance_scaled = enquo(.abundance_scaled) - - # x-annotation df - n_x = .data %>% select(!!.horizontal) |> distinct() |> nrow() - n_y = .data %>% select(!!.vertical) |> distinct() |> nrow() - - # Sample wise columns - horizontal_cols= - .data %>% - select(-!!.horizontal, -!!.vertical, -!!.abundance) %>% - colnames %>% - map( - ~ - .x %>% - when( - .data %>% - select(!!.horizontal, !!as.symbol(.x)) %>% - distinct() |> - nrow() %>% - equals(n_x) ~ .x, - ~ NULL - ) - ) %>% +get_x_y_annotation_columns <- function(.data, .horizontal, .vertical, .abundance, .abundance_scaled) { - # Drop NULL - { (.)[lengths((.)) != 0] } %>% - unlist - - # Transcript wise columns - vertical_cols= - .data %>% - select(-!!.horizontal, -!!.vertical, -!!.abundance, -horizontal_cols) %>% - colnames %>% - map( - ~ - .x %>% - ifelse_pipe( - .data %>% - select(!!.vertical, !!as.symbol(.x)) |> - distinct() |> - nrow() %>% - equals(n_y), - ~ .x, - ~ NULL - ) - ) %>% - - # Drop NULL - { (.)[lengths((.)) != 0] } %>% - unlist - - # Counts wise columns, at the moment scaled counts is treated as special and not accounted for here - counts_cols = - .data %>% - select(-!!.horizontal, -!!.vertical, -!!.abundance) %>% + # Comply with CRAN NOTES + . <- NULL - # Exclude horizontal - ifelse_pipe(!is.null(horizontal_cols), ~ .x %>% select(-horizontal_cols)) %>% + # Make col names + .horizontal <- enquo(.horizontal) + .vertical <- enquo(.vertical) + .abundance <- enquo(.abundance) + .abundance_scaled <- enquo(.abundance_scaled) - # Exclude vertical - ifelse_pipe(!is.null(vertical_cols), ~ .x %>% select(-vertical_cols)) %>% + # x-annotation df + n_x <- .data %>% select(!!.horizontal) |> distinct() |> nrow() + n_y <- .data %>% select(!!.vertical) |> distinct() |> nrow() - # Exclude scaled counts if exist - ifelse_pipe(.abundance_scaled %>% quo_is_symbol, ~ .x %>% select(-!!.abundance_scaled) ) %>% + # Sample wise columns + horizontal_cols <- + .data %>% + select(-!!.horizontal, -!!.vertical, -!!.abundance) %>% + colnames %>% + map( + ~ + .x %>% + when( + .data %>% + select(!!.horizontal, !!as.symbol(.x)) %>% + distinct() |> + nrow() %>% + equals(n_x) ~ .x, + ~ NULL + ) + ) %>% + + # Drop NULL + { (.)[lengths((.)) != 0]} %>% + unlist - # Select colnames - colnames %>% + # Transcript wise columns + vertical_cols <- + .data %>% + select(-!!.horizontal, -!!.vertical, -!!.abundance, -horizontal_cols) %>% + colnames %>% + map( + ~ + .x %>% + ifelse_pipe( + .data %>% + select(!!.vertical, !!as.symbol(.x)) |> + distinct() |> + nrow() %>% + equals(n_y), + ~ .x, + ~ NULL + ) + ) %>% + + # Drop NULL + {(.)[lengths((.)) != 0]} %>% + unlist - # select columns - map( - ~ - .x %>% + # Counts wise columns, at the moment scaled counts is treated as special and not accounted for here + counts_cols <- + .data %>% + select(-!!.horizontal, -!!.vertical, -!!.abundance) %>% + + # Exclude horizontal ifelse_pipe( - .data %>% - select(!!.vertical, !!.horizontal, !!as.symbol(.x)) %>% - distinct() |> - nrow() %>% - equals(n_x * n_y), - ~ .x, - ~ NULL - ) - ) %>% + !is.null(horizontal_cols), + ~ .x %>% select(-horizontal_cols)) %>% + + # Exclude vertical + ifelse_pipe( + !is.null(vertical_cols), + ~ .x %>% select(-vertical_cols)) %>% + + # Exclude scaled counts if exist + ifelse_pipe( + .abundance_scaled %>% quo_is_symbol, + ~ .x %>% select(-!!.abundance_scaled)) %>% + + # Select colnames + colnames %>% + + # select columns + map( + ~ .x %>% + ifelse_pipe( + .data %>% + select(!!.vertical, !!.horizontal, !!as.symbol(.x)) %>% + distinct() |> + nrow() %>% + equals(n_x * n_y), + ~ .x, + ~ NULL + ) + ) %>% + + # Drop NULL + { (.)[lengths((.)) != 0]} %>% + unlist - # Drop NULL - { (.)[lengths((.)) != 0] } %>% - unlist - - list( horizontal_cols = horizontal_cols, vertical_cols = vertical_cols, counts_cols = counts_cols ) + list(horizontal_cols=horizontal_cols, vertical_cols=vertical_cols, counts_cols=counts_cols ) } #' Get matrix from tibble @@ -331,42 +336,40 @@ get_x_y_annotation_columns = function(.data, .horizontal, .vertical, .abundance, #' @examples #' #' tibble(.feature = "CD3G", count=1) |> as_matrix(rownames=.feature) -as_matrix <- function(tbl, - rownames = NULL, - do_check = TRUE) { - - # Fix NOTEs - variable = NULL - - rownames = enquo(rownames) - tbl %>% - - # Through warning if data frame is not numerical beside the rownames column (if present) - ifelse_pipe( - do_check && - tbl %>% - # If rownames defined eliminate it from the data frame - ifelse_pipe(!quo_is_null(rownames), ~ .x[,-1], ~ .x) %>% - dplyr::summarise_all(class) %>% - tidyr::gather(variable, class) %>% - pull(class) %>% - unique() %>% - `%in%`(c("numeric", "integer")) %>% not() %>% any(), - ~ { - warning("tidybulk says: there are NON-numerical columns, the matrix will NOT be numerical") - .x - } - ) %>% - as.data.frame() %>% +as_matrix <- function(tbl, rownames=NULL, do_check=TRUE) { - # Deal with rownames column if present - ifelse_pipe( - !quo_is_null(rownames), - ~ .x %>% - magrittr::set_rownames(tbl %>% pull(!!rownames)) %>% - select(-1) - ) %>% + # Fix NOTEs + variable <- NULL - # Convert to matrix - as.matrix() + rownames <- enquo(rownames) + tbl %>% + + # Through warning if data frame is not numerical beside the rownames column (if present) + ifelse_pipe( + do_check && + tbl %>% + # If rownames defined eliminate it from the data frame + ifelse_pipe(!quo_is_null(rownames), ~ .x[,-1], ~ .x) %>% + dplyr::summarise_all(class) %>% + tidyr::gather(variable, class) %>% + pull(class) %>% + unique() %>% + `%in%`(c("numeric", "integer")) %>% not() %>% any(), + ~ { + warning("tidybulk says: there are NON-numerical columns, the matrix will NOT be numerical") + .x + } + ) %>% + as.data.frame() %>% + + # Deal with rownames column if present + ifelse_pipe( + !quo_is_null(rownames), + ~ .x %>% + magrittr::set_rownames(tbl %>% pull(!!rownames)) %>% + select(-1) + ) %>% + + # Convert to matrix + as.matrix() } \ No newline at end of file diff --git a/R/tidyr_methods.R b/R/tidyr_methods.R index ca40ec3..da404dc 100755 --- a/R/tidyr_methods.R +++ b/R/tidyr_methods.R @@ -2,8 +2,10 @@ #' @rdname unnest #' @inherit tidyr::unnest #' @aliases unnest_single_cell_experiment +#' @return `tidySingleCellExperiment` #' #' @examples +#' data(pbmc_small) #' pbmc_small |> #' nest(data=-groups) |> #' unnest(data) @@ -11,16 +13,19 @@ #' @importFrom tidyr unnest #' @importFrom purrr when #' @export -unnest.tidySingleCellExperiment_nested <- function(data, cols, ..., keep_empty=FALSE, ptype=NULL, - names_sep=NULL, names_repair="check_unique", .drop, .id, .sep, .preserve) { - - cols <- enquo(cols) - - unnest_single_cell_experiment(data, !!cols, ..., keep_empty=keep_empty, ptype=ptype, - names_sep=names_sep, names_repair=names_repair) - } +unnest.tidySingleCellExperiment_nested <- function(data, cols, ..., + keep_empty=FALSE, ptype=NULL, names_sep=NULL, names_repair="check_unique", + .drop, .id, .sep, .preserve) { + + cols <- enquo(cols) + + unnest_single_cell_experiment(data, !!cols, ..., + keep_empty=keep_empty, ptype=ptype, + names_sep=names_sep, names_repair=names_repair) +} #' @rdname unnest +#' @importFrom methods is #' @importFrom tidyr unnest #' @importFrom rlang quo_name #' @importFrom rlang enquo @@ -28,48 +33,49 @@ unnest.tidySingleCellExperiment_nested <- function(data, cols, ..., keep_empty=F #' @importFrom purrr when #' @importFrom purrr imap #' @export -unnest_single_cell_experiment <- function(data, cols, ..., keep_empty=FALSE, ptype=NULL, - names_sep=NULL, names_repair="check_unique", .drop, .id, .sep, .preserve) { +unnest_single_cell_experiment <- function(data, cols, ..., + keep_empty=FALSE, ptype=NULL, names_sep=NULL, names_repair="check_unique", + .drop, .id, .sep, .preserve) { + # Need this otherwise crashes map .data_ <- data - cols <- enquo(cols) - - .data_ %>% - when( - - # If my only column to unnest is tidySingleCellExperiment - pull(., !!cols) %>% - .[[1]] %>% - is("SingleCellExperiment") %>% - any() ~ - - # Do my trick to unnest - mutate(., !!cols := imap( - !!cols, ~ .x %>% - bind_cols_( - - # Attach back the columns used for nesting - .data_ %>% select(-!!cols) %>% slice(rep(.y, nrow(as_tibble(.x)))) - - ) - )) %>% - pull(!!cols) %>% - reduce(bind_rows), - - # Else do normal stuff - ~ (.) %>% - drop_class("tidySingleCellExperiment_nested") %>% - tidyr::unnest(!!cols, ..., keep_empty=keep_empty, ptype=ptype, names_sep=names_sep, names_repair=names_repair) %>% - add_class("tidySingleCellExperiment_nested") - ) + + # If my only column to unnest() is a 'tidySingleCellExperiment' + # [HLC: comment says 'only', but only the first entry is being checked. + # is this intentional? or, what happens if, e.g., the 2nd is a tidySCE?] + .test <- .data_ |> pull(!!cols) |> _[[1]] |> is("SingleCellExperiment") + if (.test) { + # Do my trick to unnest() + .data_ |> + mutate(!!cols := imap( + !!cols, ~ .x |> + bind_cols_( + # Attach back the columns used for nesting + .data_ |> + select(-!!cols) |> + slice(rep(.y, nrow(as_tibble(.x)))) + ) + )) |> + pull(!!cols) |> + reduce(bind_rows) + } else { + # Else do normal stuff + .data_ |> + drop_class("tidySingleCellExperiment_nested") |> + tidyr::unnest(!!cols, ..., keep_empty=keep_empty, + ptype=ptype, names_sep=names_sep, names_repair=names_repair) |> + add_class("tidySingleCellExperiment_nested") + } } #' @name nest #' @rdname nest #' @inherit tidyr::nest +#' @return `tidySingleCellExperiment_nested` #' #' @examples +#' data(pbmc_small) #' pbmc_small |> #' nest(data=-groups) |> #' unnest(data) @@ -81,35 +87,33 @@ unnest_single_cell_experiment <- function(data, cols, ..., keep_empty=FALSE, p nest.SingleCellExperiment <- function(.data, ..., .names_sep = NULL) { cols <- enquos(...) col_name_data <- names(cols) - + # Deprecation of special column names - if(is_sample_feature_deprecated_used( - .data, - (enquos(..., .ignore_empty = "all") %>% map(~ quo_name(.x)) %>% unlist) - )){ - .data= ping_old_special_column_into_metadata(.data) + .cols <- enquos(..., .ignore_empty="all") %>% + map(~ quo_name(.x)) %>% unlist() + if (is_sample_feature_deprecated_used(.data, .cols)) { + .data <- ping_old_special_column_into_metadata(.data) } - - my_data__ = .data - + + my_data__ <- .data + cols_sym <- as.symbol(col_name_data) + cell_sym <- c_(my_data__)$symbol + my_data__ %>% - # This is needed otherwise nest goes into loop and fails to_tib() %>% tidyr::nest(...) %>% mutate( - !!as.symbol(col_name_data) := map( - !!as.symbol(col_name_data), - ~ my_data__ %>% - - # Subset cells - filter(!!c_(my_data__)$symbol %in% pull(.x, !!c_(my_data__)$symbol)) %>% - - # Subset columns - select(colnames(.x)) + !!cols_sym := map( + !!cols_sym, ~ { + my_data__ %>% + # Subset cells + filter(!!cell_sym %in% pull(.x, !!cell_sym)) %>% + # Subset columns + select(colnames(.x)) + } ) ) %>% - # Coerce to tidySingleCellExperiment_nested for unnesting add_class("tidySingleCellExperiment_nested") } @@ -117,9 +121,11 @@ nest.SingleCellExperiment <- function(.data, ..., .names_sep = NULL) { #' @name extract #' @rdname extract #' @inherit tidyr::extract +#' @return `tidySingleCellExperiment` #' #' @examples -#' pbmc_small|> +#' data(pbmc_small) +#' pbmc_small |> #' extract(groups, #' into="g", #' regex="g([0-9])", @@ -129,35 +135,34 @@ nest.SingleCellExperiment <- function(.data, ..., .names_sep = NULL) { #' @importFrom SummarizedExperiment colData<- #' @importFrom tidyr extract #' @export -extract.SingleCellExperiment <- function(data, col, into, regex="([[:alnum:]]+)", remove=TRUE, - convert=FALSE, ...) { +extract.SingleCellExperiment <- function(data, col, into, + regex="([[:alnum:]]+)", remove=TRUE, convert=FALSE, ...) { col <- enquo(col) - + # Deprecation of special column names - if(is_sample_feature_deprecated_used( - data, - c(quo_name(col), into) - )){ - data= ping_old_special_column_into_metadata(data) + .cols <- c(quo_name(col), into) + if (is_sample_feature_deprecated_used(data, .cols)) { + data <- ping_old_special_column_into_metadata(data) } - + colData(data) <- data %>% as_tibble() %>% - tidyr::extract(col=!!col, into=into, regex=regex, remove=remove, convert=convert, ...) %>% + tidyr::extract(col=!!col, into=into, + regex=regex, remove=remove, convert=convert, ...) %>% as_meta_data(data) - - + data } #' @name pivot_longer #' @rdname pivot_longer #' @inherit tidyr::pivot_longer +#' @return `tidySingleCellExperiment` #' #' @export #' @examples -#' # See vignette("pivot") for examples and explanation +#' data(pbmc_small) #' pbmc_small |> pivot_longer( #' cols=c(orig.ident, groups), #' names_to="name", values_to="value") @@ -166,104 +171,101 @@ extract.SingleCellExperiment <- function(data, col, into, regex="([[:alnum:]]+)" #' @importFrom tidyr pivot_longer #' @export pivot_longer.SingleCellExperiment <- function(data, - cols, ..., cols_vary = "fastest", names_to = "name", - names_prefix = NULL, names_sep = NULL, names_pattern = NULL, - names_ptypes = NULL, names_transform = NULL, names_repair = "check_unique", - values_to = "value", values_drop_na = FALSE, values_ptypes = NULL, - values_transform = NULL) { + cols, ..., cols_vary = "fastest", names_to = "name", + names_prefix = NULL, names_sep = NULL, names_pattern = NULL, + names_ptypes = NULL, names_transform = NULL, names_repair = "check_unique", + values_to = "value", values_drop_na = FALSE, values_ptypes = NULL, + values_transform = NULL) { cols <- enquo(cols) - + message(data_frame_returned_message) - + # Deprecation of special column names - if(is_sample_feature_deprecated_used( - data, - c(quo_names(cols)) - )){ - data= ping_old_special_column_into_metadata(data) + .cols <- c(quo_names(cols)) + if (is_sample_feature_deprecated_used(data, .cols)) { + data <- ping_old_special_column_into_metadata(data) } - + data %>% as_tibble() %>% tidyr::pivot_longer(!!cols, - ..., - cols_vary = cols_vary, - names_to = names_to, - names_prefix = names_prefix, - names_sep = names_sep, - names_pattern = names_pattern, - names_ptypes = names_ptypes, - names_transform = names_transform, - names_repair = names_repair, - values_to = values_to, - values_drop_na = values_drop_na, - values_ptypes = values_ptypes, - values_transform = values_transform - ) + ..., + cols_vary = cols_vary, + names_to = names_to, + names_prefix = names_prefix, + names_sep = names_sep, + names_pattern = names_pattern, + names_ptypes = names_ptypes, + names_transform = names_transform, + names_repair = names_repair, + values_to = values_to, + values_drop_na = values_drop_na, + values_ptypes = values_ptypes, + values_transform = values_transform) } #' @name unite #' @rdname unite #' @inherit tidyr::unite +#' @return `tidySingleCellExperiment` #' #' @examples +#' data(pbmc_small) #' pbmc_small |> unite( #' col="new_col", -#' c(orig.ident, groups)) +#' c("orig.ident", "groups")) #' #' @importFrom SummarizedExperiment colData #' @importFrom SummarizedExperiment colData<- -#' @importFrom ellipsis check_dots_unnamed +#' @importFrom rlang enquo enquos quo_name #' @importFrom tidyr unite #' @export -unite.SingleCellExperiment <- function(data, col, ..., sep="_", remove=TRUE, na.rm=FALSE) { - +unite.SingleCellExperiment <- function(data, col, + ..., sep="_", remove=TRUE, na.rm=FALSE) { + # Check that we are not modifying a key column cols <- enquo(col) - + # Deprecation of special column names - if(is_sample_feature_deprecated_used( - data, - (enquos(..., .ignore_empty = "all") %>% map(~ quo_name(.x)) %>% unlist) - )){ - data= ping_old_special_column_into_metadata(data) + .cols <- enquos(..., .ignore_empty="all") %>% + map(~ quo_name(.x)) %>% unlist() + if (is_sample_feature_deprecated_used(data, .cols)) { + data <- ping_old_special_column_into_metadata(data) } - - tst <- - intersect( - cols %>% quo_names(), - get_special_columns(data) %>% c(get_needed_columns(data)) - ) %>% - length() %>% - gt(0) & - remove - - if (tst) { - columns = - get_special_columns(data) %>% - c(get_needed_columns(data)) %>% - paste(collapse=", ") - stop( - "tidySingleCellExperiment says: you are trying to rename a column that is view only", - columns, " ", - "(it is not present in the colData). If you want to mutate a view-only column, make a copy and mutate that one." - ) + + .view_only_cols <- c( + get_special_columns(data), + get_needed_columns(data)) + + .test <- intersect( + quo_names(cols), + .view_only_cols) + + if (remove && length(.test)) { + stop("tidySingleCellExperiment says:", + " you are trying to rename a column", + " that is view only ", + paste(.view_only_cols, collapse=", "), + " (it is not present in the colData).", + " If you want to mutate a view-only column,", + " make a copy and mutate that one.") } - colData(data) <- data %>% as_tibble() %>% tidyr::unite(!!cols, ..., sep=sep, remove=remove, na.rm=na.rm) %>% as_meta_data(data) - + data } #' @name separate #' @rdname separate #' @inherit tidyr::separate +#' @return `tidySingleCellExperiment` #' #' @examples +#' data(pbmc_small) #' un <- pbmc_small |> unite("new_col", c(orig.ident, groups)) #' un |> separate(new_col, c("orig.ident", "groups")) #' @@ -272,47 +274,44 @@ unite.SingleCellExperiment <- function(data, col, ..., sep="_", remove=TRUE, na. #' @importFrom ellipsis check_dots_used #' @importFrom tidyr separate #' @export -separate.SingleCellExperiment <- function(data, col, into, sep="[^[:alnum:]]+", remove=TRUE, - convert=FALSE, extra="warn", fill="warn", ...) { - +separate.SingleCellExperiment <- function(data, col, into, + sep="[^[:alnum:]]+", remove=TRUE, convert=FALSE, + extra="warn", fill="warn", ...) { + # Check that we are not modifying a key column cols <- enquo(col) - + # Deprecation of special column names - if(is_sample_feature_deprecated_used( - data, - c(quo_names(cols)) - )){ - data= ping_old_special_column_into_metadata(data) + .cols <- c(quo_names(cols)) + if (is_sample_feature_deprecated_used(data, .cols)) { + data <- ping_old_special_column_into_metadata(data) } - - tst <- - intersect( - cols %>% quo_names(), - get_special_columns(data) %>% c(get_needed_columns(data)) - ) %>% - length() %>% - gt(0) & - remove - - if (tst) { - columns = - get_special_columns(data) %>% - c(get_needed_columns(data)) %>% - paste(collapse=", ") - stop( - "tidySingleCellExperiment says: you are trying to rename a column that is view only", - columns, " ", - "(it is not present in the colData). If you want to mutate a view-only column, make a copy and mutate that one." - ) + + .view_only_cols <- c( + get_special_columns(data), + get_needed_columns(data)) + + .test <- intersect( + quo_names(cols), + .view_only_cols) + + if (remove && length(.test)) { + stop("tidySingleCellExperiment says:", + " you are trying to rename a column", + " that is view only ", + paste(.view_only_cols, collapse=", "), + "(it is not present in the colData).", + " If you want to mutate a view-only column,", + " make a copy and mutate that one.") } - - + colData(data) <- data %>% as_tibble() %>% - tidyr::separate(!!cols, into=into, sep=sep, remove=remove, convert=convert, extra=extra, fill=fill, ...) %>% + tidyr::separate( + !!cols, into=into, sep=sep, remove=remove, + convert=convert, extra=extra, fill=fill, ...) %>% as_meta_data(data) - + data } diff --git a/R/utilities.R b/R/utilities.R index d947188..5699732 100755 --- a/R/utilities.R +++ b/R/utilities.R @@ -42,14 +42,12 @@ prepend <- function(x, values, before=1) { stopifnot(before > 0 && before <= n) if (before == 1) { c(values, x) - } - else { - c(x[seq_len(before - 1)], values, x[before:n]) + } else { + c(x[seq_len(before-1)], values, x[seq(before, n)]) } } #' Add class to abject #' -#' #' @keywords internal #' #' @param var A tibble @@ -57,16 +55,15 @@ prepend <- function(x, values, before=1) { #' #' @return A tibble with an additional attribute add_class <- function(var, name) { - if (!name %in% class(var)) class(var) <- prepend(class(var), name) - - var + if (!name %in% class(var)) + class(var) <- prepend(class(var), name) + return(var) } #' Remove class to abject #' #' @keywords internal #' -#' #' @param var A tibble #' @param name A character name of the class #' @@ -74,7 +71,7 @@ add_class <- function(var, name) { #' @keywords internal drop_class <- function(var, name) { class(var) <- class(var)[!class(var) %in% name] - var + return(var) } #' get abundance long @@ -83,70 +80,61 @@ drop_class <- function(var, name) { #' #' @importFrom magrittr "%$%" #' @importFrom utils tail -#' @importFrom SummarizedExperiment assays #' @importFrom stats setNames +#' @importFrom SummarizedExperiment assay assayNames #' -#' @param .data A tidySingleCellExperiment +#' @param .data A `tidySingleCellExperiment` #' @param features A character #' @param all A boolean -#' @param ... Parameters to pass to join wide, i.e. assay name to extract feature abundance from -#' +#' @param ... Parameters to pass to join wide, i.e., +#' `assay` to extract feature abundances from #' #' @return A tidySingleCellExperiment object #' -#' #' @noRd -get_abundance_sc_wide <- function(.data, features=NULL, all=FALSE, assay = assays(.data) %>% as.list() %>% tail(1) %>% names, prefix = "" ) { - +get_abundance_sc_wide <- function(.data, + features=NULL, all=FALSE, assay=rev(assayNames(.data))[1], prefix="") { + # Solve CRAN warnings . <- NULL - + # For SCE there is not filed for variable features variable_feature <- c() - + # Check if output would be too big without forcing - if ( - length(variable_feature) == 0 & - is.null(features) & - all == FALSE - ) { - stop(" - Your object does not contain variable feature labels, - feature argument is empty and all arguments are set to FALSE. - Either: - 1. use detect_variable_features() to select variable feature - 2. pass an array of feature names - 3. set all=TRUE (this will output a very large object, does your computer have enough RAM?) - ") - } - - # Get variable features if existing - if ( - length(variable_feature) > 0 & - is.null(features) & - all == FALSE - ) { - variable_genes <- variable_feature - } # Else - else { + if (isFALSE(all) && is.null(features)) { + if (!length(variable_feature)) { + stop("Your object does not contain variable feature labels,\n", + " feature argument is empty and all arguments are set to FALSE.\n", + " Either:\n", + " 1. use detect_variable_features() to select variable feature\n", + " 2. pass an array of feature names\n", + " 3. set all=TRUE (this will output a very large object;", + " does your computer have enough RAM?)") + } else { + # Get variable features if existing + variable_genes <- variable_feature + } + } else { variable_genes <- NULL } - - # Just grub last assay - assays(.data) %>% - as.list() %>% - .[[assay]] %>% - when( - variable_genes %>% is.null() %>% `!`() ~ (.)[variable_genes, , drop=FALSE], - features %>% is.null() %>% `!`() ~ (.)[features, , drop=FALSE], - ~ stop("It is not convenient to extract all genes, you should have either variable features or feature list to extract") - ) %>% - as.matrix() %>% - t() %>% + + if (!is.null(variable_genes)) { + gs <- variable_genes + } else if (!is.null(features)) { + gs <- features + } else { + stop("It is not convenient to extract all genes.", + " You should have either variable features,", + " or a feature list to extract.") + } + mtx <- assay(.data, assay) + mtx <- mtx[gs, , drop=FALSE] + + mtx %>% + as.matrix() %>% t() %>% as_tibble(rownames=c_(.data)$name) %>% - - # Add prefix - setNames(c(c_(.data)$name, sprintf("%s%s", prefix, colnames(.)[-1]))) + setNames(c(c_(.data)$name, sprintf("%s%s", prefix, gs))) } #' get abundance long @@ -158,7 +146,7 @@ get_abundance_sc_wide <- function(.data, features=NULL, all=FALSE, assay = assay #' @importFrom tibble as_tibble #' @importFrom purrr when #' @importFrom purrr map2 -#' @importFrom SummarizedExperiment assays +#' @importFrom SummarizedExperiment assays assayNames #' #' @param .data A tidySingleCellExperiment #' @param features A character @@ -167,136 +155,113 @@ get_abundance_sc_wide <- function(.data, features=NULL, all=FALSE, assay = assay #' #' @return A tidySingleCellExperiment object #' -#' #' @noRd -get_abundance_sc_long <- function(.data, features=NULL, all=FALSE, exclude_zeros=FALSE) { - +get_abundance_sc_long <- function(.data, + features=NULL, all=FALSE, exclude_zeros=FALSE) { + # Solve CRAN warnings . <- NULL - + # For SCE there is not filed for variable features variable_feature <- c() - + # Check if output would be too big without forcing - if ( - length(variable_feature) == 0 & - is.null(features) & - all == FALSE - ) { - stop(" - Your object does not contain variable feature labels, - feature argument is empty and all arguments are set to FALSE. - Either: - 1. use detect_variable_features() to select variable feature - 2. pass an array of feature names - 3. set all=TRUE (this will output a very large object, does your computer have enough RAM?) - ") - } - - - # Get variable features if existing - if ( - length(variable_feature) > 0 & - is.null(features) & - all == FALSE - ) { - variable_genes <- variable_feature - } # Else - else { + if (isFALSE(all) && is.null(features)) { + if (!length(variable_feature)) { + stop("Your object does not contain variable feature labels,\n", + " feature argument is empty and all arguments are set to FALSE.\n", + " Either:\n", + " 1. use detect_variable_features() to select variable feature\n", + " 2. pass an array of feature names\n", + " 3. set all=TRUE (this will output a very large object;", + " does your computer have enough RAM?)") + } else { + # Get variable features if existing + variable_genes <- variable_feature + } + } else { variable_genes <- NULL } - - assay_names <- assays(.data) %>% names() - - # Check that I have assay manes - if(length(assay_names) == 0) - stop("tidySingleCellExperiment says: there are no assays names in the source SingleCellExperiment.") - + + # Check that I have assay names + if (!length(assayNames(.data))) + stop("tidySingleCellExperiment says:", + " there are no assay names in the", + " source SingleCellExperiment.") + + if (!is.null(variable_genes)) { + gs <- variable_genes + } else if (!is.null(features)){ + gs <- features + } else if (isTRUE(all)) { + gs <- TRUE + } else { + stop("It is not convenient to extract all genes.", + " You should have either variable features,", + " or a feature list to extract.") + } + assays(.data) %>% as.list() %>% - # Take active assay - map2( - assay_names, - - ~ .x %>% - when( - variable_genes %>% is.null() %>% `!`() ~ .x[variable_genes, , drop=FALSE], - features %>% is.null() %>% `!`() ~ .x[toupper(rownames(.x)) %in% toupper(features), , drop=FALSE], - all ~ .x, - ~ stop("It is not convenient to extract all genes, you should have either variable features or feature list to extract") - ) %>% - - # Replace 0 with NA - when(exclude_zeros ~ (.) %>% { - x <- (.) - x[x == 0] <- NA - x - }, ~ (.)) %>% + map2(assayNames(.data), ~ { + # Subset specified features + .x <- .x[gs, , drop=FALSE] + # Replace 0 with NA + if (isTRUE(exclude_zeros)) + .x[.x == 0] <- NA + .x %>% as.matrix() %>% - data.frame(check.names = FALSE) %>% + data.frame(check.names=FALSE) %>% as_tibble(rownames=".feature") %>% tidyr::pivot_longer( - cols=- .feature, + cols=-.feature, names_to=c_(.data)$name, values_to=".abundance" %>% paste(.y, sep="_"), - values_drop_na=TRUE - ) - # %>% - # mutate_if(is.character, as.factor) %>% - ) %>% - Reduce(function(...) full_join(..., by=c(".feature", c_(.data)$name)), .) + values_drop_na=TRUE) + }) %>% Reduce(function(...) full_join(..., + by=c(".feature", c_(.data)$name)), .) } -#' @importFrom dplyr select_if +#' @importFrom dplyr select any_of #' @importFrom S4Vectors DataFrame #' #' @keywords internal #' #' @param .data A tibble -#' @param SingleCellExperiment_object A tidySingleCellExperiment +#' @param SingleCellExperiment_object A `tidySingleCellExperiment` #' #' @noRd as_meta_data <- function(.data, SingleCellExperiment_object) { - # Solve CRAN warnings - . <- NULL - col_to_exclude <- - - # special_datasets_to_tibble(SingleCellExperiment_object) |> - # colnames() - get_special_columns(SingleCellExperiment_object) |> - - - # I need this in case we have multiple reduced dimension data frames with overlapping names of the columns. - # For example multiple PCA versions - vctrs::vec_as_names(repair = "unique") |> - - # To avoid name change by the bind_cols of as_tibble - trick_to_avoid_renaming_of_already_unique_columns_by_dplyr() - - .data_df = - .data %>% - select_if(!colnames(.) %in% col_to_exclude) %>% - data.frame() - - # Set row names in a robust way. the argument row.names of the data.frame function does not work for 1-row data frames - rownames(.data_df) = .data_df |> pull(!!c_(SingleCellExperiment_object)$symbol) - .data_df = .data_df |> select(-!!c_(SingleCellExperiment_object)$symbol) - - .data_df %>% DataFrame() - + get_special_columns(SingleCellExperiment_object) |> + # Need this in case we have multiple reduced dimensions + # with overlapping column names, e.g., multiple PCAs + vctrs::vec_as_names(repair="unique") |> + # To avoid name change by the 'bind_cols()' of 'as_tibble()' + trick_to_avoid_renaming_of_already_unique_columns_by_dplyr() + + .data_df <- .data %>% + select(-any_of(col_to_exclude)) %>% + data.frame() + + # Set row names in a robust way; the 'row.names' argument + # of 'data.frame()' does not work for 1-row 'data.frame's + sym <- c_(SingleCellExperiment_object)$symbol + rownames(.data_df) <- pull(.data_df, !!sym) + + .data_df <- select(.data_df, -!!sym) + return(DataFrame(.data_df)) } #' @importFrom purrr map_chr #' #' @keywords internal #' -#' @param SingleCellExperiment_object A tidySingleCellExperiment +#' @param SingleCellExperiment_object A `tidySingleCellExperiment` #' #' @noRd -#' get_special_columns <- function(SingleCellExperiment_object) { get_special_datasets(SingleCellExperiment_object) %>% map(~ .x %>% colnames()) %>% @@ -304,22 +269,24 @@ get_special_columns <- function(SingleCellExperiment_object) { as.character() } -get_special_datasets <- function(SingleCellExperiment_object, n_dimensions_to_return = Inf) { - rd <- SingleCellExperiment_object@int_colData@listData$reducedDims - - map2(rd %>% as.list(), names(rd), ~ { - mat <- .x[, seq_len(min(n_dimensions_to_return, ncol(.x))), drop=FALSE] - - # Set names as SCE is much less constrained and there could be missing names - if (length(colnames(mat)) == 0) colnames(mat) <- sprintf("%s%s", .y, seq_len(ncol(mat))) - - mat +#' @importFrom SingleCellExperiment reducedDims +get_special_datasets <- function(SingleCellExperiment_object, n_dimensions_to_return=Inf) { + + rd <- reducedDims(SingleCellExperiment_object) + + map2(as.list(rd), names(rd), ~ { + n_dims <- min(n_dimensions_to_return, ncol(.x)) + mat <- .x[, seq_len(n_dims), drop=FALSE] + # Set names as SCE is much less constrained + # and there could be missing names + if (is.null(colnames(mat))) colnames(mat) <- + sprintf("%s%s", .y, seq_len(ncol(mat))) + return(mat) }) } get_needed_columns <- function(.data) { - - c(c_(.data)$name) + c(c_(.data)$name) } #' Convert array of quosure (e.g. c(col_a, col_b)) into character vector @@ -345,62 +312,67 @@ quo_names <- function(v) { #' @importFrom tidyselect eval_select select_helper <- function(.data, ...) { loc <- tidyselect::eval_select(expr(c(...)), .data) - dplyr::select(.data, loc) } -data_frame_returned_message = "tidySingleCellExperiment says: A data frame is returned for independent data analysis." -duplicated_cell_names = "tidySingleCellExperiment says: This operation lead to duplicated cell names. A data frame is returned for independent data analysis." +data_frame_returned_message <- paste( + "tidySingleCellExperiment says:", + "A data frame is returned for independent data analysis.") +duplicated_cell_names <- paste( + "tidySingleCellExperiment says:", + "This operation lead to duplicated cell names.", + "A data frame is returned for independent data analysis.") # This function is used for the change of special sample column to .sample # Check if "sample" is included in the query and is not part of any other existing annotation #' @importFrom stringr str_detect #' @importFrom stringr regex -is_sample_feature_deprecated_used = function(.data, user_columns, use_old_special_names = FALSE){ - - old_standard_is_used_for_cell = - ( - ( any(str_detect(user_columns , regex("\\bcell\\b"))) & !any(str_detect(user_columns , regex("\\W*(\\.cell)\\W*"))) ) | - "cell" %in% user_columns - ) & - !"cell" %in% colnames(colData(.data)) - - old_standard_is_used = old_standard_is_used_for_cell - - if(old_standard_is_used){ - warning("tidySingleCellExperiment says: from version 1.3.1, the special columns including cell id (colnames(se)) has changed to \".cell\". This dataset is returned with the old-style vocabulary (cell), however we suggest to update your workflow to reflect the new vocabulary (.cell)") - - use_old_special_names = TRUE - } - - use_old_special_names +is_sample_feature_deprecated_used <- function(.data, + user_columns, use_old_special_names=FALSE) { + + cell <- any(str_detect(user_columns, regex("\\bcell\\b"))) + .cell <- any(str_detect(user_columns, regex("\\W*(\\.cell)\\W*"))) + + old_standard_is_used <- + !"cell" %in% colnames(colData(.data)) && + ("cell" %in% user_columns || (cell && !.cell)) + + if (old_standard_is_used) { + warning("tidySingleCellExperiment says:", + " from version 1.3.1, the special columns including", + " cell id (colnames(se)) has changed to \".cell\".", + " This dataset is returned with the old-style vocabulary (cell),", + " however, we suggest to update your workflow", + " to reflect the new vocabulary (.cell).") + use_old_special_names <- TRUE + } + use_old_special_names } -get_special_column_name_symbol = function(name){ - list(name = name, symbol = as.symbol(name)) +get_special_column_name_symbol <- function(name) { + list(name=name, symbol=as.symbol(name)) } # Key column names #' @importFrom S4Vectors metadata #' @importFrom S4Vectors metadata<- -ping_old_special_column_into_metadata = function(.data){ - - metadata(.data)$cell__ = get_special_column_name_symbol("cell") - - .data +ping_old_special_column_into_metadata <- function(.data) { + metadata(.data)$cell__ <- get_special_column_name_symbol("cell") + return(.data) } -get_special_column_name_cell = function(name){ - list(name = name, symbol = as.symbol(name)) +get_special_column_name_cell <- function(name) { + list(name=name, symbol=as.symbol(name)) } -cell__ = get_special_column_name_symbol(".cell") +cell__ <- get_special_column_name_symbol(".cell") #' @importFrom S4Vectors metadata -c_ = function(x){ - # Check if old deprecated columns are used - if("cell__" %in% names(metadata(x))) cell__ = metadata(x)$cell__ - return(cell__) +c_ <- function(x) { + # Check if old deprecated columns are used + if ("cell__" %in% names(metadata(x))) + cell__ <- metadata(x)$cell__ + return(cell__) } #' Add attribute to abject @@ -408,46 +380,40 @@ c_ = function(x){ #' @keywords internal #' @noRd #' -#' #' @param var A tibble #' @param attribute An object #' @param name A character name of the attribute #' #' @return A tibble with an additional attribute -add_attr = function(var, attribute, name) { - attr(var, name) <- attribute - var +add_attr <- function(var, attribute, name) { + attr(var, name) <- attribute + return(var) } -#' @importFrom purrr reduce +#' @importFrom tidyr spread #' @importFrom tibble enframe -special_datasets_to_tibble = function(.singleCellExperiment, ...){ - x = - .singleCellExperiment |> - get_special_datasets(...) %>% - map(~ .x %>% when( - - # If row == 1 do a trick - dim(.) %>% is.null() ~ { - (.) %>% - tibble::enframe() %>% - spread(name, value) - }, - - # Otherwise continue normally - ~ as_tibble(.) - )) %>% - reduce(bind_cols) - - # To avoid name change by the bind_cols of as_tibble - colnames(x) = colnames(x) |> trick_to_avoid_renaming_of_already_unique_columns_by_dplyr() - - x +#' @importFrom purrr map reduce +special_datasets_to_tibble <- function(.singleCellExperiment, ...) { + x <- .singleCellExperiment %>% + get_special_datasets(...) %>% + map(~ { + if (!is.null(dim(.x))) + return(as_tibble(.x)) + # If row == 1 do a trick + .x %>% + tibble::enframe() %>% + tidyr::spread(name, value) + }) %>% purrr::reduce(bind_cols) + + # To avoid name change by the 'bind_cols()' of 'as_tibble()' + colnames(x) <- colnames(x) |> + trick_to_avoid_renaming_of_already_unique_columns_by_dplyr() + return(x) } #' @importFrom stringr str_replace_all -trick_to_avoid_renaming_of_already_unique_columns_by_dplyr = function(x){ - x |> str_replace_all("\\.\\.\\.", "___") +trick_to_avoid_renaming_of_already_unique_columns_by_dplyr <- function(x) { + str_replace_all(x, "\\.\\.\\.", "___") } #' Get specific annotation columns @@ -465,36 +431,28 @@ trick_to_avoid_renaming_of_already_unique_columns_by_dplyr = function(x){ #' @param .col A vector of column names #' #' @return A character -get_specific_annotation_columns = function(.data, .col){ - - # Comply with CRAN NOTES - . = NULL - - # Make col names - .col = enquo(.col) - - # x-annotation df - n_x = .data %>% distinct_at(vars(!!.col)) %>% nrow - - # element wise columns - .data %>% - select(-!!.col) %>% - colnames %>% - map( - ~ - .x %>% - when( - .data %>% - distinct_at(vars(!!.col, .x)) %>% - nrow %>% - equals(n_x) ~ (.), - ~ NULL - ) - ) %>% +get_specific_annotation_columns <- function(.data, .col) { + + # Comply with CRAN NOTES + . <- NULL + + # Make col names + .col <- enquo(.col) - # Drop NULL - { (.)[lengths((.)) != 0] } %>% - unlist + # x-annotation df + n_x <- .data |> distinct_at(vars(!!.col)) |> nrow() + + # element wise columns + .data |> + select(-!!.col) |> + colnames() |> + map(~ { + n_.x <- .data |> distinct_at(vars(!!.col, .x)) |> nrow() + if (n_.x == n_x) .x else NULL + }) %>% + # Drop NULL + { (.)[lengths((.)) != 0] } |> + unlist() } #' Subset columns @@ -508,21 +466,21 @@ get_specific_annotation_columns = function(.data, .col){ #' @param .column A vector of column names #' #' @return A tibble -subset = function(.data, .column) { - - # Make col names - .column = enquo(.column) - - # Check if column present - if(quo_names(.column) %in% colnames(.data) %>% all %>% `!`) - stop("nanny says: some of the .column specified do not exist in the input data frame.") - - .data %>% +subset <- function(.data, .column) { + + # Make col names + .column <- enquo(.column) + + # Check if column present + if (!all(quo_names(.column) %in% colnames(.data))) + stop("nanny says: some of the .column specified", + " do not exist in the input data frame.") - # Selecting the right columns - select( !!.column, get_specific_annotation_columns(.data, !!.column) ) %>% - distinct() + .data |> + # Selecting the right columns + select(!!.column, get_specific_annotation_columns(.data, !!.column)) %>% + distinct() } -feature__ = get_special_column_name_symbol(".feature") -sample__ = get_special_column_name_symbol(".sample") \ No newline at end of file +feature__ <- get_special_column_name_symbol(".feature") +sample__ <- get_special_column_name_symbol(".sample") \ No newline at end of file diff --git a/R/zzz.R b/R/zzz.R index ece89a4..c1154fb 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -1,24 +1,23 @@ #' @importFrom utils packageDescription .onAttach <- function(libname, pkgname) { - version <- packageDescription(pkgname, fields="Version") - - # msg = paste0("======================================== - # ", pkgname, " version ", version, " - # If you use TIDYBULK in published research, please cite: - # - # Mangiola et al. tidybulk: an R tidy framework for modular - # transcriptomic data analysis. Genome Biology 2021. - # - # This message can be suppressed by: - # suppressPackageStartupMessages(library(tidybulk)) - # ======================================== - # ") - # - # packageStartupMessage(msg) - - # Attach tidyverse - attached <- tidyverse_attach() - + version <- packageDescription(pkgname, fields="Version") + + # msg = paste0("======================================== + # ", pkgname, " version ", version, " + # If you use TIDYBULK in published research, please cite: + # + # Mangiola et al. tidybulk: an R tidy framework for modular + # transcriptomic data analysis. Genome Biology 2021. + # + # This message can be suppressed by: + # suppressPackageStartupMessages(library(tidybulk)) + # ======================================== + # ") + # + # packageStartupMessage(msg) + + # Attach tidyverse + attached <- tidyverse_attach() } # rv = R.Version() diff --git a/man/figures/plotly.png b/inst/extdata/plotly.png similarity index 100% rename from man/figures/plotly.png rename to inst/extdata/plotly.png diff --git a/man/aggregate_cells.Rd b/man/aggregate_cells.Rd index f2731ac..e93d722 100644 --- a/man/aggregate_cells.Rd +++ b/man/aggregate_cells.Rd @@ -31,7 +31,7 @@ A tibble object Combine cells into groups based on shared variables and aggregate feature counts. } \examples{ -data("pbmc_small") +data(pbmc_small) pbmc_small_pseudo_bulk <- pbmc_small |> aggregate_cells(c(groups, ident), assays="counts") diff --git a/man/arrange.Rd b/man/arrange.Rd index 2deba4c..8ce8e58 100644 --- a/man/arrange.Rd +++ b/man/arrange.Rd @@ -61,6 +61,7 @@ The following methods are currently available in loaded packages: } \examples{ +data(pbmc_small) pbmc_small |> arrange(nFeature_RNA) diff --git a/man/as_tibble.Rd b/man/as_tibble.Rd index bec62a5..8a614e3 100644 --- a/man/as_tibble.Rd +++ b/man/as_tibble.Rd @@ -47,6 +47,9 @@ Use \code{as_tibble(rownames_to_column(...))} to safeguard against this case. Read more in \link[tibble]{rownames}.} } +\value{ +`tibble` +} \description{ \code{as_tibble()} turns an existing object, such as a data frame or matrix, into a so-called tibble, a data frame with class \code{\link[tibble]{tbl_df}}. This is @@ -92,6 +95,7 @@ prefer the more expressive \code{as_tibble_row()} and } \examples{ +data(pbmc_small) pbmc_small |> as_tibble() } diff --git a/man/bind_rows.Rd b/man/bind_rows.Rd index 7b54fe3..99f2ad8 100644 --- a/man/bind_rows.Rd +++ b/man/bind_rows.Rd @@ -59,6 +59,7 @@ The output of `bind_rows()` will contain a column if that column appears in any of the inputs. } \examples{ +data(pbmc_small) tt <- pbmc_small bind_rows(tt, tt) diff --git a/man/cell_type_df.Rd b/man/cell_type_df.Rd index 53d9406..479ce3f 100644 --- a/man/cell_type_df.Rd +++ b/man/cell_type_df.Rd @@ -5,9 +5,9 @@ \alias{cell_type_df} \title{Cell types of 80 PBMC single cells} \format{ -A tibble containing 80 rows and 2 columns. Cells are a subsample of - the Peripheral Blood Mononuclear Cells (PBMC) dataset of 2,700 single - cell. Cell types were identified with SingleR. +A tibble containing 80 rows and 2 columns. + Cells are a subsample of the Peripheral Blood Mononuclear Cells (PBMC) + dataset of 2,700 single cell. Cell types were identified with SingleR. \describe{ \item{cell}{cell identifier, barcode} \item{first.labels}{cell type} @@ -19,6 +19,9 @@ A tibble containing 80 rows and 2 columns. Cells are a subsample of \usage{ data(cell_type_df) } +\value{ +`tibble` +} \description{ A dataset containing the barcodes and cell types of 80 PBMC single cells. } diff --git a/man/count.Rd b/man/count.Rd index d614e27..f8a6ab3 100644 --- a/man/count.Rd +++ b/man/count.Rd @@ -66,6 +66,7 @@ but use \code{mutate()} instead of \code{summarise()} so that they add a new col with group-wise counts. } \examples{ +data(pbmc_small) pbmc_small |> count(groups) } diff --git a/man/distinct.Rd b/man/distinct.Rd index 65c860f..f329851 100644 --- a/man/distinct.Rd +++ b/man/distinct.Rd @@ -49,7 +49,7 @@ The following methods are currently available in loaded packages: } \examples{ -pbmc_small |> - distinct(groups) +data(pbmc_small) +pbmc_small |> distinct(groups) } diff --git a/man/extract.Rd b/man/extract.Rd index 8e1b590..eb5d7e4 100644 --- a/man/extract.Rd +++ b/man/extract.Rd @@ -38,6 +38,9 @@ NB: this will cause string \code{"NA"}s to be converted to \code{NA}s.} \item{...}{Additional arguments passed on to methods.} } +\value{ +`tidySingleCellExperiment` +} \description{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#superseded}{\figure{lifecycle-superseded.svg}{options: alt='[Superseded]'}}}{\strong{[Superseded]}} @@ -51,7 +54,8 @@ each group into a new column. If the groups don't match, or the input is NA, the output will be NA. } \examples{ -pbmc_small|> +data(pbmc_small) +pbmc_small |> extract(groups, into="g", regex="g([0-9])", diff --git a/man/figures/lifecycle-archived.svg b/man/figures/lifecycle-archived.svg deleted file mode 100644 index 48f72a6..0000000 --- a/man/figures/lifecycle-archived.svg +++ /dev/null @@ -1 +0,0 @@ - lifecyclelifecyclearchivedarchived \ No newline at end of file diff --git a/man/figures/lifecycle-defunct.svg b/man/figures/lifecycle-defunct.svg deleted file mode 100644 index 01452e5..0000000 --- a/man/figures/lifecycle-defunct.svg +++ /dev/null @@ -1 +0,0 @@ -lifecyclelifecycledefunctdefunct \ No newline at end of file diff --git a/man/figures/lifecycle-deprecated.svg b/man/figures/lifecycle-deprecated.svg deleted file mode 100644 index 4baaee0..0000000 --- a/man/figures/lifecycle-deprecated.svg +++ /dev/null @@ -1 +0,0 @@ -lifecyclelifecycledeprecateddeprecated \ No newline at end of file diff --git a/man/figures/lifecycle-experimental.svg b/man/figures/lifecycle-experimental.svg deleted file mode 100644 index d1d060e..0000000 --- a/man/figures/lifecycle-experimental.svg +++ /dev/null @@ -1 +0,0 @@ -lifecyclelifecycleexperimentalexperimental \ No newline at end of file diff --git a/man/figures/lifecycle-maturing.svg b/man/figures/lifecycle-maturing.svg deleted file mode 100644 index df71310..0000000 --- a/man/figures/lifecycle-maturing.svg +++ /dev/null @@ -1 +0,0 @@ -lifecyclelifecyclematuringmaturing \ No newline at end of file diff --git a/man/figures/lifecycle-questioning.svg b/man/figures/lifecycle-questioning.svg deleted file mode 100644 index 08ee0c9..0000000 --- a/man/figures/lifecycle-questioning.svg +++ /dev/null @@ -1 +0,0 @@ -lifecyclelifecyclequestioningquestioning \ No newline at end of file diff --git a/man/figures/lifecycle-stable.svg b/man/figures/lifecycle-stable.svg deleted file mode 100644 index e015dc8..0000000 --- a/man/figures/lifecycle-stable.svg +++ /dev/null @@ -1 +0,0 @@ -lifecyclelifecyclestablestable \ No newline at end of file diff --git a/man/figures/lifecycle-superseded.svg b/man/figures/lifecycle-superseded.svg deleted file mode 100644 index 75f24f5..0000000 --- a/man/figures/lifecycle-superseded.svg +++ /dev/null @@ -1 +0,0 @@ - lifecyclelifecyclesupersededsuperseded \ No newline at end of file diff --git a/man/figures/pc_plot-1.png b/man/figures/pc_plot-1.png deleted file mode 100644 index a25bdde..0000000 Binary files a/man/figures/pc_plot-1.png and /dev/null differ diff --git a/man/figures/plot1-1.png b/man/figures/plot1-1.png deleted file mode 100644 index 313d446..0000000 Binary files a/man/figures/plot1-1.png and /dev/null differ diff --git a/man/figures/plot2-1.png b/man/figures/plot2-1.png deleted file mode 100644 index c428d2e..0000000 Binary files a/man/figures/plot2-1.png and /dev/null differ diff --git a/man/figures/unnamed-chunk-10-1.png b/man/figures/unnamed-chunk-10-1.png deleted file mode 100644 index 2346256..0000000 Binary files a/man/figures/unnamed-chunk-10-1.png and /dev/null differ diff --git a/man/figures/unnamed-chunk-11-1.png b/man/figures/unnamed-chunk-11-1.png deleted file mode 100644 index 6c0790a..0000000 Binary files a/man/figures/unnamed-chunk-11-1.png and /dev/null differ diff --git a/man/figures/unnamed-chunk-12-1.png b/man/figures/unnamed-chunk-12-1.png deleted file mode 100644 index ec56172..0000000 Binary files a/man/figures/unnamed-chunk-12-1.png and /dev/null differ diff --git a/man/figures/unnamed-chunk-15-1.png b/man/figures/unnamed-chunk-15-1.png deleted file mode 100644 index 27de944..0000000 Binary files a/man/figures/unnamed-chunk-15-1.png and /dev/null differ diff --git a/man/figures/unnamed-chunk-16-1.png b/man/figures/unnamed-chunk-16-1.png deleted file mode 100644 index 2b36e12..0000000 Binary files a/man/figures/unnamed-chunk-16-1.png and /dev/null differ diff --git a/man/figures/unnamed-chunk-17-1.png b/man/figures/unnamed-chunk-17-1.png deleted file mode 100644 index b57f073..0000000 Binary files a/man/figures/unnamed-chunk-17-1.png and /dev/null differ diff --git a/man/figures/unnamed-chunk-19-1.png b/man/figures/unnamed-chunk-19-1.png deleted file mode 100644 index 1d68b6e..0000000 Binary files a/man/figures/unnamed-chunk-19-1.png and /dev/null differ diff --git a/man/figures/unnamed-chunk-20-1.png b/man/figures/unnamed-chunk-20-1.png deleted file mode 100644 index 633c476..0000000 Binary files a/man/figures/unnamed-chunk-20-1.png and /dev/null differ diff --git a/man/filter.Rd b/man/filter.Rd index 7401b69..4a0312e 100644 --- a/man/filter.Rd +++ b/man/filter.Rd @@ -99,8 +99,8 @@ The following methods are currently available in loaded packages: } \examples{ -pbmc_small |> - filter(groups == "g1") +data(pbmc_small) +pbmc_small |> filter(groups == "g1") # Learn more in ?dplyr_tidy_eval diff --git a/man/formatting.Rd b/man/formatting.Rd index a0b759e..6268be8 100644 --- a/man/formatting.Rd +++ b/man/formatting.Rd @@ -21,6 +21,10 @@ Otherwise, will print as many rows as specified by the \item{width}{Width of text output to generate. This defaults to \code{NULL}, which means use the \code{width} \link[pillar:pillar_options]{option}.} } +\value{ +Prints a message to the console describing + the contents of the `tidySingleCellExperiment`. +} \description{ One of the main features of the \code{tbl_df} class is the printing: \itemize{ @@ -46,6 +50,7 @@ See \code{vignette("extending", package = "pillar")} for details, and \link[pillar:pillar_options]{pillar::pillar_options} for options that control the display in the console. } \examples{ +data(pbmc_small) print(pbmc_small) } diff --git a/man/full_join.Rd b/man/full_join.Rd index 2d77f69..efc2976 100644 --- a/man/full_join.Rd +++ b/man/full_join.Rd @@ -158,6 +158,7 @@ Methods available in currently loaded packages: } \examples{ +data(pbmc_small) tt <- pbmc_small tt |> full_join(tibble::tibble(groups="g1", other=1:4)) diff --git a/man/ggplot.Rd b/man/ggplot.Rd index cafabda..e034fcb 100644 --- a/man/ggplot.Rd +++ b/man/ggplot.Rd @@ -20,6 +20,9 @@ If not specified, must be supplied in each layer added to the plot.} \item{environment}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}} Used prior to tidy evaluation.} } +\value{ +`ggplot` +} \description{ \code{ggplot()} initializes a ggplot object. It can be used to declare the input data frame for a graphic and to specify the @@ -60,6 +63,7 @@ below, however, they are left in place for clarity. } \examples{ library(ggplot2) +data(pbmc_small) pbmc_small |> ggplot(aes(groups, nCount_RNA)) + geom_boxplot() diff --git a/man/glimpse.Rd b/man/glimpse.Rd index 2be4ce9..4db8b9d 100644 --- a/man/glimpse.Rd +++ b/man/glimpse.Rd @@ -40,6 +40,7 @@ See \code{\link[pillar:format_glimpse]{format_glimpse()}} for details on the for } \examples{ +data(pbmc_small) pbmc_small |> glimpse() } diff --git a/man/group_by.Rd b/man/group_by.Rd index e38aa21..029f20c 100644 --- a/man/group_by.Rd +++ b/man/group_by.Rd @@ -91,8 +91,8 @@ also force calls to \code{\link[dplyr:arrange]{arrange()}} to use the system loc } \examples{ -pbmc_small |> - group_by(groups) +data(pbmc_small) +pbmc_small |> group_by(groups) } \seealso{ diff --git a/man/inner_join.Rd b/man/inner_join.Rd index c79c265..4f4a799 100644 --- a/man/inner_join.Rd +++ b/man/inner_join.Rd @@ -158,6 +158,7 @@ Methods available in currently loaded packages: } \examples{ +data(pbmc_small) tt <- pbmc_small tt |> inner_join(tt |> distinct(groups) |> diff --git a/man/join_features.Rd b/man/join_features.Rd index 9426652..2d43d5b 100644 --- a/man/join_features.Rd +++ b/man/join_features.Rd @@ -40,7 +40,7 @@ This function extracts information for specified features and returns the information in either long or wide format. } \examples{ -data("pbmc_small") +data(pbmc_small) pbmc_small \%>\% join_features( features=c("HLA-DRA", "LYZ")) diff --git a/man/left_join.Rd b/man/left_join.Rd index 5f122ce..0c10d0e 100644 --- a/man/left_join.Rd +++ b/man/left_join.Rd @@ -158,6 +158,7 @@ Methods available in currently loaded packages: } \examples{ +data(pbmc_small) tt <- pbmc_small tt |> left_join(tt |> distinct(groups) |> diff --git a/man/mutate.Rd b/man/mutate.Rd index 00b3b66..5a55b69 100644 --- a/man/mutate.Rd +++ b/man/mutate.Rd @@ -99,8 +99,8 @@ Methods available in currently loaded packages: } \examples{ -pbmc_small |> - mutate(nFeature_RNA=1) +data(pbmc_small) +pbmc_small |> mutate(nFeature_RNA=1) } \seealso{ diff --git a/man/nest.Rd b/man/nest.Rd index 2a7b0c6..a74ff6b 100644 --- a/man/nest.Rd +++ b/man/nest.Rd @@ -29,6 +29,9 @@ the former outer names. If a string, the new inner names will use the outer names with \code{names_sep} automatically stripped. This makes \code{names_sep} roughly symmetric between nesting and unnesting.} } +\value{ +`tidySingleCellExperiment_nested` +} \description{ Nesting creates a list-column of data frames; unnesting flattens it back out into regular columns. Nesting is implicitly a summarising operation: you @@ -78,6 +81,7 @@ represent what you are nesting by. } \examples{ +data(pbmc_small) pbmc_small |> nest(data=-groups) |> unnest(data) diff --git a/man/pbmc_small.Rd b/man/pbmc_small.Rd index 8d2b9ed..57a4ebd 100644 --- a/man/pbmc_small.Rd +++ b/man/pbmc_small.Rd @@ -5,8 +5,9 @@ \alias{pbmc_small} \title{pbmc_small} \format{ -A SingleCellExperiment object containing 80 Peripheral Blood - Mononuclear Cells (PBMC) from 10x Genomics. Generated by subsampling the PBMC dataset of 2,700 single cells. +A `SingleCellExperiment` object containing 80 Peripheral Blood + Mononuclear Cells (PBMC) from 10x Genomics. Generated by subsampling + the PBMC dataset of 2,700 single cells. } \source{ \url{https://satijalab.org/seurat/v3.1/pbmc3k_tutorial.html} @@ -14,7 +15,10 @@ A SingleCellExperiment object containing 80 Peripheral Blood \usage{ data(pbmc_small) } +\value{ +`tidySingleCellExperiment` +} \description{ -PBMC single cell RNA-seq data in SingleCellExperiment format +PBMC single cell RNA-seq data in `SingleCellExperiment` format. } \keyword{datasets} diff --git a/man/pbmc_small_nested_interactions.Rd b/man/pbmc_small_nested_interactions.Rd index 128ed26..609c8be 100644 --- a/man/pbmc_small_nested_interactions.Rd +++ b/man/pbmc_small_nested_interactions.Rd @@ -3,10 +3,12 @@ \docType{data} \name{pbmc_small_nested_interactions} \alias{pbmc_small_nested_interactions} -\title{Intercellular ligand-receptor interactions for 38 ligands from a single cell RNA-seq cluster.} +\title{Intercellular ligand-receptor interactions for +38 ligands from a single cell RNA-seq cluster.} \format{ -A tibble containing 100 rows and 9 columns. Cells are a subsample of - the PBMC dataset of 2,700 single cells. Cell interactions were identified with SingleCellSignalR. +A `tibble` containing 100 rows and 9 columns. + Cells are a subsample of the PBMC dataset of 2,700 single cells. + Cell interactions were identified with `SingleCellSignalR`. \describe{ \item{sample}{sample identifier} \item{ligand}{cluster and ligand identifier} @@ -25,8 +27,12 @@ A tibble containing 100 rows and 9 columns. Cells are a subsample of \usage{ data(pbmc_small_nested_interactions) } +\value{ +`tibble` +} \description{ -A dataset containing ligand-receptor interactions withibn a sample. There are 38 ligands from a single cell cluster versus -35 receptors in 6 other clusters. +A dataset containing ligand-receptor interactions within a sample. +There are 38 ligands from a single cell cluster versus 35 receptors +in 6 other clusters. } \keyword{datasets} diff --git a/man/pivot_longer.Rd b/man/pivot_longer.Rd index 4bd3acb..a8a368b 100644 --- a/man/pivot_longer.Rd +++ b/man/pivot_longer.Rd @@ -115,6 +115,9 @@ in the \code{value_to} column. This effectively converts explicit missing values to implicit missing values, and should generally be used only when missing values in \code{data} were created by its structure.} } +\value{ +`tidySingleCellExperiment` +} \description{ \code{pivot_longer()} "lengthens" data, increasing the number of rows and decreasing the number of columns. The inverse transformation is @@ -129,7 +132,7 @@ simpler to use and to handle more use cases. We recommend you use under active development. } \examples{ -# See vignette("pivot") for examples and explanation +data(pbmc_small) pbmc_small |> pivot_longer( cols=c(orig.ident, groups), names_to="name", values_to="value") diff --git a/man/plotly.Rd b/man/plotly.Rd index f1ec22b..c06b179 100644 --- a/man/plotly.Rd +++ b/man/plotly.Rd @@ -170,6 +170,9 @@ Any \code{lty} (see \link{par}) value or \href{https://plotly.com/r/reference/#s with the source argument in \code{\link[plotly:event_data]{event_data()}} to retrieve the event data corresponding to a specific plot (shiny apps can have multiple plots).} } +\value{ +`plotly` +} \description{ This function maps R objects to \href{https://plotly.com/javascript/}{plotly.js}, an (MIT licensed) web-based interactive charting library. It provides diff --git a/man/pull.Rd b/man/pull.Rd index f539535..945c577 100644 --- a/man/pull.Rd +++ b/man/pull.Rd @@ -52,6 +52,7 @@ The following methods are currently available in loaded packages: } \examples{ +data(pbmc_small) pbmc_small |> pull(groups) } diff --git a/man/rename.Rd b/man/rename.Rd index 9f318b1..8cdc32b 100644 --- a/man/rename.Rd +++ b/man/rename.Rd @@ -45,8 +45,8 @@ The following methods are currently available in loaded packages: } \examples{ -pbmc_small |> - rename(s_score=nFeature_RNA) +data(pbmc_small) +pbmc_small |> rename(s_score=nFeature_RNA) } \seealso{ diff --git a/man/right_join.Rd b/man/right_join.Rd index 4487c89..293a71d 100644 --- a/man/right_join.Rd +++ b/man/right_join.Rd @@ -158,6 +158,7 @@ Methods available in currently loaded packages: } \examples{ +data(pbmc_small) tt <- pbmc_small tt |> right_join(tt |> distinct(groups) |> diff --git a/man/sample_n.Rd b/man/sample_n.Rd index 65bcb03..62d4a72 100644 --- a/man/sample_n.Rd +++ b/man/sample_n.Rd @@ -29,6 +29,9 @@ the input. Weights are automatically standardised to sum to 1.} \item{...}{ignored} } +\value{ +`tidySingleCellExperiment` +} \description{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#superseded}{\figure{lifecycle-superseded.svg}{options: alt='[Superseded]'}}}{\strong{[Superseded]}} \code{sample_n()} and \code{sample_frac()} have been superseded in favour of @@ -51,6 +54,7 @@ undocumented. } } \examples{ +data(pbmc_small) pbmc_small |> sample_n(50) pbmc_small |> sample_frac(0.1) diff --git a/man/select.Rd b/man/select.Rd index 9a08f0f..261a090 100644 --- a/man/select.Rd +++ b/man/select.Rd @@ -247,6 +247,7 @@ To take the difference between two selections, combine the \code{&} and } \examples{ +data(pbmc_small) pbmc_small |> select(cell, orig.ident) } diff --git a/man/separate.Rd b/man/separate.Rd index d0f8262..9f0d600 100644 --- a/man/separate.Rd +++ b/man/separate.Rd @@ -63,6 +63,9 @@ happens when there are not enough pieces. There are three valid options: \item{...}{Additional arguments passed on to methods.} } +\value{ +`tidySingleCellExperiment` +} \description{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#superseded}{\figure{lifecycle-superseded.svg}{options: alt='[Superseded]'}}}{\strong{[Superseded]}} @@ -76,6 +79,7 @@ Given either a regular expression or a vector of character positions, \code{separate()} turns a single character column into multiple columns. } \examples{ +data(pbmc_small) un <- pbmc_small |> unite("new_col", c(orig.ident, groups)) un |> separate(new_col, c("orig.ident", "groups")) diff --git a/man/slice.Rd b/man/slice.Rd index 268cf7d..175f6b2 100644 --- a/man/slice.Rd +++ b/man/slice.Rd @@ -86,6 +86,7 @@ Methods available in currently loaded packages: } \examples{ +data(pbmc_small) pbmc_small |> slice(1) } diff --git a/man/summarise.Rd b/man/summarise.Rd index 2b1c63f..df30ca5 100644 --- a/man/summarise.Rd +++ b/man/summarise.Rd @@ -93,8 +93,8 @@ The following methods are currently available in loaded packages: } \examples{ -pbmc_small |> - summarise(mean(nCount_RNA)) +data(pbmc_small) +pbmc_small |> summarise(mean(nCount_RNA)) } \seealso{ diff --git a/man/tidy.Rd b/man/tidy.Rd index a84756a..144cb68 100644 --- a/man/tidy.Rd +++ b/man/tidy.Rd @@ -19,6 +19,7 @@ A `tidySingleCellExperiment` object. tidy for `SingleCellExperiment` } \examples{ -tidySingleCellExperiment::pbmc_small +data(pbmc_small) +pbmc_small } diff --git a/man/unite.Rd b/man/unite.Rd index e65c56d..6c90d88 100644 --- a/man/unite.Rd +++ b/man/unite.Rd @@ -28,13 +28,17 @@ tidyverse; we support it here for backward compatibility).} \item{na.rm}{If \code{TRUE}, missing values will be removed prior to uniting each value.} } +\value{ +`tidySingleCellExperiment` +} \description{ Convenience function to paste together multiple columns into one. } \examples{ +data(pbmc_small) pbmc_small |> unite( col="new_col", - c(orig.ident, groups)) + c("orig.ident", "groups")) } \seealso{ diff --git a/man/unnest.Rd b/man/unnest.Rd index 36c8554..8427717 100644 --- a/man/unnest.Rd +++ b/man/unnest.Rd @@ -91,6 +91,9 @@ convert \code{df \%>\% unnest(x, .id = "id")} to \verb{df \%>\% mutate(id = name \item{.sep}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}}: use \code{names_sep} instead.} } +\value{ +`tidySingleCellExperiment` +} \description{ Unnest expands a list-column containing data frames into rows and columns. } @@ -111,6 +114,7 @@ unnest <- unnest_legacy } \examples{ +data(pbmc_small) pbmc_small |> nest(data=-groups) |> unnest(data) diff --git a/tests/testthat/test-dplyr_methods.R b/tests/testthat/test-dplyr_methods.R index 50d5656..1a07ac9 100755 --- a/tests/testthat/test-dplyr_methods.R +++ b/tests/testthat/test-dplyr_methods.R @@ -1,3 +1,4 @@ +data(pbmc_small) df <- pbmc_small df$number <- sample(seq(ncol(df))) df$factor <- sample( @@ -82,11 +83,11 @@ test_that("mutate()", { # special columns are blocked df |> mutate(.cell=1) |> - expect_error(regexp = "you are trying to mutate a column that is view only") + expect_error("you are trying to mutate a column that is view only") df |> mutate(PC_10=1) |> - expect_error(regexp = "you are trying to mutate a column that is view only") + expect_error("you are trying to mutate a column that is view only") }) test_that("rename()", { @@ -96,27 +97,27 @@ test_that("rename()", { df |> rename(ne=mo) |> - expect_error(regexp = "Column `mo` doesn't exist") + expect_error("Column `mo` doesn't exist") # special columns are blocked # ...'to' cannot be special df |> rename(a=PC_1) |> - expect_error(regexp = "you are trying to rename a column that is view only") + expect_error("you are trying to rename a column that is view only") df |> rename(a=.cell) |> - expect_error(regexp = "you are trying to rename a column that is view only") + expect_error("you are trying to rename a column that is view only") # ...'from' cannot be special df |> rename(PC_1=number) |> - expect_error(regexp = "These names are duplicated") + expect_error("These names are duplicated") df |> rename(.cell=number) |> - expect_error(regexp = "These names are duplicated") + expect_error("These names are duplicated") }) test_that("left_join()", { @@ -223,7 +224,7 @@ test_that("add_count()", { test_that("rowwise()", { df |> summarise(sum(lys)) |> - expect_error(regexp = "object 'lys' not found") + expect_error("object 'lys' not found") df$lys <- replicate(ncol(df), sample(10, 3), FALSE) fd <- df |> rowwise() |> summarise(sum(lys)) diff --git a/tests/testthat/test-ggplotly_methods.R b/tests/testthat/test-ggplotly_methods.R index 6041ad2..a02e84e 100644 --- a/tests/testthat/test-ggplotly_methods.R +++ b/tests/testthat/test-ggplotly_methods.R @@ -1,3 +1,4 @@ +data(pbmc_small) df <- pbmc_small df$number <- rnorm(ncol(df)) df$factor <- sample(gl(3, 1, ncol(df))) diff --git a/tests/testthat/test-methods.R b/tests/testthat/test-methods.R index 4cabdf5..b42540e 100644 --- a/tests/testthat/test-methods.R +++ b/tests/testthat/test-methods.R @@ -1,8 +1,8 @@ +data(pbmc_small) df <- pbmc_small test_that("show()", { txt <- capture.output(show(df)) - expect_lt(length(txt), 20) expect_equal(grep("SingleCellExperiment", txt), 1) i <- grep(str <- ".*Features=([0-9]+).*", txt) expect_equal(gsub(str, "\\1", txt[i]), paste(nrow(df))) diff --git a/tests/testthat/test-tidyr_methods.R b/tests/testthat/test-tidyr_methods.R index be0b9de..4fb92e1 100755 --- a/tests/testthat/test-tidyr_methods.R +++ b/tests/testthat/test-tidyr_methods.R @@ -1,3 +1,4 @@ +data(pbmc_small) df <- pbmc_small df$number <- sample(seq(ncol(df))) df$factor <- sample(gl(2, 1, ncol(df), c("g1", "g2"))) @@ -18,10 +19,10 @@ test_that("un/nest()", { }) test_that("unite()/separate()", { - expect_error(unite(df, "x", c(number, x))) + expect_error(unite(df, "x", c("number", "x"))) expect_error(separate(df, x, c("a", "b"))) - fd <- unite(df, "string", c(number, factor), sep=":") + fd <- unite(df, "string", c("number", "factor"), sep=":") expect_null(fd$number) expect_null(fd$factor) expect_identical(fd$string, paste(df$number, df$factor, sep=":")) @@ -32,7 +33,7 @@ test_that("unite()/separate()", { expect_identical(fd$b, paste(df$factor)) # special columns are blocked - expect_error(unite(df, ".cell", c(number, factor), sep=":")) + expect_error(unite(df, ".cell", c("number", "factor"), sep=":")) fd <- df; colnames(fd) <- paste(colnames(df), "x", sep="-") expect_error(separate(fd, .cell, c("a", "b"), sep="-")) }) diff --git a/vignettes/introduction.Rmd b/vignettes/introduction.Rmd index 4125c80..680b2cb 100755 --- a/vignettes/introduction.Rmd +++ b/vignettes/introduction.Rmd @@ -73,11 +73,12 @@ library(dittoSeq) # Data representation of `tidySingleCellExperiment` -This is a `SingleCellExperiment` object but it is evaluated as a tibble. +This is a `SingleCellExperiment` object but it is evaluated as a `tibble`. So it is compatible both with `SingleCellExperiment` and *tidyverse*. ```{r} -pbmc_small_tidy <- tidySingleCellExperiment::pbmc_small +data(pbmc_small, package="tidySingleCellExperiment") +pbmc_small_tidy <- pbmc_small ``` **It looks like a `tibble`...** @@ -308,6 +309,7 @@ cell_type_df <- ```{r} # Join UMAP and cell type info +data(cell_type_df) pbmc_small_cell_type <- pbmc_small_UMAP %>% left_join(cell_type_df, by="cell") @@ -420,7 +422,7 @@ pbmc_small_nested_reanalysed %>% custom_theme ``` -We can perform a large number of functional analyses on data subsets. For example, we can identify intra-sample cell-cell interactions using *SingleCellSignalR* [@cabello2020singlecellsignalr], and then compare whether interactions are stronger or weaker across conditions. The code below demonstrates how this analysis could be performed. It won't work with this small example dataset as we have just two samples (one for each condition). But some example output is shown below and you can imagine how you can use tidyverse on the output to perform t-tests and visualisation. +We can perform a large number of functional analyses on data subsets. For example, we can identify intra-sample cell-cell interactions using `SingleCellSignalR` [@cabello2020singlecellsignalr], and then compare whether interactions are stronger or weaker across conditions. The code below demonstrates how this analysis could be performed. It won't work with this small example dataset as we have just two samples (one for each condition). But some example output is shown below and you can imagine how you can use tidyverse on the output to perform t-tests and visualisation. ```{r, eval=FALSE} pbmc_small_nested_interactions <- @@ -430,8 +432,8 @@ pbmc_small_nested_interactions <- # Create unambiguous clusters mutate(integrated_clusters=first.labels %>% as.factor() %>% as.integer()) %>% # Nest based on sample - tidySingleCellExperiment::nest(data=-sample) %>% - tidySingleCellExperiment::mutate(interactions=map(data, ~ { + nest(data=-sample) %>% + mutate(interactions=map(data, ~ { # Produce variables. Yuck! cluster <- colData(.x)$integrated_clusters data <- data.frame(assay(.x) %>% as.matrix()) @@ -452,7 +454,8 @@ If the dataset was not so small, and interactions could be identified, you would see something like below. ```{r} -tidySingleCellExperiment::pbmc_small_nested_interactions +data(pbmc_small_nested_interactions) +pbmc_small_nested_interactions ``` # Aggregating cells