Bug fixed: covariates indication, factor column error

Author: zhanchen

NAMESPACE

@@ -19,11 +19,15 @@ importFrom(SummarizedExperiment,colData)
 importFrom(SummarizedExperiment,rowData)
 importFrom(SummarizedExperiment,rowRanges)
 importFrom(cli,col_br_black)
+importFrom(cli,col_br_blue)
+importFrom(dplyr,across)
 importFrom(dplyr,full_join)
 importFrom(dplyr,if_else)
 importFrom(dplyr,left_join)
+importFrom(dplyr,mutate)
 importFrom(dplyr,select)
 importFrom(fansi,strwrap_ctl)
+importFrom(magrittr,"%>%")
 importFrom(magrittr,`%>%`)
 importFrom(methods,setMethod)
 importFrom(pillar,align)
@@ -37,6 +41,7 @@ importFrom(pillar,pillar_component)
 importFrom(pillar,style_subtle)
 importFrom(pillar,tbl_format_header)
 importFrom(pkgconfig,get_config)
+importFrom(purrr,keep)
 importFrom(purrr,map)
 importFrom(purrr,map2)
 importFrom(purrr,map2_chr)
@@ -47,6 +52,7 @@ importFrom(purrr,when)
 importFrom(rlang,enquo)
 importFrom(rlang,names2)
 importFrom(stats,setNames)
+importFrom(stringr,str_locate_all)
 importFrom(stringr,str_replace)
 importFrom(stringr,str_replace_all)
 importFrom(tibble,as_tibble)

R/pillar_utlis.R

@@ -19,9 +19,9 @@ pillar___strwrap2 <- function (x, width, indent, strip.spaces = TRUE)
 
 pillar___wrap <- function (..., indent=0, prefix="", width, strip.spaces = TRUE)
 {
-  
+
   x <- paste0(..., collapse="")
-  wrapped <- pillar___strwrap2(x, width - get_extent(prefix), indent, strip.spaces = strip.spaces)
+  wrapped <- pillar___strwrap2(x, width, indent, strip.spaces = strip.spaces)
   wrapped <- paste0(prefix, wrapped)
   wrapped <- gsub(NBSP, " ", wrapped)
   paste0(wrapped, collapse="\n")

R/print_methods.R

@@ -6,10 +6,10 @@
 #' @importFrom SummarizedExperiment assayNames assays rowData assays<- rowRanges
 #' @importFrom stats setNames
 #' @importFrom S4Vectors coolcat
-#' @importFrom purrr when map_chr
+#' @importFrom purrr when map_chr keep
 #' @importFrom stringr str_replace
 #' @importFrom magrittr `%>%`
-#' @importFrom dplyr if_else
+#' @importFrom dplyr if_else mutate across
 #' @export
 print.SummarizedExperiment <- function(x, design = 4, n_print = 10, ...) {
 
@@ -97,7 +97,7 @@ but they do not completely overlap.")
           ~ .[, 1:min(20, ncol(x)), drop=FALSE]
         ) %>%
         as_tibble()
-      
+
       my_tibble |>
         vctrs::new_data_frame(class=c("tidySummarizedExperiment", "tbl")) %>%
         add_attr(nrow(x),  "number_of_features") %>%
@@ -246,12 +246,20 @@ but they do not completely overlap.")
         max_width <- max(nchar(as.character(col)), na.rm = TRUE)  # Get max width in the column
         paste(rep("-", max_width), collapse = "")  # Generate a separator of the same length
       })
+
       # Modify the entire tibble to include a separator row across all columns
+      ## temporalily convert factor cols to char
+      fct_col = map(out_sub, is.factor) %>% keep(~{.x == T}) %>% names
+      if (length(fct_col)) out_sub[, fct_col] = out_sub[, fct_col] %>% mutate(across(all_of(fct_col), as.character))
+
+
       out_sub <- suppressWarnings(rbind(
         out_sub[seq_len(top_n),],
         as.list(separator_row),      # Adaptive separator row
         out_sub[(top_n+1):nrow(out_sub), ]
       ))
+      ## reverse to factor cols
+      if (length(fct_col)) out_sub[, fct_col] = out_sub[, fct_col] %>% mutate(across(all_of(fct_col), as.factor))
 
       # attr(out_sub, "n") <- n
       # attr(out_sub, "total_rows") <- x %>% dim %>% {(.)[1] * (.)[2]}
