Covariate layer

.gitignore

@@ -8,3 +8,5 @@ tidyprint.Rproj
 inst/doc
 /doc/
 /Meta/
+.DS_Store
+..Rcheck

NAMESPACE

@@ -7,6 +7,7 @@ S3method(print,SummarizedExperiment)
 S3method(tbl_format_header,SE_print_abstraction)
 S3method(tbl_format_header,tidySummarizedExperiment)
 export(demo_tidy_message)
+export(format_covariate_header)
 export(tidy_message)
 importClassesFrom(SummarizedExperiment,SummarizedExperiment)
 importFrom(S4Vectors,coolcat)
@@ -18,7 +19,16 @@ 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)
 importFrom(pillar,ctl_new_pillar)
@@ -31,16 +41,24 @@ 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)
 importFrom(purrr,map_chr)
+importFrom(purrr,map_int)
 importFrom(purrr,reduce)
 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)
 importFrom(tibble,enframe)
+importFrom(tidyr,nest)
+importFrom(tidyr,pivot_longer)
 importFrom(tidyr,spread)
 importFrom(vctrs,new_data_frame)
 importFrom(vctrs,vec_rep)

R/pillar_utlis.R

@@ -1,26 +1,27 @@
 NBSP <- "\U00A0"
 
-pillar___format_comment <- function (x, width)
+pillar___format_comment <- function (x, width, strip.spaces = TRUE)
 {
   if (length(x) == 0L) {
     return(character())
   }
   map_chr(x, pillar___wrap, prefix="# ",
-          width=min(width, cli::console_width()))
+          width=min(width, cli::console_width()), strip.spaces = strip.spaces)
 }
 
 #' @importFrom fansi strwrap_ctl
-pillar___strwrap2 <- function (x, width, indent)
+pillar___strwrap2 <- function (x, width, indent, strip.spaces = TRUE)
 {
-  fansi::strwrap_ctl(x, width=max(width, 0), indent=indent,
-                     exdent=indent + 2)
+  fansi::strwrap2_ctl(x, width=max(width, 0), indent=indent,
+                     exdent=indent + 2, strip.spaces = strip.spaces)
 }
 
 
-pillar___wrap <- function (..., indent=0, prefix="", width)
+pillar___wrap <- function (..., indent=0, prefix="", width, strip.spaces = TRUE)
 {
+
   x <- paste0(..., collapse="")
-  wrapped <- pillar___strwrap2(x, width - get_extent(prefix), indent)
+  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,12 @@
 #' @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 mutate across
 #' @export
-print.SummarizedExperiment <- function(x, design = 1, n_print = 10, ...) {
+print.SummarizedExperiment <- function(x, design = 4, n_print = 10, ...) {
 
   # Match the user-supplied design argument to one of the valid choices:
   if (is.numeric(design)) {
@@ -95,7 +97,7 @@ but they do not completely overlap.")
           ~ .[, 1:min(20, ncol(x)), drop=FALSE]
         ) %>%
         as_tibble()
-      # browser()
+
       my_tibble |>
         vctrs::new_data_frame(class=c("tidySummarizedExperiment", "tbl")) %>%
         add_attr(nrow(x),  "number_of_features") %>%
@@ -219,15 +221,15 @@ but they do not completely overlap.")
       nn <- nc * nr
       out <- c(
         list(
-          .features = vctrs::vec_rep(.features, times = nc),
-          .samples  = vctrs::vec_rep_each(.samples, times = nr)
+          .feature = vctrs::vec_rep(.features, times = nc),
+          .sample  = vctrs::vec_rep_each(.samples, times = nr)
         ),
         list(`|` = sep_(nn)),
         assays_,
         list(`|` = sep_(nn)),
-        row_,
+        col_,
         list(`|` = sep_(nn)),
-        col_
+        row_
       )
       attr(out, "row.names") <- c(NA_integer_, -nn)
       class(out) <- c("SE_abstraction", "tbl_df", "tbl", "data.frame")
@@ -244,13 +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]}
@@ -264,14 +273,16 @@ 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(
-          # sprintf(
-          #   "%s %s %s",
-          #   x %>% dim %>% {(.)[1] * (.)[2]} %>%
-          #     format(format="f", big.mark=",", digits=1),
-          #   cli::symbol$times,
-          #   ncol(out_sub)
-          # ) %>%
           '' %>%
             setNames("A SummarizedExperiment-tibble abstraction"),
           "named_header"
@@ -283,6 +294,7 @@ but they do not completely overlap.")
       invisible(x)
     }
 
+
     print_tidyprint_1(x, ...)
     invisible(x)
 

R/tibble_methods.R

@@ -1,10 +1,11 @@
-
 #' @importFrom purrr reduce
 #' @importFrom purrr map map2
 #' @importFrom tidyr spread
 #' @importFrom tibble enframe
 #' @importFrom SummarizedExperiment colData
 #' @importFrom pkgconfig get_config
+#' @importFrom rlang enquo
+#' @importFrom dplyr left_join
 #' @export
 as_tibble.SummarizedExperiment <- function(x, ...,
                                            .name_repair=c("check_unique", "unique", "universal", "minimal"),
@@ -19,7 +20,7 @@ as_tibble.SummarizedExperiment <- function(x, ...,
                                  .name_repair=c("check_unique", "unique", "universal", "minimal"),
                                  rownames=pkgconfig::get_config("tibble::rownames", NULL)) {
 
-  .subset <- enquo(.subset)
+  .subset <- rlang::enquo(.subset)
 
   sample_info <-
     colData(x) %>%