Merge branch 'master' of https://github.com/stemangiola/tidySummarizedExperiment

stemangiola · stemangiola · commit ff1fe019d7dd · 2024-04-30T09:39:13.000+09:30
diff --git a/NAMESPACE b/NAMESPACE
@@ -11,6 +11,7 @@ S3method(filter,SummarizedExperiment)
 S3method(full_join,SummarizedExperiment)
 S3method(ggplot,SummarizedExperiment)
 S3method(group_by,SummarizedExperiment)
+S3method(group_split,SummarizedExperiment)
 S3method(inner_join,SummarizedExperiment)
 S3method(left_join,SummarizedExperiment)
 S3method(mutate,SummarizedExperiment)
@@ -64,6 +65,7 @@ importFrom(dplyr,filter)
 importFrom(dplyr,full_join)
 importFrom(dplyr,group_by)
 importFrom(dplyr,group_by_drop_default)
+importFrom(dplyr,group_split)
 importFrom(dplyr,inner_join)
 importFrom(dplyr,left_join)
 importFrom(dplyr,mutate)
diff --git a/R/dplyr_methods.R b/R/dplyr_methods.R
@@ -62,29 +62,82 @@ bind_rows.SummarizedExperiment <- function(..., .id=NULL, add.cell.ids=NULL) {
 bind_cols_internal <- function(..., .id=NULL, column_belonging=NULL) {
     tts <- tts <- flatten_if(dots_values(...), is_spliced)
 
-    tts[[1]] |> 
-        as_tibble(skip_GRanges = TRUE) |>
-        dplyr::bind_cols(tts[[2]], .id=.id) %>%
-        when(
-
-            # If the column added are not sample-wise
-            # or feature-wise, return tibble
-            (colnames(tts[[2]]) %in% c(
-                get_subset_columns(., !!s_(tts[[1]])$symbol),
-                get_subset_columns(., !!f_(tts[[1]])$symbol)
-            )
-            ) |> all() ~ update_SE_from_tibble(., tts[[1]],
-                column_belonging=column_belonging),
 
-            # Return tiblle
-            ~ {
+    # If I have column corresponding bind directly
+    # Without tranformation to tibble
+    if(!is.null(column_belonging)){
+      
+      # For colData
+      colData_additions = column_belonging[column_belonging==s_(tts[[1]] )$name] |> names()
+      
+      data_frame_to_attach = 
+        tts[[1]] |> 
+        select(!!s_(tts[[1]] )$symbol) |> 
+        suppressMessages() |> 
+        bind_cols(tts[[2]] |> select(all_of(colData_additions))) |> 
+        distinct() 
+      
+      # Set row names
+      data_frame_to_attach = 
+        data_frame_to_attach |> 
+        select(-1) |> 
+        DataFrame(row.names = data_frame_to_attach |> pull(1)) 
+      
+      # Reorder
+      data_frame_to_attach = data_frame_to_attach[match(rownames(data_frame_to_attach), colnames(tts[[1]])), , drop=FALSE]
+      
+      # Attach
+      colData(tts[[1]]) = cbind(colData(tts[[1]]), data_frame_to_attach)
+      
+      # For rowData
+      rowData_additions = column_belonging[column_belonging==f_(tts[[1]] )$name] |> names()
+      
+      data_frame_to_attach = 
+        tts[[1]] |> 
+        select(!!f_(tts[[1]] )$symbol) |> 
+        suppressMessages() |> 
+        bind_cols(tts[[2]] |> select(all_of(rowData_additions))) |> 
+        distinct() 
+      
+      # Set row names
+      data_frame_to_attach = 
+        data_frame_to_attach |> 
+        select(-1) |> 
+        DataFrame(row.names = data_frame_to_attach |> pull(1)) 
+      
+      # Reorder
+      data_frame_to_attach = data_frame_to_attach[match(rownames(data_frame_to_attach), rownames(tts[[1]])), , drop=FALSE]
+      
+      # Attach
+      rowData(tts[[1]]) = cbind(rowData(tts[[1]]), data_frame_to_attach)
+      
+      tts[[1]]
+    }
+    
+    # If I DON'T have column corresponding go through tibble
+    else
+      tts[[1]] |> 
+          as_tibble(skip_GRanges = TRUE) |>
+          dplyr::bind_cols(tts[[2]], .id=.id) %>%
+          when(
+  
+              # If the column added are not sample-wise or feature-wise return tibble
+              (colnames(tts[[2]]) %in% c(
+                  get_subset_columns(., !!s_(tts[[1]])$symbol),
+                  get_subset_columns(., !!f_(tts[[1]])$symbol)
+              )
+              ) |> all() ~ update_SE_from_tibble(., tts[[1]], column_belonging = column_belonging),
+  
+              # Return tiblle
+              ~ {
                 warning("tidySummarizedExperiment says:",
-                    " The new columns do not include pure sample-wise",
-                    " or feature-wise. A data frame is returned for",
-                    " independent data analysis.")
+                        " The new columns do not include pure sample-wise",
+                        " or feature-wise. A data frame is returned for",
+                        " independent data analysis.")
                 (.)
-            }
-        )
+              }
+          )
+
 }
 
 bind_cols_ <- function(..., .id=NULL) { bind_cols_internal(..., .id=NULL) }