@@ -265,15 +273,15 @@ but they do not completely overlap.")
         add_attr(nrow(x),  "number_of_features") %>%
         add_attr(ncol(x),  "number_of_samples") %>%
         add_attr(assays(x) %>% names, "assay_names") %>%
-        add_attr(separator_row, "separator_row") |> 
-        add_attr(names(col_), "covariate_names") |> 
-        
-        add_attr(
-          # Get the actual column names that will be printed on screen
-          # This uses tibble's internal method to determine visible columns
-          pillar::tbl_format_setup(out_sub, width = getOption("width", 80) + 4)$body[1] |> as.character(),
-          "printed_colnames"
-        ) %>%
+        add_attr(separator_row, "separator_row") |>
+        add_attr(names(col_), "covariate_names") |>
+
+        # add_attr(
+        #   # Get the actual column names that will be printed on screen
+        #   # This uses tibble's internal method to determine visible columns
+        #   pillar::tbl_format_setup(out_sub, width = getOption("width", 80) + 4)$body[1] |> as.character(),
+        #   "printed_colnames"
+        # ) %>%
         add_attr(
           '' %>%
             setNames("A SummarizedExperiment-tibble abstraction"),
@@ -286,7 +294,7 @@ but they do not completely overlap.")
       invisible(x)
     }
 
-    
+
     print_tidyprint_1(x, ...)
     invisible(x)
 

R/tidyprint_1_utlis.R

