Export splv_extra and value_expr accessors

NAMESPACE

@@ -26,6 +26,7 @@ export("ref_symbol<-")
 export("row_footnotes<-")
 export("section_div<-")
 export("section_div_at_path<-")
+export("splv_extra<-")
 export("top_left<-")
 export("top_level_section_div<-")
 export("tree_children<-")
@@ -43,6 +44,7 @@ export(InstantiatedColumnInfo)
 export(LabelRow)
 export(ManualSplit)
 export(MultiVarSplit)
+export(SplitValue)
 export(TableTree)
 export(VarDynCutSplit)
 export(VarLevWBaselineSplit)
@@ -177,6 +179,7 @@ export(split_rows_by_cutfun)
 export(split_rows_by_cuts)
 export(split_rows_by_multivar)
 export(split_rows_by_quartiles)
+export(splv_extra)
 export(str)
 export(subset_cols)
 export(summarize_row_groups)
@@ -197,6 +200,7 @@ export(tt_row_path_exists)
 export(update_ref_indexing)
 export(validate_table_struct)
 export(value_at)
+export(value_expr)
 export(value_formats)
 export(value_names)
 export(vars_in_layout)
@@ -239,6 +243,7 @@ exportMethods("ref_index<-")
 exportMethods("ref_symbol<-")
 exportMethods("row_footnotes<-")
 exportMethods("row_values<-")
+exportMethods("splv_extra<-")
 exportMethods("subtitles<-")
 exportMethods("table_inset<-")
 exportMethods("top_left<-")
@@ -296,6 +301,7 @@ exportMethods(row_footnotes)
 exportMethods(row_values)
 exportMethods(simple_analysis)
 exportMethods(spl_variable)
+exportMethods(splv_extra)
 exportMethods(str)
 exportMethods(subset_cols)
 exportMethods(subtitles)
@@ -306,6 +312,7 @@ exportMethods(top_left)
 exportMethods(tree_children)
 exportMethods(tt_at_path)
 exportMethods(value_at)
+exportMethods(value_expr)
 import(formatters)
 import(methods)
 importFrom(formatters,do_forced_paginate)

NEWS.md

@@ -2,7 +2,9 @@
 
 ### New Features
  * Added `restrict_facets` function factory for use with `make_split_fun`
- * Exportd previously internal `make_subset_expr` for use when constructing custom splitting behavior
+ * Exported previously internal `make_subset_expr` for use when constructing custom splitting behavior
+ * Exported previously internal `splv_extra` and `splv_extra<-` accessors for getting and setting child-specific extra arguments on `SplitValue` objects.
+ * Exported previously internal `value_expr` accessor for retrieving the subsetting expression from a `SplitValue` or `ValueWrapper` object.
 
 ## rtables 0.6.15
 

R/00tabletrees.R

@@ -102,6 +102,30 @@ setClass("SplitValue",
   representation(extra = "list")
 )
 
