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,12 @@ importFrom(SummarizedExperiment,colData)
 importFrom(SummarizedExperiment,rowData)
 importFrom(SummarizedExperiment,rowRanges)
 importFrom(cli,col_br_black)
+importFrom(dplyr,full_join)
+importFrom(dplyr,if_else)
+importFrom(dplyr,left_join)
+importFrom(dplyr,select)
 importFrom(fansi,strwrap_ctl)
+importFrom(magrittr,`%>%`)
 importFrom(methods,setMethod)
 importFrom(pillar,align)
 importFrom(pillar,ctl_new_pillar)
@@ -33,14 +39,20 @@ importFrom(pillar,tbl_format_header)
 importFrom(pkgconfig,get_config)
 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_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 - get_extent(prefix), indent, strip.spaces = strip.spaces)
   wrapped <- paste0(prefix, wrapped)
   wrapped <- gsub(NBSP, " ", wrapped)
   paste0(wrapped, collapse="\n")

R/print_methods.R

@@ -8,8 +8,10 @@
 #' @importFrom S4Vectors coolcat
 #' @importFrom purrr when map_chr
 #' @importFrom stringr str_replace
+#' @importFrom magrittr `%>%`
+#' @importFrom dplyr if_else
 #' @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")
@@ -251,7 +253,6 @@ but they do not completely overlap.")
         out_sub[(top_n+1):nrow(out_sub), ]
       ))
 
-
       # attr(out_sub, "n") <- n
       # attr(out_sub, "total_rows") <- x %>% dim %>% {(.)[1] * (.)[2]}
 
@@ -264,14 +265,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 +286,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) %>%

R/tidyprint_1_utlis.R

@@ -1,8 +1,18 @@
-
 #' @importFrom pillar pillar_component
 #' @importFrom pillar new_pillar_shaft
 #' @importFrom pillar ctl_new_rowid_pillar
 #' @importFrom pillar new_pillar
+#' @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
+#' @importFrom stringr str_replace_all
+#' @importFrom purrr map2_chr
+#' @importFrom purrr map_int
+#' @importFrom dplyr if_else
 #' @export
 ctl_new_rowid_pillar.SE_print_abstraction <- function(controller, x, width, ...) {
   # message('attrx =', x %>% attributes())
@@ -53,7 +63,6 @@ ctl_new_rowid_pillar.SE_print_abstraction <- function(controller, x, width, ...)
 
 }
 
-
 #' @importFrom pillar pillar ctl_new_pillar
 #' @export
 ctl_new_pillar.SE_print_abstraction <- function(controller, x, width, ..., title = NULL) {
@@ -75,22 +84,116 @@ 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
 #' @importFrom pillar style_subtle
 #' @importFrom pillar tbl_format_header
 #' @importFrom cli col_br_black
 #' @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
+#' @param number_of_total_rows The total number of rows for spacing
+#' @param label The label to distribute (default: "COVARIATES")
+#' @return Formatted header string
 #' @export
-tbl_format_header.SE_print_abstraction <- function(x, setup, ...) {
+format_covariate_header <- function(separator_row, printed_colnames, covariate_names, number_of_total_rows, label = "COVARIATES") {
+  header_row <-
+    map2_chr(separator_row, names(separator_row), ~ if_else(.y %in% covariate_names, .x, .x |> str_replace_all("-", " ")))
+
+  covariate_indices <- which(printed_colnames %in% covariate_names)
+  covariate_widths <- separator_row[printed_colnames[covariate_indices]] |> purrr::map_int(nchar)
+  total_covariate_width <- sum(covariate_widths) + length(covariate_widths) + 1 # To compensate the white spaces of the tibble
+  label_length <- nchar(label)
+
+  # Center the label in the total covariate width, using only dashes and the label
+  left_pad <- floor((total_covariate_width - label_length) / 2)
+  right_pad <- total_covariate_width - 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, "|")
+
+  # Guarantee the merged_label is exactly total_covariate_width + 2
+  merged_label <- substr(merged_label, 1, total_covariate_width + 2)
+
+
+  # Now replace the first and last elements of the header_row for the covariate columns with the only merged_label
+  header_row[covariate_indices[1]] <- merged_label
 
+  # 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 = " ")
+
+
+}
+
+#' @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")
+
+  number_of_total_rows = (x |> attr("number_of_features")) * (x |> attr("number_of_samples"))
+
+  printed_colnames <- x |> attr("printed_colnames")
+
+  # 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
+
+  # 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
+  } else {
+    # Calculate character length to the end of the line
+    chars_to_third_pipe <- nchar(printed_colnames) - pipe_positions[2]
+  }
+
+  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 = "")
+
+  covariate_header <- cli::col_br_blue(merged_label)
 
 
+  # Compose the main header as before
   if (all(names2(named_header) == "")) {
     header <- named_header
   } else {
@@ -101,14 +204,21 @@ tbl_format_header.SE_print_abstraction <- function(x, setup, ...) {
         named_header
       ) %>%
       # Add further info single-cell
-      append( cli::col_br_black( sprintf(
-        " Features=%s | Samples=%s | Assays=%s",
+      #append(
+      paste0( cli::col_br_black( sprintf(
+        "Features=%s | Samples=%s | Assays=%s",
         number_of_features,
         number_of_samples,
         assay_names %>% paste(collapse=", ")
-      )), after = 1)
+      )))
+      # , after = 1)
+  }
+  # Add covariate header if present
+  if (!is.null(covariate_header)) {
+    header <- c(header, covariate_header)
   }
-  style_subtle(pillar___format_comment(header, width=setup$width))
+
+  style_subtle(pillar___format_comment(header, width=setup$width, strip.spaces = FALSE))
 }
 
 # type_sum.sep <- function(x, ...) {