@@ -85,7 +85,7 @@ ctl_new_pillar.SE_print_abstraction <- function(controller, x, width, ..., title
 
 
 #' Format covariate header by distributing label across covariate columns
-#' 
+#'
 #' @importFrom rlang names2
 #' @importFrom pillar align
 #' @importFrom pillar get_extent
@@ -95,7 +95,7 @@ ctl_new_pillar.SE_print_abstraction <- function(controller, x, width, ..., title
 #' @importFrom tibble as_tibble
 #' @importFrom stringr str_replace_all
 #' @importFrom purrr map2_chr
-#' 
+#'
 #' @param separator_row The separator row with column widths
 #' @param printed_colnames The printed column names
 #' @param covariate_names The names of covariate columns
@@ -120,10 +120,10 @@ format_covariate_header <- function(separator_row, printed_colnames, covariate_n
     label,
     paste(rep("-", right_pad), collapse = "")
   )
-  
+
   # Add '|' at the beginning and end
   merged_label <- paste0("|", merged_label, "|")
-  
+
   # Guarantee the merged_label is exactly total_covariate_width + 2
   merged_label <- substr(merged_label, 1, total_covariate_width + 2)
 
@@ -133,64 +133,84 @@ format_covariate_header <- function(separator_row, printed_colnames, covariate_n
 
   # remove the other covariate columns
   header_row[covariate_indices[-1]] <- ""
-  
+
   # Add row ID spacing at the beginning
   header_row <- c(paste(rep(" ", number_of_total_rows |> nchar() - 4), collapse = ""), header_row)
 
   # Step 2: Collapse everything with space
   paste(header_row, collapse = " ")
 
-  
+
 }
 
+#' Custom header for SE_print_abstraction tibbles
+#'
+#' Draws a banner aligned to the first rendered body line, and prints a
+#' one-line summary with feature/sample/assay counts.
+#'
+#' @importFrom pillar tbl_format_header align style_subtle
+#' @importFrom cli col_br_blue col_br_black
+#' @importFrom stringr str_locate_all
+#' @importFrom rlang names2
+#' @importFrom magrittr %>%
 #' @export
 tbl_format_header.SE_print_abstraction <- function(x, setup, ...) {
+
   number_of_features <- x |> attr("number_of_features")
   number_of_samples <- x |> attr("number_of_samples")
   named_header <- x |> attr("named_header")
   assay_names <- x |> attr("assay_names")
   separator_row <- x |> attr("separator_row")
   covariate_names <- x |> attr("covariate_names")
-  
+
+  x<<-x
+
+
   number_of_total_rows = (x |> attr("number_of_features")) * (x |> attr("number_of_samples"))
-  
-  printed_colnames <- x |> attr("printed_colnames")
-  
+
+  # printed_colnames <- x |> attr("printed_colnames")
+  printed_colnames <- pillar::tbl_format_setup(x)$body[1] |> as.character()
+
   # Find the positions of all '|' characters in the string
   pipe_positions <- stringr::str_locate_all(printed_colnames, "\\|")[[1]][, "start"]
-  
+
   # Calculate character length to the start of the second '|'
-  chars_to_second_pipe <- pipe_positions[2] - 2
-  
+  chars_to_second_pipe <- pipe_positions[2] - 3
+
   # Check if there's a third pipe
   if (length(pipe_positions) >= 3) {
     # Calculate character length between second and third pipe
-    chars_to_third_pipe <- pipe_positions[3] - pipe_positions[2] - 2
+    chars_to_third_pipe <- pipe_positions[3] - pipe_positions[2] -1
   } else {
     # Calculate character length to the end of the line
-    chars_to_third_pipe <- nchar(printed_colnames) - pipe_positions[2]
+    chars_to_third_pipe <- nchar(printed_colnames) - pipe_positions[2] -1
   }
 
   label = " COVARIATES "
   label_length <- nchar(label)
 
   # Center the label in the total covariate width, using only dashes and the label
   left_pad <- floor((chars_to_third_pipe - label_length) / 2)
-  right_pad <- chars_to_third_pipe - label_length - left_pad
-  merged_label <- paste0(
-    paste(rep("-", left_pad), collapse = ""),
-    label,
-    paste(rep("-", right_pad), collapse = "")
-  )
-  
-  # Add '|' at the beginning and end
-  merged_label <- paste0("|", merged_label, "|")
-  
-  # Pad with the spaces until chars to second pipe
-  merged_label <- c(paste(rep(" ", chars_to_second_pipe), collapse = ""), merged_label) |> 
-    paste0(collapse = "")
+  right_pad <- chars_to_third_pipe - label_length - left_pad -1
+
+  if (left_pad >0 & right_pad >0){
+    merged_label <- paste0(
+      paste(rep("-", left_pad), collapse = ""),
+      label,
+      paste(rep("-", right_pad), collapse = "")
+    )
+
+    # Add '|' at the beginning and end
+    merged_label <- paste0("|-", merged_label, "|")
 
-  covariate_header <- cli::col_br_blue(merged_label)
+    # Pad with the spaces until chars to second pipe
+    merged_label <- c(paste(rep(" ", chars_to_second_pipe), collapse = ""), merged_label) |>
+      paste0(collapse = "")
+
+    covariate_header <- cli::col_br_blue(merged_label)
+  }else{
+    covariate_header = NULL
+  }
 
 
   # Compose the main header as before
@@ -217,8 +237,10 @@ tbl_format_header.SE_print_abstraction <- function(x, setup, ...) {
   if (!is.null(covariate_header)) {
     header <- c(header, covariate_header)
   }
- 
+
+
   style_subtle(pillar___format_comment(header, width=setup$width, strip.spaces = FALSE))
+
 }
 
 # type_sum.sep <- function(x, ...) {

R/tidyse_utils.R

@@ -4,6 +4,42 @@
 #' @importFrom dplyr full_join
 # This file is a replacement of the unexported functions in the tibble
 # package, in order to specify "tibble abstraction in the header"
+#' @importFrom rlang names2
+#' @importFrom pillar align
+#' @importFrom pillar get_extent
+#' @importFrom pillar style_subtle
+#' @importFrom pillar tbl_format_header
+#' @importFrom cli col_br_black
+#' @importFrom tibble as_tibble
+#' @export
+tbl_format_header.tidySummarizedExperiment <- function(x, setup, ...) {
+
+  number_of_features <- x |> attr("number_of_features")
+  number_of_samples <- x |> attr("number_of_samples")
+  named_header <- x |> attr("named_header")
+  assay_names <- x |> attr("assay_names")
+
+
+  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( cli::col_br_black( sprintf(
+        " Features=%s | Samples=%s | Assays=%s",
+        number_of_features,
+        number_of_samples,
+        assay_names %>% paste(collapse=", ")
+      )), after = 1)
+  }
+  style_subtle(pillar___format_comment(header, width=setup$width))
+}
+
 check_if_assays_are_NOT_overlapped <- function(se, dim = "cols") {
 
   stopifnot(dim %in% c("rows", "cols"))
@@ -227,9 +263,9 @@ add_attr <- function(var, attribute, name) {
 eliminate_GRanges_metadata_columns_also_present_in_Rowdata <- function(.my_data, se) {
   .my_data %>%
     select(-one_of(colnames(rowData(se)))) %>%
-    
+
     # In case there is not metadata column
-    suppressWarnings() 
+    suppressWarnings()
 }
 
 get_special_datasets <- function(se) {