+#' Construct a `SplitValue` object
+#'
+#' Creates a `SplitValue` object representing a single facet value produced
+#' by a splitting operation, optionally carrying a custom subsetting expression
+#' and child-specific extra arguments.
+#'
+#' @param val (`ANY`)\cr the raw value for this split facet.
+#' @param extr (`list`)\cr named list of child-specific extra arguments to
+#'   forward to the analysis or content function for this facet.
+#' @param label (`character(1)`)\cr display label. Defaults to `val`.
+#' @param sub_expr (`expression` or `NULL`)\cr optional subsetting expression.
+#'   When `NULL` (default) the expression is derived automatically from `val`
+#'   during tabulation.
+#'
+#' @return A `SplitValue` object.
+#'
+#' @seealso [splv_extra()], [value_expr()]
+#'
+#' @examples
+#' sv <- SplitValue("A", sub_expr = expression(ARM == "A"))
+#' value_expr(sv)
+#' splv_extra(sv)
+#'
+#' @export
 SplitValue <- function(val, extr = list(), label = val, sub_expr = NULL) {
   if (is(val, "SplitValue")) {
     if (length(splv_extra(val)) > 0) {

R/tree_accessors.R

@@ -1843,11 +1843,32 @@ setMethod(
 #' @rdname int_methods
 setMethod("value_labels", "MultiVarSplit", function(obj) obj@var_labels)
 
-#' @rdname int_methods
+#' Retrieve the subset expression from a split value
+#'
+#' Returns the subsetting expression associated with a `SplitValue` (or
+#' `ValueWrapper`) object, or `NULL` for objects without one.  This expression
+#' is used internally to subset data when tabulating.
+#'
+#' @param obj (`ValueWrapper` or `ANY`)\cr a split value object, typically a
+#'   `SplitValue` constructed by [SplitValue()].  Any other object returns
+#'   `NULL`.
+#'
+#' @return An `expression` object, or `NULL`.
+#'
+#' @examples
+#' sv <- SplitValue("A", sub_expr = expression(ARM == "A"))
+#' value_expr(sv)
+#'
+#' value_expr("not a SplitValue") # NULL
+#'
+#' @export
+#' @rdname value_expr
 setGeneric("value_expr", function(obj) standardGeneric("value_expr"))
-#' @rdname int_methods
+#' @exportMethod value_expr
+#' @rdname value_expr
 setMethod("value_expr", "ValueWrapper", function(obj) obj@subset_expression)
-#' @rdname int_methods
+#' @exportMethod value_expr
+#' @rdname value_expr
 setMethod("value_expr", "ANY", function(obj) NULL)
 ## no setters for now, we'll see about that.
 
@@ -1875,21 +1896,51 @@ setMethod("spl_varlabels<-", "MultiVarSplit", function(object, value) {
 ## to *all the chidlren*,
 ## while splv_extra is for *child-specific* extra arguments,
 ## associated with specific values of the split
-#' @rdname int_methods
+
+#' Access or set child-specific extra arguments on a split value
+#'
+#' `splv_extra` retrieves the named list of *child-specific* extra arguments
+#' stored on a `SplitValue` object.  These arguments are forwarded to the
+#' analysis or content function only for the facet represented by that
+#' particular split value, making them distinct from [split_exargs()] which
+#' applies to *all* children of a split.
+#'
+#' @param obj (`SplitValue`)\cr a split value object, typically produced by
+#'   [SplitValue()] or as a result of a splitting operation.
+#' @param value (`list`)\cr named list of extra arguments to store on `obj`.
+#'
+#' @return
+#' * `splv_extra` returns the current `list` of child-specific extra args.
+#' * `splv_extra<-` returns `obj` with the extra arguments replaced.
+#'
+#' @seealso [split_exargs()] for split-level (all-children) extra arguments.
+#'
+#' @examples
+#' sv <- SplitValue("A", extr = list(my_arg = 1))
+#' splv_extra(sv)
+#'
+#' splv_extra(sv) <- list(my_arg = 99)
+#' splv_extra(sv)
+#'
+#' @export
+#' @rdname splv_extra
 setGeneric("splv_extra", function(obj) standardGeneric("splv_extra"))
 
-#' @rdname int_methods
+#' @exportMethod splv_extra
+#' @rdname splv_extra
 setMethod(
   "splv_extra", "SplitValue",
   function(obj) obj@extra
 )
 
-#' @rdname int_methods
+#' @export
+#' @rdname splv_extra
 setGeneric(
   "splv_extra<-",
   function(obj, value) standardGeneric("splv_extra<-")
 )
-#' @rdname int_methods
+#' @exportMethod splv_extra<-
+#' @rdname splv_extra
 setMethod(
   "splv_extra<-", "SplitValue",
   function(obj, value) {

tests/testthat/test-accessors.R

@@ -4,9 +4,9 @@
   ## coltree
   col_extra_args <- rtables:::col_extra_args
 
   l <- basic_table() %>%
     split_cols_by("ARM") %>%
     split_cols_by_multivar(c("AGE", "BMRKR1")) %>%
     analyze_colvars(list(mean, sd))
 
   pred <- coltree(l, DM)
@@ -227,21 +227,21 @@
 # section_div tests ------------------------------------------------------------
 test_structure_with_a_getter <- function(tbl, getter, val_per_lev) {
   # Main table obj
   expect_identical(tbl %>% getter(), val_per_lev$global)
   # Its labelrow (could be also not visible)
   expect_identical(tt_labelrow(tbl) %>% getter(), val_per_lev$global_labelrow)
 
   # First split row + its labels
   split1 <- tree_children(tbl)[[1]]
   expect_identical(split1 %>% getter(), val_per_lev$split)
   expect_identical(tt_labelrow(split1) %>% getter(), val_per_lev$split_labelrow)
 
   # Content table checks if there
   content_elem_tbl <- content_table(split1)
   if (nrow(content_elem_tbl) > 0) {
     expect_identical(content_elem_tbl %>% getter(), val_per_lev$content)
     expect_identical(tt_labelrow(content_elem_tbl) %>% getter(), val_per_lev$content_labelrow)
     expect_identical(tree_children(content_elem_tbl)[[1]] %>% getter(), val_per_lev$contentrow)
   }
 
   ## The elementary table has it?
@@ -628,3 +628,31 @@
   top_lev_div_str <- strsplit(toString(tbl), "\n")[[1]][7]
   expect_true(check_pattern(top_lev_div_str, "=", nchar(top_lev_div_str)))
 })
+
+test_that("splv_extra getter and setter work", {
+  sv <- SplitValue("A", extr = list(foo = 1L))
+
+  expect_identical(splv_extra(sv), list(foo = 1L))
+
+  splv_extra(sv) <- list(foo = 99L, bar = "x")
+  expect_identical(splv_extra(sv), list(foo = 99L, bar = "x"))
+
+  sv_bare <- SplitValue("B")
+  expect_identical(splv_extra(sv_bare), list())
+
+  sv2 <- SplitValue(sv, extr = list(baz = TRUE))
+  expect_identical(splv_extra(sv2), list(foo = 99L, bar = "x", baz = TRUE))
+})
+
+test_that("value_expr returns subset expression or NULL", {
+  sv_no_expr <- SplitValue("X")
+  expect_null(value_expr(sv_no_expr))
+
+  expr <- expression(ARM == "A")
+  sv_with_expr <- SplitValue("A", sub_expr = expr)
+  expect_identical(value_expr(sv_with_expr), expr)
+
+  expect_null(value_expr("not a SplitValue"))
+  expect_null(value_expr(42L))
+  expect_null(value_expr(list()))
+})