@@ -630,19 +683,28 @@ select.SummarizedExperiment <- function(.data, ...) {
         data.frame(row.names=pull(., !!f_(.data)$symbol)) |>
         select(-!!f_(.data)$symbol) |>
         DataFrame()
-  
+    
+    # If SE does not have rownames, 
+    # I have to take them our of here, otherwise count integration, 
+    # which is a matrix and behaved differently from DataFrame fails
+    if(rownames(.data) |> is.null()) rownames(row_data_DF)  = NULL
+    
     col_data_tibble <- 
         colData(.data) |> 
         as_tibble(rownames = s_(.data)$name) 
   
     col_data_DF <-
         col_data_tibble |>  
-        select(one_of(columns_query), !!s_(.data)$symbol) |>
-        suppressWarnings() %>% 
-        data.frame(row.names=pull(., !!s_(.data)$symbol)) |>
+        select(any_of(columns_query), !!s_(.data)$symbol) |>
+        data.frame(row.names=pull(col_data_tibble, !!s_(.data)$symbol)) |>
         select(-!!s_(.data)$symbol) |>
         DataFrame()
   
+    # If SE does not have rownames, 
+    # I have to take them our of here, otherwise count integration, 
+    # which is a matrix and behaved differently from DataFrame fails
+    if(colnames(.data) |> is.null()) rownames(col_data_DF)  = NULL
+    
     count_data <-
         assays(.data)@listData %>%
             .[names(assays(.data)@listData) %in% columns_query]
@@ -862,3 +924,46 @@ pull.SummarizedExperiment <- function(.data, var=-1, name=NULL, ...) {
         as_tibble(skip_GRanges=skip_GRanges) |>
         dplyr::pull(var=!!var, name=!!name, ...)
 }
+
+#' @name group_split
+#' @rdname group_split
+#' @inherit dplyr::group_split
+#' 
+#' @examples
+#' data(pasilla, package = "tidySummarizedExperiment")
+#' pasilla |> group_split(condition)
+#' pasilla |> group_split(counts > 0)
+#' pasilla |> group_split(condition, counts > 0)
+#' 
+#' @importFrom ellipsis check_dots_used
+#' @importFrom dplyr group_split
+#' @export
+group_split.SummarizedExperiment <- function(.tbl, ..., .keep = TRUE) {
+  
+  var_list <- enquos(...)
+  data_nested <- NULL
+  
+  nested <- .tbl |> 
+    mutate(!!!var_list) |> 
+    nest(data_nested = -(substring(as.character(var_list), 2)))
+  
+  if(.keep) {
+    grouped_data <- nested |> 
+      pull(data_nested)
+    
+    grouping_cols <- nested |> 
+      select(substring(as.character(var_list), 2))
+    
+    for(i in 1:length(grouped_data)) {
+      grouped_data[[i]] <- grouped_data[[i]] |> 
+        mutate(grouping_cols[i,])
+    }
+    
+    grouped_data
+    
+  } else {
+    nested |> 
+      pull(data_nested)
+  }
+    
+}
diff --git a/R/tidyr_methods.R b/R/tidyr_methods.R
@@ -41,7 +41,6 @@ unnest.tidySummarizedExperiment_nested <- function(data, cols, ...,
 unnest_summarized_experiment <- function(data, cols, ...,
     keep_empty=FALSE, ptype=NULL, names_sep=NULL,
     names_repair="check_unique", .drop, .id, .sep, .preserve) {
-
     . <- NULL
 
     # Need this otherwise crashes map
@@ -71,6 +70,7 @@ unnest_summarized_experiment <- function(data, cols, ...,
         )
     }
 
+
     # If both nested by transcript and sample
     if (s_(se)$name %in% colnames(data) &
         f_(se)$name %in% colnames(data) ) {
@@ -88,11 +88,11 @@ unnest_summarized_experiment <- function(data, cols, ...,
 
     
         # Mark if columns belong to feature or sample
-        my_unnested_tibble <-
-            mutate(data, !!cols := map(!!cols, ~ as_tibble(.x))) %>%
-            select(-suppressWarnings(one_of(s_(my_se)$name,
-                f_(my_se)$name))) %>%
-            unnest(!!cols)
+        my_unnested_tibble =
+          data |> 
+          mutate(!!cols := map(!!cols, ~ as_tibble(.x))) |>
+          select(-any_of(c(s_(my_se)$name, f_(my_se)$name))) |> 
+          unnest(!!cols)
     
         # Get which column is relative to feature or sample
         sample_columns <- my_unnested_tibble %>%
@@ -130,14 +130,14 @@ unnest_summarized_experiment <- function(data, cols, ...,
             
             # Attach back the columns used for nesting
             .data_ %>%
-              select(-!!cols, - any_of(c(s_(my_se)$name, f_(my_se)$name))) %>%
+              select(-!!cols, -any_of(c(s_(my_se)$name, f_(my_se)$name))) %>%
               slice(rep(as.integer(.y), ncol(.x) * nrow(.x))),
             
             # Column sample-wise or feature-wise
             column_belonging =
               source_column[
                 .data_ %>%
-                  select(-!!cols, - any_of(c(s_(my_se)$name, f_(my_se)$name))) %>%
+                  select(-!!cols, -any_of(c(s_(my_se)$name, f_(my_se)$name))) %>%
                   colnames()
               ]
           )
@@ -219,6 +219,14 @@ nest.SummarizedExperiment <- function(.data, ..., .names_sep=NULL) {
         .data <- ping_old_special_column_into_metadata(.data)
     }
     
+    # if the data does not have raw, names or clumn names
+    # we have to add them, otherwise the nesting and a nesting will get confused with 
+    # the link between Sample wise, columns, and Sample IDs
+    if(rownames(.data) |> is.null() | colnames(.data) |> is.null() )
+      warning("tidySummarizedExperiment says: the nesting and unnesting operations require row names and column names to avoid side-effects. Therefore, doors will be added as \"1\", \"2\", \"3\".")
+    if(rownames(.data) |> is.null() ) rownames(.data) = .data |> nrow() |> seq_len() |> as.character()
+    if(colnames(.data) |> is.null() ) colnames(.data) = .data |> ncol() |> seq_len() |> as.character()
+    
     my_data__ <- .data 
     
     # Names
@@ -256,12 +264,6 @@ nest.SummarizedExperiment <- function(.data, ..., .names_sep=NULL) {
             " We are working for optimising a generalised solution of nest().")
     }
 
-    # my_data__nested <-
-    #     my_data__ %>% 
-    #     # This is needed otherwise nest goes into loop and fails
-    #     as_tibble() %>%
-    #     tidyr::nest(...)
-     
     # If I nest only for .feature -> THIS WORKS ONLY WITH THE CHECK ABOVE
     if (feature_name %in% colnames(my_test_nest)) {
         return(
@@ -280,7 +282,7 @@ nest.SummarizedExperiment <- function(.data, ..., .names_sep=NULL) {
     
 
     my_data__ %>%
-        select(!!sample_symbol, !!feature_symbol, my_nesting_column) |> 
+        select(!!sample_symbol, !!feature_symbol, all_of(my_nesting_column)) |> 
         as_tibble() %>%
         tidyr::nest(...) |> 
 
@@ -311,15 +313,18 @@ nest.SummarizedExperiment <- function(.data, ..., .names_sep=NULL) {
                     # Here I am filtering because if I have 0 features this leads to failure
                     else my_transcripts= ..1 |> filter(!is.na(!!feature_symbol)) |>  pull(!!feature_symbol)
                     
-                    ###
-
+                    # if the summarised experiment does not have feature ID or Sample ID, 
+                    # convert back those to integers
+                    # Note to self: this is convoluted, because if feature ID and sample ID 
+                    # were to stay integers all along, these will not be needed
+                    if(rownames(my_data__) |> is.null()) my_transcripts = as.integer(my_transcripts)
+                    if(colnames(my_data__) |> is.null()) my_samples = as.integer(my_samples)
+                    
                     my_data__[unique(my_transcripts),unique(my_samples)] |>
-                      select(-one_of(
+                      select(-any_of(
                         my_nesting_column |> 
                           setdiff(c(sample_name, feature_name))
-                      )) |> 
-                      suppressWarnings()
-
+                      )) 
                  
                 }
             )
diff --git a/R/utilities.R b/R/utilities.R
@@ -749,7 +749,8 @@ get_count_datasets <- function(se) {
   se <- check_se_dimnames(se)
   
   # Join assays
-  map2( 
+  list_assays = 
+    map2( 
     assays(se, withDimnames = FALSE) %>% as.list(),
     names(assays(se)),
     ~ {
@@ -807,21 +808,27 @@ get_count_datasets <- function(se) {
       f_(se)$name %in% colnames(.x) %>% not ~ mutate(.x, !!f_(se)$symbol := as.character(NA)),
       s_(se)$name %in% colnames(.x) %>% not ~ mutate(.x, !!s_(se)$symbol := as.character(NA)),
       ~ .x
-    )) |> 
-    
-    when(
-      length(.)>0 ~ 
-        
-        reduce(., full_join, by = c(f_(se)$name, s_(se)$name)),
-      # reduce(., left_join, by = c(f_(se)$name, s_(se)$name)),
-      # bind_cols(.,  .name_repair = c("minimal")) %>% .[!duplicated(colnames(.))], 
-      ~ expand.grid(
-        rownames(se), colnames(se)
-      ) %>% 
-        setNames(c(f_(se)$name, s_(se)$name)) %>%
-        tibble::as_tibble()
-    ) 
+    )) 
+  
+  # If assays is non empty 
+  if(list_assays |> length() > 0)
+    list_assays |> 
+    reduce(full_join, by = c(f_(se)$name, s_(se)$name))
   
+  # If assays is empty 
+  else {
+    
+    # If I don't have row column names
+    if(se |> rownames() |> is.null()) rn = nrow(se) |> seq_len() |> as.character()
+    else rn = rownames(se)
+    if(se |> colnames() |> is.null()) cn = ncol(se) |> seq_len() |> as.character()
+    else cn = colnames(se)
+    
+    expand.grid(  rn, cn  ) |> 
+             setNames(c(f_(se)$name, s_(se)$name)) |> 
+             tibble::as_tibble()
+  }
+   
   
 }
 
diff --git a/man/group_split.Rd b/man/group_split.Rd
diff --git a/tests/testthat/test-dplyr_methods.R b/tests/testthat/test-dplyr_methods.R
