Feature branch work ready for merg into main (#237)

* Exp allow a/cfuns + splfuns to accept .prev_splvals arg. #203 dev vbump * Fix bug where names weren't showing up for .prev_splvals. #203 dev vbump * Fix off-by-one error in pagination, sep in txt export. Fixes #213 * add experimental fnotes_at_path function. Needs tests. #219. vbump * Exp allow a/cfuns + splfuns to accept .prev_splvals arg. #203 dev vbump * Fix bug where names weren't showing up for .prev_splvals. #203 dev vbump * Fix off-by-one error in pagination, sep in txt export. Fixes #213 * add experimental fnotes_at_path function. Needs tests. #219. vbump * Run GH actions for all branches * Working fntes_at_path with tests. Closes #219. dev vbump * col ref footnote support. related to #219. Closes #187. dev vbump * Support and tests for trim_levels_to_map. closes #203. Devel vbump. * cell_values and value_at methods for Row objects. closes #210. dev vbump * Trim outer levels to trim_levels_in_groups by deflt. #236 dev vbump * Cleanup, additional tests, and fix bugs uncovered by new tests. * Add NEWS entries, prepare for merge into main Co-authored-by: dinakar29 <26552821+dinakar29@users.noreply.github.com>
insightsengineering · Aug 27, 2021 · e788d7f · e788d7f
1 parent 36a4a40
commit e788d7f
Show file tree

Hide file tree

Showing 34 changed files with 1,272 additions and 490 deletions.
diff --git a/.Rbuildignore b/.Rbuildignore
@@ -14,7 +14,8 @@
 ^\..*$
 ^temp$
 ^[^/]*.R$
+^[^/]*html$
 ^.lintr$
 (^|/)\.[#][^/]*$
 (^|/)[#][^/]*#$
-~$
+~$
diff --git a/.github/workflows/build-check-install.yaml b/.github/workflows/build-check-install.yaml
@@ -3,7 +3,7 @@ name: R CMD Check
 on:
   push:
     branches:
-      - main
+      - '*'
   pull_request:
     branches:
       - main

diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,7 +1,7 @@
 Package: rtables
 Title: Reporting Tables
 Date: 2021-07-07
-Version: 0.3.8.9000
+Version: 0.3.8.9001
 Authors@R: c(
   person("Gabriel", "Becker", email = "gabembecker@gmail.com", role = c("aut", "cre")),
   person("Adrian", "Waddell", email = "adrian.waddell@roche.com", role = "aut"),

diff --git a/NAMESPACE b/NAMESPACE
@@ -5,9 +5,11 @@ S3method(print,RowsVerticalSection)
 export("cell_footnotes<-")
 export("clayout<-")
 export("col_counts<-")
+export("col_fnotes_here<-")
 export("col_info<-")
 export("col_total<-")
 export("content_table<-")
+export("fnotes_at_path<-")
 export("obj_label<-")
 export("obj_name<-")
 export("ref_index<-")
@@ -56,6 +58,7 @@ export(clayout)
 export(clear_indent_mods)
 export(col_counts)
 export(col_exprs)
+export(col_fnotes_here)
 export(col_info)
 export(col_paths)
 export(col_paths_summary)
@@ -101,6 +104,7 @@ export(paginate_table)
 export(propose_column_widths)
 export(prune_empty_level)
 export(prune_table)
+export(rawvalues)
 export(rbindl_rtables)
 export(rcell)
 export(ref_index)
@@ -135,13 +139,14 @@ export(table_structure)
 export(toString)
 export(top_left)
 export(tree_children)
-export(trim_levels_by_map)
 export(trim_levels_in_group)
+export(trim_levels_to_map)
 export(trim_rows)
 export(trim_zero_rows)
 export(tt_at_path)
 export(update_ref_indexing)
 export(value_at)
+export(value_names)
 export(var_labels)
 export(var_labels_remove)
 export(var_relabel)
@@ -163,9 +168,11 @@ exportMethods("[[")
 exportMethods("cell_footnotes<-")
 exportMethods("clayout<-")
 exportMethods("col_counts<-")
+exportMethods("col_fnotes_here<-")
 exportMethods("col_info<-")
 exportMethods("col_total<-")
 exportMethods("content_table<-")
+exportMethods("fnotes_at_path<-")
 exportMethods("obj_label<-")
 exportMethods("obj_name<-")
 exportMethods("ref_index<-")
@@ -181,6 +188,7 @@ exportMethods(cell_values)
 exportMethods(clayout)
 exportMethods(clear_indent_mods)
 exportMethods(col_counts)
+exportMethods(col_fnotes_here)
 exportMethods(col_info)
 exportMethods(col_total)
 exportMethods(collect_leaves)
@@ -209,6 +217,7 @@ exportMethods(toString)
 exportMethods(top_left)
 exportMethods(tree_children)
 exportMethods(tt_at_path)
+exportMethods(value_at)
 import(methods)
 importFrom(htmltools,tagList)
 importFrom(htmltools,tags)

diff --git a/NEWS.md b/NEWS.md
@@ -1,3 +1,13 @@
+## rtables 0.3.8.9001
+ * new `trim_levels_to_map` split function based on wwojtek's work in #203
+ * support for column referential footnotes
+ * support for adding footnotes to existint table via `fnotes_at_path<-` function
+ * `trim_levels_in_group` now trims empty levels of outer (split) variable by default
+ * `value_at` and `cell_values` now work for tablerow objects
+ * Fixed `as_html` bug in multvar split columns case 
+ * Fixed pagination off-by-one error
+
+
 ## rtables 0.3.8.9000
 
 ## rtables 0.3.8

diff --git a/R/00tabletrees.R b/R/00tabletrees.R
@@ -976,28 +976,32 @@ setClass("LayoutAxisTree", contains = "VLayoutTree",
          validity = function(object) all(sapply(object@children, function(x) is(x, "LayoutAxisTree") || is(x, "LayoutAxisLeaf"))))
 
 setClass("LayoutAxisLeaf", contains = "VLayoutLeaf", ##"VNodeInfo",
-         representation(func = "function"))
+         representation(func = "function",
+                        col_footnotes = "list"))
 
 
 setClass("LayoutColTree", contains = "LayoutAxisTree",
          representation(display_columncounts = "logical",
-                        columncount_format = "character"))
+                        columncount_format = "character",
+                        col_footnotes = "list"))
 
 setClass("LayoutColLeaf", contains = "LayoutAxisLeaf")
 setClass("LayoutRowTree", contains = "LayoutAxisTree")
 setClass("LayoutRowLeaf", contains = "LayoutAxisLeaf")
 LayoutColTree <- function(lev = 0L,
-                         name = label,
-                         label = "",
+                         name = obj_name(spl),
+                         label = obj_label(spl),
                          kids = list(),
                          spl = EmptyAllSplit,
                          tpos = TreePos(),
                          summary_function = NULL,
                          disp_colcounts = FALSE,
-                         colcount_format = "(N=xx)") {## ,
+                         colcount_format = "(N=xx)",
+                         footnotes = list()) {## ,
                          ## sub = expression(TRUE),
                          ## svar = NA_character_,
     ## slab = NA_character_) {
+    footnotes <- make_ref_value(footnotes)
     if (!is.null(spl)) {
         new("LayoutColTree", level = lev, children = kids,
             name = .chkname(name),
@@ -1008,7 +1012,8 @@ LayoutColTree <- function(lev = 0L,
             ## splitvar = svar,
             label = label,
             display_columncounts = disp_colcounts,
-            columncount_format = colcount_format)
+            columncount_format = colcount_format,
+            col_footnotes = footnotes)
     } else {
         stop("problema my manitar")
         LayoutColLeaf(lev = lev, label = label, tpos = tpos,

diff --git a/R/colby_constructors.R b/R/colby_constructors.R
@@ -1642,6 +1642,9 @@ list_wrap_df = function(f) {
 #'
 #' @export
 #' @inheritParams constr_args
+#' @param show_colcounts logical(1). Should column counts be displayed in the resulting table
+#' when this layout is applied to data
+#'
 #' @inherit split_cols_by return
 #'
 #' @examples
@@ -1654,11 +1657,15 @@ list_wrap_df = function(f) {
 basic_table <- function(title = "",
                         subtitles = character(),
                         main_footer = character(),
-                        prov_footer = character()) {
-    PreDataTableLayouts(title = title,
+                        prov_footer = character(),
+                        show_colcounts = FALSE) {
+    ret <- PreDataTableLayouts(title = title,
                         subtitles = subtitles,
                         main_footer = main_footer,
                         prov_footer = prov_footer)
+    if(show_colcounts)
+        ret <- add_colcounts(ret)
+    ret
 }
 
 

diff --git a/R/format_rcell.R b/R/format_rcell.R
@@ -102,9 +102,9 @@ sprintf_format <- function(format) {
     }
 }
 
-sprintf_format_old <- function(format) {
-  structure(format, "format_type" = "sprintf")
-}
+## sprintf_format_old <- function(format) {
+##   structure(format, "format_type" = "sprintf")
+## }
 
 
 

diff --git a/R/index_footnotes.R b/R/index_footnotes.R
@@ -1,23 +1,75 @@
 
-.idx_helper <- function(tr , cur_idx_fun) {
-    if(length(row_footnotes(tr)) > 0) {
-        row_footnotes(tr) <- lapply(row_footnotes(tr),
-                                    function(ref) {
-            ref_index(ref) <- cur_idx_fun()
-            ref
-        })
-    }
+.reindex_one_pos <- function(refs, cur_idx_fun) {
+    if(length(refs) == 0)
+        return(refs)
+
+    lapply(refs, function(refi) {
+        ref_index(refi) <- cur_idx_fun()
+        refi
+    })
+}
+
+
+setGeneric(".idx_helper", function(tr, cur_idx_fun) standardGeneric(".idx_helper"))
+
+
+setMethod(".idx_helper", "TableRow",
+          function(tr , cur_idx_fun) {
+    row_footnotes(tr) <- .reindex_one_pos(row_footnotes(tr),
+                                          cur_idx_fun)
+
+    ## if(length(row_footnotes(tr)) > 0) {
+    ##     row_footnotes(tr) <- .reindex_one_pos(row_footnotes(tr),
+    ##                                           cur_idx_fun)
+    ## }
 
-    crfs <- cell_footnotes(tr)
-    if(length(unlist(crfs)) > 0) {
+    ## crfs <- cell_footnotes(tr)
+    ## if(length(unlist(crfs)) > 0) {
 
-        cell_footnotes(tr) <- lapply(crfs,
-                                     function(refs) lapply(refs, function(refi) {
-                                                        ref_index(refi) <- cur_idx_fun()
-                                                        refi
-                                                    }))
+        cell_footnotes(tr) <- lapply(cell_footnotes(tr), ##crfs,
+                                     .reindex_one_pos,
+                                     cur_idx_fun = cur_idx_fun
+                                     )
+    tr
+})
+
+setMethod(".idx_helper", "VTableTree",
+          function(tr, cur_idx_fun) {
+    if(!labelrow_visible(tr)) {
+        stop("got a row footnote on a non-visible label row. this should never happen")
     }
+    lr <- tt_labelrow(tr)
+
+    row_footnotes(lr) <- .reindex_one_pos(row_footnotes(lr),
+                                          cur_idx_fun)
+
+    tt_labelrow(tr) <- lr
+
     tr
+})
+
+index_col_refs <- function(tt, cur_idx_fun) {
+    ctree <- coltree(tt)
+    ctree <- .index_col_refs_inner(ctree, cur_idx_fun)
+    coltree(tt) <- ctree
+    tt
+}
+
+
+.index_col_refs_inner <- function(ctree, cur_idx_fun) {
+    col_fnotes_here(ctree) <- .reindex_one_pos(col_fnotes_here(ctree),
+                                               cur_idx_fun)
+
+    if(is(ctree, "LayoutColTree"))
+        tree_children(ctree) <- lapply(tree_children(ctree),
+                                       .index_col_refs_inner,
+                                       cur_idx_fun = cur_idx_fun)
+    ctree
+    ## cfs <- col_fnotes_here(ctree)
+    ## if(length(unlist(cfs)) > 0) {
+    ##     col_fnotes_here(ctree) <- .reindex_one_pos(lapply(cfs,
+    ##                                      function(refs) lapply(refs, function(refi) {
+
 }
 
 #' Update footnote indexes on a built table
@@ -34,15 +86,19 @@
 #' manually.
 #' @export
 update_ref_indexing <- function(tt) {
-    ## TODO when column refs are a thing we will
-    ## still need to do those here before returning!!!
-    if(nrow(tt) == 0)
-        return(tt)
     curind <- 0L
     cur_index <- function() {
         curind <<- curind + 1L
         curind
     }
+    if(ncol(tt) > 0)
+        tt <- index_col_refs(tt, cur_index) ##col_info(tt) <- index_col_refs(col_info(tt), cur_index)
+    ## TODO when column refs are a thing we will
+    ## still need to do those here before returning!!!
+    if(nrow(tt) == 0)
+        return(tt)
+
+
     rdf <- make_row_df(tt)
 
     rdf <- rdf[rdf$nreflines > 0,]

diff --git a/R/make_subset_expr.R b/R/make_subset_expr.R
@@ -99,9 +99,12 @@ setMethod("make_subset_expr", "character",
 })
 
 .combine_subset_exprs = function(ex1, ex2) {
-    if(is.null(ex1) && is.expression(ex2))
-        return(ex2)
-
+    if(is.null(ex1) || identical(ex1, expression(TRUE))) {
+        if( is.expression(ex2) && !identical(ex2, expression(TRUE)))
+            return(ex2)
+        else
+            return(expression(TRUE))
+    }
     stopifnot(is.expression(ex1), is.expression(ex2))
     as.expression(bquote((.(a)) & .(b), list(a = ex1[[1]], b = ex2[[1]])))
 }
@@ -138,20 +141,6 @@ get_col_extras = function(ctree) {
 }
 
 setGeneric("make_col_subsets",function(lyt, df) standardGeneric("make_col_subsets"))
-setMethod("make_col_subsets", "PreDataTableLayouts",
-          function(lyt, df) {
-    make_col_subsets(clayout(lyt), df)
-})
-setMethod("make_col_subsets", "PreDataColLayout",
-          function(lyt, df) {
-    unlist(lapply(lyt, make_col_subsets, df = df))
-})
-
-setMethod("make_col_subsets", "SplitVector",
-          function(lyt, df) {
-    build_splits_expr(lyt, df)
-
-})
 
 setMethod("make_col_subsets", "LayoutColTree",
           function(lyt, df) {