From 5ac207ed704858163625995b0c7f142cc7c12deb Mon Sep 17 00:00:00 2001 From: Biomiha Date: Wed, 23 Aug 2023 20:48:17 +0100 Subject: [PATCH 001/140] test change print_method.R --- R/print_method.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/print_method.R b/R/print_method.R index 14d0ec6..2bc8980 100755 --- a/R/print_method.R +++ b/R/print_method.R @@ -36,7 +36,7 @@ tbl_format_header.tidySingleCellExperiment <- function(x, setup, ...){ # Add further info single-cell append(sprintf( - "\033[90m Features=%s | Cells=%s | Assays=%s\033[39m", + "\033[90m Creatures=%s | Cells=%s | Assays=%s\033[39m", number_of_features, nrow(x), assay_names %>% paste(collapse=", ") From c1db700e2102a88c11276cd2c2b54cdd6afc3e42 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Wed, 23 Aug 2023 21:52:05 +0100 Subject: [PATCH 002/140] Update print_method.R --- R/print_method.R | 89 +++++++++++++++++++++++------------------------- 1 file changed, 42 insertions(+), 47 deletions(-) diff --git a/R/print_method.R b/R/print_method.R index 2bc8980..813c699 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,56 @@ #' @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 Creatures=%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") + altExpNames <- x |> attr("altExpNames") + + # 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 | altExpNames=%s\033[39m", + number_of_features, nrow(x), + paste(assay_names, collapse=", "), + paste(altExpNames, 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 +#' @importFrom SingleCellExperiment altExpNames #' @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") %>% + add_attr(altExpNames(x), "altExpNames") %>% + print() + + invisible(x) } From 5a5b71b43e8c56c35a9c084e7df734adca78c682 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Wed, 23 Aug 2023 22:04:15 +0100 Subject: [PATCH 003/140] Update print_method.R --- R/print_method.R | 16 ++++++++++++---- 1 file changed, 12 insertions(+), 4 deletions(-) diff --git a/R/print_method.R b/R/print_method.R index 813c699..dc16e69 100755 --- a/R/print_method.R +++ b/R/print_method.R @@ -31,12 +31,20 @@ tbl_format_header.tidySingleCellExperiment <- function(x, setup, ...) { align(paste0(names2(named_header), ":"), space=NBSP), " ", named_header) %>% # Add further info single-cell + if(length(altExpNames) != 0) { append(sprintf( - "\033[90m Features=%s | Cells=%s | Assays=%s | altExpNames=%s\033[39m", - number_of_features, nrow(x), - paste(assay_names, collapse=", "), - paste(altExpNames, collapse=", ") + "\033[90m Features=%s | Cells=%s | Assays=%s | altExpNames=%s\033[39m", + number_of_features, nrow(x), + paste(assay_names, collapse=", "), + paste(altExpNames, collapse=", ") ), after=1) + } else { + 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)) } From 67a48f04c31c76f7b7f28a7d6b2def9ca5cfe692 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Wed, 23 Aug 2023 22:17:02 +0100 Subject: [PATCH 004/140] Update print_method.R --- R/print_method.R | 14 +++----------- 1 file changed, 3 insertions(+), 11 deletions(-) diff --git a/R/print_method.R b/R/print_method.R index dc16e69..13127e5 100755 --- a/R/print_method.R +++ b/R/print_method.R @@ -31,20 +31,12 @@ tbl_format_header.tidySingleCellExperiment <- function(x, setup, ...) { align(paste0(names2(named_header), ":"), space=NBSP), " ", named_header) %>% # Add further info single-cell - if(length(altExpNames) != 0) { - append(sprintf( + append(sprintf( "\033[90m Features=%s | Cells=%s | Assays=%s | altExpNames=%s\033[39m", number_of_features, nrow(x), paste(assay_names, collapse=", "), - paste(altExpNames, collapse=", ") - ), after=1) - } else { - append(sprintf( - "\033[90m Features=%s | Cells=%s | Assays=%s\033[39m", - number_of_features, nrow(x), - paste(assay_names, collapse=", ") - ), after=1) - } + if(length(nchar(altExpNames)) > 0) paste(altExpNames, collapse=", ") else {"NULL"} + ), after=1) } style_subtle(pillar___format_comment(header, width=setup$width)) } From 430cdff628a1371ab63066a409b21ca511fe0af3 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Sun, 27 Aug 2023 17:16:27 +0100 Subject: [PATCH 005/140] Update print_method.R --- R/print_method.R | 84 +++++++++++++++++++++++++++--------------------- 1 file changed, 47 insertions(+), 37 deletions(-) diff --git a/R/print_method.R b/R/print_method.R index 13127e5..c155ea1 100755 --- a/R/print_method.R +++ b/R/print_method.R @@ -4,10 +4,10 @@ #' @name tbl_format_header #' @rdname tbl_format_header #' @inherit pillar::tbl_format_header -#' +#' #' @examples #' # TODO -#' +#' #' @importFrom rlang names2 #' @importFrom pillar align #' @importFrom pillar get_extent @@ -15,30 +15,41 @@ #' @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") - altExpNames <- x |> attr("altExpNames") - - # 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 | altExpNames=%s\033[39m", - number_of_features, nrow(x), - paste(assay_names, collapse=", "), - if(length(nchar(altExpNames)) > 0) paste(altExpNames, collapse=", ") else {"NULL"} - ), after=1) - } - style_subtle(pillar___format_comment(header, width=setup$width)) + 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), + if(length(names(altExps(x))) > 0) { + main_exp_assay_string <- paste(names(assays(x)), collapse = ", ") + alt_exp_assays <- map(.x = seq_along(altExps(x)), .f = \(.num) names(assays(altExps(x)[[.num]]))) |> + set_names(altExpNames(x)) |> + enframe() + + alt_exp_assay_string <- alt_exp_assays |> + unnest(value) |> + mutate(alt_exp_string = map_chr(.x = seq_along(name), .f = \(.num) paste(name[[.num]], value[[.num]], sep = "-"))) |> + pull(alt_exp_string) |> + paste0(collapse = ", ") + paste0(main_exp_assay_string, ", ", alt_exp_assay_string) + } else paste(names(assays(x)), collapse = ", ") + ), after = 1) + } + style_subtle(pillar___format_comment(header, width = setup$width)) } #' @name formatting @@ -51,19 +62,18 @@ tbl_format_header.tidySingleCellExperiment <- function(x, setup, ...) { #' @examples #' data(pbmc_small) #' print(pbmc_small) -#' +#' #' @importFrom vctrs new_data_frame #' @importFrom SummarizedExperiment assayNames #' @importFrom SingleCellExperiment altExpNames #' @export -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") %>% - add_attr(altExpNames(x), "altExpNames") %>% - 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) } From 5aaba6a6841892bab8f0fb78283d099b77c4671b Mon Sep 17 00:00:00 2001 From: Biomiha Date: Mon, 28 Aug 2023 18:01:44 +0100 Subject: [PATCH 006/140] Update print_method.R --- R/print_method.R | 14 ++++---------- 1 file changed, 4 insertions(+), 10 deletions(-) diff --git a/R/print_method.R b/R/print_method.R index c155ea1..51ba67d 100755 --- a/R/print_method.R +++ b/R/print_method.R @@ -36,16 +36,10 @@ tbl_format_header.tidySingleCellExperiment <- function(x, setup, ...) { nrow(x), if(length(names(altExps(x))) > 0) { main_exp_assay_string <- paste(names(assays(x)), collapse = ", ") - alt_exp_assays <- map(.x = seq_along(altExps(x)), .f = \(.num) names(assays(altExps(x)[[.num]]))) |> - set_names(altExpNames(x)) |> - enframe() - - alt_exp_assay_string <- alt_exp_assays |> - unnest(value) |> - mutate(alt_exp_string = map_chr(.x = seq_along(name), .f = \(.num) paste(name[[.num]], value[[.num]], sep = "-"))) |> - pull(alt_exp_string) |> - paste0(collapse = ", ") - paste0(main_exp_assay_string, ", ", alt_exp_assay_string) + alt_exp_assays <- list() + assay_names_list <- lapply(altExps(x), assayNames) + assay_names_df <- stack(assay_names_list) + paste(assay_names_df$ind, assay_names_df$values, sep = "-") } else paste(names(assays(x)), collapse = ", ") ), after = 1) } From 672ef06fd83e2d1abc32b1f40254d6913ba2c936 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Mon, 28 Aug 2023 18:06:28 +0100 Subject: [PATCH 007/140] Update print_method.R From af9204b9f7dc5892182aab4a798018024eb686dd Mon Sep 17 00:00:00 2001 From: Biomiha Date: Mon, 28 Aug 2023 18:13:16 +0100 Subject: [PATCH 008/140] Update print_method.R --- R/print_method.R | 8 ++------ 1 file changed, 2 insertions(+), 6 deletions(-) diff --git a/R/print_method.R b/R/print_method.R index 51ba67d..3791888 100755 --- a/R/print_method.R +++ b/R/print_method.R @@ -35,12 +35,8 @@ tbl_format_header.tidySingleCellExperiment <- function(x, setup, ...) { number_of_features, nrow(x), if(length(names(altExps(x))) > 0) { - main_exp_assay_string <- paste(names(assays(x)), collapse = ", ") - alt_exp_assays <- list() - assay_names_list <- lapply(altExps(x), assayNames) - assay_names_df <- stack(assay_names_list) - paste(assay_names_df$ind, assay_names_df$values, sep = "-") - } else paste(names(assays(x)), collapse = ", ") + print("yes") + } else print("no") ), after = 1) } style_subtle(pillar___format_comment(header, width = setup$width)) From a8f1bb247b43e8ad43d5f1f20fb9aea70d817452 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Mon, 28 Aug 2023 18:15:18 +0100 Subject: [PATCH 009/140] Update print_method.R --- R/print_method.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/print_method.R b/R/print_method.R index 3791888..4ecc194 100755 --- a/R/print_method.R +++ b/R/print_method.R @@ -35,8 +35,8 @@ tbl_format_header.tidySingleCellExperiment <- function(x, setup, ...) { number_of_features, nrow(x), if(length(names(altExps(x))) > 0) { - print("yes") - } else print("no") + paste(assayNames(x) + } else "no" ), after = 1) } style_subtle(pillar___format_comment(header, width = setup$width)) From 97dfdc9487738f2e757877f01f3974997fe9e170 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Mon, 28 Aug 2023 18:39:33 +0100 Subject: [PATCH 010/140] Update print_method.R --- R/print_method.R | 18 +++++++++++++++--- 1 file changed, 15 insertions(+), 3 deletions(-) diff --git a/R/print_method.R b/R/print_method.R index 4ecc194..cf382eb 100755 --- a/R/print_method.R +++ b/R/print_method.R @@ -30,13 +30,25 @@ tbl_format_header.tidySingleCellExperiment <- function(x, setup, ...) { " ", named_header ) %>% # Add further info single-cell + if(length(names(altExps(x))) > 0) { + main_exp_assay_string <- paste(names(assays(x)), collapse = ", ") + alt_exp_assays <- list() + assay_names_list <- lapply(altExps(x), assayNames) + assay_names_df <- stack(assay_names_list) + append(sprintf( "\033[90m Features=%s | Cells=%s | Assays=%s\033[39m", number_of_features, nrow(x), - if(length(names(altExps(x))) > 0) { - paste(assayNames(x) - } else "no" + paste0(main_exp_assay_string, ", ", paste0(paste(assay_names_df$ind, assay_names_df$values, sep = "-"), + collapse = ", ")) + } else { + append(sprintf( + "\033[90m Features=%s | Cells=%s | Assays=%s\033[39m", + number_of_features, + nrow(x), + paste(assayNames(x), collapse = ", "))) + } ), after = 1) } style_subtle(pillar___format_comment(header, width = setup$width)) From 7f41b60ffea7ca65d3b4379a0fb50b60e1eb5176 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Mon, 28 Aug 2023 19:04:48 +0100 Subject: [PATCH 011/140] Update print_method.R --- R/print_method.R | 26 +++++++++++++------------- 1 file changed, 13 insertions(+), 13 deletions(-) diff --git a/R/print_method.R b/R/print_method.R index cf382eb..875a168 100755 --- a/R/print_method.R +++ b/R/print_method.R @@ -30,25 +30,25 @@ tbl_format_header.tidySingleCellExperiment <- function(x, setup, ...) { " ", named_header ) %>% # Add further info single-cell - if(length(names(altExps(x))) > 0) { - main_exp_assay_string <- paste(names(assays(x)), collapse = ", ") - alt_exp_assays <- list() - assay_names_list <- lapply(altExps(x), assayNames) - assay_names_df <- stack(assay_names_list) + # if(length(names(altExps(x))) > 0) { + # main_exp_assay_string <- paste(names(assays(x)), collapse = ", ") + # alt_exp_assays <- list() + # assay_names_list <- lapply(altExps(x), assayNames) + # assay_names_df <- stack(assay_names_list) - append(sprintf( - "\033[90m Features=%s | Cells=%s | Assays=%s\033[39m", - number_of_features, - nrow(x), - paste0(main_exp_assay_string, ", ", paste0(paste(assay_names_df$ind, assay_names_df$values, sep = "-"), - collapse = ", ")) - } else { + # append(sprintf( + # "\033[90m Features=%s | Cells=%s | Assays=%s\033[39m", + # number_of_features, + # nrow(x), + # paste0(main_exp_assay_string, ", ", paste0(paste(assay_names_df$ind, assay_names_df$values, sep = "-"), + # collapse = ", ")) + # } else { append(sprintf( "\033[90m Features=%s | Cells=%s | Assays=%s\033[39m", number_of_features, nrow(x), paste(assayNames(x), collapse = ", "))) - } + # } ), after = 1) } style_subtle(pillar___format_comment(header, width = setup$width)) From d4d45c41a614c22e79a7acb09c3cb17ea394754e Mon Sep 17 00:00:00 2001 From: Biomiha Date: Mon, 28 Aug 2023 19:09:20 +0100 Subject: [PATCH 012/140] Update print_method.R --- R/print_method.R | 30 +++++++++++++++--------------- 1 file changed, 15 insertions(+), 15 deletions(-) diff --git a/R/print_method.R b/R/print_method.R index 875a168..af5ddfd 100755 --- a/R/print_method.R +++ b/R/print_method.R @@ -30,26 +30,26 @@ tbl_format_header.tidySingleCellExperiment <- function(x, setup, ...) { " ", named_header ) %>% # Add further info single-cell - # if(length(names(altExps(x))) > 0) { - # main_exp_assay_string <- paste(names(assays(x)), collapse = ", ") - # alt_exp_assays <- list() - # assay_names_list <- lapply(altExps(x), assayNames) - # assay_names_df <- stack(assay_names_list) + if(length(names(altExps(x))) > 0) { + main_exp_assay_string <- paste(names(assays(x)), collapse = ", ") + alt_exp_assays <- list() + assay_names_list <- lapply(altExps(x), assayNames) + assay_names_df <- stack(assay_names_list) - # append(sprintf( - # "\033[90m Features=%s | Cells=%s | Assays=%s\033[39m", - # number_of_features, - # nrow(x), - # paste0(main_exp_assay_string, ", ", paste0(paste(assay_names_df$ind, assay_names_df$values, sep = "-"), - # collapse = ", ")) - # } else { + append(sprintf( + "\033[90m Features=%s | Cells=%s | Assays=%s\033[39m", + number_of_features, + nrow(x), + paste0(main_exp_assay_string, ", ", paste0(paste(assay_names_df$ind, assay_names_df$values, sep = "-"), + collapse = ", "))), + after = 1) + } else { append(sprintf( "\033[90m Features=%s | Cells=%s | Assays=%s\033[39m", number_of_features, nrow(x), - paste(assayNames(x), collapse = ", "))) - # } - ), after = 1) + paste(assayNames(x), collapse = ", ") + ), after = 1) } style_subtle(pillar___format_comment(header, width = setup$width)) } From ec3735461a21332346d855e682da7265fc9744f7 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Tue, 29 Aug 2023 05:33:11 +0100 Subject: [PATCH 013/140] Update print_method.R --- R/print_method.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/print_method.R b/R/print_method.R index af5ddfd..ad8829b 100755 --- a/R/print_method.R +++ b/R/print_method.R @@ -30,7 +30,7 @@ tbl_format_header.tidySingleCellExperiment <- function(x, setup, ...) { " ", named_header ) %>% # Add further info single-cell - if(length(names(altExps(x))) > 0) { + {if(length(names(altExps(x))) > 0) { main_exp_assay_string <- paste(names(assays(x)), collapse = ", ") alt_exp_assays <- list() assay_names_list <- lapply(altExps(x), assayNames) @@ -50,7 +50,7 @@ tbl_format_header.tidySingleCellExperiment <- function(x, setup, ...) { nrow(x), paste(assayNames(x), collapse = ", ") ), after = 1) - } + }} style_subtle(pillar___format_comment(header, width = setup$width)) } From 434409849b76c1a5296345a71e3d013afc74f48c Mon Sep 17 00:00:00 2001 From: Biomiha Date: Tue, 29 Aug 2023 05:36:14 +0100 Subject: [PATCH 014/140] Update print_method.R --- R/print_method.R | 19 ++----------------- 1 file changed, 2 insertions(+), 17 deletions(-) diff --git a/R/print_method.R b/R/print_method.R index ad8829b..24bd0cf 100755 --- a/R/print_method.R +++ b/R/print_method.R @@ -30,27 +30,12 @@ tbl_format_header.tidySingleCellExperiment <- function(x, setup, ...) { " ", named_header ) %>% # Add further info single-cell - {if(length(names(altExps(x))) > 0) { - main_exp_assay_string <- paste(names(assays(x)), collapse = ", ") - alt_exp_assays <- list() - assay_names_list <- lapply(altExps(x), assayNames) - assay_names_df <- stack(assay_names_list) - append(sprintf( - "\033[90m Features=%s | Cells=%s | Assays=%s\033[39m", + "\033[90m Features=%s | Cells=%s | Assays=%s\033[39m", number_of_features, nrow(x), - paste0(main_exp_assay_string, ", ", paste0(paste(assay_names_df$ind, assay_names_df$values, sep = "-"), - collapse = ", "))), + paste0(assayNames(x), collapse = ", ")), after = 1) - } else { - append(sprintf( - "\033[90m Features=%s | Cells=%s | Assays=%s\033[39m", - number_of_features, - nrow(x), - paste(assayNames(x), collapse = ", ") - ), after = 1) - }} style_subtle(pillar___format_comment(header, width = setup$width)) } From bef9d3a35e5e4d10ec36a89a7dacd7ff94afcb19 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Tue, 29 Aug 2023 05:38:18 +0100 Subject: [PATCH 015/140] Update print_method.R --- R/print_method.R | 20 +++++++++++++------- 1 file changed, 13 insertions(+), 7 deletions(-) diff --git a/R/print_method.R b/R/print_method.R index 24bd0cf..2fc5544 100755 --- a/R/print_method.R +++ b/R/print_method.R @@ -25,18 +25,24 @@ tbl_format_header.tidySingleCellExperiment <- function(x, setup, ...) { if (all(names2(named_header) == "")) { header <- named_header } else { - header <- paste0( - align(paste0(names2(named_header), ":"), space = NBSP), - " ", named_header - ) %>% + 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, + number_of_features, nrow(x), - paste0(assayNames(x), collapse = ", ")), - after = 1) + assay_names %>% paste(collapse=", ") + ), after = 1) + } + style_subtle(pillar___format_comment(header, width = setup$width)) + } #' @name formatting From fd1c9bd65e3447d5463a27bf8f600a02da9eb9fb Mon Sep 17 00:00:00 2001 From: Biomiha Date: Tue, 29 Aug 2023 05:50:06 +0100 Subject: [PATCH 016/140] Update print_method.R --- R/print_method.R | 30 +++++++++++++++++++++--------- 1 file changed, 21 insertions(+), 9 deletions(-) diff --git a/R/print_method.R b/R/print_method.R index 2fc5544..bafcaae 100755 --- a/R/print_method.R +++ b/R/print_method.R @@ -14,17 +14,20 @@ #' @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") +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" + + # Change name + names(named_header) = "A SingleCellExperiment-tibble abstraction" if (all(names2(named_header) == "")) { header <- named_header - } else { + } + else { header <- paste0( align(paste0(names2(named_header), ":"), space = NBSP), @@ -37,7 +40,7 @@ tbl_format_header.tidySingleCellExperiment <- function(x, setup, ...) { "\033[90m Features=%s | Cells=%s | Assays=%s\033[39m", number_of_features, nrow(x), - assay_names %>% paste(collapse=", ") + assay_names ), after = 1) } @@ -60,12 +63,21 @@ tbl_format_header.tidySingleCellExperiment <- function(x, setup, ...) { #' @importFrom SummarizedExperiment assayNames #' @importFrom SingleCellExperiment altExpNames #' @export -print.SingleCellExperiment <- function(x, ..., n = NULL, width = NULL) { +print.SingleCellExperiment <- function(x, ..., n = NULL, width = NULL, n_extra = NULL) { + if (length(names(altExps(x))) > 0) { + alt_exp_assays <- list() + assay_names_list <- lapply(altExps(x), assayNames) + assay_names_df <- stack(assay_names_list) + assay_names_string <- c(assayNames(x), paste(assay_names_df$ind, assay_names_df$values, sep = "-")) |> + paste(collapse = ", ") + } else { + assay_names_string <- paste(assayNames(x), collapse = ", ") + } 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") %>% + add_attr(assay_names_string, "assay_names") %>% print() invisible(x) From 5dbdd24b479e936854dec24152e84dcca5a605d1 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Tue, 29 Aug 2023 06:59:55 +0100 Subject: [PATCH 017/140] Update test-methods.R Add show test for alt experiments --- tests/testthat/test-methods.R | 122 ++++++++++++++++++---------------- 1 file changed, 64 insertions(+), 58 deletions(-) diff --git a/tests/testthat/test-methods.R b/tests/testthat/test-methods.R index 4cabdf5..a6260b7 100644 --- a/tests/testthat/test-methods.R +++ b/tests/testthat/test-methods.R @@ -1,71 +1,77 @@ +data("pbmc_small") +set.seed(2023-08-29) +rand_mat <- matrix(data = runif(n = length(LETTERS) * dim(pbmc_small)[[2]]), ncol = dim(pbmc_small)[[2]]) +colnames(rand_mat) <- rownames(colData(pbmc_small)) +rownames(rand_mat) <- LETTERS +altExps(pbmc_small)[["ADT"]] <- SingleCellExperiment(assays = list(normcounts = rand_mat)) 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))) - i <- grep(str <- ".*Cells=([0-9]+).*", txt) - expect_equal(gsub(str, "\\1", txt[i]), paste(ncol(df))) + 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))) + i <- grep(str <- ".*Cells=([0-9]+).*", txt) + expect_equal(gsub(str, "\\1", txt[i]), paste(ncol(df))) }) test_that("join_features()", { - gs <- sample(rownames(df), 3) - # long - fd <- join_features(df, gs, shape="long") - expect_s3_class(fd, "tbl_df") - expect_setequal(unique(fd$.feature), gs) - expect_true(all(table(fd$.feature) == ncol(df))) - expect_identical( - matrix(fd$.abundance_counts, nrow=length(gs)), - as.matrix(unname(counts(df)[fd$.feature[seq_along(gs)], ]))) - # wide - fd <- join_features(df, gs, shape="wide", assay="counts") - expect_s4_class(fd, "SingleCellExperiment") - expect_null(fd$.feature) - expect_identical( - unname(t(as.matrix(as_tibble(fd)[, make.names(gs)]))), - as.matrix(unname(counts(df)[gs, ]))) + gs <- sample(rownames(df), 3) + # long + fd <- join_features(df, gs, shape="long") + expect_s3_class(fd, "tbl_df") + expect_setequal(unique(fd$.feature), gs) + expect_true(all(table(fd$.feature) == ncol(df))) + expect_identical( + matrix(fd$.abundance_counts, nrow=length(gs)), + as.matrix(unname(counts(df)[fd$.feature[seq_along(gs)], ]))) + # wide + fd <- join_features(df, gs, shape="wide", assay="counts") + expect_s4_class(fd, "SingleCellExperiment") + expect_null(fd$.feature) + expect_identical( + unname(t(as.matrix(as_tibble(fd)[, make.names(gs)]))), + as.matrix(unname(counts(df)[gs, ]))) }) test_that("as_tibble()", { - fd <- as_tibble(df) - expect_s3_class(fd, "tbl_df") - expect_equal(nrow(fd), ncol(df)) - ncd <- ncol(colData(df)) - ndr <- vapply(reducedDims(df), ncol, integer(1)) - expect_equal(ncol(fd), sum(1, ncd, ndr)) - # duplicated PCs - reducedDim(df, "PCB") <- reducedDim(df, "PCA") - fd <- as_tibble(mutate(df, abc=1)) - expect_equal(ncol(fd), ncol(as_tibble(df))+1) + fd <- as_tibble(df) + expect_s3_class(fd, "tbl_df") + expect_equal(nrow(fd), ncol(df)) + ncd <- ncol(colData(df)) + ndr <- vapply(reducedDims(df), ncol, integer(1)) + expect_equal(ncol(fd), sum(1, ncd, ndr)) + # duplicated PCs + reducedDim(df, "PCB") <- reducedDim(df, "PCA") + fd <- as_tibble(mutate(df, abc=1)) + expect_equal(ncol(fd), ncol(as_tibble(df))+1) }) test_that("aggregate_cells()", { - df$factor <- sample(gl(3, 1, ncol(df))) - df$string <- sample(c("a", "b"), ncol(df), TRUE) - tbl <- distinct(select(df, factor, string)) - fd <- aggregate_cells(df, c(factor, string)) - expect_identical(assayNames(fd), assayNames(df)) - # [HLC: aggregate_cells() currently - # reorders features alphabetically] - fd <- fd[rownames(df), ] - expect_s4_class(fd, "SummarizedExperiment") - expect_equal(dim(fd), c(nrow(df), nrow(tbl))) - foo <- mapply( - f=tbl$factor, - s=tbl$string, - \(f, s) { - expect_identical( - df |> - filter(factor == f, string == s) |> - assay() |> rowSums() |> as.vector(), - fd[, fd$factor == f & fd$string == s] |> - assay() |> as.vector()) - }) - # specified 'assays' are subsetted - expect_error(aggregate_cells(df, c(factor, string), assays="x")) - fd <- aggregate_cells(df, c(factor, string), assays="counts") - expect_identical(assayNames(fd), "counts") + df$factor <- sample(gl(3, 1, ncol(df))) + df$string <- sample(c("a", "b"), ncol(df), TRUE) + tbl <- distinct(select(df, factor, string)) + fd <- aggregate_cells(df, c(factor, string)) + expect_identical(assayNames(fd), assayNames(df)) + # [HLC: aggregate_cells() currently + # reorders features alphabetically] + fd <- fd[rownames(df), ] + expect_s4_class(fd, "SummarizedExperiment") + expect_equal(dim(fd), c(nrow(df), nrow(tbl))) + foo <- mapply( + f=tbl$factor, + s=tbl$string, + \(f, s) { + expect_identical( + df |> + filter(factor == f, string == s) |> + assay() |> rowSums() |> as.vector(), + fd[, fd$factor == f & fd$string == s] |> + assay() |> as.vector()) + }) + # specified 'assays' are subsetted + expect_error(aggregate_cells(df, c(factor, string), assays="x")) + fd <- aggregate_cells(df, c(factor, string), assays="counts") + expect_identical(assayNames(fd), "counts") }) From 8dbb158000dd04cbab9db13f83699d6dc083db30 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Tue, 29 Aug 2023 07:16:51 +0100 Subject: [PATCH 018/140] Update test-methods.R Add test --- tests/testthat/test-methods.R | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/tests/testthat/test-methods.R b/tests/testthat/test-methods.R index a6260b7..a11e4e4 100644 --- a/tests/testthat/test-methods.R +++ b/tests/testthat/test-methods.R @@ -14,6 +14,18 @@ test_that("show()", { expect_equal(gsub(str, "\\1", txt[i]), paste(nrow(df))) i <- grep(str <- ".*Cells=([0-9]+).*", txt) expect_equal(gsub(str, "\\1", txt[i]), paste(ncol(df))) + i <- grep(".*Assays=.*", txt) + x <- substring(txt[i], (gregexpr(pattern = "Assays", txt[i])[[1]] + 7)) + x <- substring(x, first = 1, last = nchar(x) - 4) |> + strsplit(split = ", ") |> + unlist() + y <- assayNames(df) + for (k in seq_along(altExps(pbmc_small))) { + y <- append(x = y, paste(altExpNames(pbmc_small)[[k]], assayNames(altExps(pbmc_small)[[k]]), sep = "-")) + } + for(j in seq_along(y)) { + expect_contains(x, y[j]) + } }) test_that("join_features()", { From 6a9d4f65f0b5df54a36e62f35ed6073f225a6ec8 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Wed, 30 Aug 2023 09:56:34 +0100 Subject: [PATCH 019/140] Update test-methods.R New, more comprehensive unit tests --- tests/testthat/test-methods.R | 35 +++++++++++++++++++++++++++++++---- 1 file changed, 31 insertions(+), 4 deletions(-) diff --git a/tests/testthat/test-methods.R b/tests/testthat/test-methods.R index a11e4e4..0cf0b29 100644 --- a/tests/testthat/test-methods.R +++ b/tests/testthat/test-methods.R @@ -1,9 +1,36 @@ data("pbmc_small") +# Mock up ADT and cell hashing experiments set.seed(2023-08-29) -rand_mat <- matrix(data = runif(n = length(LETTERS) * dim(pbmc_small)[[2]]), ncol = dim(pbmc_small)[[2]]) -colnames(rand_mat) <- rownames(colData(pbmc_small)) -rownames(rand_mat) <- LETTERS -altExps(pbmc_small)[["ADT"]] <- SingleCellExperiment(assays = list(normcounts = rand_mat)) +# Antibody tags +pos_myus <- sample(x = 7500:20000, size = 5) +int_myus <- sample(x = 100:1500, size = 5) +neg_myus <- sample(x = 1:30, size = 15) +all_myus <- c(pos_myus, int_myus, neg_myus) +all_myus <- sample(x = all_myus, size = length(all_myus)) + +mat <- list() +for(i in seq_along(all_myus)) { + mat[[i]] <- MASS::rnegbin(n = dim(pbmc_small)[[2]], mu = all_myus[[i]], theta = all_myus[[i]]/500) +} +mat <- Reduce(f = cbind, x = mat) +colnames(mat) <- paste("Ab", seq_along(mat[1,]), sep = "-") +rownames(mat) <- colnames(pbmc_small) + +altExps(pbmc_small)[["ADT"]] <- SingleCellExperiment(assays = list(counts = t(mat), logcounts = log10(t(mat) + 1))) + +# Cell hashing +HTO_myus <- sample(x = c(100, 100000), size = 6, replace = TRUE) +mat <- list() +for(i in seq_along(HTO_myus)) { + mat[[i]] <- MASS::rnegbin(n = dim(pbmc_small)[[2]], mu = HTO_myus[[i]], theta = HTO_myus[[i]]/500) +} + +mat <- Reduce(f = cbind, x = mat) +colnames(mat) <- paste("HTO", seq_along(mat[1,]), sep = "-") +rownames(mat) <- colnames(pbmc_small) + +altExps(pbmc_small)[["Hashtag demultiplex"]] <- SingleCellExperiment(assays = list(counts = t(mat), logcounts = log10(t(mat) + 1))) + df <- pbmc_small test_that("show()", { From 41b284409f1ff7678487f77e74e5939e28eb20f7 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Fri, 1 Sep 2023 18:44:18 +0100 Subject: [PATCH 020/140] Update utilities.R Add altExp functionality to `get_abundance_sc_wide` and `get_abundance_sc_long`. --- R/utilities.R | 326 +++++++++++++++++++++++++++++++++----------------- 1 file changed, 217 insertions(+), 109 deletions(-) diff --git a/R/utilities.R b/R/utilities.R index d947188..f7e0534 100755 --- a/R/utilities.R +++ b/R/utilities.R @@ -96,21 +96,21 @@ drop_class <- function(var, name) { #' #' #' @noRd -get_abundance_sc_wide <- function(.data, features=NULL, all=FALSE, assay = assays(.data) %>% as.list() %>% tail(1) %>% names, 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(" +get_abundance_sc_wide <- function(.data, features=NULL, all=FALSE, assay = assays(.data) |> as.list() |> tail(1) |> names(), prefix = "" ) { + + # Solve CRAN warnings + . <- NULL + + # For SCE there is no field 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: @@ -118,35 +118,80 @@ get_abundance_sc_wide <- function(.data, features=NULL, all=FALSE, assay = assay 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 { - 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() %>% - as_tibble(rownames=c_(.data)$name) %>% - - # Add prefix - setNames(c(c_(.data)$name, sprintf("%s%s", prefix, colnames(.)[-1]))) + } + + # Get variable features if existing + if ( + length(variable_feature) > 0 & + is.null(features) & + all == FALSE + ) { + variable_genes <- variable_feature + } # Else + else { + variable_genes <- NULL + } + + # Get assays + assay_names <- names(assays(.data)) + alt_exp_assays <- list() + alt_exp_assay_names_list <- lapply(altExps(.data), assayNames) + names(assay_names) <- rep("Main", length(assay_names)) + alt_exp_assay_names_df <- stack(alt_exp_assay_names_list) + alt_exp_assay_names <- paste(alt_exp_assay_names_df$ind, alt_exp_assay_names_df$values, sep = "-") + names(alt_exp_assay_names) <- alt_exp_assay_names_df$ind + all_assay_names_df <- rbind(stack(assay_names), alt_exp_assay_names_df) + all_assay_names <- c(assay_names, alt_exp_assay_names) + all_assay_names_ext_df <- stack(all_assay_names) + all_assay_names_ext_df <- cbind(all_assay_names_ext_df, all_assay_names_df$values) + colnames(all_assay_names_ext_df) <- c("assay_id", "exp_id", "assay_name") + + # Get list of features + features_lookup <- vector("list", length = length(all_assay_names)) + main_features <- vector("list", length = 1) + names(main_features) <- "Main" + main_features[["Main"]] <- rownames(rowData(.data)) + temp_funct <- function(x) rownames(rowData(x)) + alt_exp_features <- lapply(altExps(.data), temp_funct) + feature_df <- stack(c(main_features, alt_exp_features)) + colnames(feature_df) <- c("feature", "exp_id") + feature_df <- merge(feature_df, all_assay_names_ext_df, by = "exp_id") + + # Get selected features + selected_features <- feature_df[(feature_df$feature %in% features), ] + selected_features_df <- selected_features[(selected_features$assay_id %in% assay),] + if(!(nrow(selected_features_df) > 0 && all(selected_features_df$assay_id %in% assay))) stop("tidySingleCellExperiment says: Please specify correct assay.") + selected_features_exp <- unique(selected_features_df$exp_id) + if(length(selected_features_exp) > 1) stop("Please avoid mixing features from different experiments.") + selected_features_assay <- unique(selected_features_df$assay_name) + + if(isTRUE(selected_features_exp) && selected_features_exp == "Main") { + assays(.data)[[assay]][features,] %>% + 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() %>% + as_tibble(rownames=c_(.data)$name) %>% + + # Add prefix + setNames(c(c_(.data)$name, sprintf("%s%s", prefix, colnames(.)[-1]))) + } else { + assays(altExps(.data)[[selected_features_exp]])[[selected_features_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() %>% + as_tibble(rownames=c_(.data)$name) %>% + + # Add prefix + setNames(c(c_(.data)$name, sprintf("%s%s", prefix, colnames(.)[-1]))) + } } #' get abundance long @@ -169,21 +214,20 @@ get_abundance_sc_wide <- function(.data, features=NULL, all=FALSE, assay = assay #' #' #' @noRd -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(" +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: @@ -191,61 +235,125 @@ get_abundance_sc_long <- function(.data, features=NULL, all=FALSE, exclude_zeros 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 { - variable_genes <- NULL - } + # Get variable features if existing + if ( + length(variable_feature) > 0 & + is.null(features) & + all == FALSE + ) { + variable_genes <- variable_feature + } # Else + else { + variable_genes <- NULL + } - assay_names <- assays(.data) %>% names() + assay_names <- names(assays(.data)) - # 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 - can you even have an sce object with no assays? + if (length(assay_names) == 0) { + stop("tidySingleCellExperiment says: there are no assays names in the source SingleCellExperiment.") + } + # Get assays + alt_exp_assays <- list() + alt_exp_assay_names_list <- lapply(altExps(.data), assayNames) + names(assay_names) <- rep("Main", length(assay_names)) + alt_exp_assay_names_df <- stack(alt_exp_assay_names_list) + alt_exp_assay_names <- paste(alt_exp_assay_names_df$ind, alt_exp_assay_names_df$values, sep = "-") + names(alt_exp_assay_names) <- alt_exp_assay_names_df$ind + all_assay_names_df <- rbind(stack(assay_names), alt_exp_assay_names_df) + all_assay_names <- c(assay_names, alt_exp_assay_names) + all_assay_names_ext_df <- stack(all_assay_names) + all_assay_names_ext_df <- cbind(all_assay_names_ext_df, all_assay_names_df$values) + colnames(all_assay_names_ext_df) <- c("assay_id", "exp_id", "assay_name") + + # Get list of features + features_lookup <- vector("list", length = length(all_assay_names)) + main_features <- vector("list", length = 1) + names(main_features) <- "Main" + main_features[["Main"]] <- rownames(rowData(.data)) + temp_funct <- function(x) rownames(rowData(x)) + alt_exp_features <- lapply(altExps(.data), temp_funct) + feature_df <- stack(c(main_features, alt_exp_features)) + colnames(feature_df) <- c("feature", "exp_id") + feature_df <- merge(feature_df, all_assay_names_ext_df, by = "exp_id") + + # Get selected features + selected_features <- feature_df[(feature_df$feature %in% features), ] + selected_features_exp <- unique(selected_features$exp_id) + if(length(selected_features_exp) > 1) stop("Please avoid mixing features from different experiments.") + selected_features_assay_names <- unique(selected_features$assay_id) + + if (selected_features_exp == "Main") { 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 - }, ~ (.)) %>% - as.matrix() %>% - data.frame(check.names = FALSE) %>% - as_tibble(rownames=".feature") %>% - tidyr::pivot_longer( - 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)), .) + 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 + }, ~ (.)) %>% + as.matrix() %>% + data.frame(check.names = FALSE) %>% + as_tibble(rownames = ".feature") %>% + tidyr::pivot_longer( + 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)), .) + } else { + assays(altExps(.data)[[selected_features_exp]]) %>% + as.list() %>% + # Take active assay + map2( + selected_features_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 + }, ~ (.)) %>% + as.matrix() %>% + data.frame(check.names = FALSE) %>% + as_tibble(rownames = ".feature") %>% + tidyr::pivot_longer( + 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)), .) + } } #' @importFrom dplyr select_if @@ -525,4 +633,4 @@ subset = function(.data, .column) { } feature__ = get_special_column_name_symbol(".feature") -sample__ = get_special_column_name_symbol(".sample") \ No newline at end of file +sample__ = get_special_column_name_symbol(".sample") From 1e93081b00ea3da0336a16cf3ecc02836650293d Mon Sep 17 00:00:00 2001 From: Biomiha Date: Sat, 2 Sep 2023 16:35:08 +0100 Subject: [PATCH 021/140] Update utilities.R --- R/utilities.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/utilities.R b/R/utilities.R index f7e0534..931c42b 100755 --- a/R/utilities.R +++ b/R/utilities.R @@ -165,7 +165,7 @@ get_abundance_sc_wide <- function(.data, features=NULL, all=FALSE, assay = assay if(length(selected_features_exp) > 1) stop("Please avoid mixing features from different experiments.") selected_features_assay <- unique(selected_features_df$assay_name) - if(isTRUE(selected_features_exp) && selected_features_exp == "Main") { + if(selected_features_exp == "Main") { assays(.data)[[assay]][features,] %>% when( variable_genes %>% is.null() %>% `!`() ~ (.)[variable_genes, , drop=FALSE], From 65bda14cc474f1156c5a0ace49ab1e926c1ac6c2 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Sat, 9 Sep 2023 12:23:55 +0100 Subject: [PATCH 022/140] Update utilities.R Split out functions --- R/utilities.R | 293 ++++++++++++++++++++++++-------------------------- 1 file changed, 139 insertions(+), 154 deletions(-) diff --git a/R/utilities.R b/R/utilities.R index 931c42b..bc5933a 100755 --- a/R/utilities.R +++ b/R/utilities.R @@ -7,45 +7,45 @@ #' #' @noRd to_tib <- function(.data) { - colData(.data) %>% - as.data.frame() %>% - as_tibble(rownames=c_(.data)$name) + colData(.data) %>% + as.data.frame() %>% + as_tibble(rownames=c_(.data)$name) } # Greater than gt <- function(a, b) { - a > b + a > b } # Smaller than st <- function(a, b) { - a < b + a < b } # Negation not <- function(is) { - !is + !is } # Raise to the power pow <- function(a, b) { - a^b + a^b } # Equals eq <- function(a, b) { - a == b + a == b } prepend <- function(x, values, before=1) { - n <- length(x) - stopifnot(before > 0 && before <= n) - if (before == 1) { - c(values, x) - } - else { - c(x[seq_len(before - 1)], values, x[before:n]) - } + n <- length(x) + stopifnot(before > 0 && before <= n) + if (before == 1) { + c(values, x) + } + else { + c(x[seq_len(before - 1)], values, x[before:n]) + } } #' Add class to abject #' @@ -57,9 +57,9 @@ 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) + + var } #' Remove class to abject @@ -73,8 +73,40 @@ add_class <- function(var, name) { #' @return A tibble with an additional attribute #' @keywords internal drop_class <- function(var, name) { - class(var) <- class(var)[!class(var) %in% name] - var + class(var) <- class(var)[!class(var) %in% name] + var +} + +# Get assays +get_all_assays <- function(x) { + assay_names <- names(assays(x)) + alt_exp_assays <- list() + alt_exp_assay_names_list <- lapply(altExps(x), assayNames) + names(assay_names) <- rep("Main", length(assay_names)) + alt_exp_assay_names_df <- stack(alt_exp_assay_names_list) + alt_exp_assay_names <- paste(alt_exp_assay_names_df$ind, alt_exp_assay_names_df$values, sep = "-") + names(alt_exp_assay_names) <- alt_exp_assay_names_df$ind + all_assay_names_df <- rbind(stack(assay_names), alt_exp_assay_names_df) + all_assay_names <- c(assay_names, alt_exp_assay_names) + all_assay_names_ext_df <- stack(all_assay_names) + all_assay_names_ext_df <- cbind(all_assay_names_ext_df, all_assay_names_df$values) + colnames(all_assay_names_ext_df) <- c("assay_id", "exp_id", "assay_name") + return(all_assay_names_ext_df) +} + +# Get list of features +get_all_features <- function(x) { + all_assay_names_ext_df <- get_all_assays(x) + features_lookup <- vector("list", length = length(all_assay_names_ext_df$assay_id)) + main_features <- vector("list", length = 1) + names(main_features) <- "Main" + main_features[["Main"]] <- rownames(rowData(x)) + temp_funct <- function(x) rownames(rowData(x)) + alt_exp_features <- lapply(altExps(x), temp_funct) + feature_df <- stack(c(main_features, alt_exp_features)) + colnames(feature_df) <- c("feature", "exp_id") + feature_df <- merge(feature_df, all_assay_names_ext_df, by = "exp_id") + return(feature_df) } #' get abundance long @@ -132,32 +164,8 @@ get_abundance_sc_wide <- function(.data, features=NULL, all=FALSE, assay = assay variable_genes <- NULL } - # Get assays - assay_names <- names(assays(.data)) - alt_exp_assays <- list() - alt_exp_assay_names_list <- lapply(altExps(.data), assayNames) - names(assay_names) <- rep("Main", length(assay_names)) - alt_exp_assay_names_df <- stack(alt_exp_assay_names_list) - alt_exp_assay_names <- paste(alt_exp_assay_names_df$ind, alt_exp_assay_names_df$values, sep = "-") - names(alt_exp_assay_names) <- alt_exp_assay_names_df$ind - all_assay_names_df <- rbind(stack(assay_names), alt_exp_assay_names_df) - all_assay_names <- c(assay_names, alt_exp_assay_names) - all_assay_names_ext_df <- stack(all_assay_names) - all_assay_names_ext_df <- cbind(all_assay_names_ext_df, all_assay_names_df$values) - colnames(all_assay_names_ext_df) <- c("assay_id", "exp_id", "assay_name") - - # Get list of features - features_lookup <- vector("list", length = length(all_assay_names)) - main_features <- vector("list", length = 1) - names(main_features) <- "Main" - main_features[["Main"]] <- rownames(rowData(.data)) - temp_funct <- function(x) rownames(rowData(x)) - alt_exp_features <- lapply(altExps(.data), temp_funct) - feature_df <- stack(c(main_features, alt_exp_features)) - colnames(feature_df) <- c("feature", "exp_id") - feature_df <- merge(feature_df, all_assay_names_ext_df, by = "exp_id") - # Get selected features + feature_df <- get_all_features(.data) selected_features <- feature_df[(feature_df$feature %in% features), ] selected_features_df <- selected_features[(selected_features$assay_id %in% assay),] if(!(nrow(selected_features_df) > 0 && all(selected_features_df$assay_id %in% assay))) stop("tidySingleCellExperiment says: Please specify correct assay.") @@ -217,15 +225,15 @@ get_abundance_sc_wide <- function(.data, features=NULL, all=FALSE, assay = assay 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 + is.null(features) & + all == FALSE ) { stop(" Your object does not contain variable feature labels, @@ -236,57 +244,34 @@ get_abundance_sc_long <- function(.data, features = NULL, all = FALSE, exclude_z 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 + is.null(features) & + all == FALSE ) { variable_genes <- variable_feature } # Else else { variable_genes <- NULL } - + assay_names <- names(assays(.data)) - + # Check that I have assay names - can you even have an sce object with no assays? if (length(assay_names) == 0) { stop("tidySingleCellExperiment says: there are no assays names in the source SingleCellExperiment.") } - - # Get assays - alt_exp_assays <- list() - alt_exp_assay_names_list <- lapply(altExps(.data), assayNames) - names(assay_names) <- rep("Main", length(assay_names)) - alt_exp_assay_names_df <- stack(alt_exp_assay_names_list) - alt_exp_assay_names <- paste(alt_exp_assay_names_df$ind, alt_exp_assay_names_df$values, sep = "-") - names(alt_exp_assay_names) <- alt_exp_assay_names_df$ind - all_assay_names_df <- rbind(stack(assay_names), alt_exp_assay_names_df) - all_assay_names <- c(assay_names, alt_exp_assay_names) - all_assay_names_ext_df <- stack(all_assay_names) - all_assay_names_ext_df <- cbind(all_assay_names_ext_df, all_assay_names_df$values) - colnames(all_assay_names_ext_df) <- c("assay_id", "exp_id", "assay_name") - - # Get list of features - features_lookup <- vector("list", length = length(all_assay_names)) - main_features <- vector("list", length = 1) - names(main_features) <- "Main" - main_features[["Main"]] <- rownames(rowData(.data)) - temp_funct <- function(x) rownames(rowData(x)) - alt_exp_features <- lapply(altExps(.data), temp_funct) - feature_df <- stack(c(main_features, alt_exp_features)) - colnames(feature_df) <- c("feature", "exp_id") - feature_df <- merge(feature_df, all_assay_names_ext_df, by = "exp_id") - - # Get selected features + + # Get selected features + feature_df <- get_all_features(.data) selected_features <- feature_df[(feature_df$feature %in% features), ] selected_features_exp <- unique(selected_features$exp_id) if(length(selected_features_exp) > 1) stop("Please avoid mixing features from different experiments.") selected_features_assay_names <- unique(selected_features$assay_id) - + if (selected_features_exp == "Main") { assays(.data) %>% as.list() %>% @@ -302,11 +287,11 @@ get_abundance_sc_long <- function(.data, features = NULL, all = FALSE, exclude_z ) %>% # Replace 0 with NA when(exclude_zeros ~ (.) %>% - { - x <- (.) - x[x == 0] <- NA - x - }, ~ (.)) %>% + { + x <- (.) + x[x == 0] <- NA + x + }, ~ (.)) %>% as.matrix() %>% data.frame(check.names = FALSE) %>% as_tibble(rownames = ".feature") %>% @@ -335,11 +320,11 @@ get_abundance_sc_long <- function(.data, features = NULL, all = FALSE, exclude_z ) %>% # Replace 0 with NA when(exclude_zeros ~ (.) %>% - { - x <- (.) - x[x == 0] <- NA - x - }, ~ (.)) %>% + { + x <- (.) + x[x == 0] <- NA + x + }, ~ (.)) %>% as.matrix() %>% data.frame(check.names = FALSE) %>% as_tibble(rownames = ".feature") %>% @@ -366,35 +351,35 @@ get_abundance_sc_long <- function(.data, features = NULL, all = FALSE, exclude_z #' #' @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") |> - + + # 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() - + + .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() + } #' @importFrom purrr map_chr @@ -406,27 +391,27 @@ as_meta_data <- function(.data, SingleCellExperiment_object) { #' @noRd #' get_special_columns <- function(SingleCellExperiment_object) { - get_special_datasets(SingleCellExperiment_object) %>% - map(~ .x %>% colnames()) %>% - unlist() %>% - as.character() + get_special_datasets(SingleCellExperiment_object) %>% + map(~ .x %>% colnames()) %>% + unlist() %>% + 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 - }) + 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 + }) } get_needed_columns <- function(.data) { - + c(c_(.data)$name) } @@ -441,10 +426,10 @@ get_needed_columns <- function(.data) { #' #' @return A character vector quo_names <- function(v) { - v <- quo_name(quo_squash(v)) - gsub("^c\\(|`|\\)$", "", v) %>% - strsplit(", ") %>% - unlist() + v <- quo_name(quo_squash(v)) + gsub("^c\\(|`|\\)$", "", v) %>% + strsplit(", ") %>% + unlist() } #' @importFrom purrr when @@ -452,9 +437,9 @@ quo_names <- function(v) { #' @importFrom rlang expr #' @importFrom tidyselect eval_select select_helper <- function(.data, ...) { - loc <- tidyselect::eval_select(expr(c(...)), .data) - - dplyr::select(.data, loc) + 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." @@ -465,22 +450,22 @@ duplicated_cell_names = "tidySingleCellExperiment says: This operation lead to d #' @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 } @@ -492,9 +477,9 @@ get_special_column_name_symbol = function(name){ #' @importFrom S4Vectors metadata #' @importFrom S4Vectors metadata<- ping_old_special_column_into_metadata = function(.data){ - + metadata(.data)$cell__ = get_special_column_name_symbol("cell") - + .data } @@ -534,22 +519,22 @@ special_datasets_to_tibble = function(.singleCellExperiment, ...){ .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 } @@ -617,7 +602,7 @@ get_specific_annotation_columns = function(.data, .col){ #' #' @return A tibble subset = function(.data, .column) { - + # Make col names .column = enquo(.column) From b4e366597d448c20e5decbc4833d89a0cc87bc22 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Sat, 9 Sep 2023 12:25:21 +0100 Subject: [PATCH 023/140] Update methods.R Add altExp functionality to aggregate_cells --- R/methods.R | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/R/methods.R b/R/methods.R index 589cbbe..cad17ce 100755 --- a/R/methods.R +++ b/R/methods.R @@ -133,6 +133,14 @@ setMethod("aggregate_cells", "SingleCellExperiment", function(.data, # Subset only wanted assays if(!is.null(assays)){ .data@assays@data = .data@assays@data[assays] + } else { + assay_info <- get_all_assays(.data) + if(!any(assay_info$assay_id %in% assays)) stop("Please select an appropriate assay name") + selected_assays <- assay_info[assay_info$assay_id %in% assays,] + selected_exp <- unique(selected_assays$exp_id) + if(length(selected_exp) > 1) stop("Please avoid mixing features from different experiments.") + .data <- altExps(.data)[[selected_exp]] + .data@assays@data = .data@assays@data[selected_assays$assay_name] } .data %>% From 79c2001f174c51406cb952f0c13fe3177349fa57 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Sat, 9 Sep 2023 16:02:15 +0100 Subject: [PATCH 024/140] Update methods.R Tweak to aggregate_cells --- R/methods.R | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/R/methods.R b/R/methods.R index cad17ce..6c4a995 100755 --- a/R/methods.R +++ b/R/methods.R @@ -132,15 +132,17 @@ setMethod("aggregate_cells", "SingleCellExperiment", function(.data, # Subset only wanted assays if(!is.null(assays)){ - .data@assays@data = .data@assays@data[assays] - } else { assay_info <- get_all_assays(.data) if(!any(assay_info$assay_id %in% assays)) stop("Please select an appropriate assay name") selected_assays <- assay_info[assay_info$assay_id %in% assays,] selected_exp <- unique(selected_assays$exp_id) if(length(selected_exp) > 1) stop("Please avoid mixing features from different experiments.") + if(selected_exp == "Main") { + .data <- .data@assays@data[selected_assays$assay_name] + } else { .data <- altExps(.data)[[selected_exp]] - .data@assays@data = .data@assays@data[selected_assays$assay_name] + .data@assays@data = .data@assays@data[selected_assays$assay_name] + } } .data %>% From 6bd2829f82c64c5173513734a9b3a54b20fd9be6 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Sat, 9 Sep 2023 16:11:40 +0100 Subject: [PATCH 025/140] Update methods.R Tweak aggregate_cells --- R/methods.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/methods.R b/R/methods.R index 6c4a995..74b3cd4 100755 --- a/R/methods.R +++ b/R/methods.R @@ -138,7 +138,7 @@ setMethod("aggregate_cells", "SingleCellExperiment", function(.data, selected_exp <- unique(selected_assays$exp_id) if(length(selected_exp) > 1) stop("Please avoid mixing features from different experiments.") if(selected_exp == "Main") { - .data <- .data@assays@data[selected_assays$assay_name] + .data@assays@data <- .data@assays@data[selected_assays$assay_name] } else { .data <- altExps(.data)[[selected_exp]] .data@assays@data = .data@assays@data[selected_assays$assay_name] From a68f14015e372d50496c97d2b966cc676924d8e5 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Sat, 9 Sep 2023 16:14:09 +0100 Subject: [PATCH 026/140] Update test-methods.R --- tests/testthat/test-methods.R | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/tests/testthat/test-methods.R b/tests/testthat/test-methods.R index 0cf0b29..6e2b332 100644 --- a/tests/testthat/test-methods.R +++ b/tests/testthat/test-methods.R @@ -42,8 +42,15 @@ test_that("show()", { i <- grep(str <- ".*Cells=([0-9]+).*", txt) expect_equal(gsub(str, "\\1", txt[i]), paste(ncol(df))) i <- grep(".*Assays=.*", txt) - x <- substring(txt[i], (gregexpr(pattern = "Assays", txt[i])[[1]] + 7)) - x <- substring(x, first = 1, last = nchar(x) - 4) |> + j <- grep(".cell*", txt) -1 + header_text <- paste(txt[i:j], collapse = "") |> + stringr::str_remove_all(pattern = "# ") |> + stringr::str_remove_all(pattern = "\033") |> + stringr::str_remove_all(pattern = "\\[90m ") |> + stringr::str_remove_all(pattern = "\\[90m") |> + stringr::str_remove_all(pattern = "\\[0m") + x <- header_text |> + stringr::str_remove(pattern = ".+Assays=") |> strsplit(split = ", ") |> unlist() y <- assayNames(df) From b6334a09f119adc20439d80b668b2e03c8fc4ace Mon Sep 17 00:00:00 2001 From: Biomiha Date: Sat, 9 Sep 2023 16:56:32 +0100 Subject: [PATCH 027/140] Update utilities.R --- R/utilities.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/utilities.R b/R/utilities.R index bc5933a..487a86a 100755 --- a/R/utilities.R +++ b/R/utilities.R @@ -174,7 +174,7 @@ get_abundance_sc_wide <- function(.data, features=NULL, all=FALSE, assay = assay selected_features_assay <- unique(selected_features_df$assay_name) if(selected_features_exp == "Main") { - assays(.data)[[assay]][features,] %>% + assays(.data)[[assay]] %>% when( variable_genes %>% is.null() %>% `!`() ~ (.)[variable_genes, , drop=FALSE], features %>% is.null() %>% `!`() ~ (.)[features, , drop=FALSE], From a3596a1278ae56728c56472b55167fb0b582176e Mon Sep 17 00:00:00 2001 From: Biomiha Date: Wed, 27 Sep 2023 09:42:02 +0100 Subject: [PATCH 028/140] Update utilities.R update `get_abundance_sc_long` to allow multiple assays --- R/utilities.R | 154 +++++++++++++++++++++++++++----------------------- 1 file changed, 82 insertions(+), 72 deletions(-) diff --git a/R/utilities.R b/R/utilities.R index 202294e..ae0eb74 100755 --- a/R/utilities.R +++ b/R/utilities.R @@ -107,7 +107,7 @@ get_all_features <- function(x) { return(feature_df) } -#' get abundance long +#' get abundance wide #' #' @keywords internal #' @@ -198,6 +198,8 @@ get_abundance_sc_wide <- function(.data, #' @importFrom tibble as_tibble #' @importFrom purrr when #' @importFrom purrr map2 +#' @importFrom purrr reduce +#' @importFrom dplyr full_join #' @importFrom SummarizedExperiment assays assayNames #' #' @param .data A tidySingleCellExperiment @@ -251,80 +253,88 @@ get_abundance_sc_long <- function(.data, features = NULL, all = FALSE, exclude_z stop("tidySingleCellExperiment says: there are no assays names in the source SingleCellExperiment.") } - # Get selected features + # Get selected features + all_assays <- get_all_assays(.data) feature_df <- get_all_features(.data) selected_features <- feature_df[(feature_df$feature %in% features), ] - selected_features_exp <- unique(selected_features$exp_id) - if(length(selected_features_exp) > 1) stop("Please avoid mixing features from different experiments.") - selected_features_assay_names <- unique(selected_features$assay_id) + # If assay is specified select only specified assays + if(is.character(assay) && all_assays$assay_id %in% assay) selected_features <- selected_features[selected_features$assay_id %in% assay,] + selected_experiments_list <- split(x = selected_features, f = as.character(selected_features$exp_id)) - if (selected_features_exp == "Main") { - 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 - }, ~ (.)) %>% - as.matrix() %>% - data.frame(check.names = FALSE) %>% - as_tibble(rownames = ".feature") %>% - tidyr::pivot_longer( - 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)), .) - } else { - assays(altExps(.data)[[selected_features_exp]]) %>% - as.list() %>% - # Take active assay - map2( - selected_features_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 - }, ~ (.)) %>% - as.matrix() %>% - data.frame(check.names = FALSE) %>% - as_tibble(rownames = ".feature") %>% - tidyr::pivot_longer( - 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)), .) + extract_feature_values <- function(exp) { + selected_features_exp <- as.character(unique(exp$exp_id)) + selected_features_assay <- as.character(unique(exp$assay_name)) + selected_features_assay_names <- as.character(unique(exp$assay_id)) + if (selected_features_exp == "Main") { + assays(.data)[selected_features_assay] %>% + as.list() %>% + # Take active assay + map2( + selected_features_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 + }, ~ (.)) %>% + as.matrix() %>% + data.frame(check.names = FALSE) %>% + as_tibble(rownames = ".feature") %>% + tidyr::pivot_longer( + 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)), .) + } else { + assays(altExps(.data)[[selected_features_exp]])[selected_features_assay] %>% + as.list() %>% + # Take active assay + map2( + selected_features_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 + }, ~ (.)) %>% + as.matrix() %>% + data.frame(check.names = FALSE) %>% + as_tibble(rownames = ".feature") %>% + tidyr::pivot_longer( + 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)), .) + } } + lapply(selected_experiments_list, extract_feature_values) |> + reduce(full_join) } #' @importFrom dplyr select any_of @@ -624,4 +634,4 @@ splitColData <- function(x, f) { cell__ <- get_special_column_name_symbol(".cell") feature__ <- get_special_column_name_symbol(".feature") -sample__ <- get_special_column_name_symbol(".sample") \ No newline at end of file +sample__ <- get_special_column_name_symbol(".sample") From 06ff6068e1cb893e08624c050c70352a5c49e988 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Wed, 27 Sep 2023 09:49:32 +0100 Subject: [PATCH 029/140] Update utilities.R update to assay selection --- R/utilities.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/utilities.R b/R/utilities.R index ae0eb74..f2186d1 100755 --- a/R/utilities.R +++ b/R/utilities.R @@ -258,7 +258,7 @@ get_abundance_sc_long <- function(.data, features = NULL, all = FALSE, exclude_z feature_df <- get_all_features(.data) selected_features <- feature_df[(feature_df$feature %in% features), ] # If assay is specified select only specified assays - if(is.character(assay) && all_assays$assay_id %in% assay) selected_features <- selected_features[selected_features$assay_id %in% assay,] + if(!is.null(assays)) selected_features <- selected_features[selected_features$assay_id %in% assays,] selected_experiments_list <- split(x = selected_features, f = as.character(selected_features$exp_id)) extract_feature_values <- function(exp) { From 6c9d6694ce333dd8ecb046a9e8c82682c869daf0 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Wed, 27 Sep 2023 09:53:50 +0100 Subject: [PATCH 030/140] Update utilities.R dealing with assays specification --- R/utilities.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/utilities.R b/R/utilities.R index f2186d1..a653faf 100755 --- a/R/utilities.R +++ b/R/utilities.R @@ -258,7 +258,7 @@ get_abundance_sc_long <- function(.data, features = NULL, all = FALSE, exclude_z feature_df <- get_all_features(.data) selected_features <- feature_df[(feature_df$feature %in% features), ] # If assay is specified select only specified assays - if(!is.null(assays)) selected_features <- selected_features[selected_features$assay_id %in% assays,] + if(is.vector(assays)) selected_features <- selected_features[selected_features$assay_id %in% assays,] selected_experiments_list <- split(x = selected_features, f = as.character(selected_features$exp_id)) extract_feature_values <- function(exp) { From 263d481b072971464a2263edf17c9a61af089ae7 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Wed, 27 Sep 2023 11:31:19 +0100 Subject: [PATCH 031/140] Update utilities.R Amend get_abundance_sc_wide --- R/utilities.R | 122 +++++++++++++++++++++++++++----------------------- 1 file changed, 65 insertions(+), 57 deletions(-) diff --git a/R/utilities.R b/R/utilities.R index a653faf..47c7365 100755 --- a/R/utilities.R +++ b/R/utilities.R @@ -114,6 +114,8 @@ get_all_features <- function(x) { #' @importFrom magrittr "%$%" #' @importFrom utils tail #' @importFrom stats setNames +#' @importFrom purrr reduce +#' @importFrom dplyr full_join #' @importFrom SummarizedExperiment assay assayNames #' #' @param .data A `tidySingleCellExperiment` @@ -125,68 +127,74 @@ get_all_features <- function(x) { #' @return A tidySingleCellExperiment object #' #' @noRd -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 (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 - } - - if (!is.null(variable_genes)) { - gs <- variable_genes - } else if (!is.null(features)) { - gs <- features +get_abundance_sc_wide <- function(.data, assay, + features=NULL, all=FALSE, 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 (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 { - stop("It is not convenient to extract all genes.", - " You should have either variable features,", - " or a feature list to extract.") + # Get variable features if existing + variable_genes <- variable_feature } - # Get selected features - feature_df <- get_all_features(.data) - selected_features <- feature_df[(feature_df$feature %in% gs), ] - selected_features_df <- selected_features[(selected_features$assay_id %in% assay),] - if(!(nrow(selected_features_df) > 0 && all(selected_features_df$assay_id %in% assay))) stop("tidySingleCellExperiment says: Please specify correct assay.") - selected_features_exp <- unique(selected_features_df$exp_id) - if(length(selected_features_exp) > 1) stop("Please avoid mixing features from different experiments.") - selected_features_assay <- unique(selected_features_df$assay_name) + } else { + variable_genes <- NULL + } - if(selected_features_exp == "Main") { - mtx <- assay(.data, assay) - mtx <- mtx[gs, , drop=FALSE] - - mtx %>% - as.matrix() %>% t() %>% - as_tibble(rownames=c_(.data)$name) %>% - setNames(c(c_(.data)$name, sprintf("%s%s", prefix, gs))) + if (!is.null(variable_genes)) { + gs <- variable_genes + } else if (!is.null(features)) { + gs <- features } else { - mtx <- assay(altExps(.data)[[selected_features_exp]], selected_features$assay_name) - mtx <- mtx[gs, , drop=FALSE] - - mtx %>% - as.matrix() %>% t() %>% - as_tibble(rownames=c_(.data)$name) %>% - setNames(c(c_(.data)$name, sprintf("%s%s", prefix, gs))) + stop("It is not convenient to extract all genes.", + " You should have either variable features,", + " or a feature list to extract.") } + # Get selected features + feature_df <- get_all_features(.data) + selected_features <- feature_df[(feature_df$feature %in% gs), ] + # If assay is specified select only specified assays + if(is.vector(assay)) { + selected_features <- selected_features[selected_features$assay_id %in% assay,] + } else stop("Please specify assay") + selected_experiments_list <- split(x = selected_features, f = as.character(selected_features$exp_id)) + extract_feature_values <- function(exp) { + selected_features_exp <- as.character(unique(exp$exp_id)) + selected_features_assay <- as.character(unique(exp$assay_name)) + selected_features_assay_names <- as.character(unique(exp$assay_id)) + if(selected_features_exp == "Main") { + selected_features_from_exp <- rownames(assay(.data, selected_features_assay_names))[(rownames(assay(.data, selected_features_assay_names)) %in% gs)] + mtx <- assay(.data, selected_features_assay_names)[selected_features_from_exp,] + if(is.null(dim(mtx))) mtx <- matrix(mtx, byrow = TRUE, nrow = 1, ncol = length(mtx)) + mtx %>% + as.matrix() %>% t() %>% + as_tibble(rownames=c_(.data)$name) %>% + setNames(c(c_(.data)$name, sprintf("%s%s", prefix, selected_features_from_exp))) + } else { + selected_features_from_exp <- rownames(altExps(.data)[[selected_features_exp]])[(rownames(altExps(.data)[[selected_features_exp]]) %in% gs)] + mtx <- assay(altExps(.data)[[selected_features_exp]], selected_features_assay)[selected_features_from_exp,] + if(is.null(dim(mtx))) mtx <- matrix(mtx, byrow = TRUE, nrow = 1, ncol = length(mtx)) + mtx %>% + as.matrix() %>% t() %>% + as_tibble(rownames=c_(.data)$name) %>% + setNames(c(c_(.data)$name, sprintf("%s%s", prefix, selected_features_from_exp))) + } + } + lapply(selected_experiments_list, extract_feature_values) |> + reduce(full_join) } #' get abundance long From 86ce152385db659a257aff89bc867a6224b52c78 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Wed, 27 Sep 2023 11:32:57 +0100 Subject: [PATCH 032/140] Update methods.R Tweak join_features --- R/methods.R | 24 +++++++++++++----------- 1 file changed, 13 insertions(+), 11 deletions(-) diff --git a/R/methods.R b/R/methods.R index 6d8a2ea..8e2292b 100755 --- a/R/methods.R +++ b/R/methods.R @@ -47,17 +47,18 @@ setMethod("join_features", "SingleCellExperiment", function(.data, # Suppress generic data frame creation message produced by left_join suppressMessages({ - .data <- - .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()) + if(is.vector(assay)) stopifnot(any(all_assays$assay_id %in% assay)) + .data <- + .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()) }) # Provide data frame creation and abundance column message @@ -80,6 +81,7 @@ setMethod("join_features", "SingleCellExperiment", function(.data, # Shape if wide } else { + if(is.vector(assay)) stopifnot(any(all_assays$assay_id %in% assay)) .data %>% left_join( by=c_(.data)$name, From 3b94f11645e3aa1c2275cfe35406c408e3a07d98 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Wed, 27 Sep 2023 11:38:48 +0100 Subject: [PATCH 033/140] Update methods.R --- R/methods.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/methods.R b/R/methods.R index 8e2292b..3168db9 100755 --- a/R/methods.R +++ b/R/methods.R @@ -56,7 +56,7 @@ setMethod("join_features", "SingleCellExperiment", function(.data, .data=.data, features=features, all=all, - exclude_zeros=exclude_zeros)) %>% + exclude_zeros=exclude_zeros, ...)) %>% select(!!c_(.data)$symbol, .feature, contains(".abundance"), everything()) }) From 58591398e157b85ae3f0fdea5c0402b8cc5f2adf Mon Sep 17 00:00:00 2001 From: Biomiha Date: Wed, 27 Sep 2023 11:43:12 +0100 Subject: [PATCH 034/140] Update utilities.R --- R/utilities.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/utilities.R b/R/utilities.R index 47c7365..fcb1511 100755 --- a/R/utilities.R +++ b/R/utilities.R @@ -218,7 +218,7 @@ get_abundance_sc_wide <- function(.data, 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, assay = NA) { # Solve CRAN warnings . <- NULL From fb08e11475751a1efbcfb3372aa9526158297d40 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Wed, 27 Sep 2023 11:47:23 +0100 Subject: [PATCH 035/140] Update utilities.R --- R/utilities.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/utilities.R b/R/utilities.R index fcb1511..14decc4 100755 --- a/R/utilities.R +++ b/R/utilities.R @@ -218,7 +218,7 @@ get_abundance_sc_wide <- function(.data, assay, #' @return A tidySingleCellExperiment object #' #' @noRd -get_abundance_sc_long <- function(.data, features = NULL, all = FALSE, exclude_zeros = FALSE, assay = NA) { +get_abundance_sc_long <- function(.data, features = NULL, all = FALSE, exclude_zeros = FALSE, ...) { # Solve CRAN warnings . <- NULL @@ -266,7 +266,7 @@ get_abundance_sc_long <- function(.data, features = NULL, all = FALSE, exclude_z feature_df <- get_all_features(.data) selected_features <- feature_df[(feature_df$feature %in% features), ] # If assay is specified select only specified assays - if(is.vector(assays)) selected_features <- selected_features[selected_features$assay_id %in% assays,] + if(is.vector(assay)) selected_features <- selected_features[selected_features$assay_id %in% assay,] selected_experiments_list <- split(x = selected_features, f = as.character(selected_features$exp_id)) extract_feature_values <- function(exp) { From 5287d2426f2c38b001c9ea593a5a99b4b2079ba7 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Wed, 27 Sep 2023 11:51:56 +0100 Subject: [PATCH 036/140] Update utilities.R --- R/utilities.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/utilities.R b/R/utilities.R index 14decc4..56bad7e 100755 --- a/R/utilities.R +++ b/R/utilities.R @@ -218,7 +218,7 @@ get_abundance_sc_wide <- function(.data, 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, assay) { # Solve CRAN warnings . <- NULL From b8bb0a46d441ad5be32e63b5b111786c7ca98e58 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Wed, 27 Sep 2023 12:00:15 +0100 Subject: [PATCH 037/140] Update methods.R --- R/methods.R | 1 + 1 file changed, 1 insertion(+) diff --git a/R/methods.R b/R/methods.R index 3168db9..7acea67 100755 --- a/R/methods.R +++ b/R/methods.R @@ -47,6 +47,7 @@ setMethod("join_features", "SingleCellExperiment", function(.data, # Suppress generic data frame creation message produced by left_join suppressMessages({ + if(!is.vector(assay)) assay <- all_assays$assay_id if(is.vector(assay)) stopifnot(any(all_assays$assay_id %in% assay)) .data <- .data %>% From 33c8ab5c84ea8f765ccb0f18c14ea7d0a96f34e1 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Wed, 27 Sep 2023 12:03:42 +0100 Subject: [PATCH 038/140] Update methods.R --- R/methods.R | 1 + 1 file changed, 1 insertion(+) diff --git a/R/methods.R b/R/methods.R index 7acea67..8b8ffc0 100755 --- a/R/methods.R +++ b/R/methods.R @@ -47,6 +47,7 @@ setMethod("join_features", "SingleCellExperiment", function(.data, # Suppress generic data frame creation message produced by left_join suppressMessages({ + all_assays <- get_all_assays(.data) if(!is.vector(assay)) assay <- all_assays$assay_id if(is.vector(assay)) stopifnot(any(all_assays$assay_id %in% assay)) .data <- From 0d8f2ce3c28fc3e06072a6cd984c5236f458943a Mon Sep 17 00:00:00 2001 From: Biomiha Date: Wed, 27 Sep 2023 12:06:51 +0100 Subject: [PATCH 039/140] Update methods.R --- R/methods.R | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/R/methods.R b/R/methods.R index 8b8ffc0..69cda6e 100755 --- a/R/methods.R +++ b/R/methods.R @@ -58,7 +58,8 @@ setMethod("join_features", "SingleCellExperiment", function(.data, .data=.data, features=features, all=all, - exclude_zeros=exclude_zeros, ...)) %>% + exclude_zeros=exclude_zeros, + assay = assay)) %>% select(!!c_(.data)$symbol, .feature, contains(".abundance"), everything()) }) @@ -90,7 +91,8 @@ setMethod("join_features", "SingleCellExperiment", function(.data, get_abundance_sc_wide( .data=.data, features=features, - all=all, ...)) + all=all, + assay = assay)) } }) From 6d1b241e13439e670f59dbb651926dd60c7a6c33 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Wed, 27 Sep 2023 12:12:12 +0100 Subject: [PATCH 040/140] Update methods.R --- R/methods.R | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/R/methods.R b/R/methods.R index 69cda6e..1f13f47 100755 --- a/R/methods.R +++ b/R/methods.R @@ -42,14 +42,14 @@ setMethod("join_features", "SingleCellExperiment", function(.data, .cell <- NULL .feature <- NULL + all_assays <- get_all_assays(.data) + if(!is.vector(assay)) assay <- all_assays$assay_id + if(is.vector(assay)) stopifnot(any(all_assays$assay_id %in% assay)) # Shape is long if (shape == "long") { # Suppress generic data frame creation message produced by left_join suppressMessages({ - all_assays <- get_all_assays(.data) - if(!is.vector(assay)) assay <- all_assays$assay_id - if(is.vector(assay)) stopifnot(any(all_assays$assay_id %in% assay)) .data <- .data %>% left_join( @@ -59,7 +59,7 @@ setMethod("join_features", "SingleCellExperiment", function(.data, features=features, all=all, exclude_zeros=exclude_zeros, - assay = assay)) %>% + ...)) %>% select(!!c_(.data)$symbol, .feature, contains(".abundance"), everything()) }) @@ -84,7 +84,6 @@ setMethod("join_features", "SingleCellExperiment", function(.data, # Shape if wide } else { - if(is.vector(assay)) stopifnot(any(all_assays$assay_id %in% assay)) .data %>% left_join( by=c_(.data)$name, @@ -92,7 +91,7 @@ setMethod("join_features", "SingleCellExperiment", function(.data, .data=.data, features=features, all=all, - assay = assay)) + ...)) } }) From da5545dfa567a77ef104cbd6c9f62cfe077e9686 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Wed, 27 Sep 2023 12:52:29 +0100 Subject: [PATCH 041/140] Update methods.R --- R/methods.R | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/R/methods.R b/R/methods.R index 1f13f47..ebd31fa 100755 --- a/R/methods.R +++ b/R/methods.R @@ -43,8 +43,10 @@ setMethod("join_features", "SingleCellExperiment", function(.data, .feature <- NULL all_assays <- get_all_assays(.data) - if(!is.vector(assay)) assay <- all_assays$assay_id - if(is.vector(assay)) stopifnot(any(all_assays$assay_id %in% assay)) + if(!is.vector(assay)) assays_to_use <- NA + if(is.vector(assay)) { + stopifnot(any(all_assays$assay_id %in% assay)) + } else assays_to_use <- assay # Shape is long if (shape == "long") { From 1024f9ec11cffdd91ffabe7e67d4c537aa058a50 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Wed, 27 Sep 2023 12:53:37 +0100 Subject: [PATCH 042/140] Update utilities.R --- R/utilities.R | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/R/utilities.R b/R/utilities.R index 56bad7e..adc4957 100755 --- a/R/utilities.R +++ b/R/utilities.R @@ -127,7 +127,7 @@ get_all_features <- function(x) { #' @return A tidySingleCellExperiment object #' #' @noRd -get_abundance_sc_wide <- function(.data, assay, +get_abundance_sc_wide <- function(.data, assay_to_use = assay_to_use, features=NULL, all=FALSE, prefix="") { # Solve CRAN warnings @@ -167,9 +167,9 @@ get_abundance_sc_wide <- function(.data, assay, feature_df <- get_all_features(.data) selected_features <- feature_df[(feature_df$feature %in% gs), ] # If assay is specified select only specified assays - if(is.vector(assay)) { - selected_features <- selected_features[selected_features$assay_id %in% assay,] - } else stop("Please specify assay") + if(any(!is.na(assay_to_use))) { + selected_features <- selected_features[selected_features$assay_id %in% assay_to_use,] + } else if(is.na(assay_to_use)) stop("Please specify assay") selected_experiments_list <- split(x = selected_features, f = as.character(selected_features$exp_id)) extract_feature_values <- function(exp) { selected_features_exp <- as.character(unique(exp$exp_id)) @@ -218,7 +218,7 @@ get_abundance_sc_wide <- function(.data, assay, #' @return A tidySingleCellExperiment object #' #' @noRd -get_abundance_sc_long <- function(.data, features = NULL, all = FALSE, exclude_zeros = FALSE, assay) { +get_abundance_sc_long <- function(.data, features = NULL, all = FALSE, exclude_zeros = FALSE, assay_to_use = assay_to_use) { # Solve CRAN warnings . <- NULL @@ -266,7 +266,9 @@ get_abundance_sc_long <- function(.data, features = NULL, all = FALSE, exclude_z feature_df <- get_all_features(.data) selected_features <- feature_df[(feature_df$feature %in% features), ] # If assay is specified select only specified assays - if(is.vector(assay)) selected_features <- selected_features[selected_features$assay_id %in% assay,] + if(any(!is.na(assay_to_use))) { + selected_features <- selected_features[selected_features$assay_id %in% assay_to_use,] + } selected_experiments_list <- split(x = selected_features, f = as.character(selected_features$exp_id)) extract_feature_values <- function(exp) { From d31fd7a0becc5240bc7743718d03665e131e074d Mon Sep 17 00:00:00 2001 From: Biomiha Date: Wed, 27 Sep 2023 13:09:26 +0100 Subject: [PATCH 043/140] Update methods.R --- R/methods.R | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/R/methods.R b/R/methods.R index ebd31fa..f732213 100755 --- a/R/methods.R +++ b/R/methods.R @@ -43,10 +43,10 @@ setMethod("join_features", "SingleCellExperiment", function(.data, .feature <- NULL all_assays <- get_all_assays(.data) - if(!is.vector(assay)) assays_to_use <- NA if(is.vector(assay)) { - stopifnot(any(all_assays$assay_id %in% assay)) - } else assays_to_use <- assay + stopifnot(any(all_assays$assay_id %in% assay)) + } else if(!is.vector(assay)) assays_to_use <- NA + # Shape is long if (shape == "long") { From d018a6064acfa8763d3a0583c7bfc5dac953a142 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Wed, 27 Sep 2023 13:15:11 +0100 Subject: [PATCH 044/140] Update utilities.R --- R/utilities.R | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/R/utilities.R b/R/utilities.R index adc4957..fde70cb 100755 --- a/R/utilities.R +++ b/R/utilities.R @@ -262,13 +262,9 @@ get_abundance_sc_long <- function(.data, features = NULL, all = FALSE, exclude_z } # Get selected features - all_assays <- get_all_assays(.data) feature_df <- get_all_features(.data) selected_features <- feature_df[(feature_df$feature %in% features), ] - # If assay is specified select only specified assays - if(any(!is.na(assay_to_use))) { - selected_features <- selected_features[selected_features$assay_id %in% assay_to_use,] - } + if(any(selected_features$assay_id %in% assays_to_use)) selected_features <- selected_features[selected_features$assay_id %in% assays_to_use,] selected_experiments_list <- split(x = selected_features, f = as.character(selected_features$exp_id)) extract_feature_values <- function(exp) { From 5956947bada76731121469ae72f6994f0f8175da Mon Sep 17 00:00:00 2001 From: Biomiha Date: Wed, 27 Sep 2023 13:20:49 +0100 Subject: [PATCH 045/140] Update utilities.R --- R/utilities.R | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/R/utilities.R b/R/utilities.R index fde70cb..2ebd698 100755 --- a/R/utilities.R +++ b/R/utilities.R @@ -127,7 +127,7 @@ get_all_features <- function(x) { #' @return A tidySingleCellExperiment object #' #' @noRd -get_abundance_sc_wide <- function(.data, assay_to_use = assay_to_use, +get_abundance_sc_wide <- function(.data, assays_to_use = assays_to_use, features=NULL, all=FALSE, prefix="") { # Solve CRAN warnings @@ -167,9 +167,9 @@ get_abundance_sc_wide <- function(.data, assay_to_use = assay_to_use, feature_df <- get_all_features(.data) selected_features <- feature_df[(feature_df$feature %in% gs), ] # If assay is specified select only specified assays - if(any(!is.na(assay_to_use))) { - selected_features <- selected_features[selected_features$assay_id %in% assay_to_use,] - } else if(is.na(assay_to_use)) stop("Please specify assay") + if(any(!is.na(assays_to_use))) { + selected_features <- selected_features[selected_features$assay_id %in% assays_to_use,] + } else if(is.na(assays_to_use)) stop("Please specify assay") selected_experiments_list <- split(x = selected_features, f = as.character(selected_features$exp_id)) extract_feature_values <- function(exp) { selected_features_exp <- as.character(unique(exp$exp_id)) @@ -218,7 +218,7 @@ get_abundance_sc_wide <- function(.data, assay_to_use = assay_to_use, #' @return A tidySingleCellExperiment object #' #' @noRd -get_abundance_sc_long <- function(.data, features = NULL, all = FALSE, exclude_zeros = FALSE, assay_to_use = assay_to_use) { +get_abundance_sc_long <- function(.data, features = NULL, all = FALSE, exclude_zeros = FALSE, assays_to_use = assays_to_use) { # Solve CRAN warnings . <- NULL From d3be26340b53b3f21d9c1f67247fef46e1503891 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Wed, 27 Sep 2023 13:25:11 +0100 Subject: [PATCH 046/140] Update methods.R --- R/methods.R | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/R/methods.R b/R/methods.R index f732213..b37227e 100755 --- a/R/methods.R +++ b/R/methods.R @@ -44,8 +44,9 @@ setMethod("join_features", "SingleCellExperiment", function(.data, all_assays <- get_all_assays(.data) if(is.vector(assay)) { - stopifnot(any(all_assays$assay_id %in% assay)) - } else if(!is.vector(assay)) assays_to_use <- NA + stopifnot(any(all_assays$assay_id %in% assay)) + assays_to_use <- assay + } else assays_to_use <- NA # Shape is long if (shape == "long") { From ab81fb071eb7c477256933b9ccc38a6f56bf4b2c Mon Sep 17 00:00:00 2001 From: Biomiha Date: Wed, 27 Sep 2023 13:46:29 +0100 Subject: [PATCH 047/140] Update methods.R --- R/methods.R | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/R/methods.R b/R/methods.R index b37227e..c4d9c33 100755 --- a/R/methods.R +++ b/R/methods.R @@ -41,12 +41,12 @@ setMethod("join_features", "SingleCellExperiment", function(.data, # CRAN Note .cell <- NULL .feature <- NULL - - all_assays <- get_all_assays(.data) - if(is.vector(assay)) { - stopifnot(any(all_assays$assay_id %in% assay)) - assays_to_use <- assay - } else assays_to_use <- NA + arg_list <- c(mget(ls(environment(), sorted=F)), match.call(expand.dots=F)$...) + if(!is.null(arg_list$assay)) { + all_assays <- get_all_assays(.data) + stopifnot(any(all_assays$assay_id %in% arg_list$assay)) + assays_to_use <- arg_list$assay + } else assays_to_use <- NA # Shape is long if (shape == "long") { From eafe32103d00d89b2b4169536b1d1d5c11115759 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Wed, 27 Sep 2023 13:54:44 +0100 Subject: [PATCH 048/140] Update methods.R --- R/methods.R | 9 +++------ 1 file changed, 3 insertions(+), 6 deletions(-) diff --git a/R/methods.R b/R/methods.R index c4d9c33..f14d1e1 100755 --- a/R/methods.R +++ b/R/methods.R @@ -41,12 +41,9 @@ setMethod("join_features", "SingleCellExperiment", function(.data, # CRAN Note .cell <- NULL .feature <- NULL - arg_list <- c(mget(ls(environment(), sorted=F)), match.call(expand.dots=F)$...) - if(!is.null(arg_list$assay)) { - all_assays <- get_all_assays(.data) - stopifnot(any(all_assays$assay_id %in% arg_list$assay)) - assays_to_use <- arg_list$assay - } else assays_to_use <- NA + arg_list <- c(mget(ls(environment(), sorted=F)), match.call(expand.dots=F)$...) + print(arg_list) + assays_to_use <- NA # Shape is long if (shape == "long") { From e39791f91dfd28436edc3194f0b07d62ac67633b Mon Sep 17 00:00:00 2001 From: Biomiha Date: Wed, 27 Sep 2023 14:05:01 +0100 Subject: [PATCH 049/140] Update methods.R --- R/methods.R | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/R/methods.R b/R/methods.R index f14d1e1..e99e245 100755 --- a/R/methods.R +++ b/R/methods.R @@ -42,12 +42,11 @@ setMethod("join_features", "SingleCellExperiment", function(.data, .cell <- NULL .feature <- NULL arg_list <- c(mget(ls(environment(), sorted=F)), match.call(expand.dots=F)$...) - print(arg_list) - assays_to_use <- NA - + if(is.null(arg_list$assay)) {assays_to_use <- NA} else assays_to_use <- arg_list$assay + all_assays <- get_all_assays(x)$assay_id # Shape is long if (shape == "long") { - + if(is.na(assays_to_use)) assays_to_use <- all_assays # Suppress generic data frame creation message produced by left_join suppressMessages({ .data <- @@ -83,7 +82,8 @@ setMethod("join_features", "SingleCellExperiment", function(.data, .data # Shape if wide - } else { + } else if (shape == "wide"){ + if(is.na(assays_to_use)) stop("Please provide assay") .data %>% left_join( by=c_(.data)$name, From 0cea6fe561fcdc2fdcac50311315105b391b1523 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Wed, 27 Sep 2023 14:05:08 +0100 Subject: [PATCH 050/140] Update utilities.R --- R/utilities.R | 11 ++++------- 1 file changed, 4 insertions(+), 7 deletions(-) diff --git a/R/utilities.R b/R/utilities.R index 2ebd698..db486c0 100755 --- a/R/utilities.R +++ b/R/utilities.R @@ -163,13 +163,10 @@ get_abundance_sc_wide <- function(.data, assays_to_use = assays_to_use, " You should have either variable features,", " or a feature list to extract.") } - # Get selected features + # Get selected features and assays feature_df <- get_all_features(.data) selected_features <- feature_df[(feature_df$feature %in% gs), ] - # If assay is specified select only specified assays - if(any(!is.na(assays_to_use))) { - selected_features <- selected_features[selected_features$assay_id %in% assays_to_use,] - } else if(is.na(assays_to_use)) stop("Please specify assay") + selected_features <- selected_features[selected_features$assay_id %in% assays_to_use,] selected_experiments_list <- split(x = selected_features, f = as.character(selected_features$exp_id)) extract_feature_values <- function(exp) { selected_features_exp <- as.character(unique(exp$exp_id)) @@ -261,10 +258,10 @@ get_abundance_sc_long <- function(.data, features = NULL, all = FALSE, exclude_z stop("tidySingleCellExperiment says: there are no assays names in the source SingleCellExperiment.") } - # Get selected features + # Get selected features and assays feature_df <- get_all_features(.data) selected_features <- feature_df[(feature_df$feature %in% features), ] - if(any(selected_features$assay_id %in% assays_to_use)) selected_features <- selected_features[selected_features$assay_id %in% assays_to_use,] + selected_features <- selected_features[selected_features$assay_id %in% assays_to_use,] selected_experiments_list <- split(x = selected_features, f = as.character(selected_features$exp_id)) extract_feature_values <- function(exp) { From 3fa4f8d7e03ca6c01075131dca76f75d256872cd Mon Sep 17 00:00:00 2001 From: Biomiha Date: Wed, 27 Sep 2023 14:11:12 +0100 Subject: [PATCH 051/140] Update utilities.R --- R/utilities.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/utilities.R b/R/utilities.R index db486c0..71f825e 100755 --- a/R/utilities.R +++ b/R/utilities.R @@ -127,7 +127,7 @@ get_all_features <- function(x) { #' @return A tidySingleCellExperiment object #' #' @noRd -get_abundance_sc_wide <- function(.data, assays_to_use = assays_to_use, +get_abundance_sc_wide <- function(.data, assays_to_use = assays_from_join_call, features=NULL, all=FALSE, prefix="") { # Solve CRAN warnings @@ -215,7 +215,7 @@ get_abundance_sc_wide <- function(.data, assays_to_use = assays_to_use, #' @return A tidySingleCellExperiment object #' #' @noRd -get_abundance_sc_long <- function(.data, features = NULL, all = FALSE, exclude_zeros = FALSE, assays_to_use = assays_to_use) { +get_abundance_sc_long <- function(.data, features = NULL, all = FALSE, exclude_zeros = FALSE, assays_to_use = assays_from_join_call) { # Solve CRAN warnings . <- NULL From 3d3db341159ea6224aa43e1a1db728d479536b9c Mon Sep 17 00:00:00 2001 From: Biomiha Date: Wed, 27 Sep 2023 14:13:16 +0100 Subject: [PATCH 052/140] Update methods.R --- R/methods.R | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/R/methods.R b/R/methods.R index e99e245..dbd68e0 100755 --- a/R/methods.R +++ b/R/methods.R @@ -42,11 +42,10 @@ setMethod("join_features", "SingleCellExperiment", function(.data, .cell <- NULL .feature <- NULL arg_list <- c(mget(ls(environment(), sorted=F)), match.call(expand.dots=F)$...) - if(is.null(arg_list$assay)) {assays_to_use <- NA} else assays_to_use <- arg_list$assay all_assays <- get_all_assays(x)$assay_id + if(is.null(arg_list$assay)) assays_from_join_call <- all_assays # Shape is long if (shape == "long") { - if(is.na(assays_to_use)) assays_to_use <- all_assays # Suppress generic data frame creation message produced by left_join suppressMessages({ .data <- @@ -83,7 +82,7 @@ setMethod("join_features", "SingleCellExperiment", function(.data, # Shape if wide } else if (shape == "wide"){ - if(is.na(assays_to_use)) stop("Please provide assay") + if(is.null(arg_list$assay)) stop("Please provide assay") .data %>% left_join( by=c_(.data)$name, From 7091049bdef281d4275251d8c6127d4a6954d9ba Mon Sep 17 00:00:00 2001 From: Biomiha Date: Wed, 27 Sep 2023 20:58:02 +0100 Subject: [PATCH 053/140] Update utilities.R --- R/utilities.R | 15 ++++++++++++--- 1 file changed, 12 insertions(+), 3 deletions(-) diff --git a/R/utilities.R b/R/utilities.R index 71f825e..35fa7d3 100755 --- a/R/utilities.R +++ b/R/utilities.R @@ -127,8 +127,12 @@ get_all_features <- function(x) { #' @return A tidySingleCellExperiment object #' #' @noRd -get_abundance_sc_wide <- function(.data, assays_to_use = assays_from_join_call, - features=NULL, all=FALSE, prefix="") { +get_abundance_sc_wide <- function(.data, features=NULL, all=FALSE, prefix="", ...) { + + arg_list <- c(mget(ls(environment(), sorted=F)), match.call(expand.dots=F)$...) + assays_to_use <- eval(arg_list$assay) + if(is.null(assays_to_use)) stop("Please provide assay name") + # Solve CRAN warnings . <- NULL @@ -215,7 +219,12 @@ get_abundance_sc_wide <- function(.data, assays_to_use = assays_from_join_call, #' @return A tidySingleCellExperiment object #' #' @noRd -get_abundance_sc_long <- function(.data, features = NULL, all = FALSE, exclude_zeros = FALSE, assays_to_use = assays_from_join_call) { +get_abundance_sc_long <- function(.data, features = NULL, all = FALSE, exclude_zeros = FALSE, ...) { + + arg_list <- c(mget(ls(environment(), sorted=F)), match.call(expand.dots=F)$...) + assays_to_use <- eval(arg_list$assay) + if(is.null(assays_to_use)) assays_to_use <- get_all_assays(.data)$assay_id + # Solve CRAN warnings . <- NULL From 2d7673a5578a81ad7c3ba81adb1fe3c79c704a61 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Wed, 27 Sep 2023 21:16:41 +0100 Subject: [PATCH 054/140] Update utilities.R Solve name_repair issue --- R/utilities.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/utilities.R b/R/utilities.R index 35fa7d3..d284b8b 100755 --- a/R/utilities.R +++ b/R/utilities.R @@ -190,7 +190,7 @@ get_abundance_sc_wide <- function(.data, features=NULL, all=FALSE, prefix="", .. if(is.null(dim(mtx))) mtx <- matrix(mtx, byrow = TRUE, nrow = 1, ncol = length(mtx)) mtx %>% as.matrix() %>% t() %>% - as_tibble(rownames=c_(.data)$name) %>% + as_tibble(rownames=c_(.data)$name, .name_repair = "check_unique") %>% setNames(c(c_(.data)$name, sprintf("%s%s", prefix, selected_features_from_exp))) } } From e64de6edd24c9cbf5209e38e7f024176dd298aa3 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Wed, 27 Sep 2023 21:29:26 +0100 Subject: [PATCH 055/140] Update methods.R --- R/methods.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/methods.R b/R/methods.R index dbd68e0..889d887 100755 --- a/R/methods.R +++ b/R/methods.R @@ -42,7 +42,7 @@ setMethod("join_features", "SingleCellExperiment", function(.data, .cell <- NULL .feature <- NULL arg_list <- c(mget(ls(environment(), sorted=F)), match.call(expand.dots=F)$...) - all_assays <- get_all_assays(x)$assay_id + all_assays <- get_all_assays(.data)$assay_id if(is.null(arg_list$assay)) assays_from_join_call <- all_assays # Shape is long if (shape == "long") { From 19c65f669dd106cf220cdd329cac94c848441ede Mon Sep 17 00:00:00 2001 From: Biomiha Date: Wed, 27 Sep 2023 21:30:53 +0100 Subject: [PATCH 056/140] Update utilities.R --- R/utilities.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/utilities.R b/R/utilities.R index d284b8b..9d7b6a7 100755 --- a/R/utilities.R +++ b/R/utilities.R @@ -182,7 +182,7 @@ get_abundance_sc_wide <- function(.data, features=NULL, all=FALSE, prefix="", .. if(is.null(dim(mtx))) mtx <- matrix(mtx, byrow = TRUE, nrow = 1, ncol = length(mtx)) mtx %>% as.matrix() %>% t() %>% - as_tibble(rownames=c_(.data)$name) %>% + as_tibble(rownames=c_(.data)$name, .name_repair = "check_unique") %>% setNames(c(c_(.data)$name, sprintf("%s%s", prefix, selected_features_from_exp))) } else { selected_features_from_exp <- rownames(altExps(.data)[[selected_features_exp]])[(rownames(altExps(.data)[[selected_features_exp]]) %in% gs)] From e97ee07b2eea9e1b438278876d749bffb1eee2bd Mon Sep 17 00:00:00 2001 From: Biomiha Date: Wed, 27 Sep 2023 21:36:20 +0100 Subject: [PATCH 057/140] Update utilities.R --- R/utilities.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/utilities.R b/R/utilities.R index 9d7b6a7..44bd3b3 100755 --- a/R/utilities.R +++ b/R/utilities.R @@ -182,7 +182,7 @@ get_abundance_sc_wide <- function(.data, features=NULL, all=FALSE, prefix="", .. if(is.null(dim(mtx))) mtx <- matrix(mtx, byrow = TRUE, nrow = 1, ncol = length(mtx)) mtx %>% as.matrix() %>% t() %>% - as_tibble(rownames=c_(.data)$name, .name_repair = "check_unique") %>% + as_tibble(rownames=c_(.data)$name, .name_repair = "minimal") %>% setNames(c(c_(.data)$name, sprintf("%s%s", prefix, selected_features_from_exp))) } else { selected_features_from_exp <- rownames(altExps(.data)[[selected_features_exp]])[(rownames(altExps(.data)[[selected_features_exp]]) %in% gs)] @@ -190,7 +190,7 @@ get_abundance_sc_wide <- function(.data, features=NULL, all=FALSE, prefix="", .. if(is.null(dim(mtx))) mtx <- matrix(mtx, byrow = TRUE, nrow = 1, ncol = length(mtx)) mtx %>% as.matrix() %>% t() %>% - as_tibble(rownames=c_(.data)$name, .name_repair = "check_unique") %>% + as_tibble(rownames=c_(.data)$name, .name_repair = "minimal") %>% setNames(c(c_(.data)$name, sprintf("%s%s", prefix, selected_features_from_exp))) } } From 4fa50536e6f7a253793232bb96e4f03862997a45 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Wed, 27 Sep 2023 21:58:07 +0100 Subject: [PATCH 058/140] Update dplyr_methods.R --- R/dplyr_methods.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/dplyr_methods.R b/R/dplyr_methods.R index db079f9..3d275cf 100755 --- a/R/dplyr_methods.R +++ b/R/dplyr_methods.R @@ -351,7 +351,7 @@ left_join.SingleCellExperiment <- function(x, y, } z <- x |> - as_tibble() |> + as_tibble(.name_repair = "minimal") |> dplyr::left_join(y, by=by, copy=copy, suffix=suffix, ...) # If duplicated cells returns tibble From ca7b27b6d9eb4bedfd7cacd317bf5a941b2ec0bc Mon Sep 17 00:00:00 2001 From: Biomiha Date: Wed, 27 Sep 2023 22:04:13 +0100 Subject: [PATCH 059/140] Update dplyr_methods.R --- R/dplyr_methods.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/dplyr_methods.R b/R/dplyr_methods.R index 3d275cf..db079f9 100755 --- a/R/dplyr_methods.R +++ b/R/dplyr_methods.R @@ -351,7 +351,7 @@ left_join.SingleCellExperiment <- function(x, y, } z <- x |> - as_tibble(.name_repair = "minimal") |> + as_tibble() |> dplyr::left_join(y, by=by, copy=copy, suffix=suffix, ...) # If duplicated cells returns tibble From 203e1f236fae422e29a3cc20e96f613738af5420 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Wed, 27 Sep 2023 22:10:42 +0100 Subject: [PATCH 060/140] Update utilities.R --- R/utilities.R | 2 ++ 1 file changed, 2 insertions(+) diff --git a/R/utilities.R b/R/utilities.R index 44bd3b3..208e5a9 100755 --- a/R/utilities.R +++ b/R/utilities.R @@ -181,6 +181,7 @@ get_abundance_sc_wide <- function(.data, features=NULL, all=FALSE, prefix="", .. mtx <- assay(.data, selected_features_assay_names)[selected_features_from_exp,] if(is.null(dim(mtx))) mtx <- matrix(mtx, byrow = TRUE, nrow = 1, ncol = length(mtx)) mtx %>% + `colnames<-`(colnames(.data)) %>% as.matrix() %>% t() %>% as_tibble(rownames=c_(.data)$name, .name_repair = "minimal") %>% setNames(c(c_(.data)$name, sprintf("%s%s", prefix, selected_features_from_exp))) @@ -189,6 +190,7 @@ get_abundance_sc_wide <- function(.data, features=NULL, all=FALSE, prefix="", .. mtx <- assay(altExps(.data)[[selected_features_exp]], selected_features_assay)[selected_features_from_exp,] if(is.null(dim(mtx))) mtx <- matrix(mtx, byrow = TRUE, nrow = 1, ncol = length(mtx)) mtx %>% + `colnames<-`(colnames(.data)) %>% as.matrix() %>% t() %>% as_tibble(rownames=c_(.data)$name, .name_repair = "minimal") %>% setNames(c(c_(.data)$name, sprintf("%s%s", prefix, selected_features_from_exp))) From 8fe1ee2aa03e8344e8873a861e974e3396d531af Mon Sep 17 00:00:00 2001 From: Biomiha Date: Wed, 27 Sep 2023 22:13:53 +0100 Subject: [PATCH 061/140] Update utilities.R --- R/utilities.R | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/R/utilities.R b/R/utilities.R index 208e5a9..bdce393 100755 --- a/R/utilities.R +++ b/R/utilities.R @@ -196,8 +196,10 @@ get_abundance_sc_wide <- function(.data, features=NULL, all=FALSE, prefix="", .. setNames(c(c_(.data)$name, sprintf("%s%s", prefix, selected_features_from_exp))) } } - lapply(selected_experiments_list, extract_feature_values) |> - reduce(full_join) + suppressMessages({ + lapply(selected_experiments_list, extract_feature_values) |> + reduce(full_join) + }) } #' get abundance long @@ -347,8 +349,10 @@ get_abundance_sc_long <- function(.data, features = NULL, all = FALSE, exclude_z Reduce(function(...) full_join(..., by = c(".feature", c_(.data)$name)), .) } } - lapply(selected_experiments_list, extract_feature_values) |> - reduce(full_join) + suppressMessages({ + lapply(selected_experiments_list, extract_feature_values) |> + reduce(full_join) + }) } #' @importFrom dplyr select any_of From 6493ad9f3ae4ea630186b05d6d6364ccbce15653 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Fri, 29 Sep 2023 09:31:50 +0100 Subject: [PATCH 062/140] Update methods.R --- R/methods.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/methods.R b/R/methods.R index 889d887..7c1cc01 100755 --- a/R/methods.R +++ b/R/methods.R @@ -43,7 +43,7 @@ setMethod("join_features", "SingleCellExperiment", function(.data, .feature <- NULL arg_list <- c(mget(ls(environment(), sorted=F)), match.call(expand.dots=F)$...) all_assays <- get_all_assays(.data)$assay_id - if(is.null(arg_list$assay)) assays_from_join_call <- all_assays + if(is.null(arg_list$assays)) assays_from_join_call <- all_assays # Shape is long if (shape == "long") { # Suppress generic data frame creation message produced by left_join @@ -82,7 +82,7 @@ setMethod("join_features", "SingleCellExperiment", function(.data, # Shape if wide } else if (shape == "wide"){ - if(is.null(arg_list$assay)) stop("Please provide assay") + if(is.null(arg_list$assays)) stop("Please provide assay") .data %>% left_join( by=c_(.data)$name, From 5a64c2da31aa4ee57c1129e54c668e7ae0e386fa Mon Sep 17 00:00:00 2001 From: Biomiha Date: Fri, 29 Sep 2023 09:33:28 +0100 Subject: [PATCH 063/140] Update utilities.R --- R/utilities.R | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/R/utilities.R b/R/utilities.R index bdce393..6ab3fde 100755 --- a/R/utilities.R +++ b/R/utilities.R @@ -130,8 +130,8 @@ get_all_features <- function(x) { get_abundance_sc_wide <- function(.data, features=NULL, all=FALSE, prefix="", ...) { arg_list <- c(mget(ls(environment(), sorted=F)), match.call(expand.dots=F)$...) - assays_to_use <- eval(arg_list$assay) - if(is.null(assays_to_use)) stop("Please provide assay name") + assays_to_use <- eval(arg_list$assays) + if(is.null(assays_to_use)) stop("Please provide assay names") # Solve CRAN warnings @@ -226,7 +226,7 @@ get_abundance_sc_wide <- function(.data, features=NULL, all=FALSE, prefix="", .. get_abundance_sc_long <- function(.data, features = NULL, all = FALSE, exclude_zeros = FALSE, ...) { arg_list <- c(mget(ls(environment(), sorted=F)), match.call(expand.dots=F)$...) - assays_to_use <- eval(arg_list$assay) + assays_to_use <- eval(arg_list$assays) if(is.null(assays_to_use)) assays_to_use <- get_all_assays(.data)$assay_id # Solve CRAN warnings From ca20f9011adea1837819611ccb62a0c0ee438ad6 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Fri, 29 Sep 2023 09:39:31 +0100 Subject: [PATCH 064/140] Update methods.R --- R/methods.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/methods.R b/R/methods.R index 7c1cc01..3646dd5 100755 --- a/R/methods.R +++ b/R/methods.R @@ -82,7 +82,7 @@ setMethod("join_features", "SingleCellExperiment", function(.data, # Shape if wide } else if (shape == "wide"){ - if(is.null(arg_list$assays)) stop("Please provide assay") + if(is.null(arg_list$assays)) stop("Please provide assays") .data %>% left_join( by=c_(.data)$name, From ed0400e85980a4240dd1b6897ecc1ffa2ec15e91 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Sat, 30 Sep 2023 19:17:20 +0100 Subject: [PATCH 065/140] Update methods.R Fix aggregate cells --- R/methods.R | 100 +++++++++++++++++++++++++++------------------------- 1 file changed, 52 insertions(+), 48 deletions(-) diff --git a/R/methods.R b/R/methods.R index 3646dd5..6479381 100755 --- a/R/methods.R +++ b/R/methods.R @@ -143,61 +143,65 @@ tidy.SingleCellExperiment <- function(object) { #' @importFrom S4Vectors split #' @importFrom stringr str_remove #' @importFrom dplyr group_split +#' @importFrom dplyr full_join #' #' #' @export setMethod("aggregate_cells", "SingleCellExperiment", function(.data, - .sample = NULL, - slot = "data", - assays = NULL, - aggregation_function = Matrix::rowSums){ - + .sample = NULL, + slot = "data", + assays = NULL, + aggregation_function = Matrix::rowSums) { # Fix NOTEs - feature = NULL - - .sample = enquo(.sample) - + feature <- NULL + + .sample <- enquo(.sample) + # Subset only wanted assays - if(!is.null(assays)){ + if (!is.null(assays)) { assay_info <- get_all_assays(.data) - if(!any(assay_info$assay_id %in% assays)) stop("Please select an appropriate assay name") - selected_assays <- assay_info[assay_info$assay_id %in% assays,] - selected_exp <- unique(selected_assays$exp_id) - if(length(selected_exp) > 1) stop("Please avoid mixing features from different experiments.") - if(selected_exp == "Main") { - .data@assays@data <- .data@assays@data[selected_assays$assay_name] - } else { - .data <- altExps(.data)[[selected_exp]] - .data@assays@data = .data@assays@data[selected_assays$assay_name] + if (!any(assay_info$assay_id %in% assays)) stop("Please select an appropriate assay name") + selected_assays <- assay_info[assay_info$assay_id %in% assays, ] + selected_experiments_list <- split(x = selected_assays, f = as.character(selected_assays$exp_id)) + if ("Main" %in% names(selected_experiments_list)) selected_experiments_list <- selected_experiments_list[c("Main", setdiff(names(selected_experiments_list), "Main"))] + + aggregate_exp <- function(exp) { + selected_exp <- unique(exp$exp_id) + if (selected_exp == "Main") { + .data@assays@data <- .data@assays@data[exp$assay_name] + } else { + col_data <- colData(.data) + .data <- altExps(.data)[[selected_exp]] + colData(.data) <- col_data + .data@assays@data <- .data@assays@data[exp$assay_name] + names(.data@assays@data) <- exp$assay_id + } + .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)), 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) } - } - - .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)), 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) %>% - + suppressMessages({ + Reduce(f = full_join, x = lapply(selected_experiments_list, aggregate_exp)) + }) + } %>% drop_class("tidySingleCellExperiment_nested") %>% - as_SummarizedExperiment(.sample = !!.sample, .transcript = feature, .abundance = !!as.symbol(names(.data@assays))) -}) +} From 376b260b5a95e881945763ff67a66b4240b7dd71 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Sat, 30 Sep 2023 19:21:29 +0100 Subject: [PATCH 066/140] Update methods.R --- R/methods.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/methods.R b/R/methods.R index 6479381..bde3118 100755 --- a/R/methods.R +++ b/R/methods.R @@ -204,4 +204,4 @@ setMethod("aggregate_cells", "SingleCellExperiment", function(.data, } %>% drop_class("tidySingleCellExperiment_nested") %>% as_SummarizedExperiment(.sample = !!.sample, .transcript = feature, .abundance = !!as.symbol(names(.data@assays))) -} +}) From 1c8a03d904dd831411e205c5d6fa85afa0cc3629 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Sat, 30 Sep 2023 20:52:08 +0100 Subject: [PATCH 067/140] Update methods.R --- R/methods.R | 93 +++++++++++++++++++++++++---------------------------- 1 file changed, 44 insertions(+), 49 deletions(-) diff --git a/R/methods.R b/R/methods.R index bde3118..1d3de29 100755 --- a/R/methods.R +++ b/R/methods.R @@ -147,61 +147,56 @@ tidy.SingleCellExperiment <- function(object) { #' #' #' @export -setMethod("aggregate_cells", "SingleCellExperiment", function(.data, - .sample = NULL, - slot = "data", - assays = NULL, - aggregation_function = Matrix::rowSums) { +setMethod("aggregate_cells", "SingleCellExperiment", function(.data, + .sample = NULL, + slot = "data", + assays = NULL, + aggregation_function = Matrix::rowSums) { # Fix NOTEs feature <- NULL - - .sample <- enquo(.sample) + .col <- ensym(.sample) # Subset only wanted assays if (!is.null(assays)) { - assay_info <- get_all_assays(.data) - if (!any(assay_info$assay_id %in% assays)) stop("Please select an appropriate assay name") - selected_assays <- assay_info[assay_info$assay_id %in% assays, ] - selected_experiments_list <- split(x = selected_assays, f = as.character(selected_assays$exp_id)) - if ("Main" %in% names(selected_experiments_list)) selected_experiments_list <- selected_experiments_list[c("Main", setdiff(names(selected_experiments_list), "Main"))] + { + assay_info <- get_all_assays(.data) + if (!any(assay_info$assay_id %in% assays)) stop("Please select an appropriate assay name") + selected_assays <- assay_info[assay_info$assay_id %in% assays, ] + selected_experiments_list <- split(x = selected_assays, f = as.character(selected_assays$exp_id)) + if ("Main" %in% names(selected_experiments_list)) selected_experiments_list <- selected_experiments_list[c("Main", setdiff(names(selected_experiments_list), "Main"))] - aggregate_exp <- function(exp) { - selected_exp <- unique(exp$exp_id) - if (selected_exp == "Main") { - .data@assays@data <- .data@assays@data[exp$assay_name] - } else { - col_data <- colData(.data) - .data <- altExps(.data)[[selected_exp]] - colData(.data) <- col_data - .data@assays@data <- .data@assays@data[exp$assay_name] - names(.data@assays@data) <- exp$assay_id + aggregate_exp <- function(exp) { + selected_exp <- unique(exp$exp_id) + if (selected_exp == "Main") { + .data@assays@data <- .data@assays@data[exp$assay_name] + } else { + col_data <- colData(.data) + .data <- altExps(.data)[[selected_exp]] + colData(.data) <- col_data + .data@assays@data <- .data@assays@data[exp$assay_name] + names(.data@assays@data) <- exp$assay_id + } + nested_data <- .data %>% + nest(data = -any_of(.col)) %>% + mutate(.aggregated_cells = as.integer(map(data, ~ ncol(.x)))) + + aggregate_nested <- function(sce) { + assays(sce)[exp$assay_id] |> + lapply(FUN = aggregation_function) |> + bind_cols() |> + mutate(feature = rownames(sce)) |> + select(feature, everything()) + } + + lapply(nested_data$data, aggregate_nested) |> + set_names(nested_data[[1]]) |> + bind_rows(.id = rlang::as_name(.col)) } - .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)), 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) + suppressMessages({ + lapply(selected_experiments_list, aggregate_exp) |> + purrr::reduce(full_join) |> + select(rlang::as_name(.col), feature, selected_assays$assay_id, everything()) + }) } - suppressMessages({ - Reduce(f = full_join, x = lapply(selected_experiments_list, aggregate_exp)) - }) - } %>% - drop_class("tidySingleCellExperiment_nested") %>% - as_SummarizedExperiment(.sample = !!.sample, .transcript = feature, .abundance = !!as.symbol(names(.data@assays))) + } }) From 7c774bf964b902022cb16011b7b386d83d342d5c Mon Sep 17 00:00:00 2001 From: Biomiha Date: Sat, 30 Sep 2023 20:56:02 +0100 Subject: [PATCH 068/140] Update methods.R --- R/methods.R | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/R/methods.R b/R/methods.R index 1d3de29..9bdeed8 100755 --- a/R/methods.R +++ b/R/methods.R @@ -134,7 +134,8 @@ tidy.SingleCellExperiment <- function(object) { #' pbmc_small_pseudo_bulk <- pbmc_small |> #' aggregate_cells(c(groups, ident), assays="counts") #' -#' @importFrom rlang enquo +#' @importFrom rlang ensym +#' @importFrom rlang as_name #' @importFrom magrittr "%>%" #' @importFrom tibble enframe #' @importFrom Matrix rowSums @@ -144,6 +145,7 @@ tidy.SingleCellExperiment <- function(object) { #' @importFrom stringr str_remove #' @importFrom dplyr group_split #' @importFrom dplyr full_join +#' @importFrom purrr reduce #' #' #' @export @@ -190,12 +192,12 @@ setMethod("aggregate_cells", "SingleCellExperiment", function(.data, lapply(nested_data$data, aggregate_nested) |> set_names(nested_data[[1]]) |> - bind_rows(.id = rlang::as_name(.col)) + bind_rows(.id = as_name(.col)) } suppressMessages({ lapply(selected_experiments_list, aggregate_exp) |> - purrr::reduce(full_join) |> - select(rlang::as_name(.col), feature, selected_assays$assay_id, everything()) + reduce(full_join) |> + select(as_name(.col), feature, selected_assays$assay_id, everything()) }) } } From a2cf4abb83f5e2d4e035d20218c6200f38353cf7 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Sun, 1 Oct 2023 13:20:22 +0100 Subject: [PATCH 069/140] Update utilities.R --- R/utilities.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/utilities.R b/R/utilities.R index 6ab3fde..9e58810 100755 --- a/R/utilities.R +++ b/R/utilities.R @@ -198,7 +198,7 @@ get_abundance_sc_wide <- function(.data, features=NULL, all=FALSE, prefix="", .. } suppressMessages({ lapply(selected_experiments_list, extract_feature_values) |> - reduce(full_join) + purrr::reduce(full_join) }) } @@ -351,7 +351,7 @@ get_abundance_sc_long <- function(.data, features = NULL, all = FALSE, exclude_z } suppressMessages({ lapply(selected_experiments_list, extract_feature_values) |> - reduce(full_join) + purrr::reduce(full_join) }) } From 8df074a38a6138eeca9d4546de3171f7b495c2be Mon Sep 17 00:00:00 2001 From: Biomiha Date: Sun, 1 Oct 2023 15:17:00 +0100 Subject: [PATCH 070/140] Update utilities.R --- R/utilities.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/utilities.R b/R/utilities.R index 9e58810..c184083 100755 --- a/R/utilities.R +++ b/R/utilities.R @@ -198,7 +198,7 @@ get_abundance_sc_wide <- function(.data, features=NULL, all=FALSE, prefix="", .. } suppressMessages({ lapply(selected_experiments_list, extract_feature_values) |> - purrr::reduce(full_join) + Reduce(f = full_join) }) } @@ -351,7 +351,7 @@ get_abundance_sc_long <- function(.data, features = NULL, all = FALSE, exclude_z } suppressMessages({ lapply(selected_experiments_list, extract_feature_values) |> - purrr::reduce(full_join) + Reduce(f = full_join) }) } From 8965104450caddcbe4c2f9b1766df2c76414b071 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Sun, 1 Oct 2023 15:23:13 +0100 Subject: [PATCH 071/140] Update test-methods.R --- tests/testthat/test-methods.R | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/tests/testthat/test-methods.R b/tests/testthat/test-methods.R index fc4f509..37354a8 100644 --- a/tests/testthat/test-methods.R +++ b/tests/testthat/test-methods.R @@ -41,7 +41,7 @@ test_that("show()", { expect_equal(gsub(str, "\\1", txt[i]), paste(nrow(df))) i <- grep(str <- ".*Cells=([0-9]+).*", txt) expect_equal(gsub(str, "\\1", txt[i]), paste(ncol(df))) - i <- grep(".*Assays=.*", txt) + i <- grep(".*s=.*", txt) j <- grep(".cell*", txt) -1 header_text <- paste(txt[i:j], collapse = "") |> stringr::str_remove_all(pattern = "# ") |> @@ -50,12 +50,12 @@ test_that("show()", { stringr::str_remove_all(pattern = "\\[90m") |> stringr::str_remove_all(pattern = "\\[0m") x <- header_text |> - stringr::str_remove(pattern = ".+Assays=") |> + stringr::str_remove(pattern = ".+s=") |> strsplit(split = ", ") |> unlist() - y <- assayNames(df) + y <- Names(df) for (k in seq_along(altExps(pbmc_small))) { - y <- append(x = y, paste(altExpNames(pbmc_small)[[k]], assayNames(altExps(pbmc_small)[[k]]), sep = "-")) + y <- append(x = y, paste(altExpNames(pbmc_small)[[k]], Names(altExps(pbmc_small)[[k]]), sep = "-")) } for(j in seq_along(y)) { expect_contains(x, y[j]) @@ -74,7 +74,7 @@ test_that("join_features()", { matrix(fd$.abundance_counts, nrow=length(gs)), as.matrix(unname(counts(df)[fd$.feature[seq_along(gs)], ]))) # wide - fd <- join_features(df, gs, shape="wide", assay="counts") + fd <- join_features(df, gs, shape="wide", assays="counts") expect_s4_class(fd, "SingleCellExperiment") expect_null(fd$.feature) expect_identical( @@ -93,7 +93,7 @@ test_that("join_features()", { matrix(fd |> select(starts_with(".abundance")) |> pull(1), nrow=length(gs)), as.matrix(unname(assays(altExp(df))[[1]][fd$.feature[seq_along(gs)], ]))) # wide - fd <- join_features(df, gs, shape="wide", assay="ADT-counts") + fd <- join_features(df, gs, shape="wide", assays="ADT-counts") expect_s4_class(fd, "SingleCellExperiment") expect_null(fd$.feature) expect_identical( @@ -141,4 +141,4 @@ test_that("aggregate_cells()", { expect_error(aggregate_cells(df, c(factor, string), assays="x")) fd <- aggregate_cells(df, c(factor, string), assays="counts") expect_identical(assayNames(fd), "counts") -}) \ No newline at end of file +}) From fe2ca4e0a7d4eeeaf91d3dcf3a2e1ba9bc169c3f Mon Sep 17 00:00:00 2001 From: Biomiha Date: Sun, 1 Oct 2023 15:32:11 +0100 Subject: [PATCH 072/140] Update test-methods.R --- tests/testthat/test-methods.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/testthat/test-methods.R b/tests/testthat/test-methods.R index 37354a8..ab182dc 100644 --- a/tests/testthat/test-methods.R +++ b/tests/testthat/test-methods.R @@ -53,9 +53,9 @@ test_that("show()", { stringr::str_remove(pattern = ".+s=") |> strsplit(split = ", ") |> unlist() - y <- Names(df) + y <- assayNames(df) for (k in seq_along(altExps(pbmc_small))) { - y <- append(x = y, paste(altExpNames(pbmc_small)[[k]], Names(altExps(pbmc_small)[[k]]), sep = "-")) + y <- append(x = y, paste(altExpNames(pbmc_small)[[k]], assayNames(altExps(pbmc_small)[[k]]), sep = "-")) } for(j in seq_along(y)) { expect_contains(x, y[j]) From e67876789eec2685be7ae935e0f145403042e660 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Sun, 1 Oct 2023 15:36:08 +0100 Subject: [PATCH 073/140] Update methods.R --- R/methods.R | 98 +++++++++++++++++++++++++++-------------------------- 1 file changed, 50 insertions(+), 48 deletions(-) diff --git a/R/methods.R b/R/methods.R index 9bdeed8..fb13e95 100755 --- a/R/methods.R +++ b/R/methods.R @@ -149,56 +149,58 @@ tidy.SingleCellExperiment <- function(object) { #' #' #' @export -setMethod("aggregate_cells", "SingleCellExperiment", function(.data, - .sample = NULL, - slot = "data", - assays = NULL, - aggregation_function = Matrix::rowSums) { +setMethod("aggregate_cells", "SingleCellExperiment", function(.data, + .sample = NULL, + slot = "data", + assays = NULL, + aggregation_function = Matrix::rowSums){ + # Fix NOTEs - feature <- NULL - .col <- ensym(.sample) - + feature = NULL + + .sample = enquo(.sample) + # Subset only wanted assays - if (!is.null(assays)) { - { - assay_info <- get_all_assays(.data) - if (!any(assay_info$assay_id %in% assays)) stop("Please select an appropriate assay name") - selected_assays <- assay_info[assay_info$assay_id %in% assays, ] - selected_experiments_list <- split(x = selected_assays, f = as.character(selected_assays$exp_id)) - if ("Main" %in% names(selected_experiments_list)) selected_experiments_list <- selected_experiments_list[c("Main", setdiff(names(selected_experiments_list), "Main"))] - - aggregate_exp <- function(exp) { - selected_exp <- unique(exp$exp_id) - if (selected_exp == "Main") { - .data@assays@data <- .data@assays@data[exp$assay_name] - } else { - col_data <- colData(.data) - .data <- altExps(.data)[[selected_exp]] - colData(.data) <- col_data - .data@assays@data <- .data@assays@data[exp$assay_name] - names(.data@assays@data) <- exp$assay_id - } - nested_data <- .data %>% - nest(data = -any_of(.col)) %>% - mutate(.aggregated_cells = as.integer(map(data, ~ ncol(.x)))) - - aggregate_nested <- function(sce) { - assays(sce)[exp$assay_id] |> - lapply(FUN = aggregation_function) |> - bind_cols() |> - mutate(feature = rownames(sce)) |> - select(feature, everything()) - } - - lapply(nested_data$data, aggregate_nested) |> - set_names(nested_data[[1]]) |> - bind_rows(.id = as_name(.col)) - } - suppressMessages({ - lapply(selected_experiments_list, aggregate_exp) |> - reduce(full_join) |> - select(as_name(.col), feature, selected_assays$assay_id, everything()) - }) + if(!is.null(assays)){ + assay_info <- get_all_assays(.data) + if(!any(assay_info$assay_id %in% assays)) stop("Please select an appropriate assay name") + selected_assays <- assay_info[assay_info$assay_id %in% assays,] + selected_exp <- unique(selected_assays$exp_id) + if(length(selected_exp) > 1) stop("Please avoid mixing features from different experiments.") + if(selected_exp == "Main") { + .data@assays@data <- .data@assays@data[selected_assays$assay_name] + } else { + .data <- altExps(.data)[[selected_exp]] + .data@assays@data = .data@assays@data[selected_assays$assay_name] } } + + .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)), 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) %>% + + drop_class("tidySingleCellExperiment_nested") %>% + + as_SummarizedExperiment(.sample = !!.sample, .transcript = feature, .abundance = !!as.symbol(names(.data@assays))) }) From 5dfc7be34a74d221b4680babf4669c82b5f6a4e9 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Sun, 1 Oct 2023 16:11:19 +0100 Subject: [PATCH 074/140] Update methods.R --- R/methods.R | 121 +++++++++++++++++++++++++++++++++++----------------- 1 file changed, 81 insertions(+), 40 deletions(-) diff --git a/R/methods.R b/R/methods.R index fb13e95..c35bd7a 100755 --- a/R/methods.R +++ b/R/methods.R @@ -150,57 +150,98 @@ tidy.SingleCellExperiment <- function(object) { #' #' @export setMethod("aggregate_cells", "SingleCellExperiment", function(.data, - .sample = NULL, - slot = "data", - assays = NULL, - aggregation_function = Matrix::rowSums){ + .sample=NULL, slot="data", assays=NULL, + aggregation_function=Matrix::rowSums, + ...) { # Fix NOTEs - feature = NULL - - .sample = enquo(.sample) + feature <- NULL + .sample <- enquo(.sample) # Subset only wanted assays - if(!is.null(assays)){ + if (!is.null(assays)) { assay_info <- get_all_assays(.data) if(!any(assay_info$assay_id %in% assays)) stop("Please select an appropriate assay name") selected_assays <- assay_info[assay_info$assay_id %in% assays,] selected_exp <- unique(selected_assays$exp_id) - if(length(selected_exp) > 1) stop("Please avoid mixing features from different experiments.") - if(selected_exp == "Main") { - .data@assays@data <- .data@assays@data[selected_assays$assay_name] - } else { - .data <- altExps(.data)[[selected_exp]] - .data@assays@data = .data@assays@data[selected_assays$assay_name] - } + selected_experiments_list <- split(x = selected_assays, f = as.character(selected_assays$exp_id)) + if("Main" %in% selected_exp) selected_experiments_list <- selected_experiments_list[c("Main", setdiff(names(selected_experiments_list), "Main"))] } - .data %>% + aggregate_exps <- function(exp) { + if(unique(exp$exp_id) == "Main") + { + assays(.data) <- assays(.data)[exp$assay_name] + } else { + col_data <- colData(.data) + .data <- altExps(.data)[[unique(exp$exp_id)]] + colData(.data) <- col_data + assays(.data) <- assays(.data)[exp$assay_name] + } + grouping_factor = + .data |> + colData() |> + as_tibble() |> + select(!!.sample) |> + suppressMessages() |> + unite("my_id_to_split_by___", !!.sample, sep = "___") |> + pull(my_id_to_split_by___) |> + as.factor() + + list_count_cells = table(grouping_factor) |> as.list() - 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) %>% + # New method + list_assays = + .data |> + assays() |> + as.list() |> + map(~ .x |> splitColData(grouping_factor)) |> + unlist(recursive=FALSE) + + list_assays = + list_assays |> + map2(names(list_assays), ~ { + # Get counts + .x %>% + aggregation_function(na.rm=TRUE) %>% + enframe( + name =".feature", + value="x") %>% # sprintf("%s", .y)) %>% + + # In case we don't have rownames + mutate(.feature=as.character(.feature)) + }) |> + enframe(name = ".sample") |> + + # Clean groups + mutate(assay_name = assayNames(!!.data) |> rep(each=length(levels(grouping_factor)))) |> + mutate(.sample = .sample |> str_remove(assay_name) |> str_remove("\\.")) |> + group_split(.sample) |> + map(~ .x |> unnest(value) |> pivot_wider(names_from = assay_name, values_from = x) ) |> + + # Add cell count + map2( + list_count_cells, + ~ .x |> mutate(.aggregated_cells = .y) + ) - drop_class("tidySingleCellExperiment_nested") %>% - as_SummarizedExperiment(.sample = !!.sample, .transcript = feature, .abundance = !!as.symbol(names(.data@assays))) + do.call(rbind, list_assays) |> + + left_join( + .data |> + colData() |> + as_tibble() |> + subset(!!.sample) |> + unite("my_id_to_split_by___", !!.sample, remove=FALSE, sep = "___"), + by= join_by(".sample" == "my_id_to_split_by___") + ) + } + + lapply(selected_experiments_list, aggregate_exps) |> + bind_rows() |> + as_SummarizedExperiment( + .sample=.sample, + .transcript=.feature, + .abundance=!!as.symbol(names(.data@assays))) }) From 2b908a2bd143537b934315ab837f544ae1d25138 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Thu, 19 Oct 2023 17:47:36 +0100 Subject: [PATCH 075/140] Update utilities.R --- R/utilities.R | 256 ++++++++++++++++++++++++-------------------------- 1 file changed, 124 insertions(+), 132 deletions(-) diff --git a/R/utilities.R b/R/utilities.R index c184083..6e74572 100755 --- a/R/utilities.R +++ b/R/utilities.R @@ -127,8 +127,8 @@ get_all_features <- function(x) { #' @return A tidySingleCellExperiment object #' #' @noRd -get_abundance_sc_wide <- function(.data, features=NULL, all=FALSE, prefix="", ...) { - +get_abundance_sc_wide <- function(.data, features=NULL, all=FALSE, prefix="", variable_features = NA, ...) { + arg_list <- c(mget(ls(environment(), sorted=F)), match.call(expand.dots=F)$...) assays_to_use <- eval(arg_list$assays) if(is.null(assays_to_use)) stop("Please provide assay names") @@ -137,22 +137,21 @@ get_abundance_sc_wide <- function(.data, features=NULL, all=FALSE, prefix="", .. # Solve CRAN warnings . <- NULL - # For SCE there is not filed for variable features - variable_feature <- c() - + # For SCE there is no a priori field for variable features + if(!all(is.na(variable_features))) all <- FALSE # Check if output would be too big without forcing if (isFALSE(all) && is.null(features)) { - if (!length(variable_feature)) { + if (all(is.na(variable_features))) { stop("Your object does not contain variable feature labels,\n", - " feature argument is empty and all arguments are set to FALSE.\n", + "The features 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", + " 1. use scran::getTopHVGs() to select variable features\n", + " 2. pass an array of feature names to `variable_features`\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 + variable_genes <- variable_features } } else { variable_genes <- NULL @@ -162,13 +161,10 @@ get_abundance_sc_wide <- function(.data, features=NULL, all=FALSE, prefix="", .. 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.") } # Get selected features and assays feature_df <- get_all_features(.data) + if(isTRUE(all)) gs <- feature_df[feature_df$assay_id %in% assays_to_use, "feature"] selected_features <- feature_df[(feature_df$feature %in% gs), ] selected_features <- selected_features[selected_features$assay_id %in% assays_to_use,] selected_experiments_list <- split(x = selected_features, f = as.character(selected_features$exp_id)) @@ -198,8 +194,8 @@ get_abundance_sc_wide <- function(.data, features=NULL, all=FALSE, prefix="", .. } suppressMessages({ lapply(selected_experiments_list, extract_feature_values) |> - Reduce(f = full_join) - }) + Reduce(f = full_join) + }) } #' get abundance long @@ -223,136 +219,132 @@ get_abundance_sc_wide <- function(.data, features=NULL, all=FALSE, prefix="", .. #' @return A tidySingleCellExperiment object #' #' @noRd -get_abundance_sc_long <- function(.data, features = NULL, all = FALSE, exclude_zeros = FALSE, ...) { - - arg_list <- c(mget(ls(environment(), sorted=F)), match.call(expand.dots=F)$...) - assays_to_use <- eval(arg_list$assays) - if(is.null(assays_to_use)) assays_to_use <- get_all_assays(.data)$assay_id - +get_abundance_sc_long <- function(.data, features = NULL, all = FALSE, exclude_zeros = FALSE, variable_features = NA, ...) { # Solve CRAN warnings . <- NULL - - # For SCE there is not filed for variable features - variable_feature <- c() - + + # For SCE there is no a priori field for variable features + # For SCE there is no a priori field for variable features + if(!all(is.na(variable_features))) all <- FALSE # 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 (all(is.na(variable_features))) { + stop("Your object does not contain variable feature labels,\n", + "The features argument is empty and all arguments are set to FALSE.\n", + " Either:\n", + " 1. use scran::getTopHVGs() to select variable features\n", + " 2. pass an array of feature names to `variable_features`\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_features + features <- variable_features + } + } else if (isTRUE(all)) { variable_genes <- NULL } - + assay_names <- names(assays(.data)) - + # Check that I have assay names - can you even have an sce object with no assays? if (length(assay_names) == 0) { stop("tidySingleCellExperiment says: there are no assays names in the source SingleCellExperiment.") } - - # Get selected features and assays + + # Get assays + alt_exp_assays <- list() + alt_exp_assay_names_list <- lapply(altExps(.data), assayNames) + names(assay_names) <- rep("Main", length(assay_names)) + alt_exp_assay_names_df <- stack(alt_exp_assay_names_list) + alt_exp_assay_names <- paste(alt_exp_assay_names_df$ind, alt_exp_assay_names_df$values, sep = "-") + names(alt_exp_assay_names) <- alt_exp_assay_names_df$ind + all_assay_names_df <- rbind(stack(assay_names), alt_exp_assay_names_df) + all_assay_names <- c(assay_names, alt_exp_assay_names) + all_assay_names_ext_df <- stack(all_assay_names) + all_assay_names_ext_df <- cbind(all_assay_names_ext_df, all_assay_names_df$values) + colnames(all_assay_names_ext_df) <- c("assay_id", "exp_id", "assay_name") + + # Get list of features feature_df <- get_all_features(.data) + + # Get selected features selected_features <- feature_df[(feature_df$feature %in% features), ] - selected_features <- selected_features[selected_features$assay_id %in% assays_to_use,] - selected_experiments_list <- split(x = selected_features, f = as.character(selected_features$exp_id)) + if (isTRUE(all)) { + selected_features <- feature_df[feature_df$assay_id %in% assays_to_use, ] + } - extract_feature_values <- function(exp) { - selected_features_exp <- as.character(unique(exp$exp_id)) - selected_features_assay <- as.character(unique(exp$assay_name)) - selected_features_assay_names <- as.character(unique(exp$assay_id)) - if (selected_features_exp == "Main") { - assays(.data)[selected_features_assay] %>% - as.list() %>% - # Take active assay - map2( - selected_features_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 - }, ~ (.)) %>% - as.matrix() %>% - data.frame(check.names = FALSE) %>% - as_tibble(rownames = ".feature") %>% - tidyr::pivot_longer( - 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)), .) - } else { - assays(altExps(.data)[[selected_features_exp]])[selected_features_assay] %>% - as.list() %>% - # Take active assay - map2( - selected_features_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 - }, ~ (.)) %>% - as.matrix() %>% - data.frame(check.names = FALSE) %>% - as_tibble(rownames = ".feature") %>% - tidyr::pivot_longer( - 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)), .) - } + selected_features_exp <- unique(selected_features$exp_id) + if(length(selected_features_exp) > 1) stop("Please avoid mixing features from different experiments.") + selected_features_assay_names <- unique(selected_features$assay_id) + + if (selected_features_exp == "Main") { + 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 + }, ~ (.)) %>% + as.matrix() %>% + data.frame(check.names = FALSE) %>% + as_tibble(rownames = ".feature") %>% + tidyr::pivot_longer( + cols = -.feature, + names_to = c_(.data)$name, + values_to = ".abundance" %>% paste(.y, sep = "_"), + values_drop_na = TRUE + ) + # %>% + # mutate_if(is.character, as.factor) %>% + ) %>% + base::Reduce(function(...) full_join(..., by = c(".feature", c_(.data)$name)), .) + } else { + assays(altExps(.data)[[selected_features_exp]]) %>% + as.list() %>% + # Take active assay + map2( + selected_features_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 + }, ~ (.)) %>% + as.matrix() %>% + data.frame(check.names = FALSE) %>% + as_tibble(rownames = ".feature") %>% + tidyr::pivot_longer( + cols = -.feature, + names_to = c_(.data)$name, + values_to = ".abundance" %>% paste(.y, sep = "_"), + values_drop_na = TRUE + ) + # %>% + # mutate_if(is.character, as.factor) %>% + ) %>% + base::Reduce(function(...) full_join(..., by = c(".feature", c_(.data)$name)), .) } - suppressMessages({ - lapply(selected_experiments_list, extract_feature_values) |> - Reduce(f = full_join) - }) } #' @importFrom dplyr select any_of From 8e0501cf04744565bde28d99a203ae58d9014ec8 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Thu, 19 Oct 2023 17:57:00 +0100 Subject: [PATCH 076/140] Update utilities.R --- R/utilities.R | 18 ++++++++++++------ 1 file changed, 12 insertions(+), 6 deletions(-) diff --git a/R/utilities.R b/R/utilities.R index 6e74572..76cc3d0 100755 --- a/R/utilities.R +++ b/R/utilities.R @@ -220,6 +220,18 @@ get_abundance_sc_wide <- function(.data, features=NULL, all=FALSE, prefix="", va #' #' @noRd get_abundance_sc_long <- function(.data, features = NULL, all = FALSE, exclude_zeros = FALSE, variable_features = NA, ...) { + + assay_names <- names(assays(.data)) + + # Check that I have assay names - can you even have an sce object with no assays? + if (length(assay_names) == 0) { + stop("tidySingleCellExperiment says: there are no assays names in the source SingleCellExperiment.") + } + + arg_list <- c(mget(ls(environment(), sorted=F)), match.call(expand.dots=F)$...) + assays_to_use <- eval(arg_list$assays) + if(is.null(assays_to_use)) assays_to_use <- tail(names(assays(cbmc_sce)), n = 1) + # Solve CRAN warnings . <- NULL @@ -245,12 +257,6 @@ get_abundance_sc_long <- function(.data, features = NULL, all = FALSE, exclude_z variable_genes <- NULL } - assay_names <- names(assays(.data)) - - # Check that I have assay names - can you even have an sce object with no assays? - if (length(assay_names) == 0) { - stop("tidySingleCellExperiment says: there are no assays names in the source SingleCellExperiment.") - } # Get assays alt_exp_assays <- list() From 830529f08a0f1d05284f430a12cc62a3bee00e0f Mon Sep 17 00:00:00 2001 From: Biomiha Date: Thu, 19 Oct 2023 18:02:14 +0100 Subject: [PATCH 077/140] Update utilities.R --- R/utilities.R | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/R/utilities.R b/R/utilities.R index 76cc3d0..a891d1f 100755 --- a/R/utilities.R +++ b/R/utilities.R @@ -236,8 +236,11 @@ get_abundance_sc_long <- function(.data, features = NULL, all = FALSE, exclude_z . <- NULL # For SCE there is no a priori field for variable features - # For SCE there is no a priori field for variable features - if(!all(is.na(variable_features))) all <- FALSE + if(!all(is.na(variable_features))) {all <- FALSE} + if(!all(is.null(features))) { + all <- FALSE + variable_genes <- NULL + } # Check if output would be too big without forcing if (isFALSE(all) && is.null(features)) { if (all(is.na(variable_features))) { From d89e38fa8e4d07bfedf21e3de25fd2d230c8d828 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Fri, 20 Oct 2023 08:06:35 +0100 Subject: [PATCH 078/140] Update utilities.R --- R/utilities.R | 1 + 1 file changed, 1 insertion(+) diff --git a/R/utilities.R b/R/utilities.R index a891d1f..8111ad9 100755 --- a/R/utilities.R +++ b/R/utilities.R @@ -281,6 +281,7 @@ get_abundance_sc_long <- function(.data, features = NULL, all = FALSE, exclude_z selected_features <- feature_df[(feature_df$feature %in% features), ] if (isTRUE(all)) { selected_features <- feature_df[feature_df$assay_id %in% assays_to_use, ] + warning("To avoid mixing features from different experiments only features from the Main experiment will be used!") } selected_features_exp <- unique(selected_features$exp_id) From 2600e468739c348b3dd4bf4a555123bd74d68b4c Mon Sep 17 00:00:00 2001 From: Biomiha Date: Fri, 20 Oct 2023 08:16:50 +0100 Subject: [PATCH 079/140] Update utilities.R --- R/utilities.R | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/R/utilities.R b/R/utilities.R index 8111ad9..a82dd99 100755 --- a/R/utilities.R +++ b/R/utilities.R @@ -278,14 +278,14 @@ get_abundance_sc_long <- function(.data, features = NULL, all = FALSE, exclude_z feature_df <- get_all_features(.data) # Get selected features - selected_features <- feature_df[(feature_df$feature %in% features), ] + selected_features <- feature_df[(feature_df$feature %in% features), ] + selected_features_exp <- unique(selected_features$exp_id) + if(length(selected_features_exp) > 1) stop("Please avoid mixing features from different experiments.") + if (isTRUE(all)) { selected_features <- feature_df[feature_df$assay_id %in% assays_to_use, ] warning("To avoid mixing features from different experiments only features from the Main experiment will be used!") } - - selected_features_exp <- unique(selected_features$exp_id) - if(length(selected_features_exp) > 1) stop("Please avoid mixing features from different experiments.") selected_features_assay_names <- unique(selected_features$assay_id) if (selected_features_exp == "Main") { From 3272e663d30e7e0bf8799513a569b42320ba4691 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Fri, 20 Oct 2023 08:22:55 +0100 Subject: [PATCH 080/140] Update utilities.R --- R/utilities.R | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/R/utilities.R b/R/utilities.R index a82dd99..759db55 100755 --- a/R/utilities.R +++ b/R/utilities.R @@ -279,13 +279,12 @@ get_abundance_sc_long <- function(.data, features = NULL, all = FALSE, exclude_z # Get selected features selected_features <- feature_df[(feature_df$feature %in% features), ] - selected_features_exp <- unique(selected_features$exp_id) - if(length(selected_features_exp) > 1) stop("Please avoid mixing features from different experiments.") - if (isTRUE(all)) { selected_features <- feature_df[feature_df$assay_id %in% assays_to_use, ] warning("To avoid mixing features from different experiments only features from the Main experiment will be used!") } + selected_features_exp <- unique(selected_features$exp_id) + if(length(selected_features_exp) > 1) stop("Please avoid mixing features from different experiments.") selected_features_assay_names <- unique(selected_features$assay_id) if (selected_features_exp == "Main") { From 347d0cf064a3b8ead86df27813ac2f9efcf5075d Mon Sep 17 00:00:00 2001 From: Biomiha Date: Fri, 20 Oct 2023 18:12:05 +0100 Subject: [PATCH 081/140] Update utilities.R Trying all features --- R/utilities.R | 160 ++++++++++++++++++++++++-------------------------- 1 file changed, 77 insertions(+), 83 deletions(-) diff --git a/R/utilities.R b/R/utilities.R index 759db55..1d0ad0f 100755 --- a/R/utilities.R +++ b/R/utilities.R @@ -230,7 +230,6 @@ get_abundance_sc_long <- function(.data, features = NULL, all = FALSE, exclude_z arg_list <- c(mget(ls(environment(), sorted=F)), match.call(expand.dots=F)$...) assays_to_use <- eval(arg_list$assays) - if(is.null(assays_to_use)) assays_to_use <- tail(names(assays(cbmc_sce)), n = 1) # Solve CRAN warnings . <- NULL @@ -262,98 +261,93 @@ get_abundance_sc_long <- function(.data, features = NULL, all = FALSE, exclude_z # Get assays - alt_exp_assays <- list() - alt_exp_assay_names_list <- lapply(altExps(.data), assayNames) - names(assay_names) <- rep("Main", length(assay_names)) - alt_exp_assay_names_df <- stack(alt_exp_assay_names_list) - alt_exp_assay_names <- paste(alt_exp_assay_names_df$ind, alt_exp_assay_names_df$values, sep = "-") - names(alt_exp_assay_names) <- alt_exp_assay_names_df$ind - all_assay_names_df <- rbind(stack(assay_names), alt_exp_assay_names_df) - all_assay_names <- c(assay_names, alt_exp_assay_names) - all_assay_names_ext_df <- stack(all_assay_names) - all_assay_names_ext_df <- cbind(all_assay_names_ext_df, all_assay_names_df$values) - colnames(all_assay_names_ext_df) <- c("assay_id", "exp_id", "assay_name") + all_assay_names_ext_df <- get_all_assays(.data) # Get list of features feature_df <- get_all_features(.data) # Get selected features - selected_features <- feature_df[(feature_df$feature %in% features), ] - if (isTRUE(all)) { - selected_features <- feature_df[feature_df$assay_id %in% assays_to_use, ] - warning("To avoid mixing features from different experiments only features from the Main experiment will be used!") + if(is.null(features) && isTRUE(all)) { + features <- unique(feature_df$feature) } + selected_features <- feature_df[(feature_df$feature %in% features), ] selected_features_exp <- unique(selected_features$exp_id) - if(length(selected_features_exp) > 1) stop("Please avoid mixing features from different experiments.") selected_features_assay_names <- unique(selected_features$assay_id) + selected_experiments_list <- split(x = selected_features, f = as.character(selected_features$exp_id)) + if("Main" %in% selected_features_exp) selected_experiments_list <- selected_experiments_list[c("Main", setdiff(names(selected_experiments_list), "Main"))] - if (selected_features_exp == "Main") { - 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 - }, ~ (.)) %>% - as.matrix() %>% - data.frame(check.names = FALSE) %>% - as_tibble(rownames = ".feature") %>% - tidyr::pivot_longer( - cols = -.feature, - names_to = c_(.data)$name, - values_to = ".abundance" %>% paste(.y, sep = "_"), - values_drop_na = TRUE - ) - # %>% - # mutate_if(is.character, as.factor) %>% - ) %>% - base::Reduce(function(...) full_join(..., by = c(".feature", c_(.data)$name)), .) - } else { - assays(altExps(.data)[[selected_features_exp]]) %>% - as.list() %>% - # Take active assay - map2( - selected_features_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 - }, ~ (.)) %>% - as.matrix() %>% - data.frame(check.names = FALSE) %>% - as_tibble(rownames = ".feature") %>% - tidyr::pivot_longer( - cols = -.feature, - names_to = c_(.data)$name, - values_to = ".abundance" %>% paste(.y, sep = "_"), - values_drop_na = TRUE - ) - # %>% - # mutate_if(is.character, as.factor) %>% - ) %>% - base::Reduce(function(...) full_join(..., by = c(".feature", c_(.data)$name)), .) + extract_feature_values <- function(exp) { + selected_exp <- unique(exp$exp_id) + if (selected_exp == "Main") { + 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 + }, ~ (.)) %>% + as.matrix() %>% + data.frame(check.names = FALSE) %>% + as_tibble(rownames = ".feature") %>% + tidyr::pivot_longer( + cols = -.feature, + names_to = c_(.data)$name, + values_to = ".abundance" %>% paste(.y, sep = "_"), + values_drop_na = TRUE + ) + # %>% + # mutate_if(is.character, as.factor) %>% + ) %>% + base::Reduce(function(...) full_join(..., by = c(".feature", c_(.data)$name)), .) + } else { + assays(altExps(.data)[[unique(exp$exp_id)]]) %>% + as.list() %>% + # Take active assay + map2( + unique(exp$assay_id), + ~ .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 + }, ~ (.)) %>% + as.matrix() %>% + data.frame(check.names = FALSE) %>% + as_tibble(rownames = ".feature") %>% + tidyr::pivot_longer( + cols = -.feature, + names_to = c_(.data)$name, + values_to = ".abundance" %>% paste(.y, sep = "_"), + values_drop_na = TRUE + ) + # %>% + # mutate_if(is.character, as.factor) %>% + ) %>% + base::Reduce(function(...) full_join(..., by = c(".feature", c_(.data)$name)), .) + } } + lapply(selected_experiments_list, extract_feature_values) |> + bind_rows() } #' @importFrom dplyr select any_of From 4f6f1cbd2f28da2d928f0d9f1d48f2123cf71344 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Fri, 20 Oct 2023 18:27:32 +0100 Subject: [PATCH 082/140] Update utilities.R Tweak to allow specific assays --- R/utilities.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/utilities.R b/R/utilities.R index 1d0ad0f..200be02 100755 --- a/R/utilities.R +++ b/R/utilities.R @@ -271,8 +271,8 @@ get_abundance_sc_long <- function(.data, features = NULL, all = FALSE, exclude_z features <- unique(feature_df$feature) } selected_features <- feature_df[(feature_df$feature %in% features), ] + if(!is.null(assays_to_use)) selected_features <- selected_features[selected_features$assay_id %in% assays_to_use,] selected_features_exp <- unique(selected_features$exp_id) - selected_features_assay_names <- unique(selected_features$assay_id) selected_experiments_list <- split(x = selected_features, f = as.character(selected_features$exp_id)) if("Main" %in% selected_features_exp) selected_experiments_list <- selected_experiments_list[c("Main", setdiff(names(selected_experiments_list), "Main"))] From fc4351b3a3482192f0ac95e4db251e7f3d686416 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Fri, 20 Oct 2023 18:47:06 +0100 Subject: [PATCH 083/140] Update utilities.R Should capture all possible assay specifications now --- R/utilities.R | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/R/utilities.R b/R/utilities.R index 200be02..c220d78 100755 --- a/R/utilities.R +++ b/R/utilities.R @@ -281,9 +281,10 @@ get_abundance_sc_long <- function(.data, features = NULL, all = FALSE, exclude_z if (selected_exp == "Main") { assays(.data) %>% as.list() %>% + .[unique(exp$assay_name)] %>% # Take active assay map2( - assay_names, + unique(exp$assay_id), ~ .x %>% when( variable_genes %>% is.null() %>% `!`() ~ .x[variable_genes, , drop = FALSE], @@ -314,6 +315,7 @@ get_abundance_sc_long <- function(.data, features = NULL, all = FALSE, exclude_z } else { assays(altExps(.data)[[unique(exp$exp_id)]]) %>% as.list() %>% + .[unique(exp$assay_name)] %>% # Take active assay map2( unique(exp$assay_id), From a7dd8af5c0c121e5bde49f77311f36462a9cecdf Mon Sep 17 00:00:00 2001 From: Biomiha Date: Fri, 20 Oct 2023 19:14:58 +0100 Subject: [PATCH 084/140] Update utilities.R Tweak wide to account for features that have the same name in multiple assays --- R/utilities.R | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/R/utilities.R b/R/utilities.R index c220d78..0e7eecd 100755 --- a/R/utilities.R +++ b/R/utilities.R @@ -168,6 +168,7 @@ get_abundance_sc_wide <- function(.data, features=NULL, all=FALSE, prefix="", va selected_features <- feature_df[(feature_df$feature %in% gs), ] selected_features <- selected_features[selected_features$assay_id %in% assays_to_use,] selected_experiments_list <- split(x = selected_features, f = as.character(selected_features$exp_id)) + if("Main" %in% names(selected_experiments_list)) selected_experiments_list <- selected_experiments_list[c("Main", setdiff(names(selected_experiments_list), "Main"))] extract_feature_values <- function(exp) { selected_features_exp <- as.character(unique(exp$exp_id)) selected_features_assay <- as.character(unique(exp$assay_name)) @@ -193,8 +194,8 @@ get_abundance_sc_wide <- function(.data, features=NULL, all=FALSE, prefix="", va } } suppressMessages({ - lapply(selected_experiments_list, extract_feature_values) |> - Reduce(f = full_join) + feature_values_list <- lapply(selected_experiments_list, extract_feature_values) + purrr::reduce(feature_values_list, full_join, by = join_by(.cell), suffix = paste0(".", names(feature_values_list))) }) } From 8d461333dc20078670d881365c74be321cceed20 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Mon, 23 Oct 2023 20:57:55 +0100 Subject: [PATCH 085/140] Update methods.R new aggregate_cells --- R/methods.R | 165 +++++++++++++++++++++++++--------------------------- 1 file changed, 79 insertions(+), 86 deletions(-) diff --git a/R/methods.R b/R/methods.R index c35bd7a..31c3b56 100755 --- a/R/methods.R +++ b/R/methods.R @@ -134,8 +134,7 @@ tidy.SingleCellExperiment <- function(object) { #' pbmc_small_pseudo_bulk <- pbmc_small |> #' aggregate_cells(c(groups, ident), assays="counts") #' -#' @importFrom rlang ensym -#' @importFrom rlang as_name +#' @importFrom rlang enquo #' @importFrom magrittr "%>%" #' @importFrom tibble enframe #' @importFrom Matrix rowSums @@ -143,14 +142,22 @@ tidy.SingleCellExperiment <- function(object) { #' @importFrom SummarizedExperiment assays assays<- assayNames #' @importFrom S4Vectors split #' @importFrom stringr str_remove -#' @importFrom dplyr group_split #' @importFrom dplyr full_join +#' @importFrom dplyr left_join +#' @importFrom dplyr group_by +#' @importFrom dplyr pick +#' @importFrom dplyr group_rows +#' @importFrom dplyr group_keys +#' @importFrom dplyr bind_rows +#' @importFrom tidyr unite +#' @importFrom tidyr separate #' @importFrom purrr reduce +#' @importFrom purrr map #' #' #' @export setMethod("aggregate_cells", "SingleCellExperiment", function(.data, - .sample=NULL, slot="data", assays=NULL, + .sample=NULL, assays=NULL, aggregation_function=Matrix::rowSums, ...) { @@ -158,90 +165,76 @@ setMethod("aggregate_cells", "SingleCellExperiment", function(.data, feature <- NULL .sample <- enquo(.sample) - # Subset only wanted assays - if (!is.null(assays)) { - assay_info <- get_all_assays(.data) - if(!any(assay_info$assay_id %in% assays)) stop("Please select an appropriate assay name") - selected_assays <- assay_info[assay_info$assay_id %in% assays,] - selected_exp <- unique(selected_assays$exp_id) - selected_experiments_list <- split(x = selected_assays, f = as.character(selected_assays$exp_id)) - if("Main" %in% selected_exp) selected_experiments_list <- selected_experiments_list[c("Main", setdiff(names(selected_experiments_list), "Main"))] - } + arg_list <- c(mget(ls(environment(), sorted=F)), match.call(expand.dots=F)$...) + assays_to_use <- eval(arg_list$assays) + if(is.null(assays_to_use)) assays_to_use <- tail(names(assays(.data)), n = 1) + + sample_groups <- .data |> + as_tibble() |> + group_by(pick({{.sample}})) + + sample_group_idx <- sample_groups |> + group_rows() + + sample_group_keys <- sample_groups |> + group_keys() + + .sample_names <- colnames(sample_group_keys) + + sce_split <- map(.x = seq_along(sample_group_idx), .f = \(.num) .data[, sample_group_idx[[.num]]]) |> + set_names(sample_group_keys |> unite(col = "grouping_factor", !!.sample, sep = "___") |> + pull(grouping_factor)) + + grouping_factor = + .data |> + colData() |> + as_tibble() |> + select(!!.sample) |> + suppressMessages() |> + unite("my_id_to_split_by___", !!.sample, sep = "___") |> + pull(my_id_to_split_by___) |> + as.factor() - aggregate_exps <- function(exp) { - if(unique(exp$exp_id) == "Main") - { - assays(.data) <- assays(.data)[exp$assay_name] + list_count_cells = table(grouping_factor) |> + enframe(name = "grouping_factor", value = ".aggregated_cells") |> + mutate(.aggregated_cells = as.integer(.aggregated_cells)) + + feature_df <- get_all_features(.data) + selected_features <- feature_df[feature_df$assay_id %in% assays_to_use,] + selected_experiments_list <- split(x = selected_features, f = as.character(selected_features$exp_id)) + if("Main" %in% names(selected_experiments_list)) selected_experiments_list <- selected_experiments_list[c("Main", setdiff(names(selected_experiments_list), "Main"))] + + aggregate_assays_fun <- function(exp){ + selected_features_exp <- unique(exp$exp_id) + if(selected_features_exp == "Main") { + selected_assays <- unique(exp$assay_name) + aggregate_sce_fun <- function(sce) { + aggregated_vals <- assays(sce)[selected_assays] |> + as.list() |> + map(.f = \(.list) aggregation_function(.list)) + map(.x = seq_along(aggregated_vals), \(.num) enframe(x = aggregated_vals[[.num]], name = ".feature", value = selected_assays[[.num]])) |> + suppressMessages(reduce(full_join)) + } + suppressMessages(lapply(sce_split, aggregate_sce_fun) |> + map(.f = ~.x |> reduce(full_join)) |> + bind_rows(.id = "grouping_factor")) } else { - col_data <- colData(.data) - .data <- altExps(.data)[[unique(exp$exp_id)]] - colData(.data) <- col_data - assays(.data) <- assays(.data)[exp$assay_name] + aggregate_sce_fun <- function(sce) { + selected_exp <- unique(exp$exp_id) + selected_assays <- exp |> distinct(assay_name, .keep_all = TRUE) + aggregated_vals <- assays(altExps(sce)[[selected_exp]])[selected_assays$assay_name] |> + as.list() |> + map(.f = \(.list) aggregation_function(.list)) + map(.x = seq_along(aggregated_vals), \(.num) enframe(x = aggregated_vals[[.num]], name = ".feature", value = selected_assays$assay_id[[.num]])) |> + suppressMessages(reduce(full_join)) + } + suppressMessages(lapply(sce_split, aggregate_sce_fun) |> + map(.f = ~.x |> reduce(full_join)) |> + bind_rows(.id = "grouping_factor")) } - grouping_factor = - .data |> - colData() |> - as_tibble() |> - select(!!.sample) |> - suppressMessages() |> - unite("my_id_to_split_by___", !!.sample, sep = "___") |> - pull(my_id_to_split_by___) |> - as.factor() - - list_count_cells = table(grouping_factor) |> as.list() - - # New method - list_assays = - .data |> - assays() |> - as.list() |> - map(~ .x |> splitColData(grouping_factor)) |> - unlist(recursive=FALSE) - - list_assays = - list_assays |> - map2(names(list_assays), ~ { - # Get counts - .x %>% - aggregation_function(na.rm=TRUE) %>% - enframe( - name =".feature", - value="x") %>% # sprintf("%s", .y)) %>% - - # In case we don't have rownames - mutate(.feature=as.character(.feature)) - }) |> - enframe(name = ".sample") |> - - # Clean groups - mutate(assay_name = assayNames(!!.data) |> rep(each=length(levels(grouping_factor)))) |> - mutate(.sample = .sample |> str_remove(assay_name) |> str_remove("\\.")) |> - group_split(.sample) |> - map(~ .x |> unnest(value) |> pivot_wider(names_from = assay_name, values_from = x) ) |> - - # Add cell count - map2( - list_count_cells, - ~ .x |> mutate(.aggregated_cells = .y) - ) - - - do.call(rbind, list_assays) |> - - left_join( - .data |> - colData() |> - as_tibble() |> - subset(!!.sample) |> - unite("my_id_to_split_by___", !!.sample, remove=FALSE, sep = "___"), - by= join_by(".sample" == "my_id_to_split_by___") - ) } - - lapply(selected_experiments_list, aggregate_exps) |> - bind_rows() |> - as_SummarizedExperiment( - .sample=.sample, - .transcript=.feature, - .abundance=!!as.symbol(names(.data@assays))) + suppressMessages(lapply(selected_experiments_list, aggregate_assays_fun) |> + bind_rows() |> + left_join(list_count_cells) |> + separate(col = grouping_factor, into = .sample_names, sep = "___")) }) From 608d85baa1aa7ebbe349e9573933a812768d0698 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Mon, 23 Oct 2023 21:01:25 +0100 Subject: [PATCH 086/140] Update methods.R --- R/methods.R | 1 + 1 file changed, 1 insertion(+) diff --git a/R/methods.R b/R/methods.R index 31c3b56..a3835a4 100755 --- a/R/methods.R +++ b/R/methods.R @@ -153,6 +153,7 @@ tidy.SingleCellExperiment <- function(object) { #' @importFrom tidyr separate #' @importFrom purrr reduce #' @importFrom purrr map +#' @importFrom purrr set_names #' #' #' @export From 9ea6dce1fb42273e7f1ba265aee6aa54e3a4b317 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Mon, 23 Oct 2023 21:04:34 +0100 Subject: [PATCH 087/140] Update methods.R --- R/methods.R | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/R/methods.R b/R/methods.R index a3835a4..725ba07 100755 --- a/R/methods.R +++ b/R/methods.R @@ -149,6 +149,7 @@ tidy.SingleCellExperiment <- function(object) { #' @importFrom dplyr group_rows #' @importFrom dplyr group_keys #' @importFrom dplyr bind_rows +#' @importFrom dplyr pull #' @importFrom tidyr unite #' @importFrom tidyr separate #' @importFrom purrr reduce @@ -183,7 +184,7 @@ setMethod("aggregate_cells", "SingleCellExperiment", function(.data, .sample_names <- colnames(sample_group_keys) sce_split <- map(.x = seq_along(sample_group_idx), .f = \(.num) .data[, sample_group_idx[[.num]]]) |> - set_names(sample_group_keys |> unite(col = "grouping_factor", !!.sample, sep = "___") |> + purrr::set_names(sample_group_keys |> unite(col = "grouping_factor", !!.sample, sep = "___") |> pull(grouping_factor)) grouping_factor = From 4bf0c59407a314a981f3dd3063f6661e5e65ad4b Mon Sep 17 00:00:00 2001 From: Biomiha Date: Wed, 25 Oct 2023 10:23:58 +0100 Subject: [PATCH 088/140] Update methods.R Add SummarizedExperiment as output --- R/methods.R | 110 ++++++++++++++++++++++++++++------------------------ 1 file changed, 60 insertions(+), 50 deletions(-) diff --git a/R/methods.R b/R/methods.R index 725ba07..50bd6d7 100755 --- a/R/methods.R +++ b/R/methods.R @@ -166,28 +166,31 @@ setMethod("aggregate_cells", "SingleCellExperiment", function(.data, # Fix NOTEs feature <- NULL .sample <- enquo(.sample) - - arg_list <- c(mget(ls(environment(), sorted=F)), match.call(expand.dots=F)$...) + + arg_list <- c(mget(ls(environment(), sorted = F)), match.call(expand.dots = F)$...) assays_to_use <- eval(arg_list$assays) - if(is.null(assays_to_use)) assays_to_use <- tail(names(assays(.data)), n = 1) - - sample_groups <- .data |> - as_tibble() |> - group_by(pick({{.sample}})) - - sample_group_idx <- sample_groups |> + if (is.null(assays_to_use)) assays_to_use <- tail(names(assays(.data)), n = 1) + + sample_groups <- .data |> + as_tibble() |> + group_by(pick({{ .sample }})) + + sample_group_idx <- sample_groups |> group_rows() - - sample_group_keys <- sample_groups |> + + sample_group_keys <- sample_groups |> group_keys() - + .sample_names <- colnames(sample_group_keys) - - sce_split <- map(.x = seq_along(sample_group_idx), .f = \(.num) .data[, sample_group_idx[[.num]]]) |> - purrr::set_names(sample_group_keys |> unite(col = "grouping_factor", !!.sample, sep = "___") |> - pull(grouping_factor)) - - grouping_factor = + + grouping_factor_names <- sample_group_keys |> + unite(col = "grouping_factor", !!.sample, sep = "___") |> + pull(grouping_factor) + + sce_split <- map(.x = seq_along(sample_group_idx), .f = \(.num) .data[, sample_group_idx[[.num]]]) |> + purrr::set_names(grouping_factor_names) + + grouping_factor <- .data |> colData() |> as_tibble() |> @@ -196,47 +199,54 @@ setMethod("aggregate_cells", "SingleCellExperiment", function(.data, unite("my_id_to_split_by___", !!.sample, sep = "___") |> pull(my_id_to_split_by___) |> as.factor() - - list_count_cells = table(grouping_factor) |> - enframe(name = "grouping_factor", value = ".aggregated_cells") |> + + list_count_cells <- table(grouping_factor) |> + enframe(name = "grouping_factor", value = ".aggregated_cells") |> mutate(.aggregated_cells = as.integer(.aggregated_cells)) - + feature_df <- get_all_features(.data) - selected_features <- feature_df[feature_df$assay_id %in% assays_to_use,] + selected_features <- feature_df[feature_df$assay_id %in% assays_to_use, ] selected_experiments_list <- split(x = selected_features, f = as.character(selected_features$exp_id)) - if("Main" %in% names(selected_experiments_list)) selected_experiments_list <- selected_experiments_list[c("Main", setdiff(names(selected_experiments_list), "Main"))] - - aggregate_assays_fun <- function(exp){ - selected_features_exp <- unique(exp$exp_id) - if(selected_features_exp == "Main") { - selected_assays <- unique(exp$assay_name) + if ("Main" %in% names(selected_experiments_list)) selected_experiments_list <- selected_experiments_list[c("Main", setdiff(names(selected_experiments_list), "Main"))] + + aggregate_assays_fun <- function(exp) { + selected_exp <- unique(exp$exp_id) + selected_assays <- exp |> distinct(assay_name, .keep_all = TRUE) + if (selected_exp == "Main") { aggregate_sce_fun <- function(sce) { - aggregated_vals <- assays(sce)[selected_assays] |> - as.list() |> + aggregated_vals <- assays(sce)[selected_assays$assay_name] |> + as.list() |> map(.f = \(.list) aggregation_function(.list)) - map(.x = seq_along(aggregated_vals), \(.num) enframe(x = aggregated_vals[[.num]], name = ".feature", value = selected_assays[[.num]])) |> + map(.x = seq_along(aggregated_vals), \(.num) enframe(x = aggregated_vals[[.num]], name = ".feature", value = selected_assays$assay_id[[.num]])) |> suppressMessages(reduce(full_join)) - } - suppressMessages(lapply(sce_split, aggregate_sce_fun) |> - map(.f = ~.x |> reduce(full_join)) |> - bind_rows(.id = "grouping_factor")) + } + aggregated_list <- lapply(sce_split, aggregate_sce_fun) |> + list_transpose() |> + map(.f = \(.list) .list |> bind_rows(.id = "grouping_factor")) + aggregated_assay_names <- map_chr(.x = aggregated_list, .f = \(.tbl) colnames(.tbl) |> tail(n = 1)) + map(.x = seq_along(aggregated_list), .f = \(.num) aggregated_list[[.num]] |> + pivot_wider(id_cols = .feature, names_from = grouping_factor, values_from = selected_assays$assay_id[[.num]])) |> + purrr::set_names(selected_assays$assay_id) } else { aggregate_sce_fun <- function(sce) { - selected_exp <- unique(exp$exp_id) - selected_assays <- exp |> distinct(assay_name, .keep_all = TRUE) - aggregated_vals <- assays(altExps(sce)[[selected_exp]])[selected_assays$assay_name] |> - as.list() |> - map(.f = \(.list) aggregation_function(.list)) - map(.x = seq_along(aggregated_vals), \(.num) enframe(x = aggregated_vals[[.num]], name = ".feature", value = selected_assays$assay_id[[.num]])) |> - suppressMessages(reduce(full_join)) + aggregated_vals <- assays(altExps(sce)[[selected_exp]])[selected_assays$assay_name] |> + as.list() |> + set_names(selected_assays$assay_id) |> + map(.f = \(.list) aggregation_function(.list)) + map(.x = seq_along(aggregated_vals), \(.num) enframe(x = aggregated_vals[[.num]], name = ".feature", value = selected_assays$assay_id[[.num]])) |> + suppressMessages(reduce(full_join)) } - suppressMessages(lapply(sce_split, aggregate_sce_fun) |> - map(.f = ~.x |> reduce(full_join)) |> - bind_rows(.id = "grouping_factor")) + aggregated_list <- lapply(sce_split, aggregate_sce_fun) |> + list_transpose() |> + map(.f = \(.list) .list |> bind_rows(.id = "grouping_factor")) + map(.x = seq_along(aggregated_list), .f = \(.num) aggregated_list[[.num]] |> + pivot_wider(id_cols = .feature, names_from = grouping_factor, values_from = selected_assays$assay_id[[.num]])) |> + purrr::set_names(selected_assays$assay_id) } } - suppressMessages(lapply(selected_experiments_list, aggregate_assays_fun) |> - bind_rows() |> - left_join(list_count_cells) |> - separate(col = grouping_factor, into = .sample_names, sep = "___")) + se <- lapply(selected_experiments_list, aggregate_assays_fun) |> + lapply(SummarizedExperiment) + # Remove "Main" from the names if this is the only assay + if(length(names(se)) == 1 && names(se) == "Main") names(se) <- NULL + return(se) }) From 93e517de177c93a04735d297451583146064ef78 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Wed, 25 Oct 2023 15:36:54 +0100 Subject: [PATCH 089/140] Update methods.R --- R/methods.R | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/R/methods.R b/R/methods.R index 50bd6d7..0c47b8a 100755 --- a/R/methods.R +++ b/R/methods.R @@ -244,9 +244,10 @@ setMethod("aggregate_cells", "SingleCellExperiment", function(.data, purrr::set_names(selected_assays$assay_id) } } - se <- lapply(selected_experiments_list, aggregate_assays_fun) |> - lapply(SummarizedExperiment) - # Remove "Main" from the names if this is the only assay - if(length(names(se)) == 1 && names(se) == "Main") names(se) <- NULL - return(se) + se <- lapply(selected_experiments_list, aggregate_assays_fun) + se |> + purrr::flatten() |> + map(.f = \(.tbl) .tbl |> + column_to_rownames(var = ".feature") |> + as_SummarizedExperiment()) }) From 2a4ea903b8702e1a60e9d811bc9cfce64ed6de4d Mon Sep 17 00:00:00 2001 From: Biomiha Date: Wed, 25 Oct 2023 15:43:08 +0100 Subject: [PATCH 090/140] Update methods.R --- R/methods.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/methods.R b/R/methods.R index 0c47b8a..5df36db 100755 --- a/R/methods.R +++ b/R/methods.R @@ -249,5 +249,5 @@ setMethod("aggregate_cells", "SingleCellExperiment", function(.data, purrr::flatten() |> map(.f = \(.tbl) .tbl |> column_to_rownames(var = ".feature") |> - as_SummarizedExperiment()) + SummarizedExperiment()) }) From 34047d32b504cd9ed95b316f3bcee74a9789de34 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Thu, 26 Oct 2023 14:28:43 +0100 Subject: [PATCH 091/140] Update methods.R Try coercing into a SummarizedExperiment object --- R/methods.R | 43 ++++++++++++++++++++++++++++++------------- 1 file changed, 30 insertions(+), 13 deletions(-) diff --git a/R/methods.R b/R/methods.R index 5df36db..5252f0e 100755 --- a/R/methods.R +++ b/R/methods.R @@ -223,10 +223,13 @@ setMethod("aggregate_cells", "SingleCellExperiment", function(.data, aggregated_list <- lapply(sce_split, aggregate_sce_fun) |> list_transpose() |> map(.f = \(.list) .list |> bind_rows(.id = "grouping_factor")) - aggregated_assay_names <- map_chr(.x = aggregated_list, .f = \(.tbl) colnames(.tbl) |> tail(n = 1)) - map(.x = seq_along(aggregated_list), .f = \(.num) aggregated_list[[.num]] |> - pivot_wider(id_cols = .feature, names_from = grouping_factor, values_from = selected_assays$assay_id[[.num]])) |> - purrr::set_names(selected_assays$assay_id) + interim_res <- map(.x = seq_along(aggregated_list), .f = \(.num) aggregated_list[[.num]] |> + separate(col = grouping_factor, into = .sample_names, sep = "___")) |> + purrr::set_names(nm = selected_exp) + map(.x = seq_along(interim_res), .f = \(.num) interim_res[[.num]] |> mutate(data_source = names(interim_res)[[.num]])) |> + purrr::reduce(full_join) |> + mutate(data_source = ifelse(data_source == "Main", yes = "RNA", no = data_source)) |> + select(data_source, everything()) } else { aggregate_sce_fun <- function(sce) { aggregated_vals <- assays(altExps(sce)[[selected_exp]])[selected_assays$assay_name] |> @@ -239,15 +242,29 @@ setMethod("aggregate_cells", "SingleCellExperiment", function(.data, aggregated_list <- lapply(sce_split, aggregate_sce_fun) |> list_transpose() |> map(.f = \(.list) .list |> bind_rows(.id = "grouping_factor")) - map(.x = seq_along(aggregated_list), .f = \(.num) aggregated_list[[.num]] |> - pivot_wider(id_cols = .feature, names_from = grouping_factor, values_from = selected_assays$assay_id[[.num]])) |> - purrr::set_names(selected_assays$assay_id) + interim_res <- map(.x = seq_along(aggregated_list), .f = \(.num) aggregated_list[[.num]] |> + separate(col = grouping_factor, into = .sample_names, sep = "___")) |> + purrr::set_names(nm = selected_exp) + map(.x = seq_along(interim_res), .f = \(.num) interim_res[[.num]] |> + mutate(data_source = names(interim_res)[[.num]])) |> + purrr::reduce(full_join) |> + mutate(data_source = ifelse(data_source == "Main", yes = "RNA", no = data_source)) |> + select(data_source, everything()) } } - se <- lapply(selected_experiments_list, aggregate_assays_fun) - se |> - purrr::flatten() |> - map(.f = \(.tbl) .tbl |> - column_to_rownames(var = ".feature") |> - SummarizedExperiment()) + se <- lapply(selected_experiments_list, aggregate_assays_fun) |> + purrr::reduce(full_join) + if(any(unique(se$data_source) %in% "RNA") && length(unique(se$data_source))) { + se |> + tidybulk::as_SummarizedExperiment( + .sample = .sample_names, # these should be replaced with the dynamic gaming established in utilities.R + .transcript = .feature, + .abundance = setdiff(colnames(se), c("data_source", .sample_names, ".feature"))) + } else { + se |> + tidybulk::as_SummarizedExperiment( + .sample = .sample_names, # these should be replaced with the dynamic gaming established in utilities.R + .transcript = c(data_source, .feature), + .abundance = setdiff(colnames(se), c("data_source", .sample_names, ".feature"))) + } }) From 5c62b25978a1fa9ded403b03e7120be91b0bb256 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Fri, 27 Oct 2023 10:34:34 +0100 Subject: [PATCH 092/140] Update methods.R --- R/methods.R | 16 ++++------------ 1 file changed, 4 insertions(+), 12 deletions(-) diff --git a/R/methods.R b/R/methods.R index 5252f0e..488ee88 100755 --- a/R/methods.R +++ b/R/methods.R @@ -254,17 +254,9 @@ setMethod("aggregate_cells", "SingleCellExperiment", function(.data, } se <- lapply(selected_experiments_list, aggregate_assays_fun) |> purrr::reduce(full_join) - if(any(unique(se$data_source) %in% "RNA") && length(unique(se$data_source))) { se |> - tidybulk::as_SummarizedExperiment( - .sample = .sample_names, # these should be replaced with the dynamic gaming established in utilities.R - .transcript = .feature, - .abundance = setdiff(colnames(se), c("data_source", .sample_names, ".feature"))) - } else { - se |> - tidybulk::as_SummarizedExperiment( - .sample = .sample_names, # these should be replaced with the dynamic gaming established in utilities.R - .transcript = c(data_source, .feature), - .abundance = setdiff(colnames(se), c("data_source", .sample_names, ".feature"))) - } + tidybulk::as_SummarizedExperiment( + .sample = .sample_names, + .transcript = .feature, + .abundance = setdiff(colnames(se), c("data_source", .sample_names, ".feature"))) }) From a7f2046153b9bc04ae77052cb39e84d023975388 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Fri, 27 Oct 2023 10:38:39 +0100 Subject: [PATCH 093/140] Update methods.R --- R/methods.R | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/R/methods.R b/R/methods.R index 488ee88..c168ce2 100755 --- a/R/methods.R +++ b/R/methods.R @@ -159,10 +159,9 @@ tidy.SingleCellExperiment <- function(object) { #' #' @export setMethod("aggregate_cells", "SingleCellExperiment", function(.data, - .sample=NULL, assays=NULL, - aggregation_function=Matrix::rowSums, - ...) { - + .sample = NULL, assays = NULL, + aggregation_function = Matrix::rowSums, + ...) { # Fix NOTEs feature <- NULL .sample <- enquo(.sample) @@ -254,7 +253,7 @@ setMethod("aggregate_cells", "SingleCellExperiment", function(.data, } se <- lapply(selected_experiments_list, aggregate_assays_fun) |> purrr::reduce(full_join) - se |> + se |> tidybulk::as_SummarizedExperiment( .sample = .sample_names, .transcript = .feature, From 4797b814b945e47b5d04f8f6b8d2e983ab5010a0 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Fri, 27 Oct 2023 10:55:43 +0100 Subject: [PATCH 094/140] Update methods.R --- R/methods.R | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/R/methods.R b/R/methods.R index c168ce2..14e6805 100755 --- a/R/methods.R +++ b/R/methods.R @@ -252,7 +252,8 @@ setMethod("aggregate_cells", "SingleCellExperiment", function(.data, } } se <- lapply(selected_experiments_list, aggregate_assays_fun) |> - purrr::reduce(full_join) + purrr::reduce(full_join) |> + suppressMessages() se |> tidybulk::as_SummarizedExperiment( .sample = .sample_names, From 2fb771a4eb4cafda6630b862d4d72e1afab44871 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Sun, 29 Oct 2023 08:54:56 +0000 Subject: [PATCH 095/140] Update methods.R --- R/methods.R | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/R/methods.R b/R/methods.R index 14e6805..c783848 100755 --- a/R/methods.R +++ b/R/methods.R @@ -155,6 +155,7 @@ tidy.SingleCellExperiment <- function(object) { #' @importFrom purrr reduce #' @importFrom purrr map #' @importFrom purrr set_names +#' @importFrom purrr list_transpose #' #' #' @export @@ -220,7 +221,7 @@ setMethod("aggregate_cells", "SingleCellExperiment", function(.data, suppressMessages(reduce(full_join)) } aggregated_list <- lapply(sce_split, aggregate_sce_fun) |> - list_transpose() |> + purrr::list_transpose() |> map(.f = \(.list) .list |> bind_rows(.id = "grouping_factor")) interim_res <- map(.x = seq_along(aggregated_list), .f = \(.num) aggregated_list[[.num]] |> separate(col = grouping_factor, into = .sample_names, sep = "___")) |> From cd53a8688271b5e3c3e7cf664472826ae7f780d4 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Sun, 29 Oct 2023 09:11:26 +0000 Subject: [PATCH 096/140] Update test-methods.R Add altExp optionality to the unit test for aggregate_cells --- tests/testthat/test-methods.R | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/tests/testthat/test-methods.R b/tests/testthat/test-methods.R index ab182dc..df4a2cd 100644 --- a/tests/testthat/test-methods.R +++ b/tests/testthat/test-methods.R @@ -119,7 +119,7 @@ test_that("aggregate_cells()", { df$factor <- sample(gl(3, 1, ncol(df))) df$string <- sample(c("a", "b"), ncol(df), TRUE) tbl <- distinct(select(df, factor, string)) - fd <- aggregate_cells(df, c(factor, string)) + fd <- aggregate_cells(df, .sample = c(factor, string), assays = assayNames(df)) expect_identical(assayNames(fd), assayNames(df)) # [HLC: aggregate_cells() currently # reorders features alphabetically] @@ -141,4 +141,11 @@ test_that("aggregate_cells()", { expect_error(aggregate_cells(df, c(factor, string), assays="x")) fd <- aggregate_cells(df, c(factor, string), assays="counts") expect_identical(assayNames(fd), "counts") + # Aggregate when using multiple assays + assays_to_use <- c("logcounts", "ADT-logcounts") + fd <- aggregate_cells(df, .sample = c(factor, string), assays = assays_to_use) + expect_identical(assayNames(fd), assays_to_use) + fd_all_features <- tidySingleCellExperiment:::get_all_features(df) |> + filter(assay_id %in% assays_to_use) |> pull(feature) |> sort() + expect_identical(fd_all_features, sort(rownames(fd))) }) From a8dc2a84927c8091159e0ea1814f5150fd20723e Mon Sep 17 00:00:00 2001 From: Biomiha Date: Tue, 31 Oct 2023 08:24:22 +0000 Subject: [PATCH 097/140] Update methods.R --- R/methods.R | 1 + 1 file changed, 1 insertion(+) diff --git a/R/methods.R b/R/methods.R index c783848..2a26dc3 100755 --- a/R/methods.R +++ b/R/methods.R @@ -255,6 +255,7 @@ setMethod("aggregate_cells", "SingleCellExperiment", function(.data, se <- lapply(selected_experiments_list, aggregate_assays_fun) |> purrr::reduce(full_join) |> suppressMessages() + if(length(selected_experiments_list) >1 ) warning("tidySingleCellExperiment says: Features from all experiments have been combined") se |> tidybulk::as_SummarizedExperiment( .sample = .sample_names, From 6df2a39ff39ac9ade9609fbce46a147b92169210 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Tue, 31 Oct 2023 08:43:05 +0000 Subject: [PATCH 098/140] Update methods.R --- R/methods.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/methods.R b/R/methods.R index 2a26dc3..3884e1c 100755 --- a/R/methods.R +++ b/R/methods.R @@ -255,7 +255,7 @@ setMethod("aggregate_cells", "SingleCellExperiment", function(.data, se <- lapply(selected_experiments_list, aggregate_assays_fun) |> purrr::reduce(full_join) |> suppressMessages() - if(length(selected_experiments_list) >1 ) warning("tidySingleCellExperiment says: Features from all experiments have been combined") + if(length(selected_experiments_list) >1 ) warning("tidySingleCellExperiment says: Features from all selected assays have been combined!") se |> tidybulk::as_SummarizedExperiment( .sample = .sample_names, From 61c18d75076a1ce810b0f358504cae6efbe042fb Mon Sep 17 00:00:00 2001 From: Biomiha Date: Tue, 31 Oct 2023 22:28:01 +0000 Subject: [PATCH 099/140] Update methods.R --- R/methods.R | 41 ++++++++++++++++++++++++++++++++++++++--- 1 file changed, 38 insertions(+), 3 deletions(-) diff --git a/R/methods.R b/R/methods.R index 3884e1c..e80e9a4 100755 --- a/R/methods.R +++ b/R/methods.R @@ -255,10 +255,45 @@ setMethod("aggregate_cells", "SingleCellExperiment", function(.data, se <- lapply(selected_experiments_list, aggregate_assays_fun) |> purrr::reduce(full_join) |> suppressMessages() - if(length(selected_experiments_list) >1 ) warning("tidySingleCellExperiment says: Features from all selected assays have been combined!") - se |> + + if(se |> + distinct(assay_type, .feature) |> + pull(.feature) |> + duplicated() |> + any()) { + warning("tidySingleCellExperiment says: The selected assays have overlapping feature names. The feature names have been combined with the selected assay_type, to keep the rownames of the SingleCellExperiment unique. You can find the original feature names in the orig.feature.names column in the rowData slot of your object.") + orig_features <- se |> + distinct(assay_type, .feature) + dup_features <- orig_features |> + filter(duplicated(.feature)) |> + pull(.feature) + se <- se |> + mutate(.feature = case_when(.feature %in% dup_features ~ str_c(assay_type, .feature, sep = ".."), .default = .feature)) + } + + se <- se |> tidybulk::as_SummarizedExperiment( .sample = .sample_names, .transcript = .feature, - .abundance = setdiff(colnames(se), c("data_source", .sample_names, ".feature"))) + .abundance = setdiff(colnames(se), c("assay_type", .sample_names, ".feature"))) + if(exists("assay_type", where = as.data.frame(colData(se)))) { + rowData(se) <- rownames(se) |> + enframe(name = NULL, value = "rowname") |> + mutate(assay_type = unique(colData(se)$assay_type)) |> + tibble::column_to_rownames() |> + as.data.frame() |> + as(Class = "DataFrame") + colData(se)$assay_type <- NULL + } + if(rownames(se) |> grep(pattern = "\\.\\.") |> any()) { + rowData(se) <- rowData(se) |> + as.data.frame() |> + rownames_to_column() |> + mutate(orig.feature.names = rowname, + orig.feature.names = str_remove_all(string = orig.feature.names, pattern = ".+(?=\\.\\.)"), + orig.feature.names = str_remove_all(string = orig.feature.names, pattern = "^\\..")) |> + column_to_rownames() |> + as(Class = "DataFrame") + } + return(se) }) From f400720200052ee6a76ba34d92e33828e86b0aeb Mon Sep 17 00:00:00 2001 From: Biomiha Date: Tue, 31 Oct 2023 22:32:45 +0000 Subject: [PATCH 100/140] Update methods.R --- R/methods.R | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/R/methods.R b/R/methods.R index e80e9a4..f7b0b62 100755 --- a/R/methods.R +++ b/R/methods.R @@ -226,10 +226,10 @@ setMethod("aggregate_cells", "SingleCellExperiment", function(.data, interim_res <- map(.x = seq_along(aggregated_list), .f = \(.num) aggregated_list[[.num]] |> separate(col = grouping_factor, into = .sample_names, sep = "___")) |> purrr::set_names(nm = selected_exp) - map(.x = seq_along(interim_res), .f = \(.num) interim_res[[.num]] |> mutate(data_source = names(interim_res)[[.num]])) |> + map(.x = seq_along(interim_res), .f = \(.num) interim_res[[.num]] |> mutate(assay_type = names(interim_res)[[.num]])) |> purrr::reduce(full_join) |> - mutate(data_source = ifelse(data_source == "Main", yes = "RNA", no = data_source)) |> - select(data_source, everything()) + mutate(assay_type = ifelse(assay_type == "Main", yes = "RNA", no = assay_type)) |> + select(assay_type, everything()) } else { aggregate_sce_fun <- function(sce) { aggregated_vals <- assays(altExps(sce)[[selected_exp]])[selected_assays$assay_name] |> @@ -246,10 +246,10 @@ setMethod("aggregate_cells", "SingleCellExperiment", function(.data, separate(col = grouping_factor, into = .sample_names, sep = "___")) |> purrr::set_names(nm = selected_exp) map(.x = seq_along(interim_res), .f = \(.num) interim_res[[.num]] |> - mutate(data_source = names(interim_res)[[.num]])) |> + mutate(assay_type = names(interim_res)[[.num]])) |> purrr::reduce(full_join) |> - mutate(data_source = ifelse(data_source == "Main", yes = "RNA", no = data_source)) |> - select(data_source, everything()) + mutate(assay_type = ifelse(assay_type == "Main", yes = "RNA", no = assay_type)) |> + select(assay_type, everything()) } } se <- lapply(selected_experiments_list, aggregate_assays_fun) |> @@ -257,10 +257,10 @@ setMethod("aggregate_cells", "SingleCellExperiment", function(.data, suppressMessages() if(se |> - distinct(assay_type, .feature) |> - pull(.feature) |> - duplicated() |> - any()) { + distinct(assay_type, .feature) |> + pull(.feature) |> + duplicated() |> + any()) { warning("tidySingleCellExperiment says: The selected assays have overlapping feature names. The feature names have been combined with the selected assay_type, to keep the rownames of the SingleCellExperiment unique. You can find the original feature names in the orig.feature.names column in the rowData slot of your object.") orig_features <- se |> distinct(assay_type, .feature) From d1e9ebce607831b7d9f083df774331f41f9ca0c9 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Tue, 31 Oct 2023 22:37:44 +0000 Subject: [PATCH 101/140] Update methods.R --- R/methods.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/methods.R b/R/methods.R index f7b0b62..4c1af46 100755 --- a/R/methods.R +++ b/R/methods.R @@ -261,7 +261,7 @@ setMethod("aggregate_cells", "SingleCellExperiment", function(.data, pull(.feature) |> duplicated() |> any()) { - warning("tidySingleCellExperiment says: The selected assays have overlapping feature names. The feature names have been combined with the selected assay_type, to keep the rownames of the SingleCellExperiment unique. You can find the original feature names in the orig.feature.names column in the rowData slot of your object.") + warning("tidySingleCellExperiment says: The selected assays have overlapping feature names. The feature names have been combined with the selected assay_type, to keep the rownames of the SingleCellExperiment unique. You can find the original feature names in the orig.feature.names column of the rowData slot of your object.") orig_features <- se |> distinct(assay_type, .feature) dup_features <- orig_features |> From 94fc5728db692da183b4c5171751a3845b9b62c7 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Wed, 1 Nov 2023 08:23:14 +0000 Subject: [PATCH 102/140] Update methods.R Fix feature_original and add comments to code blocks. --- R/methods.R | 45 +++++++++++++++++++++++++++++++-------------- 1 file changed, 31 insertions(+), 14 deletions(-) diff --git a/R/methods.R b/R/methods.R index 4c1af46..1389e16 100755 --- a/R/methods.R +++ b/R/methods.R @@ -170,7 +170,8 @@ setMethod("aggregate_cells", "SingleCellExperiment", function(.data, arg_list <- c(mget(ls(environment(), sorted = F)), match.call(expand.dots = F)$...) assays_to_use <- eval(arg_list$assays) if (is.null(assays_to_use)) assays_to_use <- tail(names(assays(.data)), n = 1) - + + # Get information on sample groups sample_groups <- .data |> as_tibble() |> group_by(pick({{ .sample }})) @@ -186,7 +187,8 @@ setMethod("aggregate_cells", "SingleCellExperiment", function(.data, grouping_factor_names <- sample_group_keys |> unite(col = "grouping_factor", !!.sample, sep = "___") |> pull(grouping_factor) - + + # Split sce object by groups sce_split <- map(.x = seq_along(sample_group_idx), .f = \(.num) .data[, sample_group_idx[[.num]]]) |> purrr::set_names(grouping_factor_names) @@ -199,17 +201,21 @@ setMethod("aggregate_cells", "SingleCellExperiment", function(.data, unite("my_id_to_split_by___", !!.sample, sep = "___") |> pull(my_id_to_split_by___) |> as.factor() - + + # Add count of aggregated cells list_count_cells <- table(grouping_factor) |> enframe(name = "grouping_factor", value = ".aggregated_cells") |> mutate(.aggregated_cells = as.integer(.aggregated_cells)) + # Subset features based on selected assays feature_df <- get_all_features(.data) selected_features <- feature_df[feature_df$assay_id %in% assays_to_use, ] selected_experiments_list <- split(x = selected_features, f = as.character(selected_features$exp_id)) if ("Main" %in% names(selected_experiments_list)) selected_experiments_list <- selected_experiments_list[c("Main", setdiff(names(selected_experiments_list), "Main"))] + # Aggregate cells based on selected features from any assay / experiment type. Output is a tibble. aggregate_assays_fun <- function(exp) { + # Check where the assay data needs to be taken from (main experiment or altExp) selected_exp <- unique(exp$exp_id) selected_assays <- exp |> distinct(assay_name, .keep_all = TRUE) if (selected_exp == "Main") { @@ -231,6 +237,7 @@ setMethod("aggregate_cells", "SingleCellExperiment", function(.data, mutate(assay_type = ifelse(assay_type == "Main", yes = "RNA", no = assay_type)) |> select(assay_type, everything()) } else { + # aggregate from altExp aggregate_sce_fun <- function(sce) { aggregated_vals <- assays(altExps(sce)[[selected_exp]])[selected_assays$assay_name] |> as.list() |> @@ -252,30 +259,39 @@ setMethod("aggregate_cells", "SingleCellExperiment", function(.data, select(assay_type, everything()) } } + + # Join tibbles from each assay / experiment type into a single tibble. se <- lapply(selected_experiments_list, aggregate_assays_fun) |> purrr::reduce(full_join) |> suppressMessages() - if(se |> - distinct(assay_type, .feature) |> - pull(.feature) |> - duplicated() |> - any()) { - warning("tidySingleCellExperiment says: The selected assays have overlapping feature names. The feature names have been combined with the selected assay_type, to keep the rownames of the SingleCellExperiment unique. You can find the original feature names in the orig.feature.names column of the rowData slot of your object.") + # Sometimes feature names can be duplicated in multiple assays, e.g. CD4 in RNA and ADT. Check for duplication. + any_feat_duplicated <- se |> + distinct(assay_type, .feature) |> + pull(.feature) |> + duplicated() |> + any() + + if(any_feat_duplicated) { + warning("tidySingleCellExperiment says: The selected assays have overlapping feature names. The feature names have been combined with the selected assay_type, to keep the rownames of the SingleCellExperiment unique. You can find the original feature names in the feature_original column of the rowData slot of your object.") + # Extract original feature names for storing. orig_features <- se |> distinct(assay_type, .feature) + # Extract which features have duplicated names. dup_features <- orig_features |> filter(duplicated(.feature)) |> pull(.feature) + # Make duplicated feature names unique by combining with assay name and separating with ".." se <- se |> mutate(.feature = case_when(.feature %in% dup_features ~ str_c(assay_type, .feature, sep = ".."), .default = .feature)) } - + # Turn tibble into SummarizedExperiment object se <- se |> tidybulk::as_SummarizedExperiment( .sample = .sample_names, .transcript = .feature, .abundance = setdiff(colnames(se), c("assay_type", .sample_names, ".feature"))) + # Manually force the assay_type data to live in the rowData slot if it does not already if(exists("assay_type", where = as.data.frame(colData(se)))) { rowData(se) <- rownames(se) |> enframe(name = NULL, value = "rowname") |> @@ -285,13 +301,14 @@ setMethod("aggregate_cells", "SingleCellExperiment", function(.data, as(Class = "DataFrame") colData(se)$assay_type <- NULL } - if(rownames(se) |> grep(pattern = "\\.\\.") |> any()) { + # Add original feature name information to the rowData slot + if(any_feat_duplicated) { rowData(se) <- rowData(se) |> as.data.frame() |> rownames_to_column() |> - mutate(orig.feature.names = rowname, - orig.feature.names = str_remove_all(string = orig.feature.names, pattern = ".+(?=\\.\\.)"), - orig.feature.names = str_remove_all(string = orig.feature.names, pattern = "^\\..")) |> + mutate(feature_original = rowname, + feature_original = str_remove_all(string = feature_original, pattern = ".+(?=\\.\\.)"), + feature_original = str_remove_all(string = feature_original, pattern = "^\\..")) |> column_to_rownames() |> as(Class = "DataFrame") } From de152a3a68bfe8b246aaa8678bcdfc57bdf6b0cc Mon Sep 17 00:00:00 2001 From: Biomiha Date: Thu, 2 Nov 2023 14:24:46 +0000 Subject: [PATCH 103/140] Update utilities.R --- R/utilities.R | 12 +++++++++--- 1 file changed, 9 insertions(+), 3 deletions(-) diff --git a/R/utilities.R b/R/utilities.R index 0e7eecd..d15947b 100755 --- a/R/utilities.R +++ b/R/utilities.R @@ -81,9 +81,15 @@ get_all_assays <- function(x) { alt_exp_assays <- list() alt_exp_assay_names_list <- lapply(altExps(x), assayNames) names(assay_names) <- rep("Main", length(assay_names)) - alt_exp_assay_names_df <- stack(alt_exp_assay_names_list) - alt_exp_assay_names <- paste(alt_exp_assay_names_df$ind, alt_exp_assay_names_df$values, sep = "-") - names(alt_exp_assay_names) <- alt_exp_assay_names_df$ind + if(length(altExpNames(x)) > 0) { + alt_exp_assay_names_df <- stack(alt_exp_assay_names_list) + alt_exp_assay_names <- paste(alt_exp_assay_names_df$ind, alt_exp_assay_names_df$values, sep = "-") + names(alt_exp_assay_names) <- alt_exp_assay_names_df$ind + } else { + alt_exp_assay_names_df <- NULL + alt_exp_assay_names <- NULL + } + all_assay_names_df <- rbind(stack(assay_names), alt_exp_assay_names_df) all_assay_names <- c(assay_names, alt_exp_assay_names) all_assay_names_ext_df <- stack(all_assay_names) From 4107221daf7cf8ce9888c76dc50d70e967240c3d Mon Sep 17 00:00:00 2001 From: Biomiha Date: Thu, 2 Nov 2023 16:44:14 +0000 Subject: [PATCH 104/140] Update utilities.R --- R/utilities.R | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/R/utilities.R b/R/utilities.R index d15947b..f87b36a 100755 --- a/R/utilities.R +++ b/R/utilities.R @@ -80,7 +80,7 @@ get_all_assays <- function(x) { assay_names <- names(assays(x)) alt_exp_assays <- list() alt_exp_assay_names_list <- lapply(altExps(x), assayNames) - names(assay_names) <- rep("Main", length(assay_names)) + names(assay_names) <- rep("RNA", length(assay_names)) if(length(altExpNames(x)) > 0) { alt_exp_assay_names_df <- stack(alt_exp_assay_names_list) alt_exp_assay_names <- paste(alt_exp_assay_names_df$ind, alt_exp_assay_names_df$values, sep = "-") @@ -102,12 +102,12 @@ get_all_assays <- function(x) { get_all_features <- function(x) { all_assay_names_ext_df <- get_all_assays(x) features_lookup <- vector("list", length = length(all_assay_names_ext_df$assay_id)) - main_features <- vector("list", length = 1) - names(main_features) <- "Main" - main_features[["Main"]] <- rownames(rowData(x)) + RNA_features <- vector("list", length = 1) + names(RNA_features) <- "RNA" + RNA_features[["RNA"]] <- rownames(rowData(x)) temp_funct <- function(x) rownames(rowData(x)) alt_exp_features <- lapply(altExps(x), temp_funct) - feature_df <- stack(c(main_features, alt_exp_features)) + feature_df <- stack(c(RNA_features, alt_exp_features)) colnames(feature_df) <- c("feature", "exp_id") feature_df <- merge(feature_df, all_assay_names_ext_df, by = "exp_id") return(feature_df) @@ -174,12 +174,12 @@ get_abundance_sc_wide <- function(.data, features=NULL, all=FALSE, prefix="", va selected_features <- feature_df[(feature_df$feature %in% gs), ] selected_features <- selected_features[selected_features$assay_id %in% assays_to_use,] selected_experiments_list <- split(x = selected_features, f = as.character(selected_features$exp_id)) - if("Main" %in% names(selected_experiments_list)) selected_experiments_list <- selected_experiments_list[c("Main", setdiff(names(selected_experiments_list), "Main"))] + if("RNA" %in% names(selected_experiments_list)) selected_experiments_list <- selected_experiments_list[c("RNA", setdiff(names(selected_experiments_list), "RNA"))] extract_feature_values <- function(exp) { selected_features_exp <- as.character(unique(exp$exp_id)) selected_features_assay <- as.character(unique(exp$assay_name)) selected_features_assay_names <- as.character(unique(exp$assay_id)) - if(selected_features_exp == "Main") { + if(selected_features_exp == "RNA") { selected_features_from_exp <- rownames(assay(.data, selected_features_assay_names))[(rownames(assay(.data, selected_features_assay_names)) %in% gs)] mtx <- assay(.data, selected_features_assay_names)[selected_features_from_exp,] if(is.null(dim(mtx))) mtx <- matrix(mtx, byrow = TRUE, nrow = 1, ncol = length(mtx)) @@ -281,11 +281,11 @@ get_abundance_sc_long <- function(.data, features = NULL, all = FALSE, exclude_z if(!is.null(assays_to_use)) selected_features <- selected_features[selected_features$assay_id %in% assays_to_use,] selected_features_exp <- unique(selected_features$exp_id) selected_experiments_list <- split(x = selected_features, f = as.character(selected_features$exp_id)) - if("Main" %in% selected_features_exp) selected_experiments_list <- selected_experiments_list[c("Main", setdiff(names(selected_experiments_list), "Main"))] + if("RNA" %in% selected_features_exp) selected_experiments_list <- selected_experiments_list[c("RNA", setdiff(names(selected_experiments_list), "RNA"))] extract_feature_values <- function(exp) { selected_exp <- unique(exp$exp_id) - if (selected_exp == "Main") { + if (selected_exp == "RNA") { assays(.data) %>% as.list() %>% .[unique(exp$assay_name)] %>% From c7f84c4ab624f78a9d0840f3bf8dcdc97d501f8c Mon Sep 17 00:00:00 2001 From: Biomiha Date: Thu, 2 Nov 2023 16:45:33 +0000 Subject: [PATCH 105/140] Update methods.R --- R/methods.R | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/R/methods.R b/R/methods.R index 1389e16..df73fbd 100755 --- a/R/methods.R +++ b/R/methods.R @@ -211,14 +211,14 @@ setMethod("aggregate_cells", "SingleCellExperiment", function(.data, feature_df <- get_all_features(.data) selected_features <- feature_df[feature_df$assay_id %in% assays_to_use, ] selected_experiments_list <- split(x = selected_features, f = as.character(selected_features$exp_id)) - if ("Main" %in% names(selected_experiments_list)) selected_experiments_list <- selected_experiments_list[c("Main", setdiff(names(selected_experiments_list), "Main"))] + if ("RNA" %in% names(selected_experiments_list)) selected_experiments_list <- selected_experiments_list[c("RNA", setdiff(names(selected_experiments_list), "RNA"))] # Aggregate cells based on selected features from any assay / experiment type. Output is a tibble. aggregate_assays_fun <- function(exp) { - # Check where the assay data needs to be taken from (main experiment or altExp) + # Check where the assay data needs to be taken from (main RNA experiment or altExp) selected_exp <- unique(exp$exp_id) selected_assays <- exp |> distinct(assay_name, .keep_all = TRUE) - if (selected_exp == "Main") { + if (selected_exp == "RNA") { aggregate_sce_fun <- function(sce) { aggregated_vals <- assays(sce)[selected_assays$assay_name] |> as.list() |> @@ -234,7 +234,6 @@ setMethod("aggregate_cells", "SingleCellExperiment", function(.data, purrr::set_names(nm = selected_exp) map(.x = seq_along(interim_res), .f = \(.num) interim_res[[.num]] |> mutate(assay_type = names(interim_res)[[.num]])) |> purrr::reduce(full_join) |> - mutate(assay_type = ifelse(assay_type == "Main", yes = "RNA", no = assay_type)) |> select(assay_type, everything()) } else { # aggregate from altExp @@ -255,7 +254,6 @@ setMethod("aggregate_cells", "SingleCellExperiment", function(.data, map(.x = seq_along(interim_res), .f = \(.num) interim_res[[.num]] |> mutate(assay_type = names(interim_res)[[.num]])) |> purrr::reduce(full_join) |> - mutate(assay_type = ifelse(assay_type == "Main", yes = "RNA", no = assay_type)) |> select(assay_type, everything()) } } From 5b82e361aabdef73ecd855beecdd860d060471bb Mon Sep 17 00:00:00 2001 From: Biomiha Date: Thu, 2 Nov 2023 17:06:49 +0000 Subject: [PATCH 106/140] Update utilities.R --- R/utilities.R | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/R/utilities.R b/R/utilities.R index f87b36a..7f0e202 100755 --- a/R/utilities.R +++ b/R/utilities.R @@ -81,7 +81,8 @@ get_all_assays <- function(x) { alt_exp_assays <- list() alt_exp_assay_names_list <- lapply(altExps(x), assayNames) names(assay_names) <- rep("RNA", length(assay_names)) - if(length(altExpNames(x)) > 0) { + # Include altExp assays if they exist + if(length(altExps(x)) > 0) { alt_exp_assay_names_df <- stack(alt_exp_assay_names_list) alt_exp_assay_names <- paste(alt_exp_assay_names_df$ind, alt_exp_assay_names_df$values, sep = "-") names(alt_exp_assay_names) <- alt_exp_assay_names_df$ind From e363132d52b4f8742ade5ea3441633106681e27d Mon Sep 17 00:00:00 2001 From: Biomiha Date: Thu, 2 Nov 2023 17:14:37 +0000 Subject: [PATCH 107/140] Update utilities.R --- R/utilities.R | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/R/utilities.R b/R/utilities.R index 7f0e202..3be615a 100755 --- a/R/utilities.R +++ b/R/utilities.R @@ -145,8 +145,10 @@ get_abundance_sc_wide <- function(.data, features=NULL, all=FALSE, prefix="", va . <- NULL # For SCE there is no a priori field for variable features + # If variable_features are selected set all to FALSE. They can only be on or the other. if(!all(is.na(variable_features))) all <- FALSE - # Check if output would be too big without forcing + + # Give options if no arguments are selected if (isFALSE(all) && is.null(features)) { if (all(is.na(variable_features))) { stop("Your object does not contain variable feature labels,\n", @@ -171,6 +173,7 @@ get_abundance_sc_wide <- function(.data, features=NULL, all=FALSE, prefix="", va } # Get selected features and assays feature_df <- get_all_features(.data) + # If all = TRUE then gs are all features in the selected assays, otherwise just the selected features. if(isTRUE(all)) gs <- feature_df[feature_df$assay_id %in% assays_to_use, "feature"] selected_features <- feature_df[(feature_df$feature %in% gs), ] selected_features <- selected_features[selected_features$assay_id %in% assays_to_use,] @@ -180,6 +183,7 @@ get_abundance_sc_wide <- function(.data, features=NULL, all=FALSE, prefix="", va selected_features_exp <- as.character(unique(exp$exp_id)) selected_features_assay <- as.character(unique(exp$assay_name)) selected_features_assay_names <- as.character(unique(exp$assay_id)) + # Assay slots for the main "RNA" experiment and the altExps are treated differently and need to be run separately if(selected_features_exp == "RNA") { selected_features_from_exp <- rownames(assay(.data, selected_features_assay_names))[(rownames(assay(.data, selected_features_assay_names)) %in% gs)] mtx <- assay(.data, selected_features_assay_names)[selected_features_from_exp,] @@ -200,6 +204,7 @@ get_abundance_sc_wide <- function(.data, features=NULL, all=FALSE, prefix="", va setNames(c(c_(.data)$name, sprintf("%s%s", prefix, selected_features_from_exp))) } } + # Apply function that extracts feature values and join for all selected assays suppressMessages({ feature_values_list <- lapply(selected_experiments_list, extract_feature_values) purrr::reduce(feature_values_list, full_join, by = join_by(.cell), suffix = paste0(".", names(feature_values_list))) @@ -274,7 +279,7 @@ get_abundance_sc_long <- function(.data, features = NULL, all = FALSE, exclude_z # Get list of features feature_df <- get_all_features(.data) - # Get selected features + # Get selected features - if all = TRUE then all features in the objects are selected if(is.null(features) && isTRUE(all)) { features <- unique(feature_df$feature) } @@ -286,6 +291,7 @@ get_abundance_sc_long <- function(.data, features = NULL, all = FALSE, exclude_z extract_feature_values <- function(exp) { selected_exp <- unique(exp$exp_id) + # Assay slots for the main "RNA" experiment and the altExps are treated differently and need to be run separately if (selected_exp == "RNA") { assays(.data) %>% as.list() %>% @@ -356,6 +362,7 @@ get_abundance_sc_long <- function(.data, features = NULL, all = FALSE, exclude_z base::Reduce(function(...) full_join(..., by = c(".feature", c_(.data)$name)), .) } } + # Apply function that extracts feature values and bind_rows for all selected assays lapply(selected_experiments_list, extract_feature_values) |> bind_rows() } From 5002180ef6a78dad4c6676c38fe3a75f012bb599 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Thu, 2 Nov 2023 17:15:59 +0000 Subject: [PATCH 108/140] Update methods.R --- R/methods.R | 1 + 1 file changed, 1 insertion(+) diff --git a/R/methods.R b/R/methods.R index df73fbd..b338fee 100755 --- a/R/methods.R +++ b/R/methods.R @@ -41,6 +41,7 @@ setMethod("join_features", "SingleCellExperiment", function(.data, # CRAN Note .cell <- NULL .feature <- NULL + # Get 'assays' from function arguments list arg_list <- c(mget(ls(environment(), sorted=F)), match.call(expand.dots=F)$...) all_assays <- get_all_assays(.data)$assay_id if(is.null(arg_list$assays)) assays_from_join_call <- all_assays From 98a558417deb57fbbf7b4817f998ca3c5c2727c5 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Thu, 2 Nov 2023 21:38:37 +0000 Subject: [PATCH 109/140] Update introduction.Rmd Add assays for shape="wide" --- vignettes/introduction.Rmd | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/vignettes/introduction.Rmd b/vignettes/introduction.Rmd index 10ceb49..0168623 100755 --- a/vignettes/introduction.Rmd +++ b/vignettes/introduction.Rmd @@ -362,7 +362,7 @@ pbmc_small_cell_type %>% # Add some mitochondrial abundance values mutate(mitochondrial=rnorm(dplyr::n())) %>% # Plot correlation - join_features(features=c("CST3", "LYZ"), shape="wide") %>% + join_features(features=c("CST3", "LYZ"), shape="wide", assays="logcounts") %>% ggplot(aes(CST3+1, LYZ+1, color=groups, size=mitochondrial)) + facet_wrap(~first.labels, scales="free") + geom_point() + @@ -490,4 +490,4 @@ pbmc_small_tidy %>% sessionInfo() ``` -# References \ No newline at end of file +# References From a592c71f84b1fba6956e14d89456589422f4bd93 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Thu, 2 Nov 2023 22:27:32 +0000 Subject: [PATCH 110/140] Update introduction.Rmd --- vignettes/introduction.Rmd | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/vignettes/introduction.Rmd b/vignettes/introduction.Rmd index 0168623..1fb9eb9 100755 --- a/vignettes/introduction.Rmd +++ b/vignettes/introduction.Rmd @@ -65,6 +65,7 @@ library(tidyHeatmap) # Both library(tidySingleCellExperiment) +library(tidybulk) # Other library(Matrix) @@ -362,7 +363,7 @@ pbmc_small_cell_type %>% # Add some mitochondrial abundance values mutate(mitochondrial=rnorm(dplyr::n())) %>% # Plot correlation - join_features(features=c("CST3", "LYZ"), shape="wide", assays="logcounts") %>% + join_features(features=c("CST3", "LYZ"), shape="wide", assays="counts") %>% ggplot(aes(CST3+1, LYZ+1, color=groups, size=mitochondrial)) + facet_wrap(~first.labels, scales="free") + geom_point() + From 06aa1ec630243c2082960f8f89411683f3e1a4db Mon Sep 17 00:00:00 2001 From: Biomiha Date: Fri, 3 Nov 2023 08:19:16 +0000 Subject: [PATCH 111/140] Update methods.R --- R/methods.R | 1 + 1 file changed, 1 insertion(+) diff --git a/R/methods.R b/R/methods.R index b338fee..ad4acc3 100755 --- a/R/methods.R +++ b/R/methods.R @@ -157,6 +157,7 @@ tidy.SingleCellExperiment <- function(object) { #' @importFrom purrr map #' @importFrom purrr set_names #' @importFrom purrr list_transpose +#' @importFrom tidybulk as_SummarizedExperiment #' #' #' @export From 8776694e87e0a9b9bfe9d6b3d609a319cb21777e Mon Sep 17 00:00:00 2001 From: Biomiha Date: Fri, 3 Nov 2023 09:02:04 +0000 Subject: [PATCH 112/140] Update methods.R --- R/methods.R | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/R/methods.R b/R/methods.R index ad4acc3..f298c30 100755 --- a/R/methods.R +++ b/R/methods.R @@ -157,7 +157,6 @@ tidy.SingleCellExperiment <- function(object) { #' @importFrom purrr map #' @importFrom purrr set_names #' @importFrom purrr list_transpose -#' @importFrom tidybulk as_SummarizedExperiment #' #' #' @export @@ -287,7 +286,7 @@ setMethod("aggregate_cells", "SingleCellExperiment", function(.data, } # Turn tibble into SummarizedExperiment object se <- se |> - tidybulk::as_SummarizedExperiment( + as_SummarizedExperiment( .sample = .sample_names, .transcript = .feature, .abundance = setdiff(colnames(se), c("assay_type", .sample_names, ".feature"))) From 462a9b55102007ecd9774e3d7367aef4e50d7f78 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Fri, 3 Nov 2023 09:25:08 +0000 Subject: [PATCH 113/140] Update introduction.Rmd --- vignettes/introduction.Rmd | 1 - 1 file changed, 1 deletion(-) diff --git a/vignettes/introduction.Rmd b/vignettes/introduction.Rmd index 1fb9eb9..a4b1a1b 100755 --- a/vignettes/introduction.Rmd +++ b/vignettes/introduction.Rmd @@ -65,7 +65,6 @@ library(tidyHeatmap) # Both library(tidySingleCellExperiment) -library(tidybulk) # Other library(Matrix) From aa9726954e61ee799997b82c76acf7a188c07f24 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Fri, 3 Nov 2023 10:11:19 +0000 Subject: [PATCH 114/140] Update methods.R --- R/methods.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/methods.R b/R/methods.R index f298c30..ce8ae95 100755 --- a/R/methods.R +++ b/R/methods.R @@ -247,7 +247,7 @@ setMethod("aggregate_cells", "SingleCellExperiment", function(.data, suppressMessages(reduce(full_join)) } aggregated_list <- lapply(sce_split, aggregate_sce_fun) |> - list_transpose() |> + purrr::list_transpose() |> map(.f = \(.list) .list |> bind_rows(.id = "grouping_factor")) interim_res <- map(.x = seq_along(aggregated_list), .f = \(.num) aggregated_list[[.num]] |> separate(col = grouping_factor, into = .sample_names, sep = "___")) |> From 767b2b55fa113a448c736c58d36aec317c513981 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Fri, 3 Nov 2023 10:13:33 +0000 Subject: [PATCH 115/140] Update methods.R --- R/methods.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/methods.R b/R/methods.R index ce8ae95..f827b26 100755 --- a/R/methods.R +++ b/R/methods.R @@ -241,7 +241,7 @@ setMethod("aggregate_cells", "SingleCellExperiment", function(.data, aggregate_sce_fun <- function(sce) { aggregated_vals <- assays(altExps(sce)[[selected_exp]])[selected_assays$assay_name] |> as.list() |> - set_names(selected_assays$assay_id) |> + purrr::set_names(selected_assays$assay_id) |> map(.f = \(.list) aggregation_function(.list)) map(.x = seq_along(aggregated_vals), \(.num) enframe(x = aggregated_vals[[.num]], name = ".feature", value = selected_assays$assay_id[[.num]])) |> suppressMessages(reduce(full_join)) From 8c0e87ad644b8ecac9bc60cb3e9ab49b3824d492 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Fri, 3 Nov 2023 11:43:07 +0000 Subject: [PATCH 116/140] Update test-ggplotly_methods.R --- tests/testthat/test-ggplotly_methods.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/testthat/test-ggplotly_methods.R b/tests/testthat/test-ggplotly_methods.R index a02e84e..6958bfa 100644 --- a/tests/testthat/test-ggplotly_methods.R +++ b/tests/testthat/test-ggplotly_methods.R @@ -10,7 +10,7 @@ test_that("ggplot()", { expect_s3_class(p, "ggplot") # assay data g <- sample(rownames(df), 1) - fd <- join_features(df, g, shape="wide") + fd <- join_features(df, g, shape="wide", assays = "counts") p <- ggplot(fd, aes(factor, .data[[make.names(g)]])) expect_silent(show(p)) expect_s3_class(p, "ggplot") @@ -27,7 +27,7 @@ test_that("plotly()", { expect_s3_class(p, "plotly") # assay data g <- sample(rownames(df), 1) - fd <- join_features(df, g, shape="wide") + fd <- join_features(df, g, shape="wide", assays = "counts") p <- plot_ly(fd, x=~factor, y=g, type="violin") expect_silent(show(p)) expect_s3_class(p, "plotly") From 8aede5a57b2aa20a774f37908740b31b1c830d3f Mon Sep 17 00:00:00 2001 From: Biomiha Date: Thu, 9 Nov 2023 10:17:49 +0000 Subject: [PATCH 117/140] Update test-methods.R --- tests/testthat/test-methods.R | 2 ++ 1 file changed, 2 insertions(+) diff --git a/tests/testthat/test-methods.R b/tests/testthat/test-methods.R index df4a2cd..4792452 100644 --- a/tests/testthat/test-methods.R +++ b/tests/testthat/test-methods.R @@ -32,6 +32,8 @@ rownames(mat) <- colnames(pbmc_small) altExps(pbmc_small)[["Hashtag demultiplex"]] <- SingleCellExperiment(assays = list(counts = t(mat), logcounts = log10(t(mat) + 1))) df <- pbmc_small +df$number <- rnorm(ncol(df)) +df$factor <- sample(gl(3, 1, ncol(df))) test_that("show()", { txt <- capture.output(show(df)) From 858828d1b7b4c0b4649e47ecf27e8806837e48d4 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Thu, 9 Nov 2023 10:25:39 +0000 Subject: [PATCH 118/140] Update plotly_methods.R --- R/plotly_methods.R | 58 +++++++--------------------------------------- 1 file changed, 9 insertions(+), 49 deletions(-) diff --git a/R/plotly_methods.R b/R/plotly_methods.R index 890cdb8..2d7a61a 100755 --- a/R/plotly_methods.R +++ b/R/plotly_methods.R @@ -1,54 +1,14 @@ -#' @name plotly -#' @rdname plotly -#' @inherit plotly::plot_ly +#' @name plot_ly +#' @rdname plot_ly +#' @inherit ttservice::plot_ly #' @return `plotly` #' -#' @examples -#' # TODO +#' @examples +#' data(pbmc_small) +#' pbmc_small |> +#' plot_ly(x = ~ nCount_RNA, y = ~ nFeature_RNA) #' -#' @importFrom plotly plot_ly -#' @export -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), - span=NULL, spans=c(1, 20), - symbol=NULL, symbols=NULL, - linetype=NULL, linetypes=NULL, - split=NULL, frame=NULL, - width=NULL, height=NULL, source="A") { - UseMethod("plot_ly") -} - -#' @rdname plotly -#' @export -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), - span=NULL, spans=c(1, 20), - symbol=NULL, symbols=NULL, - linetype=NULL, linetypes=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(..., - type=type, name=name, - color=color, colors=colors, alpha=alpha, - stroke=stroke, strokes=strokes, alpha_stroke=alpha_stroke, - size=size, sizes=sizes, - span=span, spans=spans, - symbol=symbol, symbols=symbols, - linetype=linetype, linetypes=linetypes, - split=split, frame=frame, - width=width, height=height, source=source) -} - -#' @rdname plotly +#' @importFrom ttservice plot_ly #' @export plot_ly.SingleCellExperiment <- function(data=data.frame(), ..., type=NULL, name=NULL, @@ -63,7 +23,7 @@ plot_ly.SingleCellExperiment <- function(data=data.frame(), data %>% # This is a trick to not loop the call as_tibble() %>% - plot_ly(..., + ttservice::plot_ly(..., type=type, name=name, color=color, colors=colors, alpha=alpha, stroke=stroke, strokes=strokes, alpha_stroke=alpha_stroke, From 550c3b451c2019dccb1a01d4dbf30ed64dda7668 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Sun, 12 Nov 2023 11:13:16 +0000 Subject: [PATCH 119/140] Update plotly_methods.R --- R/plotly_methods.R | 200 +++++++++++++++++++++++++++++++++++++++++---- 1 file changed, 183 insertions(+), 17 deletions(-) diff --git a/R/plotly_methods.R b/R/plotly_methods.R index 2d7a61a..5bc9d3e 100755 --- a/R/plotly_methods.R +++ b/R/plotly_methods.R @@ -1,17 +1,181 @@ -#' @name plot_ly -#' @rdname plot_ly -#' @inherit ttservice::plot_ly -#' @return `plotly` -#' -#' @examples -#' data(pbmc_small) -#' pbmc_small |> -#' plot_ly(x = ~ nCount_RNA, y = ~ nFeature_RNA) -#' -#' @importFrom ttservice plot_ly +#' Initiate a plotly visualization +#' +#' +#' This function maps R objects to [plotly.js](https://plot.ly/javascript/), +#' an (MIT licensed) web-based interactive charting library. It provides +#' abstractions for doing common things (e.g. mapping data values to +#' fill colors (via `color`) or creating [animation]s (via `frame`)) and sets +#' some different defaults to make the interface feel more 'R-like' +#' (i.e., closer to [plot()] and [ggplot2::qplot()]). +#' +#' @details Unless `type` is specified, this function just initiates a plotly +#' object with 'global' attributes that are passed onto downstream uses of +#' [add_trace()] (or similar). A [formula] must always be used when +#' referencing column name(s) in `data` (e.g. `plot_ly(mtcars, x=~wt)`). +#' Formulas are optional when supplying values directly, but they do +#' help inform default axis/scale titles +#' (e.g., `plot_ly(x=mtcars$wt)` vs `plot_ly(x=~mtcars$wt)`) +#' +#' @param data A data frame (optional) or [crosstalk::SharedData] object. +#' @param ... Arguments (i.e., attributes) passed along to the trace `type`. +#' See [schema()] for a list of acceptable attributes for a given trace `type` +#' (by going to `traces` -> `type` -> `attributes`). Note that attributes +#' provided at this level may override other arguments +#' (e.g. `plot_ly(x=1:10, y=1:10, color=I("red"), marker=list(color="blue"))`). +#' @param type A character string specifying the trace type +#' (e.g. `"scatter"`, `"bar"`, `"box"`, etc). +#' If specified, it *always* creates a trace, otherwise +#' @param name Values mapped to the trace's name attribute. Since a trace can +#' only have one name, this argument acts very much like `split` in that it +#' creates one trace for every unique value. +#' @param color Values mapped to relevant 'fill-color' attribute(s) +#' (e.g. [fillcolor](https://plot.ly/r/reference#scatter-fillcolor), +#' [marker.color](https://plot.ly/r/reference#scatter-marker-color), +#' [textfont.color](https://plot.ly/r/reference/#scatter-textfont-color), etc.). +#' The mapping from data values to color codes may be controlled using +#' `colors` and `alpha`, or avoided altogether via [I()] +#' (e.g., `color=I("red")`). +#' Any color understood by [grDevices::col2rgb()] may be used in this way. +#' @param colors Either a colorbrewer2.org palette name +#' (e.g. "YlOrRd" or "Blues"), +#' or a vector of colors to interpolate in hexadecimal "#RRGGBB" format, +#' or a color interpolation function like `colorRamp()`. +#' @param stroke Similar to `color`, but values are mapped to relevant 'stroke-color' attribute(s) +#' (e.g., [marker.line.color](https://plot.ly/r/reference#scatter-marker-line-color) +#' and [line.color](https://plot.ly/r/reference#scatter-line-color) +#' for filled polygons). If not specified, `stroke` inherits from `color`. +#' @param strokes Similar to `colors`, but controls the `stroke` mapping. +#' @param alpha A number between 0 and 1 specifying the alpha channel applied to `color`. +#' Defaults to 0.5 when mapping to [fillcolor](https://plot.ly/r/reference#scatter-fillcolor) and 1 otherwise. +#' @param alpha_stroke Similar to `alpha`, but applied to `stroke`. +#' @param symbol (Discrete) values mapped to [marker.symbol](https://plot.ly/r/reference#scatter-marker-symbol). +#' The mapping from data values to symbols may be controlled using +#' `symbols`, or avoided altogether via [I()] (e.g., `symbol=I("pentagon")`). +#' Any [pch] value or [symbol name](https://plot.ly/r/reference#scatter-marker-symbol) may be used in this way. +#' @param symbols A character vector of [pch] values or [symbol names](https://plot.ly/r/reference#scatter-marker-symbol). +#' @param linetype (Discrete) values mapped to [line.dash](https://plot.ly/r/reference#scatter-line-dash). +#' The mapping from data values to symbols may be controlled using +#' `linetypes`, or avoided altogether via [I()] (e.g., `linetype=I("dash")`). +#' Any `lty` (see [par]) value or [dash name](https://plot.ly/r/reference#scatter-line-dash) may be used in this way. +#' @param linetypes A character vector of `lty` values or [dash names](https://plot.ly/r/reference#scatter-line-dash) +#' @param size (Numeric) values mapped to relevant 'fill-size' attribute(s) +#' (e.g., [marker.size](https://plot.ly/r/reference#scatter-marker-size), +#' [textfont.size](https://plot.ly/r/reference#scatter-textfont-size), +#' and [error_x.width](https://plot.ly/r/reference#scatter-error_x-width)). +#' The mapping from data values to symbols may be controlled using +#' `sizes`, or avoided altogether via [I()] (e.g., `size=I(30)`). +#' @param sizes A numeric vector of length 2 used to scale `size` to pixels. +#' @param span (Numeric) values mapped to relevant 'stroke-size' attribute(s) +#' (e.g., +#' [marker.line.width](https://plot.ly/r/reference#scatter-marker-line-width), +#' [line.width](https://plot.ly/r/reference#scatter-line-width) for filled polygons, +#' and [error_x.thickness](https://plot.ly/r/reference#scatter-error_x-thickness)) +#' The mapping from data values to symbols may be controlled using +#' `spans`, or avoided altogether via [I()] (e.g., `span=I(30)`). +#' @param spans A numeric vector of length 2 used to scale `span` to pixels. +#' @param split (Discrete) values used to create multiple traces (one trace per value). +#' @param frame (Discrete) values used to create animation frames. +#' @param width Width in pixels (optional, defaults to automatic sizing). +#' @param height Height in pixels (optional, defaults to automatic sizing). +#' @param source a character string of length 1. Match the value of this string +#' with the source argument in [event_data()] to retrieve the +#' event data corresponding to a specific plot (shiny apps can have multiple plots). +#' @author Carson Sievert +#' @references +#' @seealso \itemize{ +#' \item For initializing a plotly-geo object: [plot_geo()] +#' \item For initializing a plotly-mapbox object: [plot_mapbox()] +#' \item For translating a ggplot2 object to a plotly object: [ggplotly()] +#' \item For modifying any plotly object: [layout()], [add_trace()], [style()] +#' \item For linked brushing: [highlight()] +#' \item For arranging multiple plots: [subplot()], [crosstalk::bscols()] +#' \item For inspecting plotly objects: [plotly_json()] +#' \item For quick, accurate, and searchable plotly.js reference: [schema()] +#' } +#' +#' @return A plotly #' @export -plot_ly.SingleCellExperiment <- function(data=data.frame(), - ..., type=NULL, name=NULL, +#' @examples +#' \dontrun{ +#' # plot_ly() tries to create a sensible plot based on the information you +#' # give it. If you don't provide a trace type, plot_ly() will infer one. +#' plot_ly(economics, x=~pop) +#' plot_ly(economics, x=~date, y=~pop) +#' # plot_ly() doesn't require data frame(s), which allows one to take +#' # advantage of trace type(s) designed specifically for numeric matrices +#' plot_ly(z=~volcano) +#' plot_ly(z=~volcano, type="surface") +#' +#' # plotly has a functional interface: every plotly function takes a plotly +#' # object as it's first input argument and returns a modified plotly object +#' add_lines(plot_ly(economics, x=~date, y=~ unemploy / pop)) +#' +#' # To make code more readable, plotly imports the pipe operator from magrittr +#' economics %>% +#' plot_ly(x=~date, y=~ unemploy / pop) %>% +#' add_lines() +#' +#' # Attributes defined via plot_ly() set 'global' attributes that +#' # are carried onto subsequent traces, but those may be over-written +#' plot_ly(economics, x=~date, color=I("black")) %>% +#' add_lines(y=~uempmed) %>% +#' add_lines(y=~psavert, color=I("red")) +#' +#' # Attributes are documented in the figure reference -> https://plot.ly/r/reference +#' # You might notice plot_ly() has named arguments that aren't in this figure +#' # reference. These arguments make it easier to map abstract data values to +#' # visual attributes. +#' p <- plot_ly(iris, x=~Sepal.Width, y=~Sepal.Length) +#' add_markers(p, color=~Petal.Length, size=~Petal.Length) +#' add_markers(p, color=~Species) +#' add_markers(p, color=~Species, colors="Set1") +#' add_markers(p, symbol=~Species) +#' add_paths(p, linetype=~Species) +#' } +#' +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), + span=NULL, spans=c(1, 20), + symbol=NULL, symbols=NULL, + linetype=NULL, linetypes=NULL, + split=NULL, frame=NULL, + width=NULL, height=NULL, source="A") { + UseMethod("plot_ly") +} + +#' @export +#' +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), + span=NULL, spans=c(1, 20), + symbol=NULL, symbols=NULL, + linetype=NULL, linetypes=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(..., + type=type, name=name, + color=color, colors=colors, alpha=alpha, + stroke=stroke, strokes=strokes, alpha_stroke=alpha_stroke, + size=size, sizes=sizes, + span=span, spans=spans, + symbol=symbol, symbols=symbols, + linetype=linetype, linetypes=linetypes, + split=split, frame=frame, + width=width, height=height, source=source + ) +} + +#' @importFrom plotly plot_ly +#' @export +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), @@ -21,16 +185,18 @@ plot_ly.SingleCellExperiment <- function(data=data.frame(), split=NULL, frame=NULL, width=NULL, height=NULL, source="A") { data %>% + # This is a trick to not loop the call as_tibble() %>% - ttservice::plot_ly(..., + 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 + ) } From 961e442e65d7f7b925243f21fba5cd27419322dc Mon Sep 17 00:00:00 2001 From: Miha Kosmac Date: Mon, 1 Jan 2024 09:37:38 +0000 Subject: [PATCH 120/140] Merge plot_ly to work --- NAMESPACE | 8 +- R/plotly_methods.R | 206 ++++--------------------- man/bind_rows.Rd | 2 +- man/formatting.Rd | 2 +- tests/testthat/Rplots.pdf | Bin 0 -> 5924 bytes tests/testthat/test-dplyr_methods.R | 34 +++- tests/testthat/test-ggplotly_methods.R | 34 +++- 7 files changed, 109 insertions(+), 177 deletions(-) create mode 100644 tests/testthat/Rplots.pdf diff --git a/NAMESPACE b/NAMESPACE index 7020d9c..786c683 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -53,6 +53,7 @@ importFrom(S4Vectors,"metadata<-") importFrom(S4Vectors,DataFrame) importFrom(S4Vectors,metadata) importFrom(S4Vectors,split) +importFrom(SingleCellExperiment,altExpNames) importFrom(SingleCellExperiment,cbind) importFrom(SingleCellExperiment,reducedDims) importFrom(SummarizedExperiment,"assays<-") @@ -64,6 +65,7 @@ importFrom(SummarizedExperiment,colData) importFrom(dplyr,add_count) importFrom(dplyr,any_of) importFrom(dplyr,arrange) +importFrom(dplyr,bind_rows) importFrom(dplyr,contains) importFrom(dplyr,count) importFrom(dplyr,distinct) @@ -73,10 +75,12 @@ importFrom(dplyr,filter) importFrom(dplyr,full_join) importFrom(dplyr,group_by) importFrom(dplyr,group_by_drop_default) -importFrom(dplyr,group_split) +importFrom(dplyr,group_keys) +importFrom(dplyr,group_rows) importFrom(dplyr,inner_join) importFrom(dplyr,left_join) importFrom(dplyr,mutate) +importFrom(dplyr,pick) importFrom(dplyr,pull) importFrom(dplyr,rename) importFrom(dplyr,right_join) @@ -111,10 +115,12 @@ importFrom(pillar,tbl_format_header) importFrom(pkgconfig,get_config) importFrom(purrr,as_mapper) importFrom(purrr,imap) +importFrom(purrr,list_transpose) importFrom(purrr,map) importFrom(purrr,map2) importFrom(purrr,map_chr) importFrom(purrr,reduce) +importFrom(purrr,set_names) importFrom(purrr,when) importFrom(rlang,":=") importFrom(rlang,dots_values) diff --git a/R/plotly_methods.R b/R/plotly_methods.R index d5db214..61c76a8 100755 --- a/R/plotly_methods.R +++ b/R/plotly_methods.R @@ -1,174 +1,36 @@ -#' Initiate a plotly visualization -#' -#' -#' This function maps R objects to [plotly.js](https://plot.ly/javascript/), -#' an (MIT licensed) web-based interactive charting library. It provides -#' abstractions for doing common things (e.g. mapping data values to -#' fill colors (via `color`) or creating [animation]s (via `frame`)) and sets -#' some different defaults to make the interface feel more 'R-like' -#' (i.e., closer to [plot()] and [ggplot2::qplot()]). -#' -#' @details Unless `type` is specified, this function just initiates a plotly -#' object with 'global' attributes that are passed onto downstream uses of -#' [add_trace()] (or similar). A [formula] must always be used when -#' referencing column name(s) in `data` (e.g. `plot_ly(mtcars, x=~wt)`). -#' Formulas are optional when supplying values directly, but they do -#' help inform default axis/scale titles -#' (e.g., `plot_ly(x=mtcars$wt)` vs `plot_ly(x=~mtcars$wt)`) -#' -#' @param data A data frame (optional) or [crosstalk::SharedData] object. -#' @param ... Arguments (i.e., attributes) passed along to the trace `type`. -#' See [schema()] for a list of acceptable attributes for a given trace `type` -#' (by going to `traces` -> `type` -> `attributes`). Note that attributes -#' provided at this level may override other arguments -#' (e.g. `plot_ly(x=1:10, y=1:10, color=I("red"), marker=list(color="blue"))`). -#' @param type A character string specifying the trace type -#' (e.g. `"scatter"`, `"bar"`, `"box"`, etc). -#' If specified, it *always* creates a trace, otherwise -#' @param name Values mapped to the trace's name attribute. Since a trace can -#' only have one name, this argument acts very much like `split` in that it -#' creates one trace for every unique value. -#' @param color Values mapped to relevant 'fill-color' attribute(s) -#' (e.g. [fillcolor](https://plot.ly/r/reference#scatter-fillcolor), -#' [marker.color](https://plot.ly/r/reference#scatter-marker-color), -#' [textfont.color](https://plot.ly/r/reference/#scatter-textfont-color), etc.). -#' The mapping from data values to color codes may be controlled using -#' `colors` and `alpha`, or avoided altogether via [I()] -#' (e.g., `color=I("red")`). -#' Any color understood by [grDevices::col2rgb()] may be used in this way. -#' @param colors Either a colorbrewer2.org palette name -#' (e.g. "YlOrRd" or "Blues"), -#' or a vector of colors to interpolate in hexadecimal "#RRGGBB" format, -#' or a color interpolation function like `colorRamp()`. -#' @param stroke Similar to `color`, but values are mapped to relevant 'stroke-color' attribute(s) -#' (e.g., [marker.line.color](https://plot.ly/r/reference#scatter-marker-line-color) -#' and [line.color](https://plot.ly/r/reference#scatter-line-color) -#' for filled polygons). If not specified, `stroke` inherits from `color`. -#' @param strokes Similar to `colors`, but controls the `stroke` mapping. -#' @param alpha A number between 0 and 1 specifying the alpha channel applied to `color`. -#' Defaults to 0.5 when mapping to [fillcolor](https://plot.ly/r/reference#scatter-fillcolor) and 1 otherwise. -#' @param alpha_stroke Similar to `alpha`, but applied to `stroke`. -#' @param symbol (Discrete) values mapped to [marker.symbol](https://plot.ly/r/reference#scatter-marker-symbol). -#' The mapping from data values to symbols may be controlled using -#' `symbols`, or avoided altogether via [I()] (e.g., `symbol=I("pentagon")`). -#' Any [pch] value or [symbol name](https://plot.ly/r/reference#scatter-marker-symbol) may be used in this way. -#' @param symbols A character vector of [pch] values or [symbol names](https://plot.ly/r/reference#scatter-marker-symbol). -#' @param linetype (Discrete) values mapped to [line.dash](https://plot.ly/r/reference#scatter-line-dash). -#' The mapping from data values to symbols may be controlled using -#' `linetypes`, or avoided altogether via [I()] (e.g., `linetype=I("dash")`). -#' Any `lty` (see [par]) value or [dash name](https://plot.ly/r/reference#scatter-line-dash) may be used in this way. -#' @param linetypes A character vector of `lty` values or [dash names](https://plot.ly/r/reference#scatter-line-dash) -#' @param size (Numeric) values mapped to relevant 'fill-size' attribute(s) -#' (e.g., [marker.size](https://plot.ly/r/reference#scatter-marker-size), -#' [textfont.size](https://plot.ly/r/reference#scatter-textfont-size), -#' and [error_x.width](https://plot.ly/r/reference#scatter-error_x-width)). -#' The mapping from data values to symbols may be controlled using -#' `sizes`, or avoided altogether via [I()] (e.g., `size=I(30)`). -#' @param sizes A numeric vector of length 2 used to scale `size` to pixels. -#' @param span (Numeric) values mapped to relevant 'stroke-size' attribute(s) -#' (e.g., -#' [marker.line.width](https://plot.ly/r/reference#scatter-marker-line-width), -#' [line.width](https://plot.ly/r/reference#scatter-line-width) for filled polygons, -#' and [error_x.thickness](https://plot.ly/r/reference#scatter-error_x-thickness)) -#' The mapping from data values to symbols may be controlled using -#' `spans`, or avoided altogether via [I()] (e.g., `span=I(30)`). -#' @param spans A numeric vector of length 2 used to scale `span` to pixels. -#' @param split (Discrete) values used to create multiple traces (one trace per value). -#' @param frame (Discrete) values used to create animation frames. -#' @param width Width in pixels (optional, defaults to automatic sizing). -#' @param height Height in pixels (optional, defaults to automatic sizing). -#' @param source a character string of length 1. Match the value of this string -#' with the source argument in [event_data()] to retrieve the -#' event data corresponding to a specific plot (shiny apps can have multiple plots). -#' @author Carson Sievert -#' @references -#' @seealso \itemize{ -#' \item For initializing a plotly-geo object: [plot_geo()] -#' \item For initializing a plotly-mapbox object: [plot_mapbox()] -#' \item For translating a ggplot2 object to a plotly object: [ggplotly()] -#' \item For modifying any plotly object: [layout()], [add_trace()], [style()] -#' \item For linked brushing: [highlight()] -#' \item For arranging multiple plots: [subplot()], [crosstalk::bscols()] -#' \item For inspecting plotly objects: [plotly_json()] -#' \item For quick, accurate, and searchable plotly.js reference: [schema()] -#' } -#' -#' @return A plotly +#' @name plot_ly +#' @rdname plot_ly +#' @inherit ttservice::plot_ly +#' @return `plotly` +#' +#' @examples +#' data(pbmc_small) +#' pbmc_small |> +#' plot_ly(x = ~ nCount_RNA, y = ~ nFeature_RNA) +#' +#' @importFrom ttservice plot_ly #' @export -#' @examples -#' \dontrun{ -#' # plot_ly() tries to create a sensible plot based on the information you -#' # give it. If you don't provide a trace type, plot_ly() will infer one. -#' plot_ly(economics, x=~pop) -#' plot_ly(economics, x=~date, y=~pop) -#' # plot_ly() doesn't require data frame(s), which allows one to take -#' # advantage of trace type(s) designed specifically for numeric matrices -#' plot_ly(z=~volcano) -#' plot_ly(z=~volcano, type="surface") -#' -#' # plotly has a functional interface: every plotly function takes a plotly -#' # object as it's first input argument and returns a modified plotly object -#' add_lines(plot_ly(economics, x=~date, y=~ unemploy / pop)) -#' -#' # To make code more readable, plotly imports the pipe operator from magrittr -#' economics %>% -#' plot_ly(x=~date, y=~ unemploy / pop) %>% -#' add_lines() -#' -#' # Attributes defined via plot_ly() set 'global' attributes that -#' # are carried onto subsequent traces, but those may be over-written -#' plot_ly(economics, x=~date, color=I("black")) %>% -#' add_lines(y=~uempmed) %>% -#' add_lines(y=~psavert, color=I("red")) -#' -#' # Attributes are documented in the figure reference -> https://plot.ly/r/reference -#' # You might notice plot_ly() has named arguments that aren't in this figure -#' # reference. These arguments make it easier to map abstract data values to -#' # visual attributes. -#' p <- plot_ly(iris, x=~Sepal.Width, y=~Sepal.Length) -#' add_markers(p, color=~Petal.Length, size=~Petal.Length) -#' add_markers(p, color=~Species) -#' add_markers(p, color=~Species, colors="Set1") -#' add_markers(p, symbol=~Species) -#' add_paths(p, linetype=~Species) -#' } -#' -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), - span=NULL, spans=c(1, 20), - symbol=NULL, symbols=NULL, - linetype=NULL, linetypes=NULL, - split=NULL, frame=NULL, - width=NULL, height=NULL, source="A") { - UseMethod("plot_ly") -} - -#' @export -#' -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), - span=NULL, spans=c(1, 20), - symbol=NULL, symbols=NULL, - linetype=NULL, linetypes=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(..., - type=type, name=name, - color=color, colors=colors, alpha=alpha, - stroke=stroke, strokes=strokes, alpha_stroke=alpha_stroke, - size=size, sizes=sizes, - span=span, spans=spans, - symbol=symbol, symbols=symbols, - linetype=linetype, linetypes=linetypes, - split=split, frame=frame, - width=width, height=height, source=source - ) +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), + span=NULL, spans=c(1, 20), + symbol=NULL, symbols=NULL, + linetype=NULL, linetypes=NULL, + split=NULL, frame=NULL, + width=NULL, height=NULL, source="A") { + data %>% + # This is a trick to not loop the call + as_tibble() %>% + ttservice::plot_ly(..., + type=type, name=name, + color=color, colors=colors, alpha=alpha, + stroke=stroke, strokes=strokes, alpha_stroke=alpha_stroke, + size=size, sizes=sizes, + span=span, spans=spans, + symbol=symbol, symbols=symbols, + linetype=linetype, linetypes=linetypes, + split=split, frame=frame, + width=width, height=height, source=source) } \ No newline at end of file diff --git a/man/bind_rows.Rd b/man/bind_rows.Rd index 99f2ad8..39a9050 100644 --- a/man/bind_rows.Rd +++ b/man/bind_rows.Rd @@ -5,7 +5,7 @@ \alias{bind_rows.SingleCellExperiment} \alias{bind_cols.SingleCellExperiment} \alias{bind_cols} -\title{#' Efficiently bind multiple data frames by row and column} +\title{Efficiently bind multiple data frames by row and column} \usage{ \method{bind_rows}{SingleCellExperiment}(..., .id = NULL, add.cell.ids = NULL) diff --git a/man/formatting.Rd b/man/formatting.Rd index 6268be8..e08a87a 100644 --- a/man/formatting.Rd +++ b/man/formatting.Rd @@ -6,7 +6,7 @@ \alias{print} \title{Printing tibbles} \usage{ -\method{print}{SingleCellExperiment}(x, ..., n = NULL, width = NULL) +\method{print}{SingleCellExperiment}(x, ..., n = NULL, width = NULL, n_extra = NULL) } \arguments{ \item{x}{Object to format or print.} diff --git a/tests/testthat/Rplots.pdf b/tests/testthat/Rplots.pdf new file mode 100644 index 0000000000000000000000000000000000000000..e2755f6c8c5af190199618e54835f2d3a8e06f6a GIT binary patch literal 5924 zcma)A2|QG7+qV>%LUtlfiV(((nL)_DXJ4~r8bgyY!z|f%AzP#@B}-*mCo#ouW^FP;pU-!A@n(O?pzle#ZwiHAf1`-Jw519z*3hA>a zfFOVjfWL4Fq@)A_YY@;#5(bacM3T^enC5Ay3=}2u(% zS!RF^0qJoOgCYXPWReG&M44tnz&n#sXae;rOj=eNO2PJg;i-@~=*$@q8s|*i1@zZ$ z0I-FR2O0otAW29p-W33wAYIW!K$c=)2K+ri?vDvnJE}DSjU)YK4%WcqNR(3|Aip;q zY=$P{$pjQ-J=kySQ4M~E<18BIO1cQZWf1^a8-pcLZUC%}rNl-Pjlw&lsoN%!C?RtP zd8gmEG{ld{9IBbKUQQKgOWZ0g60f4AML5NT9E}!y_DEr$K{T9yZ9NZcM@WJrd=m~u zTpQ2X&3N^MAwqeFJ@e#auRO4j)e~hVZQ)Q~758fj0o9cW??(ecFHUcqS`-TY5b0#I zUB+`(kVZ($zo8@Hv0&FVIxA&*6VM&H#v$m%f}XPP$eyRob=LCS(cy(ROqN2%-M-OX z9@GY4`LU{CZQV#&gHm=D^>XGT!_6v1n1-}r1Pkr#Sh{nP7=w>|@yUS#*GL4#eaNz=;H z%rSOX?o}%squSs~{DqidwXWknDLcSaVwFLl$*S(Ch)R^ty@g73zdpAX=`YV*tz^uu&!8r@}oUvoD|A2rPrG8fk|#_&FJZOn#k8D>xB=x8*TOn3Ng1U zEv8?H-`B+W3T~%0|xOu%zP_I|HN(*AL6A) zu*&!d^W5&t_7vB=QD|aRR$1OVbC#lVo>wE^2A2n3sd##^?t8JXzNsk8X@zb>c>MSg zjVd1{l>;_$T*33Eb|$g$YIb0`tZEj;wbL84#$}r7Cq+sTH#Tf*gLlig55(n5b;oe` zewO4~V~k+ZSA)2Bds@-a~sy?-d@#fIk(B4kw)3s!Y#Pt-GRPsTxys3>!h4&pIK=fymB{K zqbza6I8Z`nzK)9_=c@F!dT9}(A7ecmcWL-X;0%lB*xc25UUb`}Pny2o{8p;?6#CK} z-l)w2^?4J%mcY@L>bS6}tQsuYkr_N3{cCkKt&a~ipichQAf) z`V96M-9l$%r2Ee-Wea6#>3p25ZVY6KcKSkGUteEc5sc_)hq?$1r>{O%$l#I~D_pG4 z(x{$eH5;+BtF34VGO3BA)V<$w5b}4)|L>BJT9nOz|4=j`f0u0#_-ECG%l#KgNU53} zYKLmNik8_};A{T#^Y$FHW+I0ZbOj_Dvb!}jCDd4U0+fWRCqzuEO<5HStW~Zpq)bWG zOUVd)DBpZO?nB&K38Y^?S+A>^)z!C)I*9k;c~!m8yfb(psNoeNx~RJ@%5( z-0{@?tFlV`Y_8sS^jWJX^opHsVu8&bliNCK`?_qM5f{l z-L9N^P5Q8bg8Y$8?L(Jey?FhY?NQ1~Hph|0eR8p>W+!2zOlO#N^EKZ=jV>StnG0PTyG+djP z(c!2#X1eCD(oU%57q9;gB-pu5Pz|$1NkM&^d+4U2kb>b7~r!B3?A=Y~bFz5|%PO-*!dM&mZyW zRgUr*KLWDHZDIK?;qf17Ol1Q9Dt!OUVj=)Gz&H~DJAldz z%m8Y^H3Rli-VAV{&T(p9SUkbp1Bu#0z(g}0 zbpXD%Ey`8O=dVWt6{7mH1M6vMs3VDJX8=L9a`A}gLtmj3TspIyT(0ZU- zW=+>S*QJ1gDw>3yu>G&j+Aswl%C_PBIMo;x7vt*0NPB3Rh8|1v!K0)^oqI!@E{)EA zC>EQ>vB6VQ#R6<@OZ2J4*3taPyis{h7(!!`8auVJF>KGr(<-lQoi0*t+?x6fX4omC z-zj`96l#@3T#>Z%UrR%?Dy%}omH66;o#W``$V4V9Ykq4}WOdVaYVZ1cK{qn)*}^R=xs`-!|L zK2dw~h`1zcuSX)BW@NaMVJms#z*rB6uj)g<}rB#4Hi9L~iz zSF@p|bKGO|(C5s^4I#$wWI=AWofEZD;2T<+?YU=xv&m(4EgVt%)6^qWH!^Q+u-1RS zH(Z%~_3Z{*cd`xL{bNT|0|jZsB-j8ZKj%~3O92O)bm%ubVtUe2?`(I4eh;v&IQzYY z`$SMYN=Fk~!EV|)e{08<4hGO@snXA?@=w!qyxjNfC0hjz>j!!|HL<9Do=%Vtp_~b{ zng9=Ha9I}bjZn%{?*Rijiwzcr@ZcqdpgzFl8Kpzoo%W5=n#r(a1dA_&UaKAsztVD; z%Pf)vXtW4Cy<(HVKS{q|gUv+X#sLuxbzM3x)wwLQ2LkyKv)L}wcGF^{BULoa8s%B0 z7umPCd>N0+Fy+?SK4HV|FL5%KKM)_zQ`fo-l^2o@Eq{5_gWmt}Vz_aA$_F+ZkV;4% zTkv7F(|2QJ*tlP5t0#J&U}8H~kidSA4x{=uLGYeXWwdT$UW*+kgO(P=S47z8DQPMh3y9Q;nCiNmK!}H& zIOcwA;p83RcfvJ5QmeKzD?#bp+4t%=(ad9GCtsLmN!Up26ImlCU@R&W*B$ zS$wsyf0SBelkKhPsr%(2yJM^F)xri-+xr$dB#W7d-cqRLu(pDQf`(5CA!cR&Cml}7 z#;9?PkEYRL+hVR_D2woXW3+i?Ke=Cf_S~#IvxaQ${%$kO{ZjnJuu^fZ=;%B8rTQ8A zac!Pl;zzUjd+4WUzCyQT_JL6bRZnw0Xq(}zPQ*Y(49We zJFwE%)|=mZI_I0k?Z*q*ck*jAw!_!%u~;@6>SUE@Ox^25MS$v)5<4F_e}&|d;N)Gh zNY%Hhuqs*KCSOzEE4~Z9>tC6+BzI5j9^Ih~0>y zxY)Q0u?Su=pEA@+mPMvh4hOGwQ%88popb4RB6M(~+MtHA@7#Td4N9qT_9QrNX2RN>xi{p5wD=v~w?+E#JE6j=zI@ zcQK$j;sVD-^NW3`)q=t_sljJWYj5pW?8hn#rY?5{;9POd%ef`xq1JgO&*?HgIfkM?KwV8 zs~f9Frs67RD+%^<4)<|~$~DVtaAsZ(Uh#fm+w`mftQk5<&Ea_uUGt~Zx?CLx9EFQm ziUzT+Yx-;A_=b_L>IT2=$Z?KO<_p9z>n^$B@;6>>UGMQ%#>9h4gA#rqe(=-U(vAjy z4t}WG{PJc~4M#H9#Fa&Bl<89vQ#~zo*>ah-p=GkG(8!Y4CDA4K+S5}O z>=7a$b~svNIOb_}BW$>I=sZ z+d79HyDYmW&zwm2r`onGyYufC_*%~uN!u#dHsL!$%EHSqZb4$D(vo2RN@*7d<3y{T zTX&1U10-p4TTK6MR*Jf4NmEg;XmVQH*R)V-#j1i z_IfG$$?I%vm(^>lj{|cfqvc1%tfjlaLL-7tYlw^}o!0mi#gzHyCP-`3@|Y(EPYrDO z?1vrDCS_%_0c8Dex^dQqeuXXzxo-!neX5J*zYO(RIOe_RH$1h{M zhgYZkyY9@a&#U;n|F% zx7PUsVY|f+vw-rMS>@BqPIY05sL|q+D(D|y1D{VH+e9{ocWSO4AJJ(R4LAu_aoq6U z(Hlrg%WG6Q^}~Mq_2jVE3-2AM43{GOyZzUlzM|XbAG{d)(YuIVA`N}rwdN~waZGt` z8btgcHRt}LI@OCqwsNU>>6A)p;PfW%*Ds5CvBsH{zAAim`w!j?`I~ry{?h2Qa1=cZ zgQJLaRNngcnKcHdh9hEr0wAy^#>E9q5$34Mn;igygWWMWG7(TffIZ205*mwkA%P$; z7}yz4(GrP73;=c|ATLu$E)qqia$OXLfFirQVA0+Hn1sPPQy_OFih#!f;0pva)sQk1 zi9%7dJ`mU$LvcmKP&xu>9G>Kib^*YIy-lJh)E|pQ{sX^A#U(7WClmjdO1akxfX&GlNPD6s6{Kh|Mo4$cmMHDPUR?fVql?B~ zMw2ioBnbR7F2G($|EX$v6VNUo82|zY$^3c&2sm684!8inFes&wr@jE(FARd9{5t=R zL7{L;bMhM|3#W8FzhN*0rH%g`Q=qgZ|BlH(sqOynn8Kf!yaJ{9`pu5Qj(^7>aM&Mv zh9IDS_=Q6h{+J7g!6<_5Pah-#5`#q(C{i{6Hplp)De(iqdN>z6Kvg`b3I-le0;pQW YUaW~EB!RRSX*e8)0Evib8Eb?72kgNS#Q*>R literal 0 HcmV?d00001 diff --git a/tests/testthat/test-dplyr_methods.R b/tests/testthat/test-dplyr_methods.R index 8fee11b..f48eff5 100755 --- a/tests/testthat/test-dplyr_methods.R +++ b/tests/testthat/test-dplyr_methods.R @@ -1,5 +1,37 @@ library(S4Vectors) -data(pbmc_small) +data("pbmc_small") +# Mock up ADT and cell hashing experiments +set.seed(2023-08-29) +# Antibody tags +pos_myus <- sample(x = 7500:20000, size = 5) +int_myus <- sample(x = 100:1500, size = 5) +neg_myus <- sample(x = 1:30, size = 15) +all_myus <- c(pos_myus, int_myus, neg_myus) +all_myus <- sample(x = all_myus, size = length(all_myus)) + +mat <- list() +for(i in seq_along(all_myus)) { + mat[[i]] <- MASS::rnegbin(n = dim(pbmc_small)[[2]], mu = all_myus[[i]], theta = all_myus[[i]]/500) +} +mat <- Reduce(f = cbind, x = mat) +colnames(mat) <- paste("Ab", seq_along(mat[1,]), sep = "-") +rownames(mat) <- colnames(pbmc_small) + +altExps(pbmc_small)[["ADT"]] <- SingleCellExperiment(assays = list(counts = t(mat), logcounts = log10(t(mat) + 1))) + +# Cell hashing +HTO_myus <- sample(x = c(100, 100000), size = 6, replace = TRUE) +mat <- list() +for(i in seq_along(HTO_myus)) { + mat[[i]] <- MASS::rnegbin(n = dim(pbmc_small)[[2]], mu = HTO_myus[[i]], theta = HTO_myus[[i]]/500) +} + +mat <- Reduce(f = cbind, x = mat) +colnames(mat) <- paste("HTO", seq_along(mat[1,]), sep = "-") +rownames(mat) <- colnames(pbmc_small) + +altExps(pbmc_small)[["Hashtag demultiplex"]] <- SingleCellExperiment(assays = list(counts = t(mat), logcounts = log10(t(mat) + 1))) + df <- pbmc_small df$number <- sample(seq(ncol(df))) df$factor <- sample( diff --git a/tests/testthat/test-ggplotly_methods.R b/tests/testthat/test-ggplotly_methods.R index 6958bfa..757ad60 100644 --- a/tests/testthat/test-ggplotly_methods.R +++ b/tests/testthat/test-ggplotly_methods.R @@ -1,4 +1,36 @@ -data(pbmc_small) +data("pbmc_small") +# Mock up ADT and cell hashing experiments +set.seed(2023-08-29) +# Antibody tags +pos_myus <- sample(x = 7500:20000, size = 5) +int_myus <- sample(x = 100:1500, size = 5) +neg_myus <- sample(x = 1:30, size = 15) +all_myus <- c(pos_myus, int_myus, neg_myus) +all_myus <- sample(x = all_myus, size = length(all_myus)) + +mat <- list() +for(i in seq_along(all_myus)) { + mat[[i]] <- MASS::rnegbin(n = dim(pbmc_small)[[2]], mu = all_myus[[i]], theta = all_myus[[i]]/500) +} +mat <- Reduce(f = cbind, x = mat) +colnames(mat) <- paste("Ab", seq_along(mat[1,]), sep = "-") +rownames(mat) <- colnames(pbmc_small) + +altExps(pbmc_small)[["ADT"]] <- SingleCellExperiment(assays = list(counts = t(mat), logcounts = log10(t(mat) + 1))) + +# Cell hashing +HTO_myus <- sample(x = c(100, 100000), size = 6, replace = TRUE) +mat <- list() +for(i in seq_along(HTO_myus)) { + mat[[i]] <- MASS::rnegbin(n = dim(pbmc_small)[[2]], mu = HTO_myus[[i]], theta = HTO_myus[[i]]/500) +} + +mat <- Reduce(f = cbind, x = mat) +colnames(mat) <- paste("HTO", seq_along(mat[1,]), sep = "-") +rownames(mat) <- colnames(pbmc_small) + +altExps(pbmc_small)[["Hashtag demultiplex"]] <- SingleCellExperiment(assays = list(counts = t(mat), logcounts = log10(t(mat) + 1))) + df <- pbmc_small df$number <- rnorm(ncol(df)) df$factor <- sample(gl(3, 1, ncol(df))) From e2690041c1375ba69efb6100bb344805f00ccc5f Mon Sep 17 00:00:00 2001 From: Miha Kosmac Date: Mon, 1 Jan 2024 11:11:52 +0000 Subject: [PATCH 121/140] delete unnecessary plot --- tests/testthat/Rplots.pdf | Bin 5924 -> 0 bytes 1 file changed, 0 insertions(+), 0 deletions(-) delete mode 100644 tests/testthat/Rplots.pdf diff --git a/tests/testthat/Rplots.pdf b/tests/testthat/Rplots.pdf deleted file mode 100644 index e2755f6c8c5af190199618e54835f2d3a8e06f6a..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 5924 zcma)A2|QG7+qV>%LUtlfiV(((nL)_DXJ4~r8bgyY!z|f%AzP#@B}-*mCo#ouW^FP;pU-!A@n(O?pzle#ZwiHAf1`-Jw519z*3hA>a zfFOVjfWL4Fq@)A_YY@;#5(bacM3T^enC5Ay3=}2u(% zS!RF^0qJoOgCYXPWReG&M44tnz&n#sXae;rOj=eNO2PJg;i-@~=*$@q8s|*i1@zZ$ z0I-FR2O0otAW29p-W33wAYIW!K$c=)2K+ri?vDvnJE}DSjU)YK4%WcqNR(3|Aip;q zY=$P{$pjQ-J=kySQ4M~E<18BIO1cQZWf1^a8-pcLZUC%}rNl-Pjlw&lsoN%!C?RtP zd8gmEG{ld{9IBbKUQQKgOWZ0g60f4AML5NT9E}!y_DEr$K{T9yZ9NZcM@WJrd=m~u zTpQ2X&3N^MAwqeFJ@e#auRO4j)e~hVZQ)Q~758fj0o9cW??(ecFHUcqS`-TY5b0#I zUB+`(kVZ($zo8@Hv0&FVIxA&*6VM&H#v$m%f}XPP$eyRob=LCS(cy(ROqN2%-M-OX z9@GY4`LU{CZQV#&gHm=D^>XGT!_6v1n1-}r1Pkr#Sh{nP7=w>|@yUS#*GL4#eaNz=;H z%rSOX?o}%squSs~{DqidwXWknDLcSaVwFLl$*S(Ch)R^ty@g73zdpAX=`YV*tz^uu&!8r@}oUvoD|A2rPrG8fk|#_&FJZOn#k8D>xB=x8*TOn3Ng1U zEv8?H-`B+W3T~%0|xOu%zP_I|HN(*AL6A) zu*&!d^W5&t_7vB=QD|aRR$1OVbC#lVo>wE^2A2n3sd##^?t8JXzNsk8X@zb>c>MSg zjVd1{l>;_$T*33Eb|$g$YIb0`tZEj;wbL84#$}r7Cq+sTH#Tf*gLlig55(n5b;oe` zewO4~V~k+ZSA)2Bds@-a~sy?-d@#fIk(B4kw)3s!Y#Pt-GRPsTxys3>!h4&pIK=fymB{K zqbza6I8Z`nzK)9_=c@F!dT9}(A7ecmcWL-X;0%lB*xc25UUb`}Pny2o{8p;?6#CK} z-l)w2^?4J%mcY@L>bS6}tQsuYkr_N3{cCkKt&a~ipichQAf) z`V96M-9l$%r2Ee-Wea6#>3p25ZVY6KcKSkGUteEc5sc_)hq?$1r>{O%$l#I~D_pG4 z(x{$eH5;+BtF34VGO3BA)V<$w5b}4)|L>BJT9nOz|4=j`f0u0#_-ECG%l#KgNU53} zYKLmNik8_};A{T#^Y$FHW+I0ZbOj_Dvb!}jCDd4U0+fWRCqzuEO<5HStW~Zpq)bWG zOUVd)DBpZO?nB&K38Y^?S+A>^)z!C)I*9k;c~!m8yfb(psNoeNx~RJ@%5( z-0{@?tFlV`Y_8sS^jWJX^opHsVu8&bliNCK`?_qM5f{l z-L9N^P5Q8bg8Y$8?L(Jey?FhY?NQ1~Hph|0eR8p>W+!2zOlO#N^EKZ=jV>StnG0PTyG+djP z(c!2#X1eCD(oU%57q9;gB-pu5Pz|$1NkM&^d+4U2kb>b7~r!B3?A=Y~bFz5|%PO-*!dM&mZyW zRgUr*KLWDHZDIK?;qf17Ol1Q9Dt!OUVj=)Gz&H~DJAldz z%m8Y^H3Rli-VAV{&T(p9SUkbp1Bu#0z(g}0 zbpXD%Ey`8O=dVWt6{7mH1M6vMs3VDJX8=L9a`A}gLtmj3TspIyT(0ZU- zW=+>S*QJ1gDw>3yu>G&j+Aswl%C_PBIMo;x7vt*0NPB3Rh8|1v!K0)^oqI!@E{)EA zC>EQ>vB6VQ#R6<@OZ2J4*3taPyis{h7(!!`8auVJF>KGr(<-lQoi0*t+?x6fX4omC z-zj`96l#@3T#>Z%UrR%?Dy%}omH66;o#W``$V4V9Ykq4}WOdVaYVZ1cK{qn)*}^R=xs`-!|L zK2dw~h`1zcuSX)BW@NaMVJms#z*rB6uj)g<}rB#4Hi9L~iz zSF@p|bKGO|(C5s^4I#$wWI=AWofEZD;2T<+?YU=xv&m(4EgVt%)6^qWH!^Q+u-1RS zH(Z%~_3Z{*cd`xL{bNT|0|jZsB-j8ZKj%~3O92O)bm%ubVtUe2?`(I4eh;v&IQzYY z`$SMYN=Fk~!EV|)e{08<4hGO@snXA?@=w!qyxjNfC0hjz>j!!|HL<9Do=%Vtp_~b{ zng9=Ha9I}bjZn%{?*Rijiwzcr@ZcqdpgzFl8Kpzoo%W5=n#r(a1dA_&UaKAsztVD; z%Pf)vXtW4Cy<(HVKS{q|gUv+X#sLuxbzM3x)wwLQ2LkyKv)L}wcGF^{BULoa8s%B0 z7umPCd>N0+Fy+?SK4HV|FL5%KKM)_zQ`fo-l^2o@Eq{5_gWmt}Vz_aA$_F+ZkV;4% zTkv7F(|2QJ*tlP5t0#J&U}8H~kidSA4x{=uLGYeXWwdT$UW*+kgO(P=S47z8DQPMh3y9Q;nCiNmK!}H& zIOcwA;p83RcfvJ5QmeKzD?#bp+4t%=(ad9GCtsLmN!Up26ImlCU@R&W*B$ zS$wsyf0SBelkKhPsr%(2yJM^F)xri-+xr$dB#W7d-cqRLu(pDQf`(5CA!cR&Cml}7 z#;9?PkEYRL+hVR_D2woXW3+i?Ke=Cf_S~#IvxaQ${%$kO{ZjnJuu^fZ=;%B8rTQ8A zac!Pl;zzUjd+4WUzCyQT_JL6bRZnw0Xq(}zPQ*Y(49We zJFwE%)|=mZI_I0k?Z*q*ck*jAw!_!%u~;@6>SUE@Ox^25MS$v)5<4F_e}&|d;N)Gh zNY%Hhuqs*KCSOzEE4~Z9>tC6+BzI5j9^Ih~0>y zxY)Q0u?Su=pEA@+mPMvh4hOGwQ%88popb4RB6M(~+MtHA@7#Td4N9qT_9QrNX2RN>xi{p5wD=v~w?+E#JE6j=zI@ zcQK$j;sVD-^NW3`)q=t_sljJWYj5pW?8hn#rY?5{;9POd%ef`xq1JgO&*?HgIfkM?KwV8 zs~f9Frs67RD+%^<4)<|~$~DVtaAsZ(Uh#fm+w`mftQk5<&Ea_uUGt~Zx?CLx9EFQm ziUzT+Yx-;A_=b_L>IT2=$Z?KO<_p9z>n^$B@;6>>UGMQ%#>9h4gA#rqe(=-U(vAjy z4t}WG{PJc~4M#H9#Fa&Bl<89vQ#~zo*>ah-p=GkG(8!Y4CDA4K+S5}O z>=7a$b~svNIOb_}BW$>I=sZ z+d79HyDYmW&zwm2r`onGyYufC_*%~uN!u#dHsL!$%EHSqZb4$D(vo2RN@*7d<3y{T zTX&1U10-p4TTK6MR*Jf4NmEg;XmVQH*R)V-#j1i z_IfG$$?I%vm(^>lj{|cfqvc1%tfjlaLL-7tYlw^}o!0mi#gzHyCP-`3@|Y(EPYrDO z?1vrDCS_%_0c8Dex^dQqeuXXzxo-!neX5J*zYO(RIOe_RH$1h{M zhgYZkyY9@a&#U;n|F% zx7PUsVY|f+vw-rMS>@BqPIY05sL|q+D(D|y1D{VH+e9{ocWSO4AJJ(R4LAu_aoq6U z(Hlrg%WG6Q^}~Mq_2jVE3-2AM43{GOyZzUlzM|XbAG{d)(YuIVA`N}rwdN~waZGt` z8btgcHRt}LI@OCqwsNU>>6A)p;PfW%*Ds5CvBsH{zAAim`w!j?`I~ry{?h2Qa1=cZ zgQJLaRNngcnKcHdh9hEr0wAy^#>E9q5$34Mn;igygWWMWG7(TffIZ205*mwkA%P$; z7}yz4(GrP73;=c|ATLu$E)qqia$OXLfFirQVA0+Hn1sPPQy_OFih#!f;0pva)sQk1 zi9%7dJ`mU$LvcmKP&xu>9G>Kib^*YIy-lJh)E|pQ{sX^A#U(7WClmjdO1akxfX&GlNPD6s6{Kh|Mo4$cmMHDPUR?fVql?B~ zMw2ioBnbR7F2G($|EX$v6VNUo82|zY$^3c&2sm684!8inFes&wr@jE(FARd9{5t=R zL7{L;bMhM|3#W8FzhN*0rH%g`Q=qgZ|BlH(sqOynn8Kf!yaJ{9`pu5Qj(^7>aM&Mv zh9IDS_=Q6h{+J7g!6<_5Pah-#5`#q(C{i{6Hplp)De(iqdN>z6Kvg`b3I-le0;pQW YUaW~EB!RRSX*e8)0Evib8Eb?72kgNS#Q*>R From a6419116e687da84d6d38feb514d68799d2f086b Mon Sep 17 00:00:00 2001 From: Biomiha Date: Mon, 1 Jan 2024 17:07:22 +0000 Subject: [PATCH 122/140] add error handling in yaml --- .github/workflows/rworkflows.yml | 1 + 1 file changed, 1 insertion(+) diff --git a/.github/workflows/rworkflows.yml b/.github/workflows/rworkflows.yml index 94d43eb..0b89f0b 100644 --- a/.github/workflows/rworkflows.yml +++ b/.github/workflows/rworkflows.yml @@ -55,3 +55,4 @@ jobs: runner_os: ${{ runner.os }} cache_version: cache-v1 docker_registry: ghcr.io + error-on: '"error"' From 2ad486a3a5310db5d89bd2d944352ff101051007 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Mon, 1 Jan 2024 18:42:01 +0000 Subject: [PATCH 123/140] add CMD check --- .github/workflows/R-CMD-check.yaml | 50 ++++++++++++++++++++++++++++++ .github/workflows/rworkflows.yml | 3 +- 2 files changed, 51 insertions(+), 2 deletions(-) create mode 100644 .github/workflows/R-CMD-check.yaml diff --git a/.github/workflows/R-CMD-check.yaml b/.github/workflows/R-CMD-check.yaml new file mode 100644 index 0000000..4106b06 --- /dev/null +++ b/.github/workflows/R-CMD-check.yaml @@ -0,0 +1,50 @@ +# Workflow derived from https://github.com/r-lib/actions/tree/v2/examples +# Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help +on: + push: + branches: [main, master] + pull_request: + branches: [main, master] + +name: R-CMD-check + +jobs: + R-CMD-check: + runs-on: ${{ matrix.config.os }} + + name: ${{ matrix.config.os }} (${{ matrix.config.r }}) + + strategy: + fail-fast: false + matrix: + config: + - {os: macos-latest, r: 'release'} + - {os: windows-latest, r: 'release'} + - {os: ubuntu-latest, r: 'devel', http-user-agent: 'release'} + - {os: ubuntu-latest, r: 'release'} + - {os: ubuntu-latest, r: 'oldrel-1'} + + env: + GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} + R_KEEP_PKG_SOURCE: yes + + steps: + - uses: actions/checkout@v3 + + - uses: r-lib/actions/setup-pandoc@v2 + + - uses: r-lib/actions/setup-r@v2 + with: + r-version: ${{ matrix.config.r }} + http-user-agent: ${{ matrix.config.http-user-agent }} + use-public-rspm: true + + - uses: r-lib/actions/setup-r-dependencies@v2 + with: + extra-packages: any::rcmdcheck + needs: check + + - uses: r-lib/actions/check-r-package@v2 + with: + upload-snapshots: true + error-on: error diff --git a/.github/workflows/rworkflows.yml b/.github/workflows/rworkflows.yml index 0b89f0b..dd18193 100644 --- a/.github/workflows/rworkflows.yml +++ b/.github/workflows/rworkflows.yml @@ -54,5 +54,4 @@ jobs: DOCKER_TOKEN: ${{ secrets.DOCKER_TOKEN }} runner_os: ${{ runner.os }} cache_version: cache-v1 - docker_registry: ghcr.io - error-on: '"error"' + docker_registry: ghcr.io \ No newline at end of file From 4be74fcccbe977e0725d6af02c79ca3665f712d2 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Wed, 3 Jan 2024 08:35:29 +0000 Subject: [PATCH 124/140] Update methods.R small tweaks --- R/methods.R | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/R/methods.R b/R/methods.R index f827b26..f7ba434 100755 --- a/R/methods.R +++ b/R/methods.R @@ -147,8 +147,9 @@ tidy.SingleCellExperiment <- function(object) { #' @importFrom dplyr left_join #' @importFrom dplyr group_by #' @importFrom dplyr pick -#' @importFrom dplyr group_rows #' @importFrom dplyr group_keys +#' @importFrom dplyr group_rows +#' @importFrom dplyr group_split #' @importFrom dplyr bind_rows #' @importFrom dplyr pull #' @importFrom tidyr unite From 3fe42a9c781b805807c1bc46f3af677eb3aed827 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Sat, 3 Feb 2024 20:43:43 +0000 Subject: [PATCH 125/140] Minor bug fixes to utilities --- R/utilities.R | 120 ++++++++++++++++++++++++++------------------------ 1 file changed, 62 insertions(+), 58 deletions(-) diff --git a/R/utilities.R b/R/utilities.R index 7b64b23..656459d 100755 --- a/R/utilities.R +++ b/R/utilities.R @@ -56,7 +56,7 @@ prepend <- function(x, values, before=1) { #' #' @return A tibble with an additional attribute add_class <- function(var, name) { - if (!name %in% class(var)) + if (!name %in% class(var)) class(var) <- prepend(class(var), name) return(var) } @@ -128,26 +128,26 @@ get_all_features <- function(x) { #' @param .data A `tidySingleCellExperiment` #' @param features A character #' @param all A boolean -#' @param ... Parameters to pass to join wide, i.e., +#' @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, prefix="", variable_features = NA, ...) { - + arg_list <- c(mget(ls(environment(), sorted=F)), match.call(expand.dots=F)$...) assays_to_use <- eval(arg_list$assays) - if(is.null(assays_to_use)) stop("Please provide assay names") - - + if(is.null(assays_to_use)) stop("Please provide one assay name when joining in wide format") + if(length(assays_to_use) > 1) stop("Please provide one assay name when joining in wide format") + # Solve CRAN warnings . <- NULL - + # For SCE there is no a priori field for variable features # If variable_features are selected set all to FALSE. They can only be on or the other. if(!all(is.na(variable_features))) all <- FALSE - + # Give options if no arguments are selected if (isFALSE(all) && is.null(features)) { if (all(is.na(variable_features))) { @@ -165,7 +165,7 @@ get_abundance_sc_wide <- function(.data, features=NULL, all=FALSE, prefix="", va } else { variable_genes <- NULL } - + if (!is.null(variable_genes)) { gs <- variable_genes } else if (!is.null(features)) { @@ -174,9 +174,13 @@ get_abundance_sc_wide <- function(.data, features=NULL, all=FALSE, prefix="", va # Get selected features and assays feature_df <- get_all_features(.data) # If all = TRUE then gs are all features in the selected assays, otherwise just the selected features. - if(isTRUE(all)) gs <- feature_df[feature_df$assay_id %in% assays_to_use, "feature"] + if(isTRUE(all)) gs <- feature_df[feature_df$assay_name %in% assays_to_use, "feature"] selected_features <- feature_df[(feature_df$feature %in% gs), ] - selected_features <- selected_features[selected_features$assay_id %in% assays_to_use,] + # Subset by selected assay + selected_features <- selected_features[selected_features$assay_name %in% assays_to_use,] + # If the name of the selected assay is wrong the function will throw an error. Stop before this happens. + if(!is.null(features) & nrow(selected_features) == 0) stop("Please provide matched feature and assay names") + # Split by experiment selected_experiments_list <- split(x = selected_features, f = as.character(selected_features$exp_id)) if("RNA" %in% names(selected_experiments_list)) selected_experiments_list <- selected_experiments_list[c("RNA", setdiff(names(selected_experiments_list), "RNA"))] extract_feature_values <- function(exp) { @@ -207,7 +211,7 @@ get_abundance_sc_wide <- function(.data, features=NULL, all=FALSE, prefix="", va # Apply function that extracts feature values and join for all selected assays suppressMessages({ feature_values_list <- lapply(selected_experiments_list, extract_feature_values) - purrr::reduce(feature_values_list, full_join, by = join_by(.cell), suffix = paste0(".", names(feature_values_list))) + purrr::reduce(feature_values_list, dplyr::full_join, by = dplyr::join_by(.cell), suffix = paste0(".", names(feature_values_list))) }) } @@ -233,17 +237,17 @@ get_abundance_sc_wide <- function(.data, features=NULL, all=FALSE, prefix="", va #' #' @noRd get_abundance_sc_long <- function(.data, features = NULL, all = FALSE, exclude_zeros = FALSE, variable_features = NA, ...) { - + assay_names <- names(assays(.data)) - + # Check that I have assay names - can you even have an sce object with no assays? if (length(assay_names) == 0) { stop("tidySingleCellExperiment says: there are no assays names in the source SingleCellExperiment.") } - + arg_list <- c(mget(ls(environment(), sorted=F)), match.call(expand.dots=F)$...) assays_to_use <- eval(arg_list$assays) - + # Solve CRAN warnings . <- NULL @@ -284,7 +288,7 @@ get_abundance_sc_long <- function(.data, features = NULL, all = FALSE, exclude_z features <- unique(feature_df$feature) } selected_features <- feature_df[(feature_df$feature %in% features), ] - if(!is.null(assays_to_use)) selected_features <- selected_features[selected_features$assay_id %in% assays_to_use,] + if(!is.null(assays_to_use)) selected_features <- selected_features[selected_features$assay_name %in% assays_to_use,] selected_features_exp <- unique(selected_features$exp_id) selected_experiments_list <- split(x = selected_features, f = as.character(selected_features$exp_id)) if("RNA" %in% selected_features_exp) selected_experiments_list <- selected_experiments_list[c("RNA", setdiff(names(selected_experiments_list), "RNA"))] @@ -297,7 +301,7 @@ get_abundance_sc_long <- function(.data, features = NULL, all = FALSE, exclude_z as.list() %>% .[unique(exp$assay_name)] %>% # Take active assay - map2( + purrr::map2( unique(exp$assay_id), ~ .x %>% when( @@ -331,7 +335,7 @@ get_abundance_sc_long <- function(.data, features = NULL, all = FALSE, exclude_z as.list() %>% .[unique(exp$assay_name)] %>% # Take active assay - map2( + purrr::map2( unique(exp$assay_id), ~ .x %>% when( @@ -363,7 +367,7 @@ get_abundance_sc_long <- function(.data, features = NULL, all = FALSE, exclude_z } } # Apply function that extracts feature values and bind_rows for all selected assays - lapply(selected_experiments_list, extract_feature_values) |> + lapply(selected_experiments_list, extract_feature_values) |> bind_rows() } @@ -380,21 +384,21 @@ as_meta_data <- function(.data, SingleCellExperiment_object) { col_to_exclude <- get_special_columns(SingleCellExperiment_object) |> - # Need this in case we have multiple reduced dimensions + # 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 + + # 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)) } @@ -415,15 +419,15 @@ get_special_columns <- function(SingleCellExperiment_object) { #' @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 + # Set names as SCE is much less constrained # and there could be missing names - if (is.null(colnames(mat))) colnames(mat) <- + if (is.null(colnames(mat))) colnames(mat) <- sprintf("%s%s", .y, seq_len(ncol(mat))) return(mat) }) @@ -483,17 +487,17 @@ duplicated_cell_names <- paste( # 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, + +is_sample_feature_deprecated_used <- function(.data, user_columns, use_old_special_names=FALSE) { - + cell <- user_columns |> as.character() |> str_detect(regex("\\bcell\\b")) |> any() .cell <- user_columns |> as.character() |> str_detect(regex("\\W*(\\.cell)\\W*")) |> any() - - old_standard_is_used <- + + old_standard_is_used <- !"cell" %in% colnames(colData(.data)) && ("cell" %in% as.character(user_columns) || (cell && !.cell)) - + if (old_standard_is_used) { warning("tidySingleCellExperiment says:", " from version 1.3.1, the special columns including", @@ -561,9 +565,9 @@ special_datasets_to_tibble <- function(.singleCellExperiment, ...) { 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) |> + colnames(x) <- colnames(x) |> trick_to_avoid_renaming_of_already_unique_columns_by_dplyr() return(x) } @@ -577,37 +581,37 @@ trick_to_avoid_renaming_of_already_unique_columns_by_dplyr <- function(x) { #' #' @keywords internal #' @noRd -#' +#' #' @importFrom rlang enquo #' @importFrom purrr map #' @importFrom dplyr distinct_at #' @importFrom magrittr equals #' @importFrom dplyr vars -#' +#' #' @param .data A tibble #' @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() - + # Exclude columns that have more values than my .col columns_unique_length = .data |> select(-!!.col) |> lapply(function(x) unique(x) |> length()) columns_unique_length = columns_unique_length[columns_unique_length<=n_x] - + .sample = .data |> select(!!.col) |> unite(".sample", !!.col) |> pull(.sample) - + # element wise columns columns_unique_length |> - names() |> + names() |> map(~ { n_.x <- .data |> pull(all_of(.x)) |> paste(.sample) |> unique() |> length() if (n_.x == n_x) .x else NULL @@ -621,24 +625,24 @@ get_specific_annotation_columns <- function(.data, .col) { #' #' @keywords internal #' @noRd -#' +#' #' @importFrom rlang enquo -#' +#' #' @param .data A tibble #' @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 (!all(quo_names(.column) %in% colnames(.data))) stop("nanny says: some of the .column specified", " do not exist in the input data frame.") - + .data |> # Selecting the right columns select(!!.column, get_specific_annotation_columns(.data, !!.column)) %>% @@ -647,19 +651,19 @@ subset <- function(.data, .column) { splitColData <- function(x, f) { - # This is by @jma1991 + # This is by @jma1991 # at https://github.com/drisso/SingleCellExperiment/issues/55 - + i <- split(seq_along(f), f) - + v <- vector(mode = "list", length = length(i)) - + names(v) <- names(i) - + for (n in names(i)) { v[[n]] <- x[, i[[n]]] } - + return(v) - + } cell__ <- get_special_column_name_symbol(".cell") From 443fda8d3c4de85078b06cae91444f90cdb777c7 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Sun, 4 Feb 2024 10:33:24 +0000 Subject: [PATCH 126/140] Replace deprecated function `when` with if else statements --- R/utilities.R | 50 ++++++++++++++++++++++++++------------------------ 1 file changed, 26 insertions(+), 24 deletions(-) diff --git a/R/utilities.R b/R/utilities.R index 656459d..2c35c71 100755 --- a/R/utilities.R +++ b/R/utilities.R @@ -304,19 +304,20 @@ get_abundance_sc_long <- function(.data, features = NULL, all = FALSE, exclude_z purrr::map2( unique(exp$assay_id), ~ .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") - ) %>% + function(x) { + if(!is.null(variable_genes)) { + x[variable_genes, , drop = FALSE] + } else if(!is.null(features)) { + x[toupper(rownames(.x)) %in% toupper(features), , drop = FALSE] + } else if(all) { + x + } else stop("It is not convenient to extract all genes, you should have either variable features or a feature list to extract") + } %>% # Replace 0 with NA - when(exclude_zeros ~ (.) %>% - { - x <- (.) - x[x == 0] <- NA - x - }, ~ (.)) %>% + if(exclude_zeros) function(x) { + x[x == 0] <- NA + return(x) + } %>% as.matrix() %>% data.frame(check.names = FALSE) %>% as_tibble(rownames = ".feature") %>% @@ -338,19 +339,20 @@ get_abundance_sc_long <- function(.data, features = NULL, all = FALSE, exclude_z purrr::map2( unique(exp$assay_id), ~ .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") - ) %>% + function(x) { + if(!is.null(variable_genes)) { + x[variable_genes, , drop = FALSE] + } else if(!is.null(features)) { + x[toupper(rownames(.x)) %in% toupper(features), , drop = FALSE] + } else if(all) { + x + } else stop("It is not convenient to extract all genes, you should have either variable features or a feature list to extract") + } %>% # Replace 0 with NA - when(exclude_zeros ~ (.) %>% - { - x <- (.) - x[x == 0] <- NA - x - }, ~ (.)) %>% + if(exclude_zeros) function(x) { + x[x == 0] <- NA + return(x) + } %>% as.matrix() %>% data.frame(check.names = FALSE) %>% as_tibble(rownames = ".feature") %>% From 124ddd6e00f340d02fb065eb21f5e4e9b1f18b32 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Sun, 4 Feb 2024 10:40:40 +0000 Subject: [PATCH 127/140] Update methods.R Remove importFrom dplyr::bind_rows --- R/methods.R | 1 - 1 file changed, 1 deletion(-) diff --git a/R/methods.R b/R/methods.R index f7ba434..757e41c 100755 --- a/R/methods.R +++ b/R/methods.R @@ -150,7 +150,6 @@ tidy.SingleCellExperiment <- function(object) { #' @importFrom dplyr group_keys #' @importFrom dplyr group_rows #' @importFrom dplyr group_split -#' @importFrom dplyr bind_rows #' @importFrom dplyr pull #' @importFrom tidyr unite #' @importFrom tidyr separate From 27b76232ffdb7716faddd2c3d4a8812df5fd8be9 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Sun, 4 Feb 2024 10:41:26 +0000 Subject: [PATCH 128/140] Update utilities.R Remove importFrom `when` --- R/utilities.R | 2 -- 1 file changed, 2 deletions(-) diff --git a/R/utilities.R b/R/utilities.R index 2c35c71..09ba64e 100755 --- a/R/utilities.R +++ b/R/utilities.R @@ -222,7 +222,6 @@ get_abundance_sc_wide <- function(.data, features=NULL, all=FALSE, prefix="", va #' @importFrom magrittr "%$%" #' @importFrom tidyr pivot_longer #' @importFrom tibble as_tibble -#' @importFrom purrr when #' @importFrom purrr map2 #' @importFrom purrr reduce #' @importFrom dplyr full_join @@ -468,7 +467,6 @@ return_arguments_of <- function(expression){ variables } -#' @importFrom purrr when #' @importFrom dplyr select #' @importFrom rlang expr #' @importFrom tidyselect eval_select From 0b2d3282d55ff69f3208a6add2094b0979c7ba41 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Sun, 4 Feb 2024 11:05:26 +0000 Subject: [PATCH 129/140] Sync abundance functions with master repo --- R/utilities.R | 109 +++++++++++++++++++++++--------------------------- 1 file changed, 50 insertions(+), 59 deletions(-) diff --git a/R/utilities.R b/R/utilities.R index 09ba64e..bdecd71 100755 --- a/R/utilities.R +++ b/R/utilities.R @@ -275,6 +275,23 @@ get_abundance_sc_long <- function(.data, features = NULL, all = FALSE, exclude_z variable_genes <- NULL } + # 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.") + } # Get assays all_assay_names_ext_df <- get_all_assays(.data) @@ -283,10 +300,10 @@ get_abundance_sc_long <- function(.data, features = NULL, all = FALSE, exclude_z feature_df <- get_all_features(.data) # Get selected features - if all = TRUE then all features in the objects are selected - if(is.null(features) && isTRUE(all)) { - features <- unique(feature_df$feature) + if(is.null(gs) && isTRUE(gs)) { + gs <- unique(feature_df$feature) } - selected_features <- feature_df[(feature_df$feature %in% features), ] + selected_features <- feature_df[(feature_df$feature %in% gs), ] if(!is.null(assays_to_use)) selected_features <- selected_features[selected_features$assay_name %in% assays_to_use,] selected_features_exp <- unique(selected_features$exp_id) selected_experiments_list <- split(x = selected_features, f = as.character(selected_features$exp_id)) @@ -300,71 +317,45 @@ get_abundance_sc_long <- function(.data, features = NULL, all = FALSE, exclude_z as.list() %>% .[unique(exp$assay_name)] %>% # Take active assay - purrr::map2( - unique(exp$assay_id), - ~ .x %>% - function(x) { - if(!is.null(variable_genes)) { - x[variable_genes, , drop = FALSE] - } else if(!is.null(features)) { - x[toupper(rownames(.x)) %in% toupper(features), , drop = FALSE] - } else if(all) { - x - } else stop("It is not convenient to extract all genes, you should have either variable features or a feature list to extract") - } %>% - # Replace 0 with NA - if(exclude_zeros) function(x) { - x[x == 0] <- NA - return(x) - } %>% + purrr::map2(unique(exp$assay_id), ~ { + # 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) %>% - as_tibble(rownames = ".feature") %>% + data.frame(check.names=FALSE) %>% + as_tibble(rownames=".feature") %>% tidyr::pivot_longer( - cols = -.feature, - names_to = c_(.data)$name, - values_to = ".abundance" %>% paste(.y, sep = "_"), - values_drop_na = TRUE - ) - # %>% - # mutate_if(is.character, as.factor) %>% - ) %>% - base::Reduce(function(...) full_join(..., by = c(".feature", c_(.data)$name)), .) + cols=-.feature, + names_to=c_(.data)$name, + values_to=".abundance" %>% paste(.y, sep="_"), + values_drop_na=TRUE) + }) %>% Reduce(function(...) full_join(..., + by=c(".feature", c_(.data)$name)), .) } else { assays(altExps(.data)[[unique(exp$exp_id)]]) %>% as.list() %>% .[unique(exp$assay_name)] %>% # Take active assay - purrr::map2( - unique(exp$assay_id), - ~ .x %>% - function(x) { - if(!is.null(variable_genes)) { - x[variable_genes, , drop = FALSE] - } else if(!is.null(features)) { - x[toupper(rownames(.x)) %in% toupper(features), , drop = FALSE] - } else if(all) { - x - } else stop("It is not convenient to extract all genes, you should have either variable features or a feature list to extract") - } %>% - # Replace 0 with NA - if(exclude_zeros) function(x) { - x[x == 0] <- NA - return(x) - } %>% + purrr::map2(unique(exp$assay_id), ~ { + # 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) %>% - as_tibble(rownames = ".feature") %>% + data.frame(check.names=FALSE) %>% + as_tibble(rownames=".feature") %>% tidyr::pivot_longer( - cols = -.feature, - names_to = c_(.data)$name, - values_to = ".abundance" %>% paste(.y, sep = "_"), - values_drop_na = TRUE - ) - # %>% - # mutate_if(is.character, as.factor) %>% - ) %>% - base::Reduce(function(...) full_join(..., by = c(".feature", c_(.data)$name)), .) + cols=-.feature, + names_to=c_(.data)$name, + values_to=".abundance" %>% paste(.y, sep="_"), + values_drop_na=TRUE) + }) %>% Reduce(function(...) full_join(..., + by=c(".feature", c_(.data)$name)), .) } } # Apply function that extracts feature values and bind_rows for all selected assays From 5593de0f7cfac65a58ce090553d719856a402af3 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Sun, 4 Feb 2024 11:20:55 +0000 Subject: [PATCH 130/140] Sync with master repo --- R/utilities.R | 21 +++------------------ 1 file changed, 3 insertions(+), 18 deletions(-) diff --git a/R/utilities.R b/R/utilities.R index bdecd71..720e7b7 100755 --- a/R/utilities.R +++ b/R/utilities.R @@ -237,26 +237,13 @@ get_abundance_sc_wide <- function(.data, features=NULL, all=FALSE, prefix="", va #' @noRd get_abundance_sc_long <- function(.data, features = NULL, all = FALSE, exclude_zeros = FALSE, variable_features = NA, ...) { - assay_names <- names(assays(.data)) - - # Check that I have assay names - can you even have an sce object with no assays? - if (length(assay_names) == 0) { - stop("tidySingleCellExperiment says: there are no assays names in the source SingleCellExperiment.") - } - arg_list <- c(mget(ls(environment(), sorted=F)), match.call(expand.dots=F)$...) assays_to_use <- eval(arg_list$assays) # Solve CRAN warnings . <- NULL - # For SCE there is no a priori field for variable features - if(!all(is.na(variable_features))) {all <- FALSE} - if(!all(is.null(features))) { - all <- FALSE - variable_genes <- NULL - } - # Check if output would be too big without forcing +# Check if output would be too big without forcing if (isFALSE(all) && is.null(features)) { if (all(is.na(variable_features))) { stop("Your object does not contain variable feature labels,\n", @@ -316,10 +303,9 @@ get_abundance_sc_long <- function(.data, features = NULL, all = FALSE, exclude_z assays(.data) %>% as.list() %>% .[unique(exp$assay_name)] %>% - # Take active assay purrr::map2(unique(exp$assay_id), ~ { # Subset specified features - .x <- .x[gs, , drop=FALSE] + .x <- .x[exp$feature, , drop=FALSE] # Replace 0 with NA if (isTRUE(exclude_zeros)) .x[.x == 0] <- NA @@ -338,10 +324,9 @@ get_abundance_sc_long <- function(.data, features = NULL, all = FALSE, exclude_z assays(altExps(.data)[[unique(exp$exp_id)]]) %>% as.list() %>% .[unique(exp$assay_name)] %>% - # Take active assay purrr::map2(unique(exp$assay_id), ~ { # Subset specified features - .x <- .x[gs, , drop=FALSE] + .x <- .x[exp$feature, , drop=FALSE] # Replace 0 with NA if (isTRUE(exclude_zeros)) .x[.x == 0] <- NA From 86734baa2f0abf7c165ecf10a62079a372d9ba6e Mon Sep 17 00:00:00 2001 From: Biomiha Date: Sun, 4 Feb 2024 11:27:18 +0000 Subject: [PATCH 131/140] Correct variables_genes issue --- R/utilities.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/utilities.R b/R/utilities.R index 720e7b7..95c6f3d 100755 --- a/R/utilities.R +++ b/R/utilities.R @@ -258,7 +258,7 @@ get_abundance_sc_long <- function(.data, features = NULL, all = FALSE, exclude_z variable_genes <- variable_features features <- variable_features } - } else if (isTRUE(all)) { + } else { variable_genes <- NULL } From 6e9a84aa745c3c34dc8d1bbbff89c593aec4a11e Mon Sep 17 00:00:00 2001 From: Biomiha Date: Sun, 4 Feb 2024 11:42:06 +0000 Subject: [PATCH 132/140] Sync with master repo --- R/dplyr_methods.R | 38 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 38 insertions(+) diff --git a/R/dplyr_methods.R b/R/dplyr_methods.R index 4c6bd54..8a18f54 100755 --- a/R/dplyr_methods.R +++ b/R/dplyr_methods.R @@ -820,3 +820,41 @@ pull.SingleCellExperiment <- function(.data, var=-1, name=NULL, ...) { as_tibble() %>% dplyr::pull(var=!!var, name=!!name, ...) } + +#' @name group_split +#' @rdname group_split +#' @inherit dplyr::group_split +#' +#' @examples +#' data(pbmc_small) +#' pbmc_small |> group_split(groups) +#' +#' @importFrom ellipsis check_dots_used +#' @importFrom dplyr group_by +#' @importFrom dplyr group_rows +#' @export +group_split.SingleCellExperiment <- function(.tbl, ..., .keep = TRUE) { + + var_list <- enquos(...) + + group_list <- .tbl |> + as_tibble() |> + dplyr::group_by(!!!var_list) + + groups <- group_list |> + dplyr::group_rows() + + v <- vector(mode = "list", length = length(groups)) + + for (i in seq_along(v)) { + v[[i]] <- .tbl[,groups[[i]]] + + if(.keep == FALSE) { + v[[i]] <- select(v[[i]], !(!!!var_list)) + } + } + + v + +} + From e1624fe614d3cf024067c0d413f998315573d815 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Sun, 4 Feb 2024 11:44:38 +0000 Subject: [PATCH 133/140] Sync with master repo --- plotly_methods.R | 36 ++++++++++++++++++++++++++++++++++++ 1 file changed, 36 insertions(+) create mode 100644 plotly_methods.R diff --git a/plotly_methods.R b/plotly_methods.R new file mode 100644 index 0000000..2d7a61a --- /dev/null +++ b/plotly_methods.R @@ -0,0 +1,36 @@ +#' @name plot_ly +#' @rdname plot_ly +#' @inherit ttservice::plot_ly +#' @return `plotly` +#' +#' @examples +#' data(pbmc_small) +#' pbmc_small |> +#' plot_ly(x = ~ nCount_RNA, y = ~ nFeature_RNA) +#' +#' @importFrom ttservice plot_ly +#' @export +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), + span=NULL, spans=c(1, 20), + symbol=NULL, symbols=NULL, + linetype=NULL, linetypes=NULL, + split=NULL, frame=NULL, + width=NULL, height=NULL, source="A") { + data %>% + # This is a trick to not loop the call + as_tibble() %>% + ttservice::plot_ly(..., + type=type, name=name, + color=color, colors=colors, alpha=alpha, + stroke=stroke, strokes=strokes, alpha_stroke=alpha_stroke, + size=size, sizes=sizes, + span=span, spans=spans, + symbol=symbol, symbols=symbols, + linetype=linetype, linetypes=linetypes, + split=split, frame=frame, + width=width, height=height, source=source) +} From 222aeeaf67dd0f811cd97891913de2eca40a18db Mon Sep 17 00:00:00 2001 From: Biomiha Date: Sun, 4 Feb 2024 16:02:06 +0000 Subject: [PATCH 134/140] Correct unique features --- R/utilities.R | 16 +++++++--------- 1 file changed, 7 insertions(+), 9 deletions(-) diff --git a/R/utilities.R b/R/utilities.R index 95c6f3d..e56efdf 100755 --- a/R/utilities.R +++ b/R/utilities.R @@ -243,7 +243,7 @@ get_abundance_sc_long <- function(.data, features = NULL, all = FALSE, exclude_z # Solve CRAN warnings . <- NULL -# Check if output would be too big without forcing + # Check if output would be too big without forcing if (isFALSE(all) && is.null(features)) { if (all(is.na(variable_features))) { stop("Your object does not contain variable feature labels,\n", @@ -263,17 +263,18 @@ get_abundance_sc_long <- function(.data, features = NULL, all = FALSE, exclude_z } # Check that I have assay names - if (!length(assayNames(.data))) + 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 if(is.null(gs) && isTRUE(gs)) { + gs <- unique(feature_df$feature) } else { stop("It is not convenient to extract all genes.", " You should have either variable features,", @@ -287,9 +288,6 @@ get_abundance_sc_long <- function(.data, features = NULL, all = FALSE, exclude_z feature_df <- get_all_features(.data) # Get selected features - if all = TRUE then all features in the objects are selected - if(is.null(gs) && isTRUE(gs)) { - gs <- unique(feature_df$feature) - } selected_features <- feature_df[(feature_df$feature %in% gs), ] if(!is.null(assays_to_use)) selected_features <- selected_features[selected_features$assay_name %in% assays_to_use,] selected_features_exp <- unique(selected_features$exp_id) @@ -305,7 +303,7 @@ get_abundance_sc_long <- function(.data, features = NULL, all = FALSE, exclude_z .[unique(exp$assay_name)] %>% purrr::map2(unique(exp$assay_id), ~ { # Subset specified features - .x <- .x[exp$feature, , drop=FALSE] + .x <- .x[unique(exp$feature), , drop=FALSE] # Replace 0 with NA if (isTRUE(exclude_zeros)) .x[.x == 0] <- NA @@ -326,7 +324,7 @@ get_abundance_sc_long <- function(.data, features = NULL, all = FALSE, exclude_z .[unique(exp$assay_name)] %>% purrr::map2(unique(exp$assay_id), ~ { # Subset specified features - .x <- .x[exp$feature, , drop=FALSE] + .x <- .x[unique(exp$feature), , drop=FALSE] # Replace 0 with NA if (isTRUE(exclude_zeros)) .x[.x == 0] <- NA From d1ce30fda3e95616e8ca987ae354b2f85004c2d9 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Tue, 6 Feb 2024 18:07:01 +0000 Subject: [PATCH 135/140] Can it pass checks? --- NAMESPACE | 2 +- R/print_method.R | 7 ++----- 2 files changed, 3 insertions(+), 6 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 4a768f9..f7b1814 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -66,7 +66,7 @@ importFrom(SummarizedExperiment,colData) importFrom(dplyr,add_count) importFrom(dplyr,any_of) importFrom(dplyr,arrange) -importFrom(dplyr,bind_rows) +#importFrom(dplyr,bind_rows) importFrom(dplyr,contains) importFrom(dplyr,count) importFrom(dplyr,distinct) diff --git a/R/print_method.R b/R/print_method.R index 5c79454..7ce7a8c 100755 --- a/R/print_method.R +++ b/R/print_method.R @@ -19,7 +19,6 @@ tbl_format_header.tidySingleCellExperiment <- function(x, setup, ...) { number_of_features <- x |> attr("number_of_features") assay_names <- x |> attr("assay_names") - altExpNames <- x |> attr("altExpNames") # Change name @@ -35,11 +34,9 @@ tbl_format_header.tidySingleCellExperiment <- function(x, setup, ...) { # Add further info single-cell append(sprintf( - "\033[90m Features=%s | Cells=%s | Assays=%s | altExpNames=%s\033[39m", + "\033[90m Features=%s | Cells=%s | Assays=%s\033[39m", number_of_features, nrow(x), - paste(assay_names, collapse=", "), - if(length(nchar(altExpNames)) > 0) paste(altExpNames, collapse=", ") else {"NULL"} - ), after=1) + paste(assay_names, collapse=", ")), after=1) } style_subtle(pillar___format_comment(header, width=setup$width)) From ace24f769a58a33242d72f8875db8db58bb95abe Mon Sep 17 00:00:00 2001 From: Biomiha Date: Sun, 11 Feb 2024 15:17:49 +0000 Subject: [PATCH 136/140] Add files via upload From 7ea198206e5d57a52a1efbca4c863e2887c278e3 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Sun, 11 Feb 2024 15:35:16 +0000 Subject: [PATCH 137/140] Remove MASS import requirement --- tests/testthat/test-dplyr_methods.R | 99 +++++++++++++------------- tests/testthat/test-ggplotly_methods.R | 13 ++-- tests/testthat/test-methods.R | 82 +++++++++++---------- 3 files changed, 102 insertions(+), 92 deletions(-) diff --git a/tests/testthat/test-dplyr_methods.R b/tests/testthat/test-dplyr_methods.R index d065357..ecf4f58 100755 --- a/tests/testthat/test-dplyr_methods.R +++ b/tests/testthat/test-dplyr_methods.R @@ -1,4 +1,5 @@ library(S4Vectors) +library(MASS, include.only = "rnegbin") data("pbmc_small") # Mock up ADT and cell hashing experiments set.seed(2023-08-29) @@ -11,7 +12,7 @@ all_myus <- sample(x = all_myus, size = length(all_myus)) mat <- list() for(i in seq_along(all_myus)) { - mat[[i]] <- MASS::rnegbin(n = dim(pbmc_small)[[2]], mu = all_myus[[i]], theta = all_myus[[i]]/500) + mat[[i]] <- rnegbin(n = dim(pbmc_small)[[2]], mu = all_myus[[i]], theta = all_myus[[i]]/500) } mat <- Reduce(f = cbind, x = mat) colnames(mat) <- paste("Ab", seq_along(mat[1,]), sep = "-") @@ -23,7 +24,7 @@ altExps(pbmc_small)[["ADT"]] <- SingleCellExperiment(assays = list(counts = t(ma HTO_myus <- sample(x = c(100, 100000), size = 6, replace = TRUE) mat <- list() for(i in seq_along(HTO_myus)) { - mat[[i]] <- MASS::rnegbin(n = dim(pbmc_small)[[2]], mu = HTO_myus[[i]], theta = HTO_myus[[i]]/500) + mat[[i]] <- rnegbin(n = dim(pbmc_small)[[2]], mu = HTO_myus[[i]], theta = HTO_myus[[i]]/500) } mat <- Reduce(f = cbind, x = mat) @@ -40,15 +41,15 @@ df$factor <- sample( # test_that("arrange()", { # expect_identical( -# arrange(df, number), +# arrange(df, number), # df[, order(df$number)]) # suppressWarnings({ # fd <- df %>% -# scater::logNormCounts() %>% +# scater::logNormCounts() %>% # scater::runPCA() # }) # expect_identical( -# arrange(fd, PC1), +# arrange(fd, PC1), # fd[, order(reducedDim(fd)[, 1])]) # fd <- df %>% # mutate(foo=seq(ncol(df))) %>% @@ -70,7 +71,7 @@ test_that("bind_cols()", { expect_identical(fd[[i[1]]], df$factor) expect_identical(fd[[i[2]]], df$factor) expect_identical( - select(fd, -starts_with("factor")), + select(fd, -starts_with("factor")), select(df, -factor)) }) @@ -112,12 +113,12 @@ test_that("mutate()", { expect_true(all(fd$peter == "pan")) fd <- mutate(df, number=paste(number)) expect_identical(fd$number, paste(df$number)) - + # special columns are blocked df |> mutate(.cell=1) |> expect_error("you are trying to mutate a column that is view only") - + df |> mutate(PC_10=1) |> expect_error("you are trying to mutate a column that is view only") @@ -127,35 +128,35 @@ test_that("rename()", { fd <- rename(df, num=number, fac=factor) expect_identical(fd$num, df$number) expect_identical(fd$fac, df$factor) - - df |> - rename(ne=mo) |> + + df |> + rename(ne=mo) |> expect_error("Column `mo` doesn't exist") - + # special columns are blocked # ...'to' cannot be special - + df |> rename(a=PC_1) |> - expect_error("you are trying to rename a column that is view only") - - df |> - rename(a=.cell) |> + expect_error("you are trying to rename a column that is view only") + + df |> + rename(a=.cell) |> expect_error("you are trying to rename a column that is view only") # ...'from' cannot be special - - df |> - rename(PC_1=number) |> + + df |> + rename(PC_1=number) |> expect_error("These names are duplicated") - - df |> - rename(.cell=number) |> + + df |> + rename(.cell=number) |> expect_error("These names are duplicated") }) test_that("left_join()", { - y <- df |> - distinct(factor) |> + y <- df |> + distinct(factor) |> mutate(string=letters[seq(nlevels(df$factor))]) fd <- left_join(df, y, by="factor") expect_s4_class(fd, "SingleCellExperiment") @@ -164,9 +165,9 @@ test_that("left_join()", { }) test_that("left_join(), with DataFrame y", { - y <- df |> - distinct(factor) |> - mutate(string=letters[seq(nlevels(df$factor))]) |> + y <- df |> + distinct(factor) |> + mutate(string=letters[seq(nlevels(df$factor))]) |> DataFrame() fd <- left_join(df, y, by="factor") expect_s4_class(fd, "SingleCellExperiment") @@ -175,9 +176,9 @@ test_that("left_join(), with DataFrame y", { }) test_that("inner_join()", { - y <- df |> - distinct(factor) |> - mutate(string=letters[seq(nlevels(df$factor))]) |> + y <- df |> + distinct(factor) |> + mutate(string=letters[seq(nlevels(df$factor))]) |> slice(1) fd <- inner_join(df, y, by="factor") expect_s4_class(fd, "SingleCellExperiment") @@ -186,9 +187,9 @@ test_that("inner_join()", { }) test_that("inner_join(), with DataFrame y", { - y <- df |> - distinct(factor) |> - mutate(string=letters[seq(nlevels(df$factor))]) |> + y <- df |> + distinct(factor) |> + mutate(string=letters[seq(nlevels(df$factor))]) |> slice(1) |> DataFrame() fd <- inner_join(df, y, by="factor") expect_s4_class(fd, "SingleCellExperiment") @@ -228,12 +229,12 @@ test_that("full_join()", { expect_equal(nrow(fd), ncol(df)+2*sum(df$factor == "g2")) # w/o duplicates y <- tibble(factor="g2", other=1) - + # I DON'T KNOW WHY THESE TESTS GIVES WARNING IN THE GITHUB ACTION - # fd <- expect_silent(full_join(df, y, by=join_by(factor))) + # fd <- expect_silent(full_join(df, y, by=join_by(factor))) # expect_s4_class(fd, "SingleCellExperiment") # expect_identical( - # select(fd, -other), + # select(fd, -other), # mutate(df, factor=paste(factor))) }) @@ -247,21 +248,21 @@ test_that("full_join(), with DataFrame y", { expect_equal(nrow(fd), ncol(df)+2*sum(df$factor == "g2")) # w/o duplicates y <- tibble(factor="g2", other=1) |> DataFrame() - + # I DON'T KNOW WHY THESE TESTS GIVES WARNING IN THE GITHUB ACTION - # fd <- expect_silent(full_join(df, y, by=join_by(factor))) + # fd <- expect_silent(full_join(df, y, by=join_by(factor))) # expect_s4_class(fd, "SingleCellExperiment") # expect_identical( - # select(fd, -other), + # select(fd, -other), # mutate(df, factor=paste(factor))) }) test_that("slice()", { - # I DON'T KNOW WHY THESE TESTS GIVES WARNING + # I DON'T KNOW WHY THESE TESTS GIVES WARNING # Please use `all_of()` or `any_of()` instead. #expect_identical(slice(df), df[, 0]) #expect_identical(slice(df, ncol(df)+1), df[, 0]) - + expect_identical(slice(df, 1), df[, 1]) expect_identical(slice(df, -1), df[, -1]) i <- sample(ncol(df), 5) @@ -398,10 +399,10 @@ test_that("add_count()", { }) test_that("rowwise()", { - df |> + df |> summarise(sum(lys)) |> expect_error("object 'lys' not found") - + df$lys <- replicate(ncol(df), sample(10, 3), FALSE) fd <- df |> rowwise() |> summarise(sum(lys)) expect_s3_class(fd, "tbl_df") @@ -410,22 +411,22 @@ test_that("rowwise()", { }) test_that("group_split() works for one variable", { - fd <- df |> + fd <- df |> group_split(groups) expect_equal(length(fd), length(unique(df$groups))) }) test_that("group_split() works for combination of variables", { - fd <- df |> + fd <- df |> group_split(groups, ident) expect_equal(length(fd), length(unique(df$groups)) * length(unique(df$ident))) }) test_that("group_split() works for one logical statement", { - fd_log <- df |> + fd_log <- df |> group_split(groups=="g1") - fd_var <- df |> + fd_var <- df |> group_split(groups=="g1") expect_equal(lapply(fd_var, count), lapply(fd_log, count)) }) @@ -434,7 +435,7 @@ test_that("group_split() works for two logical statements", { fd <- df |> group_split(PC_1>0 & groups=="g1") fd_counts <- lapply(fd, count) - expect_equal(c(fd_counts[[1]], fd_counts[[2]], use.names = FALSE), + expect_equal(c(fd_counts[[1]], fd_counts[[2]], use.names = FALSE), list(75, 5)) }) diff --git a/tests/testthat/test-ggplotly_methods.R b/tests/testthat/test-ggplotly_methods.R index 757ad60..9f2d263 100644 --- a/tests/testthat/test-ggplotly_methods.R +++ b/tests/testthat/test-ggplotly_methods.R @@ -1,3 +1,4 @@ +library(MASS, include.only = "rnegbin") data("pbmc_small") # Mock up ADT and cell hashing experiments set.seed(2023-08-29) @@ -10,7 +11,7 @@ all_myus <- sample(x = all_myus, size = length(all_myus)) mat <- list() for(i in seq_along(all_myus)) { - mat[[i]] <- MASS::rnegbin(n = dim(pbmc_small)[[2]], mu = all_myus[[i]], theta = all_myus[[i]]/500) + mat[[i]] <- rnegbin(n = dim(pbmc_small)[[2]], mu = all_myus[[i]], theta = all_myus[[i]]/500) } mat <- Reduce(f = cbind, x = mat) colnames(mat) <- paste("Ab", seq_along(mat[1,]), sep = "-") @@ -22,7 +23,7 @@ altExps(pbmc_small)[["ADT"]] <- SingleCellExperiment(assays = list(counts = t(ma HTO_myus <- sample(x = c(100, 100000), size = 6, replace = TRUE) mat <- list() for(i in seq_along(HTO_myus)) { - mat[[i]] <- MASS::rnegbin(n = dim(pbmc_small)[[2]], mu = HTO_myus[[i]], theta = HTO_myus[[i]]/500) + mat[[i]] <- rnegbin(n = dim(pbmc_small)[[2]], mu = HTO_myus[[i]], theta = HTO_myus[[i]]/500) } mat <- Reduce(f = cbind, x = mat) @@ -37,7 +38,7 @@ df$factor <- sample(gl(3, 1, ncol(df))) test_that("ggplot()", { # cell metadata - p <- ggplot(df, aes(factor, number)) + p <- ggplot(df, aes(factor, number)) expect_silent(show(p)) expect_s3_class(p, "ggplot") # assay data @@ -54,17 +55,17 @@ test_that("ggplot()", { test_that("plotly()", { # cell metadata - p <- plot_ly(df, x=~factor, y=~number, type="violin") + p <- plot_ly(df, x=~factor, y=~number, type="violin") expect_silent(show(p)) expect_s3_class(p, "plotly") # assay data g <- sample(rownames(df), 1) fd <- join_features(df, g, shape="wide", assays = "counts") - p <- plot_ly(fd, x=~factor, y=g, type="violin") + p <- plot_ly(fd, x=~factor, y=g, type="violin") expect_silent(show(p)) expect_s3_class(p, "plotly") # reduced dimensions - p <- plot_ly(fd, x=~PC_1, y=~PC_2, type="scatter", mode="markers") + p <- plot_ly(fd, x=~PC_1, y=~PC_2, type="scatter", mode="markers") expect_silent(show(p)) expect_s3_class(p, "plotly") }) diff --git a/tests/testthat/test-methods.R b/tests/testthat/test-methods.R index 4792452..879b299 100644 --- a/tests/testthat/test-methods.R +++ b/tests/testthat/test-methods.R @@ -1,3 +1,4 @@ +library(MASS, include.only = "rnegbin") data("pbmc_small") # Mock up ADT and cell hashing experiments set.seed(2023-08-29) @@ -10,7 +11,7 @@ all_myus <- sample(x = all_myus, size = length(all_myus)) mat <- list() for(i in seq_along(all_myus)) { - mat[[i]] <- MASS::rnegbin(n = dim(pbmc_small)[[2]], mu = all_myus[[i]], theta = all_myus[[i]]/500) + mat[[i]] <- rnegbin(n = dim(pbmc_small)[[2]], mu = all_myus[[i]], theta = all_myus[[i]]/500) } mat <- Reduce(f = cbind, x = mat) colnames(mat) <- paste("Ab", seq_along(mat[1,]), sep = "-") @@ -22,7 +23,7 @@ altExps(pbmc_small)[["ADT"]] <- SingleCellExperiment(assays = list(counts = t(ma HTO_myus <- sample(x = c(100, 100000), size = 6, replace = TRUE) mat <- list() for(i in seq_along(HTO_myus)) { - mat[[i]] <- MASS::rnegbin(n = dim(pbmc_small)[[2]], mu = HTO_myus[[i]], theta = HTO_myus[[i]]/500) + mat[[i]] <- rnegbin(n = dim(pbmc_small)[[2]], mu = HTO_myus[[i]], theta = HTO_myus[[i]]/500) } mat <- Reduce(f = cbind, x = mat) @@ -45,15 +46,15 @@ test_that("show()", { expect_equal(gsub(str, "\\1", txt[i]), paste(ncol(df))) i <- grep(".*s=.*", txt) j <- grep(".cell*", txt) -1 - header_text <- paste(txt[i:j], collapse = "") |> - stringr::str_remove_all(pattern = "# ") |> - stringr::str_remove_all(pattern = "\033") |> - stringr::str_remove_all(pattern = "\\[90m ") |> - stringr::str_remove_all(pattern = "\\[90m") |> + header_text <- paste(txt[i:j], collapse = "") |> + stringr::str_remove_all(pattern = "# ") |> + stringr::str_remove_all(pattern = "\033") |> + stringr::str_remove_all(pattern = "\\[90m ") |> + stringr::str_remove_all(pattern = "\\[90m") |> stringr::str_remove_all(pattern = "\\[0m") - x <- header_text |> - stringr::str_remove(pattern = ".+s=") |> - strsplit(split = ", ") |> + x <- header_text |> + stringr::str_remove(pattern = ".+s=") |> + strsplit(split = ", ") |> unlist() y <- assayNames(df) for (k in seq_along(altExps(pbmc_small))) { @@ -66,42 +67,49 @@ test_that("show()", { ) test_that("join_features()", { - gs <- sample(rownames(df), 3) + gs <- c(sample(rownames(df), 3), sample(rownames(altExps(df)[[1]]), 3)) + sce_counts_combined <- do.call("rbind", append(lapply(altExps(df), counts), values = list(as.matrix(counts(df))), after = 0)) # long fd <- join_features(df, gs, shape="long") expect_s3_class(fd, "tbl_df") expect_setequal(unique(fd$.feature), gs) expect_true(all(table(fd$.feature) == ncol(df))) expect_identical( - matrix(fd$.abundance_counts, nrow=length(gs)), - as.matrix(unname(counts(df)[fd$.feature[seq_along(gs)], ]))) + { + fd <- select(fd,.cell, .feature, starts_with(".abundance")) + fd <- select(fd,.cell, .feature, ends_with("-counts")|ends_with("_counts")) + fd <- mutate(fd, counts = case_when(is.na(unlist(pick(3))) ~ unlist(pick(4)), .default = unlist(pick(3)))) + fd <- pivot_wider( + data=fd, + id_cols = ".feature", + names_from = ".cell", + values_from = "counts") + fd <- as.data.frame(fd[order(fd$.feature),]) + rownames(fd) <- fd$.feature + fd <- fd[, -1] + fd <- select(fd, sort(colnames(df))) + fd <- as.matrix(fd) + fd + }, + as.matrix(sce_counts_combined[sort(gs), sort(colnames(df))])) + # wide fd <- join_features(df, gs, shape="wide", assays="counts") expect_s4_class(fd, "SingleCellExperiment") expect_null(fd$.feature) expect_identical( - unname(t(as.matrix(as_tibble(fd)[, make.names(gs)]))), - as.matrix(unname(counts(df)[gs, ]))) - - # Add features from altExp if they exist - if(!is.null(altExp(df))) { - gs <- sample(rownames(altExp(df)), 3) - # long - fd <- join_features(df, gs, shape="long") - expect_s3_class(fd, "tbl_df") - expect_setequal(unique(fd$.feature), gs) - expect_true(all(table(fd$.feature) == ncol(df))) - expect_identical( - matrix(fd |> select(starts_with(".abundance")) |> pull(1), nrow=length(gs)), - as.matrix(unname(assays(altExp(df))[[1]][fd$.feature[seq_along(gs)], ]))) - # wide - fd <- join_features(df, gs, shape="wide", assays="ADT-counts") - expect_s4_class(fd, "SingleCellExperiment") - expect_null(fd$.feature) - expect_identical( - unname(t(as.matrix(as_tibble(fd)[, make.names(gs)]))), - as.matrix(unname(assays(altExp(df))[[1]][gs, ]))) - } + { + fd <- as.data.frame(select(fd, cell = .cell, make.names(sort(gs)))) + fd <- fd[order(fd$cell), ] + rownames(fd) <- fd$cell + fd <- fd[, -1] + t(as.matrix(fd)) + }, { + sce_wide_mat <- as.matrix(sce_counts_combined[sort(gs), sort(colnames(df))]) + rownames(sce_wide_mat) <- make.names(rownames(sce_wide_mat)) + sce_wide_mat + } + ) }) test_that("as_tibble()", { @@ -133,7 +141,7 @@ test_that("aggregate_cells()", { s=tbl$string, \(f, s) { expect_identical( - df |> + df |> filter(factor == f, string == s) |> assay() |> rowSums() |> as.vector(), fd[, fd$factor == f & fd$string == s] |> @@ -147,7 +155,7 @@ test_that("aggregate_cells()", { assays_to_use <- c("logcounts", "ADT-logcounts") fd <- aggregate_cells(df, .sample = c(factor, string), assays = assays_to_use) expect_identical(assayNames(fd), assays_to_use) - fd_all_features <- tidySingleCellExperiment:::get_all_features(df) |> + fd_all_features <- tidySingleCellExperiment:::get_all_features(df) |> filter(assay_id %in% assays_to_use) |> pull(feature) |> sort() expect_identical(fd_all_features, sort(rownames(fd))) }) From 6ee25e3c52865ac41cd7e8936ca1668cfc79a281 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Sun, 11 Feb 2024 15:36:54 +0000 Subject: [PATCH 138/140] Add n_extra desc --- R/print_method.R | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/R/print_method.R b/R/print_method.R index 7ce7a8c..9028e0b 100755 --- a/R/print_method.R +++ b/R/print_method.R @@ -16,15 +16,15 @@ #' @export 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 { @@ -35,7 +35,7 @@ tbl_format_header.tidySingleCellExperiment <- function(x, setup, ...) { append(sprintf( "\033[90m Features=%s | Cells=%s | Assays=%s\033[39m", - number_of_features, nrow(x), + number_of_features, nrow(x), paste(assay_names, collapse=", ")), after=1) } @@ -46,6 +46,7 @@ tbl_format_header.tidySingleCellExperiment <- function(x, setup, ...) { #' @rdname formatting #' @aliases print #' @inherit tibble::formatting +#' @param n_extra number of extra lines #' @return Prints a message to the console describing #' the contents of the `tidySingleCellExperiment`. #' From aac9c7313f483ef48125e28e7703b1de8ca06f80 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Sun, 18 Feb 2024 19:37:42 +0000 Subject: [PATCH 139/140] Update tibble_methods.R --- R/tibble_methods.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/tibble_methods.R b/R/tibble_methods.R index 9679660..a007c17 100755 --- a/R/tibble_methods.R +++ b/R/tibble_methods.R @@ -15,7 +15,7 @@ as_tibble.SingleCellExperiment <- function(x, ..., .name_repair=c("check_unique", "unique", "universal", "minimal"), rownames=pkgconfig::get_config("tibble::rownames", NULL)) { df <- colData(x) %>% - as.data.frame() %>% + as(Class = "data.frame", strict = FALSE) %>% tibble::as_tibble(rownames=c_(x)$name) # Attach reduced dimensions only if # there are any and for special datasets From 27059cc8fd50eb12744472b5ba36a0b67c50c0d4 Mon Sep 17 00:00:00 2001 From: Biomiha Date: Sun, 18 Feb 2024 22:03:06 +0000 Subject: [PATCH 140/140] testthat methods --- DESCRIPTION | 2 +- NAMESPACE | 2 +- R/print_method.R | 3 +-- R/utilities.R | 1 + man/formatting.Rd | 2 +- tests/testthat/test-methods.R | 1 + 6 files changed, 6 insertions(+), 5 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 26dfcfb..b15712f 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -68,6 +68,6 @@ biocViews: AssayDomain, Infrastructure, RNASeq, DifferentialExpression, SingleCell, GeneExpression, Normalization, Clustering, QualityControl, Sequencing Encoding: UTF-8 -RoxygenNote: 7.2.3 +RoxygenNote: 7.3.1 URL: https://github.com/stemangiola/tidySingleCellExperiment BugReports: https://github.com/stemangiola/tidySingleCellExperiment/issues diff --git a/NAMESPACE b/NAMESPACE index f7b1814..9c9853c 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -49,6 +49,7 @@ export(tidy) export(unnest_single_cell_experiment) exportMethods(aggregate_cells) exportMethods(join_features) +importFrom(MASS,rnegbin) importFrom(Matrix,rowSums) importFrom(S4Vectors,"metadata<-") importFrom(S4Vectors,DataFrame) @@ -66,7 +67,6 @@ importFrom(SummarizedExperiment,colData) importFrom(dplyr,add_count) importFrom(dplyr,any_of) importFrom(dplyr,arrange) -#importFrom(dplyr,bind_rows) importFrom(dplyr,contains) importFrom(dplyr,count) importFrom(dplyr,distinct) diff --git a/R/print_method.R b/R/print_method.R index 9028e0b..a28c4a5 100755 --- a/R/print_method.R +++ b/R/print_method.R @@ -46,7 +46,6 @@ tbl_format_header.tidySingleCellExperiment <- function(x, setup, ...) { #' @rdname formatting #' @aliases print #' @inherit tibble::formatting -#' @param n_extra number of extra lines #' @return Prints a message to the console describing #' the contents of the `tidySingleCellExperiment`. #' @@ -59,7 +58,7 @@ tbl_format_header.tidySingleCellExperiment <- function(x, setup, ...) { #' @importFrom SingleCellExperiment altExpNames #' @export -print.SingleCellExperiment <- function(x, ..., n = NULL, width = NULL, n_extra = NULL) { +print.SingleCellExperiment <- function(x, ..., n = NULL, width = NULL) { if (length(names(altExps(x))) > 0) { alt_exp_assays <- list() assay_names_list <- lapply(altExps(x), assayNames) diff --git a/R/utilities.R b/R/utilities.R index e56efdf..4cc7c73 100755 --- a/R/utilities.R +++ b/R/utilities.R @@ -1,5 +1,6 @@ #' @importFrom tibble as_tibble #' @importFrom SummarizedExperiment colData +#' @importFrom MASS rnegbin #' #' @keywords internal #' diff --git a/man/formatting.Rd b/man/formatting.Rd index e08a87a..6268be8 100644 --- a/man/formatting.Rd +++ b/man/formatting.Rd @@ -6,7 +6,7 @@ \alias{print} \title{Printing tibbles} \usage{ -\method{print}{SingleCellExperiment}(x, ..., n = NULL, width = NULL, n_extra = NULL) +\method{print}{SingleCellExperiment}(x, ..., n = NULL, width = NULL) } \arguments{ \item{x}{Object to format or print.} diff --git a/tests/testthat/test-methods.R b/tests/testthat/test-methods.R index 879b299..e597e91 100644 --- a/tests/testthat/test-methods.R +++ b/tests/testthat/test-methods.R @@ -1,3 +1,4 @@ + library(MASS, include.only = "rnegbin") data("pbmc_small") # Mock up ADT and cell hashing experiments