rtables coverage - 90.88%

Files
Source

#' Internal generics and methods
#'
#' These are internal methods that are documented only to satisfy `R CMD check`. End users should pay no
#' attention to this documentation.
#'
#' @param x (`ANY`)\cr the object.
#' @param obj (`ANY`)\cr the object.
#'
#' @name internal_methods
#' @rdname int_methods
#' @aliases int_methods
NULL

#' @return The number of rows (`nrow`), columns (`ncol`), or both (`dim`) of the object.
#'
#' @rdname dimensions
#' @exportMethod nrow
setMethod(
  "nrow", "VTableTree",
  function(x) length(collect_leaves(x, TRUE, TRUE))
)

#' @rdname int_methods
#' @exportMethod nrow
setMethod(
  "nrow", "TableRow",
  function(x) 1L
)

#' Table dimensions
#'
#' @param x (`TableTree` or `ElementaryTable`)\cr a table object.
#'
#' @examples
#' lyt <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   analyze(c("SEX", "AGE"))
#'
#' tbl <- build_table(lyt, ex_adsl)
#'
#' dim(tbl)
#' nrow(tbl)
#' ncol(tbl)
#'
#' NROW(tbl)
#' NCOL(tbl)
#'
#' @rdname dimensions
#' @exportMethod ncol
setMethod(
  "ncol", "VTableNodeInfo",
  function(x) {
    ncol(col_info(x))
  }
)

#' @rdname int_methods
#' @exportMethod ncol
setMethod(
  "ncol", "TableRow",
  function(x) {
    if (!no_colinfo(x)) {
      ncol(col_info(x))
    } else {
      length(spanned_values(x))
    }
  }
)

#' @rdname int_methods
#' @exportMethod ncol
setMethod(
  "ncol", "LabelRow",
  function(x) {
    ncol(col_info(x))
  }
)

#' @rdname int_methods
#' @exportMethod ncol
setMethod(
  "ncol", "InstantiatedColumnInfo",
  function(x) {
    length(col_exprs(x))
  }
)

#' @rdname dimensions
#' @exportMethod dim
setMethod(
  "dim", "VTableNodeInfo",
  function(x) c(nrow(x), ncol(x))
)

#' Retrieve or set the direct children of a tree-style object
#'
#' @param x (`TableTree` or `ElementaryTable`)\cr an object with a tree structure.
#' @param value (`list`)\cr new list of children.
#'
#' @return A list of direct children of `x`.
#'
#' @export
#' @rdname tree_children
setGeneric("tree_children", function(x) standardGeneric("tree_children"))

#' @exportMethod tree_children
#' @rdname int_methods
setMethod(
  "tree_children", c(x = "VTree"),
  function(x) x@children
)

#' @exportMethod tree_children
#' @rdname int_methods
setMethod(
  "tree_children", c(x = "VTableTree"),
  function(x) x@children
)

## this includes VLeaf but also allows for general methods
## needed for table_inset being carried around by rows and
## such.
#' @exportMethod tree_children
#' @rdname int_methods
setMethod(
  "tree_children", c(x = "ANY"), ## "VLeaf"),
  function(x) list()
)

#' @export
#' @rdname tree_children
setGeneric("tree_children<-", function(x, value) standardGeneric("tree_children<-"))

#' @exportMethod tree_children<-
#' @rdname int_methods
setMethod(
  "tree_children<-", c(x = "VTree"),
  function(x, value) {
    x@children <- value
    x
  }
)

#' @exportMethod tree_children<-
#' @rdname int_methods
setMethod(
  "tree_children<-", c(x = "VTableTree"),
  function(x, value) {
    x@children <- value
    x
  }
)

#' Retrieve or set content table from a `TableTree`
#'
#' Returns the content table of `obj` if it is a `TableTree` object, or `NULL` otherwise.
#'
#' @param obj (`TableTree`)\cr the table object.
#'
#' @return the `ElementaryTable` containing the (top level) *content rows* of `obj` (or `NULL` if `obj` is not
#'   a formal table object).
#'
#' @export
#' @rdname content_table
setGeneric("content_table", function(obj) standardGeneric("content_table"))

#' @exportMethod content_table
#' @rdname int_methods
setMethod(
  "content_table", "TableTree",
  function(obj) obj@content
)

#' @exportMethod content_table
#' @rdname int_methods
setMethod(
  "content_table", "ANY",
  function(obj) NULL
)

#' @param value (`ElementaryTable`)\cr the new content table for `obj`.
#'
#' @export
#' @rdname content_table
setGeneric("content_table<-", function(obj, value) standardGeneric("content_table<-"))

#' @exportMethod "content_table<-"
#' @rdname int_methods
setMethod(
  "content_table<-", c("TableTree", "ElementaryTable"),
  function(obj, value) {
    obj@content <- value
    obj
  }
)

#' @param for_analyze (`flag`) whether split is an analyze split.
#' @rdname int_methods
setGeneric("next_rpos", function(obj, nested = TRUE, for_analyze = FALSE) standardGeneric("next_rpos"))

#' @rdname int_methods
setMethod(
  "next_rpos", "PreDataTableLayouts",
  function(obj, nested, for_analyze = FALSE) next_rpos(rlayout(obj), nested, for_analyze = for_analyze)
)

.check_if_nest <- function(obj, nested, for_analyze) {
  if (!nested) {
    FALSE
  } else {
    ## can always nest analyze splits (almost? what about colvars noncolvars mixing? prolly ok?)
    for_analyze ||
      ## If its not an analyze split it can't go under an analyze split
      !(is(last_rowsplit(obj), "VAnalyzeSplit") ||
        is(last_rowsplit(obj), "AnalyzeMultiVars")) ## should this be CompoundSplit? # nolint
  }
}

#' @rdname int_methods
setMethod(
  "next_rpos", "PreDataRowLayout",
  function(obj, nested, for_analyze) {
    l <- length(obj)
    if (length(obj[[l]]) > 0L && !.check_if_nest(obj, nested, for_analyze)) {
      l <- l + 1L
    }
    l
  }
)

#' @rdname int_methods
setMethod("next_rpos", "ANY", function(obj, nested) 1L)

#' @rdname int_methods
setGeneric("next_cpos", function(obj, nested = TRUE) standardGeneric("next_cpos"))

#' @rdname int_methods
setMethod(
  "next_cpos", "PreDataTableLayouts",
  function(obj, nested) next_cpos(clayout(obj), nested)
)

#' @rdname int_methods
setMethod(
  "next_cpos", "PreDataColLayout",
  function(obj, nested) {
    if (nested || length(obj[[length(obj)]]) == 0) {
      length(obj)
    } else {
      length(obj) + 1L
    }
  }
)

#' @rdname int_methods
setMethod("next_cpos", "ANY", function(obj, nested) 1L)

#' @rdname int_methods
setGeneric("last_rowsplit", function(obj) standardGeneric("last_rowsplit"))

#' @rdname int_methods
setMethod(
  "last_rowsplit", "NULL",
  function(obj) NULL
)

#' @rdname int_methods
setMethod(
  "last_rowsplit", "SplitVector",
  function(obj) {
    if (length(obj) == 0) {
      NULL
    } else {
      obj[[length(obj)]]
    }
  }
)

#' @rdname int_methods
setMethod(
  "last_rowsplit", "PreDataRowLayout",
  function(obj) {
    if (length(obj) == 0) {
      NULL
    } else {
      last_rowsplit(obj[[length(obj)]])
    }
  }
)

#' @rdname int_methods
setMethod(
  "last_rowsplit", "PreDataTableLayouts",
  function(obj) last_rowsplit(rlayout(obj))
)

# rlayout ----
## TODO maybe export these?

#' @rdname int_methods
setGeneric("rlayout", function(obj) standardGeneric("rlayout"))

#' @rdname int_methods
setMethod(
  "rlayout", "PreDataTableLayouts",
  function(obj) obj@row_layout
)

#' @rdname int_methods
setMethod("rlayout", "ANY", function(obj) PreDataRowLayout())

#' @rdname int_methods
setGeneric("rlayout<-", function(object, value) standardGeneric("rlayout<-"))

#' @rdname int_methods
setMethod(
  "rlayout<-", "PreDataTableLayouts",
  function(object, value) {
    object@row_layout <- value
    object
  }
)

#' @rdname int_methods
setGeneric("tree_pos", function(obj) standardGeneric("tree_pos"))

## setMethod("tree_pos", "VNodeInfo",
##           function(obj) obj@pos_in_tree)

#' @rdname int_methods
setMethod(
  "tree_pos", "VLayoutNode",
  function(obj) obj@pos_in_tree
)

#' @rdname int_methods
setGeneric("pos_subset", function(obj) standardGeneric("pos_subset"))

#' @rdname int_methods
setMethod(
  "pos_subset", "TreePos",
  function(obj) obj@subset
)

#' @rdname int_methods
setGeneric("tree_pos<-", function(obj, value) standardGeneric("tree_pos<-"))

#' @rdname int_methods
setMethod(
  "tree_pos<-", "VLayoutNode",
  function(obj, value) {
    obj@pos_in_tree <- value
    obj
  }
)

## setMethod("pos_subset", "VNodeInfo",
##           function(obj) pos_subset(tree_pos(obj)))

#' @rdname int_methods
setMethod(
  "pos_subset", "VLayoutNode",
  function(obj) pos_subset(tree_pos(obj))
)

#' @rdname int_methods
setGeneric("pos_splits", function(obj) standardGeneric("pos_splits"))

#' @rdname int_methods
setMethod(
  "pos_splits", "TreePos",
  function(obj) obj@splits
)

## setMethod("pos_splits", "VNodeInfo",
##           function(obj) pos_splits(tree_pos(obj)))

#' @rdname int_methods
setMethod(
  "pos_splits", "VLayoutNode",
  function(obj) pos_splits(tree_pos(obj))
)

#' @rdname int_methods
setGeneric("pos_splits<-", function(obj, value) standardGeneric("pos_splits<-"))

#' @rdname int_methods
setMethod(
  "pos_splits<-", "TreePos",
  function(obj, value) {
    obj@splits <- value
    obj
  }
)

#' @rdname int_methods
setMethod(
  "pos_splits<-", "VLayoutNode",
  function(obj, value) {
    pos <- tree_pos(obj)
    pos_splits(pos) <- value
    tree_pos(obj) <- pos
    obj
    obj
  }
)


#' @rdname int_methods
setGeneric("pos_splvals", function(obj) standardGeneric("pos_splvals"))

#' @rdname int_methods
setMethod(
  "pos_splvals", "TreePos",
  function(obj) obj@s_values
)

## setMethod("pos_splvals", "VNodeInfo",
##           function(obj) pos_splvals(tree_pos(obj)))

#' @rdname int_methods
setMethod(
  "pos_splvals", "VLayoutNode",
  function(obj) pos_splvals(tree_pos(obj))
)

#' @rdname int_methods
setGeneric("pos_splvals<-", function(obj, value) standardGeneric("pos_splvals<-"))

#' @rdname int_methods
setMethod(
  "pos_splvals<-", "TreePos",
  function(obj, value) {
    obj@s_values <- value
    obj
  }
)

## setMethod("pos_splvals", "VNodeInfo",
##           function(obj) pos_splvals(tree_pos(obj)))

#' @rdname int_methods
setMethod(
  "pos_splvals<-", "VLayoutNode",
  function(obj, value) {
    pos <- tree_pos(obj)
    pos_splvals(pos) <- value
    tree_pos(obj) <- pos
    obj
  }
)


#' @rdname int_methods
setGeneric("pos_splval_labels", function(obj) standardGeneric("pos_splval_labels"))

#' @rdname int_methods
setMethod(
  "pos_splval_labels", "TreePos",
  function(obj) obj@sval_labels
)
## no longer used

## setMethod("pos_splval_labels", "VNodeInfo",
##            function(obj) pos_splval_labels(tree_pos(obj)))
## #' @rdname int_methods
## setMethod("pos_splval_labels", "VLayoutNode",
##            function(obj) pos_splval_labels(tree_pos(obj)))

#' @rdname int_methods
setGeneric("spl_payload", function(obj) standardGeneric("spl_payload"))

#' @rdname int_methods
setMethod("spl_payload", "Split", function(obj) obj@payload)

#' @rdname int_methods
setGeneric("spl_payload<-", function(obj, value) standardGeneric("spl_payload<-"))

#' @rdname int_methods
setMethod("spl_payload<-", "Split", function(obj, value) {
  obj@payload <- value
  obj
})

#' @rdname int_methods
setGeneric("spl_label_var", function(obj) standardGeneric("spl_label_var"))

#' @rdname int_methods
setMethod("spl_label_var", "VarLevelSplit", function(obj) obj@value_label_var)

## TODO revisit. do we want to do this? used in vars_in_layout, but only
## for convenience.
#' @rdname int_methods
setMethod("spl_label_var", "Split", function(obj) NULL)

#' @rdname int_methods
setGeneric("spl_formats_var", function(obj) standardGeneric("spl_formats_var"))

#' @rdname int_methods
setMethod("spl_formats_var", "VAnalyzeSplit", function(obj) obj@row_formats_var)

#' @rdname int_methods
setGeneric("spl_na_strs_var", function(obj) standardGeneric("spl_na_strs_var"))

#' @rdname int_methods
setMethod("spl_na_strs_var", "VAnalyzeSplit", function(obj) obj@row_na_strs_var)

### name related things
# #' @inherit formatters::formatter_methods
#' Methods for generics in the `formatters` package
#'
#' See the `formatters` documentation for descriptions of these generics.
#'
#' @inheritParams gen_args
#'
#' @return
#' * Accessor functions return the current value of the component being accessed of `obj`
#' * Setter functions return a modified copy of `obj` with the new value.
#'
#' @rdname formatters_methods
#' @aliases formatters_methods
#' @exportMethod obj_name
setMethod(
  "obj_name", "VNodeInfo",
  function(obj) obj@name
)

#' @rdname formatters_methods
#' @exportMethod obj_name
setMethod(
  "obj_name", "Split",
  function(obj) obj@name
)

#' @rdname formatters_methods
#' @exportMethod obj_name<-
setMethod(
  "obj_name<-", "VNodeInfo",
  function(obj, value) {
    obj@name <- value
    obj
  }
)

#' @rdname formatters_methods
#' @exportMethod obj_name<-
setMethod(
  "obj_name<-", "Split",
  function(obj, value) {
    obj@name <- value
    obj
  }
)

### Label related things
#' @rdname formatters_methods
#' @exportMethod obj_label
setMethod("obj_label", "Split", function(obj) obj@split_label)

#' @rdname formatters_methods
#' @exportMethod obj_label
setMethod("obj_label", "TableRow", function(obj) obj@label)

## XXX Do we want a convenience for VTableTree that
## grabs the label from the LabelRow or will
## that just muddy the waters?
#' @rdname formatters_methods
#' @exportMethod obj_label
setMethod(
  "obj_label", "VTableTree",
  function(obj) obj_label(tt_labelrow(obj))
)

#' @rdname formatters_methods
#' @exportMethod obj_label
setMethod("obj_label", "ValueWrapper", function(obj) obj@label)

#' @rdname formatters_methods
#' @exportMethod obj_label<-
setMethod(
  "obj_label<-", "Split",
  function(obj, value) {
    obj@split_label <- value
    obj
  }
)

#' @rdname formatters_methods
#' @exportMethod obj_label<-
setMethod(
  "obj_label<-", "TableRow",
  function(obj, value) {
    obj@label <- value
    obj
  }
)

#' @rdname formatters_methods
#' @exportMethod obj_label<-
setMethod(
  "obj_label<-", "ValueWrapper",
  function(obj, value) {
    obj@label <- value
    obj
  }
)

#' @rdname formatters_methods
#' @exportMethod obj_label<-
setMethod(
  "obj_label<-", "VTableTree",
  function(obj, value) {
    lr <- tt_labelrow(obj)
    obj_label(lr) <- value
    if (!is.na(value) && nzchar(value)) {
      labelrow_visible(lr) <- TRUE
    } else if (is.na(value)) {
      labelrow_visible(lr) <- FALSE
    }
    tt_labelrow(obj) <- lr
    obj
  }
)

### Label rows.
#' @rdname int_methods
setGeneric("tt_labelrow", function(obj) standardGeneric("tt_labelrow"))

#' @rdname int_methods
setMethod(
  "tt_labelrow", "VTableTree",
  function(obj) obj@labelrow
)

#' @rdname int_methods
setGeneric("tt_labelrow<-", function(obj, value) standardGeneric("tt_labelrow<-"))

#' @rdname int_methods
setMethod(
  "tt_labelrow<-", c("VTableTree", "LabelRow"),
  function(obj, value) {
    if (no_colinfo(value)) {
      col_info(value) <- col_info(obj)
    }
    obj@labelrow <- value
    obj
  }
)

#' @rdname int_methods
setGeneric("labelrow_visible", function(obj) standardGeneric("labelrow_visible"))

#' @rdname int_methods
setMethod(
  "labelrow_visible", "VTableTree",
  function(obj) {
    labelrow_visible(tt_labelrow(obj))
  }
)

#' @rdname int_methods
setMethod(
  "labelrow_visible", "LabelRow",
  function(obj) obj@visible
)

#' @rdname int_methods
setMethod(
  "labelrow_visible", "VAnalyzeSplit",
  function(obj) .labelkids_helper(obj@var_label_position)
)

#' @rdname int_methods
setGeneric("labelrow_visible<-", function(obj, value) standardGeneric("labelrow_visible<-"))

#' @rdname int_methods
setMethod(
  "labelrow_visible<-", "VTableTree",
  function(obj, value) {
    lr <- tt_labelrow(obj)
    labelrow_visible(lr) <- value
    tt_labelrow(obj) <- lr
    obj
  }
)

#' @rdname int_methods
setMethod(
  "labelrow_visible<-", "LabelRow",
  function(obj, value) {
    obj@visible <- value
    obj
  }
)

#' @rdname int_methods
setMethod(
  "labelrow_visible<-", "VAnalyzeSplit",
  function(obj, value) {
    obj@var_label_position <- value
    obj
  }
)

## TRUE is always, FALSE is never, NA is only when no
## content function (or rows in an instantiated table) is present
#' @rdname int_methods
setGeneric("label_kids", function(spl) standardGeneric("label_kids"))

#' @rdname int_methods
setMethod("label_kids", "Split", function(spl) spl@label_children)

#' @rdname int_methods
setGeneric("label_kids<-", function(spl, value) standardGeneric("label_kids<-"))

#' @rdname int_methods
setMethod("label_kids<-", c("Split", "character"), function(spl, value) {
  label_kids(spl) <- .labelkids_helper(value)
  spl
})

#' @rdname int_methods
setMethod("label_kids<-", c("Split", "logical"), function(spl, value) {
  spl@label_children <- value
  spl
})

#' @rdname int_methods
setGeneric("vis_label", function(spl) standardGeneric("vis_label"))

#' @rdname int_methods
setMethod("vis_label", "Split", function(spl) {
  .labelkids_helper(label_position(spl))
})

## #' @rdname int_methods
## setGeneric("vis_label<-", function(spl, value) standardGeneric("vis_label<-"))
## #' @rdname int_methods
## setMethod("vis_label<-", "Split", function(spl, value) {
##     stop("defunct")
##     if(is.na(value))
##         stop("split label visibility must be TRUE or FALSE, got NA")
## #    spl@split_label_visible <- value
##     spl
## })

#' @rdname int_methods
setGeneric("label_position", function(spl) standardGeneric("label_position"))

#' @rdname int_methods
setMethod("label_position", "Split", function(spl) spl@split_label_position)

#' @rdname int_methods
setMethod("label_position", "VAnalyzeSplit", function(spl) spl@var_label_position) ## split_label_position)

#' @rdname int_methods
setGeneric("label_position<-", function(spl, value) standardGeneric("label_position<-"))

#' @rdname int_methods
setMethod("label_position<-", "Split", function(spl, value) {
  value <- match.arg(value, valid_lbl_pos)
  spl@split_label_position <- value
  spl
})

### Function accessors (summary, tabulation and split) ----

#' @rdname int_methods
setGeneric("content_fun", function(obj) standardGeneric("content_fun"))

#' @rdname int_methods
setMethod("content_fun", "Split", function(obj) obj@content_fun)

#' @rdname int_methods
setGeneric("content_fun<-", function(object, value) standardGeneric("content_fun<-"))

#' @rdname int_methods
setMethod("content_fun<-", "Split", function(object, value) {
  object@content_fun <- value
  object
})

#' @rdname int_methods
setGeneric("analysis_fun", function(obj) standardGeneric("analysis_fun"))

#' @rdname int_methods
setMethod("analysis_fun", "AnalyzeVarSplit", function(obj) obj@analysis_fun)

#' @rdname int_methods
setMethod("analysis_fun", "AnalyzeColVarSplit", function(obj) obj@analysis_fun)

## not used and probably not needed
## #' @rdname int_methods
## setGeneric("analysis_fun<-", function(object, value) standardGeneric("analysis_fun<-"))

## #' @rdname int_methods
## setMethod("analysis_fun<-", "AnalyzeVarSplit", function(object, value) {
##     object@analysis_fun <- value
##     object
## })
## #' @rdname int_methods
## setMethod("analysis_fun<-", "AnalyzeColVarSplit", function(object, value) {
##     if(is(value, "function"))
##         value <- list(value)
##     object@analysis_fun <- value
##     object
## })

#' @rdname int_methods
setGeneric("split_fun", function(obj) standardGeneric("split_fun"))

#' @rdname int_methods
setMethod("split_fun", "CustomizableSplit", function(obj) obj@split_fun)

## Only that type of split currently has the slot
## this should probably change? for now  define
## an accessor that just returns NULL
#' @rdname int_methods
setMethod("split_fun", "Split", function(obj) NULL)

#' @rdname int_methods
setGeneric("split_fun<-", function(obj, value) standardGeneric("split_fun<-"))

#' @rdname int_methods
setMethod("split_fun<-", "CustomizableSplit", function(obj, value) {
  obj@split_fun <- value
  obj
})

# nocov start
## Only that type of split currently has the slot
## this should probably change? for now  define
## an accessor that just returns NULL
#' @rdname int_methods
setMethod(
  "split_fun<-", "Split",
  function(obj, value) {
    stop(
      "Attempted to set a custom split function on a non-customizable split.",
      "This should not happen, please contact the maintainers."
    )
  }
)
# nocov end

## Content specification related accessors ----

#' @rdname int_methods
setGeneric("content_extra_args", function(obj) standardGeneric("content_extra_args"))

#' @rdname int_methods
setMethod("content_extra_args", "Split", function(obj) obj@content_extra_args)

#' @rdname int_methods
setGeneric("content_extra_args<-", function(object, value) standardGeneric("content_extra_args<-"))

#' @rdname int_methods
setMethod("content_extra_args<-", "Split", function(object, value) {
  object@content_extra_args <- value
  object
})

#' @rdname int_methods
setGeneric("content_var", function(obj) standardGeneric("content_var"))

#' @rdname int_methods
setMethod("content_var", "Split", function(obj) obj@content_var)

#' @rdname int_methods
setGeneric("content_var<-", function(object, value) standardGeneric("content_var<-"))

#' @rdname int_methods
setMethod("content_var<-", "Split", function(object, value) {
  object@content_var <- value
  object
})

### Miscellaneous accessors ----

#' @rdname int_methods
setGeneric("avar_inclNAs", function(obj) standardGeneric("avar_inclNAs"))

#' @rdname int_methods
setMethod(
  "avar_inclNAs", "VAnalyzeSplit",
  function(obj) obj@include_NAs
)

#' @rdname int_methods
setGeneric("avar_inclNAs<-", function(obj, value) standardGeneric("avar_inclNAs<-"))

#' @rdname int_methods
setMethod(
  "avar_inclNAs<-", "VAnalyzeSplit",
  function(obj, value) {
    obj@include_NAs <- value
  }
)

#' @rdname int_methods
setGeneric("spl_labelvar", function(obj) standardGeneric("spl_labelvar"))

#' @rdname int_methods
setMethod("spl_labelvar", "VarLevelSplit", function(obj) obj@value_label_var)

#' @rdname int_methods
setGeneric("spl_child_order", function(obj) standardGeneric("spl_child_order"))

#' @rdname int_methods
setMethod("spl_child_order", "VarLevelSplit", function(obj) obj@value_order)

#' @rdname int_methods
setGeneric(
  "spl_child_order<-",
  function(obj, value) standardGeneric("spl_child_order<-")
)

#' @rdname int_methods
setMethod(
  "spl_child_order<-", "VarLevelSplit",
  function(obj, value) {
    obj@value_order <- value
    obj
  }
)

#' @rdname int_methods
setMethod(
  "spl_child_order",
  "ManualSplit",
  function(obj) obj@levels
)

#' @rdname int_methods
setMethod(
  "spl_child_order",
  "MultiVarSplit",
  function(obj) spl_varnames(obj)
)

#' @rdname int_methods
setMethod(
  "spl_child_order",
  "AllSplit",
  function(obj) character()
)

#' @rdname int_methods
setMethod(
  "spl_child_order",
  "VarStaticCutSplit",
  function(obj) spl_cutlabels(obj)
)

#' @rdname int_methods
setGeneric("root_spl", function(obj) standardGeneric("root_spl"))

#' @rdname int_methods
setMethod(
  "root_spl", "PreDataAxisLayout",
  function(obj) obj@root_split
)

#' @rdname int_methods
setGeneric("root_spl<-", function(obj, value) standardGeneric("root_spl<-"))

#' @rdname int_methods
setMethod(
  "root_spl<-", "PreDataAxisLayout",
  function(obj, value) {
    obj@root_split <- value
    obj
  }
)

#' Row attribute accessors
#'
#' @inheritParams gen_args
#'
#' @return Various return values depending on the accessor called.
#'
#' @export
#' @rdname row_accessors
setGeneric("obj_avar", function(obj) standardGeneric("obj_avar"))

#' @rdname row_accessors
#' @exportMethod obj_avar
setMethod("obj_avar", "TableRow", function(obj) obj@var_analyzed)

#' @rdname row_accessors
#' @exportMethod obj_avar
setMethod("obj_avar", "ElementaryTable", function(obj) obj@var_analyzed)

#' @export
#' @rdname row_accessors
setGeneric("row_cells", function(obj) standardGeneric("row_cells"))

#' @rdname row_accessors
#' @exportMethod row_cells
setMethod("row_cells", "TableRow", function(obj) obj@leaf_value)

#' @rdname row_accessors
setGeneric("row_cells<-", function(obj, value) standardGeneric("row_cells<-"))

#' @rdname row_accessors
#' @exportMethod row_cells
setMethod("row_cells<-", "TableRow", function(obj, value) {
  obj@leaf_value <- value
  obj
})

#' @export
#' @rdname row_accessors
setGeneric("row_values", function(obj) standardGeneric("row_values"))

#' @rdname row_accessors
#' @exportMethod row_values
setMethod("row_values", "TableRow", function(obj) rawvalues(obj@leaf_value))


#' @rdname row_accessors
#' @exportMethod row_values<-
setGeneric("row_values<-", function(obj, value) standardGeneric("row_values<-"))

#' @rdname row_accessors
#' @exportMethod row_values<-
setMethod(
  "row_values<-", "TableRow",
  function(obj, value) {
    obj@leaf_value <- lapply(value, rcell)
    obj
  }
)

#' @rdname row_accessors
#' @exportMethod row_values<-
setMethod(
  "row_values<-", "LabelRow",
  function(obj, value) {
    stop("LabelRows cannot have row values.")
  }
)

#' @rdname int_methods
setGeneric("spanned_values", function(obj) standardGeneric("spanned_values"))

#' @rdname int_methods
setMethod(
  "spanned_values", "TableRow",
  function(obj) {
    rawvalues(spanned_cells(obj))
  }
)

#' @rdname int_methods
setMethod(
  "spanned_values", "LabelRow",
  function(obj) {
    rep(list(NULL), ncol(obj))
  }
)

#' @rdname int_methods
setGeneric("spanned_cells", function(obj) standardGeneric("spanned_cells"))

#' @rdname int_methods
setMethod(
  "spanned_cells", "TableRow",
  function(obj) {
    sp <- row_cspans(obj)
    rvals <- row_cells(obj)
    unlist(
      mapply(function(v, s) rep(list(v), times = s),
        v = rvals, s = sp
      ),
      recursive = FALSE
    )
  }
)

#' @rdname int_methods
setMethod(
  "spanned_cells", "LabelRow",
  function(obj) {
    rep(list(NULL), ncol(obj))
  }
)

#' @rdname int_methods
setGeneric("spanned_values<-", function(obj, value) standardGeneric("spanned_values<-"))

#' @rdname int_methods
setMethod(
  "spanned_values<-", "TableRow",
  function(obj, value) {
    sp <- row_cspans(obj)
    ## this is 3 times too clever!!!
    valindices <- unlist(lapply(sp, function(x) c(TRUE, rep(FALSE, x - 1))))

    splvec <- cumsum(valindices)
    lapply(
      split(value, splvec),
      function(v) {
        if (length(unique(v)) > 1) {
          stop(
            "Got more than one unique value within a span, ",
            "new spanned values do not appear to match the ",
            "existing spanning pattern of the row (",
            paste(sp, collapse = " "), ")"
          )
        }
      }
    )
    rvals <- value[valindices]

    ## rvals = lapply(split(value, splvec),
    ##                function(v) {
    ##     if(length(v) == 1)
    ##         return(v)
    ##     stopifnot(length(unique(v)) == 1L)
    ##     rcell(unique(v), colspan<- length(v))
    ## })
    ## if(any(splvec > 1))
    ##     rvals <- lapply(rvals, function(x) x[[1]])
    row_values(obj) <- rvals
    obj
  }
)

#' @rdname int_methods
setMethod(
  "spanned_values<-", "LabelRow",
  function(obj, value) {
    if (!is.null(value)) {
      stop("Label rows can't have non-null cell values, got", value)
    }
    obj
  }
)

### Format manipulation
### obj_format<- is not recursive
## TODO export these?
#' @rdname formatters_methods
#' @export
setMethod("obj_format", "VTableNodeInfo", function(obj) obj@format)

#' @rdname formatters_methods
#' @export
setMethod("obj_format", "CellValue", function(obj) attr(obj, "format", exact = TRUE))

#' @rdname formatters_methods
#' @export
setMethod("obj_format", "Split", function(obj) obj@split_format)

#' @rdname formatters_methods
#' @export
setMethod("obj_format<-", "VTableNodeInfo", function(obj, value) {
  obj@format <- value
  obj
})

#' @rdname formatters_methods
#' @export
setMethod("obj_format<-", "Split", function(obj, value) {
  obj@split_format <- value
  obj
})

#' @rdname formatters_methods
#' @export
setMethod("obj_format<-", "CellValue", function(obj, value) {
  attr(obj, "format") <- value
  obj
})

#' @rdname int_methods
#' @export
setMethod("obj_na_str<-", "CellValue", function(obj, value) {
  attr(obj, "format_na_str") <- value
  obj
})

#' @rdname int_methods
#' @export
setMethod("obj_na_str<-", "VTableNodeInfo", function(obj, value) {
  obj@na_str <- value
  obj
})

#' @rdname int_methods
#' @export
setMethod("obj_na_str<-", "Split", function(obj, value) {
  obj@split_na_str <- value
  obj
})

#' @rdname int_methods
#' @export
setMethod("obj_na_str", "VTableNodeInfo", function(obj) obj@na_str)

#' @rdname formatters_methods
#' @export
setMethod("obj_na_str", "Split", function(obj) obj@split_na_str)

.no_na_str <- function(x) {
  if (!is.character(x)) {
    x <- obj_na_str(x)
  }
  length(x) == 0 || all(is.na(x))
}

#' @rdname int_methods
setGeneric("set_format_recursive", function(obj, format, na_str, override = FALSE) {
  standardGeneric("set_format_recursive")
})

fmt_can_inherit <- function(obj, fmt = obj_format(obj)) {
  is.null(fmt) || identical(fmt, "default")
}

#' @param override (`flag`)\cr whether to override attribute.
#'
#' @rdname int_methods
setMethod(
  "set_format_recursive", "TableRow",
  function(obj, format, na_str, override = FALSE) {
    if (is.null(format) && .no_na_str(na_str)) {
      return(obj)
    }

    if ((fmt_can_inherit(obj) && !is.null(format)) || override) {
      obj_format(obj) <- format
    }
    if ((.no_na_str(obj) && !.no_na_str(na_str)) || override) {
      obj_na_str(obj) <- na_str
    }
    lcells <- row_cells(obj)
    lvals <- lapply(lcells, function(x) {
      if (!is.null(x) && (override || fmt_can_inherit(x))) {
        obj_format(x) <- obj_format(obj)
      }
      if (!is.null(x) && (override || .no_na_str(x))) {
        obj_na_str(x) <- obj_na_str(obj)
      }
      x
    })
    row_values(obj) <- lvals
    obj
  }
)

#' @rdname int_methods
setMethod(
  "set_format_recursive", "LabelRow",
  function(obj, format, override = FALSE) obj
)

setMethod(
  "set_format_recursive", "VTableTree",
  function(obj, format, na_str, override = FALSE) {
    force(format)
    if (is.null(format) && .no_na_str(na_str)) {
      return(obj)
    }

    if ((fmt_can_inherit(obj) && !is.null(format)) || override) {
      obj_format(obj) <- format
    }
    if ((.no_na_str(obj) && !.no_na_str(na_str)) || override) {
      obj_na_str(obj) <- na_str
    }

    kids <- tree_children(obj)
    kids <- lapply(kids, function(x, format2, na_str2, oride) {
      set_format_recursive(x,
        format = format2, na_str = na_str2, override = oride
      )
    },
    format2 = obj_format(obj), na_str2 = obj_na_str(obj), oride = override
    )
    tree_children(obj) <- kids
    obj
  }
)

#' @rdname int_methods
setGeneric("content_format", function(obj) standardGeneric("content_format"))

#' @rdname int_methods
setMethod("content_format", "Split", function(obj) obj@content_format)

#' @rdname int_methods
setGeneric("content_format<-", function(obj, value) standardGeneric("content_format<-"))

#' @rdname int_methods
setMethod("content_format<-", "Split", function(obj, value) {
  obj@content_format <- value
  obj
})

#' @rdname int_methods
setGeneric("content_na_str", function(obj) standardGeneric("content_na_str"))

#' @rdname int_methods
setMethod("content_na_str", "Split", function(obj) obj@content_na_str)

#' @rdname int_methods
setGeneric("content_na_str<-", function(obj, value) standardGeneric("content_na_str<-"))

#' @rdname int_methods
setMethod("content_na_str<-", "Split", function(obj, value) {
  obj@content_na_str <- value
  obj
})

#' Value formats
#'
#' Returns a matrix of formats for the cells in a table.
#'
#' @param obj (`VTableTree` or `TableRow`)\cr a table or row object.
#' @param default (`string`, `function`, or `list`)\cr default format.
#'
#' @return Matrix (storage mode list) containing the effective format for each cell position in the table
#'   (including 'virtual' cells implied by label rows, whose formats are always `NULL`).
#'
#' @seealso [table_shell()] and [table_shell_str()] for information on the table format structure.
#'
#' @examples
#' lyt <- basic_table() %>%
#'   split_rows_by("RACE", split_fun = keep_split_levels(c("ASIAN", "WHITE"))) %>%
#'   analyze("AGE")
#'
#' tbl <- build_table(lyt, DM)
#' value_formats(tbl)
#'
#' @export
setGeneric("value_formats", function(obj, default = obj_format(obj)) standardGeneric("value_formats"))

#' @rdname value_formats
setMethod(
  "value_formats", "ANY",
  function(obj, default) {
    obj_format(obj) %||% default
  }
)

#' @rdname value_formats
setMethod(
  "value_formats", "TableRow",
  function(obj, default) {
    if (!is.null(obj_format(obj))) {
      default <- obj_format(obj)
    }
    formats <- lapply(row_cells(obj), function(x) value_formats(x) %||% default)
    formats
  }
)

#' @rdname value_formats
setMethod(
  "value_formats", "LabelRow",
  function(obj, default) {
    rep(list(NULL), ncol(obj))
  }
)

#' @rdname value_formats
setMethod(
  "value_formats", "VTableTree",
  function(obj, default) {
    if (!is.null(obj_format(obj))) {
      default <- obj_format(obj)
    }
    rws <- collect_leaves(obj, TRUE, TRUE)
    formatrws <- lapply(rws, value_formats, default = default)
    mat <- do.call(rbind, formatrws)
    row.names(mat) <- row.names(obj)
    mat
  }
)

### Collect all leaves of a current tree
### This is a workhorse function in various
### places
### NB this is written generally enought o
### be used on all tree-based structures in the
### framework.

#' Collect leaves of a `TableTree`
#'
#' @inheritParams gen_args
#' @param incl.cont (`flag`)\cr whether to include rows from content tables within the tree. Defaults to `TRUE`.
#' @param add.labrows (`flag`)\cr whether to include label rows. Defaults to `FALSE`.
#'
#' @return A list of `TableRow` objects for all rows in the table.
#'
#' @export
setGeneric("collect_leaves",
  function(tt, incl.cont = TRUE, add.labrows = FALSE) {
    standardGeneric("collect_leaves")
  },
  signature = "tt"
)

#' @inheritParams collect_leaves
#'
#' @rdname int_methods
#' @exportMethod collect_leaves
setMethod(
  "collect_leaves", "TableTree",
  function(tt, incl.cont = TRUE, add.labrows = FALSE) {
    ret <- c(
      if (add.labrows && labelrow_visible(tt)) {
        tt_labelrow(tt)
      },
      if (incl.cont) {
        tree_children(content_table(tt))
      },
      lapply(tree_children(tt),
        collect_leaves,
        incl.cont = incl.cont, add.labrows = add.labrows
      )
    )
    unlist(ret, recursive = TRUE)
  }
)

#' @rdname int_methods
#' @exportMethod collect_leaves
setMethod(
  "collect_leaves", "ElementaryTable",
  function(tt, incl.cont = TRUE, add.labrows = FALSE) {
    ret <- tree_children(tt)
    if (add.labrows && labelrow_visible(tt)) {
      ret <- c(tt_labelrow(tt), ret)
    }
    ret
  }
)

#' @rdname int_methods
#' @exportMethod collect_leaves
setMethod(
  "collect_leaves", "VTree",
  function(tt, incl.cont, add.labrows) {
    ret <- lapply(
      tree_children(tt),
      collect_leaves
    )
    unlist(ret, recursive = TRUE)
  }
)

#' @rdname int_methods
#' @exportMethod collect_leaves
setMethod(
  "collect_leaves", "VLeaf",
  function(tt, incl.cont, add.labrows) {
    list(tt)
  }
)

#' @rdname int_methods
#' @exportMethod collect_leaves
setMethod(
  "collect_leaves", "NULL",
  function(tt, incl.cont, add.labrows) {
    list()
  }
)

#' @rdname int_methods
#' @exportMethod collect_leaves
setMethod(
  "collect_leaves", "ANY",
  function(tt, incl.cont, add.labrows) {
    stop("class ", class(tt), " does not inherit from VTree or VLeaf")
  }
)

n_leaves <- function(tt, ...) {
  length(collect_leaves(tt, ...))
}

### Spanning information ----

#' @rdname int_methods
setGeneric("row_cspans", function(obj) standardGeneric("row_cspans"))

#' @rdname int_methods
setMethod("row_cspans", "TableRow", function(obj) obj@colspans)

#' @rdname int_methods
setMethod(
  "row_cspans", "LabelRow",
  function(obj) rep(1L, ncol(obj))
)

#' @rdname int_methods
setGeneric("row_cspans<-", function(obj, value) standardGeneric("row_cspans<-"))

#' @rdname int_methods
setMethod("row_cspans<-", "TableRow", function(obj, value) {
  obj@colspans <- value
  obj
})

#' @rdname int_methods
setMethod("row_cspans<-", "LabelRow", function(obj, value) {
  stop("attempted to set colspans for LabelRow") # nocov
})

## XXX TODO colapse with above?
#' @rdname int_methods
setGeneric("cell_cspan", function(obj) standardGeneric("cell_cspan"))

#' @rdname int_methods
setMethod(
  "cell_cspan", "CellValue",
  function(obj) attr(obj, "colspan", exact = TRUE)
) ## obj@colspan)

#' @rdname int_methods
setGeneric(
  "cell_cspan<-",
  function(obj, value) standardGeneric("cell_cspan<-")
)

#' @rdname int_methods
setMethod("cell_cspan<-", "CellValue", function(obj, value) {
  ##  obj@colspan <- value
  attr(obj, "colspan") <- value
  obj
})

#' @rdname int_methods
setGeneric("cell_align", function(obj) standardGeneric("cell_align"))

#' @rdname int_methods
setMethod(
  "cell_align", "CellValue",
  function(obj) attr(obj, "align", exact = TRUE) %||% "center"
) ## obj@colspan)

#' @rdname int_methods
setGeneric(
  "cell_align<-",
  function(obj, value) standardGeneric("cell_align<-")
)

#' @rdname int_methods
setMethod("cell_align<-", "CellValue", function(obj, value) {
  ##  obj@colspan <- value
  if (is.null(value)) {
    value <- "center"
  } else {
    value <- tolower(value)
  }
  check_aligns(value)
  attr(obj, "align") <- value
  obj
})

### Level (indent) in tree structure ----

#' @rdname int_methods
setGeneric("tt_level", function(obj) standardGeneric("tt_level"))

## this will hit everything via inheritence
#' @rdname int_methods
setMethod("tt_level", "VNodeInfo", function(obj) obj@level)

#' @rdname int_methods
setGeneric("tt_level<-", function(obj, value) standardGeneric("tt_level<-"))

## this will hit everyhing via inheritence
#' @rdname int_methods
setMethod("tt_level<-", "VNodeInfo", function(obj, value) {
  obj@level <- as.integer(value)
  obj
})

#' @rdname int_methods
setMethod(
  "tt_level<-", "VTableTree",
  function(obj, value) {
    obj@level <- as.integer(value)
    tree_children(obj) <- lapply(tree_children(obj),
      `tt_level<-`,
      value = as.integer(value) + 1L
    )
    obj
  }
)

#' @rdname int_methods
#' @export
setGeneric("indent_mod", function(obj) standardGeneric("indent_mod"))

#' @rdname int_methods
setMethod(
  "indent_mod", "Split",
  function(obj) obj@indent_modifier
)

#' @rdname int_methods
setMethod(
  "indent_mod", "VTableNodeInfo",
  function(obj) obj@indent_modifier
)

#' @rdname int_methods
setMethod(
  "indent_mod", "ANY",
  function(obj) attr(obj, "indent_mod", exact = TRUE) %||% 0L
)

#' @rdname int_methods
setMethod(
  "indent_mod", "RowsVerticalSection",
  ##          function(obj) setNames(obj@indent_mods,names(obj)))
  function(obj) {
    val <- attr(obj, "indent_mods", exact = TRUE) %||%
      vapply(obj, indent_mod, 1L) ## rep(0L, length(obj))
    setNames(val, names(obj))
  }
)

#' @examples
#' lyt <- basic_table() %>%
#'   split_rows_by("RACE", split_fun = keep_split_levels(c("ASIAN", "WHITE"))) %>%
#'   analyze("AGE")
#'
#' tbl <- build_table(lyt, DM)
#' indent_mod(tbl)
#' indent_mod(tbl) <- 1L
#' tbl
#'
#' @rdname int_methods
#' @export
setGeneric("indent_mod<-", function(obj, value) standardGeneric("indent_mod<-"))

#' @rdname int_methods
setMethod(
  "indent_mod<-", "Split",
  function(obj, value) {
    obj@indent_modifier <- as.integer(value)
    obj
  }
)

#' @rdname int_methods
setMethod(
  "indent_mod<-", "VTableNodeInfo",
  function(obj, value) {
    obj@indent_modifier <- as.integer(value)
    obj
  }
)

#' @rdname int_methods
setMethod(
  "indent_mod<-", "CellValue",
  function(obj, value) {
    attr(obj, "indent_mod") <- as.integer(value)
    obj
  }
)

#' @rdname int_methods
setMethod(
  "indent_mod<-", "RowsVerticalSection",
  function(obj, value) {
    if (length(value) != 1 && length(value) != length(obj)) {
      stop(
        "When setting indent mods on a RowsVerticalSection the value ",
        "must have length 1 or the number of rows"
      )
    }
    attr(obj, "indent_mods") <- as.integer(value)
    obj

    ## obj@indent_mods <- value
    ## obj
  }
)

#' @rdname int_methods
setGeneric(
  "content_indent_mod",
  function(obj) standardGeneric("content_indent_mod")
)

#' @rdname int_methods
setMethod(
  "content_indent_mod", "Split",
  function(obj) obj@content_indent_modifier
)

#' @rdname int_methods
setMethod(
  "content_indent_mod", "VTableNodeInfo",
  function(obj) obj@content_indent_modifier
)

#' @rdname int_methods
setGeneric(
  "content_indent_mod<-",
  function(obj, value) standardGeneric("content_indent_mod<-")
)

#' @rdname int_methods
setMethod(
  "content_indent_mod<-", "Split",
  function(obj, value) {
    obj@content_indent_modifier <- as.integer(value)
    obj
  }
)

#' @rdname int_methods
setMethod(
  "content_indent_mod<-", "VTableNodeInfo",
  function(obj, value) {
    obj@content_indent_modifier <- as.integer(value)
    obj
  }
)

## TODO export these?
#' @rdname int_methods
#' @export
setGeneric("rawvalues", function(obj) standardGeneric("rawvalues"))

#' @rdname int_methods
setMethod("rawvalues", "ValueWrapper", function(obj) obj@value)

#' @rdname int_methods
setMethod("rawvalues", "LevelComboSplitValue", function(obj) obj@combolevels)

#' @rdname int_methods
setMethod("rawvalues", "list", function(obj) lapply(obj, rawvalues))

#' @rdname int_methods
setMethod("rawvalues", "ANY", function(obj) obj)

#' @rdname int_methods
setMethod("rawvalues", "CellValue", function(obj) obj[[1]])

#' @rdname int_methods
setMethod(
  "rawvalues", "TreePos",
  function(obj) rawvalues(pos_splvals(obj))
)

#' @rdname int_methods
setMethod(
  "rawvalues", "RowsVerticalSection",
  function(obj) unlist(obj, recursive = FALSE)
)

#' @rdname int_methods
#' @export
setGeneric("value_names", function(obj) standardGeneric("value_names"))

#' @rdname int_methods
setMethod(
  "value_names", "ANY",
  function(obj) as.character(rawvalues(obj))
)

#' @rdname int_methods
setMethod(
  "value_names", "TreePos",
  function(obj) value_names(pos_splvals(obj))
)

#' @rdname int_methods
setMethod(
  "value_names", "list",
  function(obj) lapply(obj, value_names)
)

#' @rdname int_methods
setMethod(
  "value_names", "ValueWrapper",
  function(obj) rawvalues(obj)
)

#' @rdname int_methods
setMethod(
  "value_names", "LevelComboSplitValue",
  function(obj) obj@value
) ## obj@comboname)

#' @rdname int_methods
setMethod(
  "value_names", "RowsVerticalSection",
  function(obj) attr(obj, "row_names", exact = TRUE)
) ## obj@row_names)

## not sure if I need these anywhere
## XXX
#' @rdname int_methods
setGeneric("value_labels", function(obj) standardGeneric("value_labels"))

#' @rdname int_methods
setMethod("value_labels", "ANY", function(obj) as.character(obj_label(obj)))

#' @rdname int_methods
setMethod(
  "value_labels", "TreePos",
  function(obj) sapply(pos_splvals(obj), obj_label)
)

#' @rdname int_methods
setMethod("value_labels", "list", function(obj) {
  ret <- lapply(obj, obj_label)
  if (!is.null(names(obj))) {
    inds <- vapply(ret, function(x) length(x) == 0, NA)
    ret[inds] <- names(obj)[inds]
  }
  ret
})

#' @rdname int_methods
setMethod(
  "value_labels",
  "RowsVerticalSection",
  function(obj) setNames(attr(obj, "row_labels", exact = TRUE), value_names(obj))
)

#' @rdname int_methods
setMethod("value_labels", "ValueWrapper", function(obj) obj_label(obj))

#' @rdname int_methods
setMethod(
  "value_labels", "LevelComboSplitValue",
  function(obj) obj_label(obj)
)

#' @rdname int_methods
setMethod("value_labels", "MultiVarSplit", function(obj) obj@var_labels)

#' @rdname int_methods
setGeneric("value_expr", function(obj) standardGeneric("value_expr"))
#' @rdname int_methods
setMethod("value_expr", "ValueWrapper", function(obj) obj@subset_expression)
#' @rdname int_methods
setMethod("value_expr", "ANY", function(obj) NULL)
## no setters for now, we'll see about that.

#' @rdname int_methods
setGeneric("spl_varlabels", function(obj) standardGeneric("spl_varlabels"))

#' @rdname int_methods
setMethod("spl_varlabels", "MultiVarSplit", function(obj) obj@var_labels)

#' @rdname int_methods
setGeneric(
  "spl_varlabels<-",
  function(object, value) standardGeneric("spl_varlabels<-")
)

#' @rdname int_methods
setMethod("spl_varlabels<-", "MultiVarSplit", function(object, value) {
  object@var_labels <- value
  object
})

## These two are similar enough we could probably combine
## them but conceptually they are pretty different
## split_exargs is a list of extra arguments that apply
## to *all the chidlren*,
## while splv_extra is for *child-specific* extra arguments,
## associated with specific values of the split
#' @rdname int_methods
setGeneric("splv_extra", function(obj) standardGeneric("splv_extra"))

#' @rdname int_methods
setMethod(
  "splv_extra", "SplitValue",
  function(obj) obj@extra
)

#' @rdname int_methods
setGeneric(
  "splv_extra<-",
  function(obj, value) standardGeneric("splv_extra<-")
)
#' @rdname int_methods
setMethod(
  "splv_extra<-", "SplitValue",
  function(obj, value) {
    obj@extra <- value
    obj
  }
)

#' @rdname int_methods
setGeneric("split_exargs", function(obj) standardGeneric("split_exargs"))

#' @rdname int_methods
setMethod(
  "split_exargs", "Split",
  function(obj) obj@extra_args
)

#' @rdname int_methods
setGeneric(
  "split_exargs<-",
  function(obj, value) standardGeneric("split_exargs<-")
)

#' @rdname int_methods
setMethod(
  "split_exargs<-", "Split",
  function(obj, value) {
    obj@extra_args <- value
    obj
  }
)

is_labrow <- function(obj) is(obj, "LabelRow")

spl_ref_group <- function(obj) {
  stopifnot(is(obj, "VarLevWBaselineSplit"))
  obj@ref_group_value
}

### column info

#' Column information/structure accessors
#'
#' @inheritParams gen_args
#' @param df (`data.frame` or `NULL`)\cr data to use if the column information is being
#'   generated from a pre-data layout object.
#' @param path (`character` or `NULL`)\cr `col_counts` accessor and setter only.
#'   Path (in column structure).
#' @param rtpos (`TreePos`)\cr root position.
#'
#' @return A `LayoutColTree` object.
#'
#' @rdname col_accessors
#' @export
setGeneric("clayout", function(obj) standardGeneric("clayout"))

#' @rdname col_accessors
#' @exportMethod clayout
setMethod(
  "clayout", "VTableNodeInfo",
  function(obj) coltree(col_info(obj))
)

#' @rdname col_accessors
#' @exportMethod clayout
setMethod(
  "clayout", "PreDataTableLayouts",
  function(obj) obj@col_layout
)

## useful convenience for the cascading methods in colby_constructors
#' @rdname col_accessors
#' @exportMethod clayout
setMethod("clayout", "ANY", function(obj) PreDataColLayout())

#' @rdname col_accessors
#' @export
setGeneric("clayout<-", function(object, value) standardGeneric("clayout<-"))

#' @rdname col_accessors
#' @exportMethod clayout<-
setMethod(
  "clayout<-", "PreDataTableLayouts",
  function(object, value) {
    object@col_layout <- value
    object
  }
)

#' @rdname col_accessors
#' @export
setGeneric("col_info", function(obj) standardGeneric("col_info"))

#' @rdname col_accessors
#' @exportMethod col_info
setMethod(
  "col_info", "VTableNodeInfo",
  function(obj) obj@col_info
)

### XXX I've made this recursive. Do we ALWAYS want it to be?
###
### I think we do.
#' @rdname col_accessors
#' @export
setGeneric("col_info<-", function(obj, value) standardGeneric("col_info<-"))

#' @return Returns various information about columns, depending on the accessor used.
#'
#' @exportMethod col_info<-
#' @rdname col_accessors
setMethod(
  "col_info<-", "TableRow",
  function(obj, value) {
    obj@col_info <- value
    obj
  }
)

.set_cinfo_kids <- function(obj) {
  kids <- lapply(
    tree_children(obj),
    function(x) {
      col_info(x) <- col_info(obj)
      x
    }
  )
  tree_children(obj) <- kids
  obj
}

#' @rdname col_accessors
#' @exportMethod col_info<-
setMethod(
  "col_info<-", "ElementaryTable",
  function(obj, value) {
    obj@col_info <- value
    .set_cinfo_kids(obj)
  }
)

#' @rdname col_accessors
#' @exportMethod col_info<-
setMethod(
  "col_info<-", "TableTree",
  function(obj, value) {
    obj@col_info <- value
    if (nrow(content_table(obj))) {
      ct <- content_table(obj)
      col_info(ct) <- value
      content_table(obj) <- ct
    }
    .set_cinfo_kids(obj)
  }
)

#' @rdname col_accessors
#' @param ccount_format (`FormatSpec`)\cr The format to be used by default for column
#' counts throughout this column tree (i.e. if not overridden by a more specific format
#' specification).
#' @export
setGeneric(
  "coltree",
  function(obj, df = NULL, rtpos = TreePos(), alt_counts_df = df, ccount_format = "(N=xx)") standardGeneric("coltree")
)

#' @rdname col_accessors
#' @exportMethod coltree
setMethod(
  "coltree", "InstantiatedColumnInfo",
  function(obj, df = NULL, rtpos = TreePos(), alt_counts_df = df, ccount_format) {
    if (!is.null(df)) {
      warning("Ignoring df argument and retrieving already-computed LayoutColTree")
    }
    obj@tree_layout
  }
)

#' @rdname col_accessors
#' @export coltree
setMethod(
  "coltree", "PreDataTableLayouts",
  function(obj, df, rtpos, alt_counts_df = df, ccount_format) {
    coltree(clayout(obj), df, rtpos, alt_counts_df = alt_counts_df, ccount_format = ccount_format)
  }
)

#' @rdname col_accessors
#' @export coltree
setMethod(
  "coltree", "PreDataColLayout",
  function(obj, df, rtpos, alt_counts_df = df, ccount_format) {
    obj <- set_def_child_ord(obj, df)
    kids <- lapply(
      obj,
      function(x) {
        splitvec_to_coltree(
          df = df,
          splvec = x,
          pos = rtpos,
          alt_counts_df = alt_counts_df,
          global_cc_format = ccount_format
        )
      }
    )
    if (length(kids) == 1) {
      res <- kids[[1]]
    } else {
      res <- LayoutColTree(
        lev = 0L,
        kids = kids,
        tpos = rtpos,
        spl = RootSplit(),
        colcount = NROW(alt_counts_df),
        colcount_format = ccount_format
      )
    }
    disp_ccounts(res) <- disp_ccounts(obj)
    res
  }
)

#' @rdname col_accessors
#' @export coltree
setMethod(
  "coltree", "LayoutColTree",
  function(obj, df, rtpos, alt_counts_df, ccount_format) obj
)

#' @rdname col_accessors
#' @export coltree
setMethod(
  "coltree", "VTableTree",
  function(obj, df, rtpos, alt_counts_df, ccount_format) coltree(col_info(obj))
)

#' @rdname col_accessors
#' @export coltree
setMethod(
  "coltree", "TableRow",
  function(obj, df, rtpos, alt_counts_df, ccount_format) coltree(col_info(obj))
)

setGeneric("coltree<-", function(obj, value) standardGeneric("coltree<-"))
setMethod(
  "coltree<-", c("InstantiatedColumnInfo", "LayoutColTree"),
  function(obj, value) {
    obj@tree_layout <- value
    obj
  }
)

setMethod(
  "coltree<-", c("VTableTree", "LayoutColTree"),
  function(obj, value) {
    cinfo <- col_info(obj)
    coltree(cinfo) <- value
    col_info(obj) <- cinfo
    obj
  }
)

#' @rdname col_accessors
#' @export
setGeneric("col_exprs", function(obj, df = NULL) standardGeneric("col_exprs"))

#' @rdname col_accessors
#' @export col_exprs
setMethod(
  "col_exprs", "PreDataTableLayouts",
  function(obj, df = NULL) col_exprs(clayout(obj), df)
)

#' @rdname col_accessors
#' @export col_exprs
setMethod(
  "col_exprs", "PreDataColLayout",
  function(obj, df = NULL) {
    if (is.null(df)) {
      stop("can't determine col_exprs without data")
    }
    ct <- coltree(obj, df = df)
    make_col_subsets(ct, df = df)
  }
)

#' @rdname col_accessors
#' @export col_exprs
setMethod(
  "col_exprs", "InstantiatedColumnInfo",
  function(obj, df = NULL) {
    if (!is.null(df)) {
      warning("Ignoring df method when extracted precomputed column subsetting expressions.")
    }
    obj@subset_exprs
  }
)

#' @rdname int_methods
setGeneric("col_extra_args", function(obj, df = NULL) standardGeneric("col_extra_args"))

#' @rdname int_methods
setMethod(
  "col_extra_args", "InstantiatedColumnInfo",
  function(obj, df) {
    if (!is.null(df)) {
      warning("Ignorning df when retrieving already-computed column extra arguments.")
    }
    obj@cextra_args
  }
)

#' @rdname int_methods
setMethod(
  "col_extra_args", "PreDataTableLayouts",
  function(obj, df) col_extra_args(clayout(obj), df)
)

#' @rdname int_methods
setMethod(
  "col_extra_args", "PreDataColLayout",
  function(obj, df) {
    col_extra_args(coltree(obj, df), NULL)
  }
)

#' @rdname int_methods
setMethod(
  "col_extra_args", "LayoutColTree",
  function(obj, df) {
    if (!is.null(df)) {
      warning("Ignoring df argument and returning already calculated extra arguments")
    }
    get_col_extras(obj)
  }
)

#' @rdname int_methods
setMethod(
  "col_extra_args", "LayoutColLeaf",
  function(obj, df) {
    if (!is.null(df)) {
      warning("Ignoring df argument and returning already calculated extra arguments")
    }

    get_pos_extra(pos = tree_pos(obj))
  }
)

#' @seealso [facet_colcount()]
#' @export
#' @rdname col_accessors
setGeneric("col_counts", function(obj, path = NULL) standardGeneric("col_counts"))

#' @export
#' @rdname col_accessors
setMethod(
  "col_counts", "InstantiatedColumnInfo",
  function(obj, path = NULL) {
    if (is.null(path)) {
      lfs <- collect_leaves(coltree(obj))
      ret <- vapply(lfs, facet_colcount, 1L, path = NULL)
    } else {
      ret <- facet_colcount(obj, path)
    }
    ## required for strict backwards compatibility,
    ## even though its undesirable behavior.
    unname(ret)
  }
)

#' @export
#' @rdname col_accessors
setMethod(
  "col_counts", "VTableNodeInfo",
  function(obj, path = NULL) col_counts(col_info(obj), path = path)
)

#' @export
#' @rdname col_accessors
setGeneric("col_counts<-", function(obj, path = NULL, value) standardGeneric("col_counts<-"))

#' @export
#' @rdname col_accessors
setMethod(
  "col_counts<-", "InstantiatedColumnInfo",
  function(obj, path = NULL, value) {
    ## obj@counts[.path_to_pos(path, obj, cols = TRUE)] <- value
    ## obj
    if (!is.null(path)) {
      all_paths <- list(path)
    } else {
      all_paths <- make_col_df(obj, visible_only = TRUE)$path
    }
    if (length(value) != length(all_paths)) {
      stop(
        "Got ", length(value), " values for ",
        length(all_paths), " column paths",
        if (is.null(path)) " (from path = NULL)",
        "."
      )
    }
    ctree <- coltree(obj)
    for (i in seq_along(all_paths)) {
      facet_colcount(ctree, all_paths[[i]]) <- value[i]
    }
    coltree(obj) <- ctree
    obj
  }
)

#' @export
#' @rdname col_accessors
setMethod(
  "col_counts<-", "VTableNodeInfo",
  function(obj, path = NULL, value) {
    cinfo <- col_info(obj)
    col_counts(cinfo, path = path) <- value
    col_info(obj) <- cinfo
    obj
  }
)

#' @export
#' @rdname col_accessors
setGeneric("col_total", function(obj) standardGeneric("col_total"))

#' @export
#' @rdname col_accessors
setMethod(
  "col_total", "InstantiatedColumnInfo",
  function(obj) obj@total_count
)

#' @export
#' @rdname col_accessors
setMethod(
  "col_total", "VTableNodeInfo",
  function(obj) col_total(col_info(obj))
)

#' @export
#' @rdname col_accessors
setGeneric("col_total<-", function(obj, value) standardGeneric("col_total<-"))

#' @export
#' @rdname col_accessors
setMethod(
  "col_total<-", "InstantiatedColumnInfo",
  function(obj, value) {
    ## all methods funnel to this one so ensure integer-ness here.
    obj@total_count <- as.integer(value)
    obj
  }
)

#' @export
#' @rdname col_accessors
setMethod(
  "col_total<-", "VTableNodeInfo",
  function(obj, value) {
    cinfo <- col_info(obj)
    col_total(cinfo) <- value
    col_info(obj) <- cinfo
    obj
  }
)

#' @rdname int_methods
setGeneric("disp_ccounts", function(obj) standardGeneric("disp_ccounts"))

#' @rdname int_methods
setMethod(
  "disp_ccounts", "VTableTree",
  function(obj) disp_ccounts(col_info(obj))
)

#' @rdname int_methods
setMethod(
  "disp_ccounts", "InstantiatedColumnInfo",
  function(obj) obj@display_columncounts
)

#' @rdname int_methods
setMethod(
  "disp_ccounts", "PreDataTableLayouts",
  function(obj) disp_ccounts(clayout(obj))
)

#' @rdname int_methods
setMethod(
  "disp_ccounts", "PreDataColLayout",
  function(obj) obj@display_columncounts
)

#' @rdname int_methods
setMethod(
  "disp_ccounts", "LayoutColTree",
  function(obj) obj@display_columncounts
)

#' @rdname int_methods
setMethod(
  "disp_ccounts", "LayoutColLeaf",
  function(obj) obj@display_columncounts
)

#' @rdname int_methods
setMethod(
  "disp_ccounts", "Split",
  function(obj) obj@child_show_colcounts
)

#' @rdname int_methods
setGeneric("disp_ccounts<-", function(obj, value) standardGeneric("disp_ccounts<-"))

#' @rdname int_methods
setMethod(
  "disp_ccounts<-", "VTableTree",
  function(obj, value) {
    cinfo <- col_info(obj)
    disp_ccounts(cinfo) <- value
    col_info(obj) <- cinfo
    obj
  }
)

#' @rdname int_methods
setMethod(
  "disp_ccounts<-", "InstantiatedColumnInfo",
  function(obj, value) {
    obj@display_columncounts <- value
    obj
  }
)

#' @rdname int_methods
setMethod(
  "disp_ccounts<-", "PreDataColLayout",
  function(obj, value) {
    obj@display_columncounts <- value
    obj
  }
)

#' @rdname int_methods
setMethod(
  "disp_ccounts<-", "LayoutColTree",
  function(obj, value) {
    obj@display_columncounts <- value
    obj
  }
)

#' @rdname int_methods
setMethod(
  "disp_ccounts<-", "LayoutColLeaf",
  function(obj, value) {
    obj@display_columncounts <- value
    obj
  }
)

#' @rdname int_methods
setMethod(
  "disp_ccounts<-", "PreDataTableLayouts",
  function(obj, value) {
    clyt <- clayout(obj)
    disp_ccounts(clyt) <- value
    clayout(obj) <- clyt
    obj
  }
)


## this is a horrible hack but when we have non-nested siblings at the top level
## the beginning of the "path <-> position" relationship breaks down.
## we probably *should* have e.g., c("root", "top_level_splname_1",
## "top_level_splname_1, "top_level_splname_1_value", ...)
## but its pretty clear why no one will be happy with that, I think
## so we punt on the problem for now with an explicit workaround
##
## those first non-nested siblings currently have (incorrect)
## empty tree_pos elements so we just look at the obj_name

pos_singleton_path <- function(obj) {
  pos <- tree_pos(obj)
  splvals <- pos_splvals(pos)
  length(splvals) == 0 ||
    (length(splvals) == 1 && is.na(unlist(value_names(splvals))))
}

## close to a duplicate of tt_at_path, but... not quite :(
#' @rdname int_methods
coltree_at_path <- function(obj, path, ...) {
  if (length(path) == 0) {
    return(obj)
  }
  stopifnot(
    is(path, "character"),
    length(path) > 0
  )
  if (any(grepl("@content", path, fixed = TRUE))) {
    stop("@content token is not valid for column paths.")
  }

  cur <- obj
  curpath <- pos_to_path(tree_pos(obj)) # path
  num_consume_path <- 2
  while (!identical(curpath, path) && !is(cur, "LayoutColLeaf")) { # length(curpath) > 0) {
    kids <- tree_children(cur)
    kidmatch <- find_kid_path_match(kids, path)
    if (length(kidmatch) == 0) {
      stop(
        "unable to match full path: ", paste(path, sep = "->"),
        "\n path of last match: ", paste(curpath, sep = "->")
      )
    }
    cur <- kids[[kidmatch]]
    curpath <- pos_to_path(tree_pos(cur))
  }
  cur
}

find_kid_path_match <- function(kids, path) {
  if (length(kids) == 0) {
    return(integer())
  }
  kidpaths <- lapply(kids, function(k) pos_to_path(tree_pos(k)))

  matches <- vapply(kidpaths, function(kpth) identical(path[seq_along(kpth)], kpth), NA)
  firstkidpos <- tree_pos(kids[[1]])
  if (all(matches) && pos_singleton_path(kids[[1]])) {
    kidpaths <- lapply(seq_along(kidpaths), function(i) c(kidpaths[[i]], obj_name(kids[[i]])))
    matches <- vapply(kidpaths, function(kpth) identical(path[seq_along(kpth)], kpth), NA)
  }
  which(matches)
}


## almost a duplicate of recursive_replace, but I spent a bunch
## of time ramming my head against the different way pathing happens
## in column space (unfortunately) before giving up building
## coltree_at_path around recursive_replace, so here we are.

ct_recursive_replace <- function(ctree, path, value, pos = 1) {
  pos <- tree_pos(ctree)
  curpth <- pos_to_path(pos)
  if (identical(path, curpth)) {
    return(value)
  } else if (is(ctree, "LayoutColLeaf")) {
    stop(
      "unable to match full path: ", paste(path, sep = "->"),
      "\n path at leaf: ", paste(curpth, sep = "->")
    )
  }
  kids <- tree_children(ctree)
  kids_singl <- pos_singleton_path(kids[[1]])
  kidind <- find_kid_path_match(kids, path)

  if (length(kidind) == 0) {
    stop("Path appears invalid for this tree at step ", path[1])
  } else if (length(kidind) > 1) {
    stop(
      "singleton step (root, cbind_root, etc) in path appears to have matched multiple children. ",
      "This shouldn't happen, please contact the maintainers."
    )
  }

  kids[[kidind]] <- ct_recursive_replace(
    kids[[kidind]],
    path, value
  )
  tree_children(ctree) <- kids
  ctree
}

`coltree_at_path<-` <- function(obj, path, value) {
  obj <- ct_recursive_replace(obj, path, value)
  obj
}

#' Set visibility of column counts for a group of sibling facets
#'
#' @inheritParams gen_args
#' @param path (`character`)\cr the path *to the parent of the
#'   desired siblings*. The last element in the path should
#'   be a split name.
#' @return obj, modified with the desired column count.
#'   display behavior
#'
#' @seealso [colcount_visible()]
#'
#' @export
`facet_colcounts_visible<-` <- function(obj, path, value) {
  coldf <- make_col_df(obj, visible_only = FALSE)
  allpaths <- coldf$path
  lenpath <- length(path)
  match_paths <- vapply(allpaths, function(path_i) {
    (length(path_i) == lenpath + 1) &&
      (all(head(path_i, -1) == path))
  }, TRUE)
  for (curpath in allpaths[match_paths]) {
    colcount_visible(obj, curpath) <- value
  }
  obj
}

#' Get or set column count for a facet in column space
#'
#' @inheritParams gen_args
#' @param path character. This path must end on a
#' split value, e.g., the level of a categorical variable
#' that was split on in column space, but it need not
#' be the path to an individual column.
#'
#' @return for `facet_colcount` the current count associated
#' with that facet in column space, for `facet_colcount<-`,
#' `obj` modified with the new column count for the specified
#' facet.
#'
#' @note Updating a lower-level (more specific)
#' column count manually **will not** update the
#' counts for its parent facets. This cannot be made
#' automatic because the rtables framework does not
#' require sibling facets to be mutually exclusive
#' (e.g., total "arm", faceting into cumulative
#' quantiles, etc) and thus the count of a parent facet
#' will not always be simply the sum of the counts for
#' all of its children.
#'
#' @seealso [col_counts()]
#'
#' @examples
#' lyt <- basic_table() %>%
#'   split_cols_by("ARM", show_colcounts = TRUE) %>%
#'   split_cols_by("SEX",
#'     split_fun = keep_split_levels(c("F", "M")),
#'     show_colcounts = TRUE
#'   ) %>%
#'   split_cols_by("STRATA1", show_colcounts = TRUE) %>%
#'   analyze("AGE")
#'
#' tbl <- build_table(lyt, ex_adsl)
#'
#' facet_colcount(tbl, c("ARM", "A: Drug X"))
#' facet_colcount(tbl, c("ARM", "A: Drug X", "SEX", "F"))
#' facet_colcount(tbl, c("ARM", "A: Drug X", "SEX", "F", "STRATA1", "A"))
#'
#' ## modify specific count after table creation
#' facet_colcount(tbl, c("ARM", "A: Drug X", "SEX", "F", "STRATA1", "A")) <- 25
#'
#' ## show black space for certain counts by assign NA
#'
#' facet_colcount(tbl, c("ARM", "A: Drug X", "SEX", "F", "STRATA1", "C")) <- NA
#'
#' @export
setGeneric(
  "facet_colcount",
  function(obj, path) standardGeneric("facet_colcount")
)

#' @rdname facet_colcount
#' @export
setMethod(
  "facet_colcount", "LayoutColTree",
  function(obj, path = NULL) {
    ## if(length(path) == 0L)
    ##   stop("face_colcount requires a non-null path") #nocov
    subtree <- coltree_at_path(obj, path)
    subtree@column_count
  }
)

#' @rdname facet_colcount
#' @export
setMethod(
  "facet_colcount", "LayoutColLeaf",
  function(obj, path = NULL) {
    ## not sure if we should check for null here as above
    obj@column_count
  }
)

#' @rdname facet_colcount
#' @export
setMethod(
  "facet_colcount", "VTableTree",
  function(obj, path) facet_colcount(coltree(obj), path = path)
)

#' @rdname facet_colcount
#' @export
setMethod(
  "facet_colcount", "InstantiatedColumnInfo",
  function(obj, path) facet_colcount(coltree(obj), path = path)
)

#' @rdname facet_colcount
#' @export
setGeneric(
  "facet_colcount<-",
  function(obj, path, value) standardGeneric("facet_colcount<-")
)

#' @rdname facet_colcount
#' @export
setMethod(
  "facet_colcount<-", "LayoutColTree",
  function(obj, path, value) {
    ct <- coltree_at_path(obj, path)
    ct@column_count <- as.integer(value)
    coltree_at_path(obj, path) <- ct
    obj
  }
)

#' @rdname facet_colcount
#' @export
setMethod(
  "facet_colcount<-", "LayoutColLeaf",
  function(obj, path, value) {
    obj@column_count <- as.integer(value)
    obj
  }
)

#' @rdname facet_colcount
#' @export
setMethod(
  "facet_colcount<-", "VTableTree",
  function(obj, path, value) {
    cinfo <- col_info(obj)
    facet_colcount(cinfo, path) <- value
    col_info(obj) <- cinfo
    obj
  }
)

#' @rdname facet_colcount
#' @export
setMethod(
  "facet_colcount<-", "InstantiatedColumnInfo",
  function(obj, path, value) {
    ct <- coltree(obj)
    facet_colcount(ct, path) <- value
    coltree(obj) <- ct
    obj
  }
)

#' Value and Visibility of specific column counts by path
#'
#' @inheritParams gen_args
#'
#' @return for `colcount_visible` a logical scalar
#' indicating whether the specified position in
#' the column hierarchy is set to display its column count;
#' for `colcount_visible<-`, `obj` updated with
#' the specified count displaying behavior set.
#'
#' @note Users generally should not call `colcount_visible`
#' directly, as setting sibling facets to have differing
#' column count visibility will result in an error when
#' printing or paginating the table.
#'
#' @export
setGeneric("colcount_visible", function(obj, path) standardGeneric("colcount_visible"))

#' @rdname colcount_visible
#' @export
setMethod(
  "colcount_visible", "VTableTree",
  function(obj, path) colcount_visible(coltree(obj), path)
)

#' @rdname colcount_visible
#' @export
setMethod(
  "colcount_visible", "InstantiatedColumnInfo",
  function(obj, path) colcount_visible(coltree(obj), path)
)

#' @rdname colcount_visible
#' @export
setMethod(
  "colcount_visible", "LayoutColTree",
  function(obj, path) {
    subtree <- coltree_at_path(obj, path)
    disp_ccounts(subtree)
  }
)

#' @rdname colcount_visible
#' @export
setGeneric("colcount_visible<-", function(obj, path, value) standardGeneric("colcount_visible<-"))

#' @rdname colcount_visible
#' @export
setMethod(
  "colcount_visible<-", "VTableTree",
  function(obj, path, value) {
    ctree <- coltree(obj)
    colcount_visible(ctree, path) <- value
    coltree(obj) <- ctree
    obj
  }
)

#' @rdname colcount_visible
#' @export
setMethod(
  "colcount_visible<-", "InstantiatedColumnInfo",
  function(obj, path, value) {
    ctree <- coltree(obj)
    colcount_visible(ctree, path) <- value
    coltree(obj) <- ctree
    obj
  }
)


#' @rdname colcount_visible
#' @export
setMethod(
  "colcount_visible<-", "LayoutColTree",
  function(obj, path, value) {
    subtree <- coltree_at_path(obj, path)
    disp_ccounts(subtree) <- value
    coltree_at_path(obj, path) <- subtree
    obj
  }
)

#' @rdname int_methods
#' @export
setGeneric("colcount_format", function(obj) standardGeneric("colcount_format"))

#' @rdname int_methods
#' @export
setMethod(
  "colcount_format", "InstantiatedColumnInfo",
  function(obj) obj@columncount_format
)

#' @rdname int_methods
#' @export
setMethod(
  "colcount_format", "VTableNodeInfo",
  function(obj) colcount_format(col_info(obj))
)

#' @rdname int_methods
#' @export
setMethod(
  "colcount_format", "PreDataColLayout",
  function(obj) obj@columncount_format
)

#' @rdname int_methods
#' @export
setMethod(
  "colcount_format", "PreDataTableLayouts",
  function(obj) colcount_format(clayout(obj))
)

#' @rdname int_methods
#' @export
setMethod(
  "colcount_format", "Split",
  function(obj) obj@child_colcount_format
)

#' @rdname int_methods
#' @export
setMethod(
  "colcount_format", "LayoutColTree",
  function(obj) obj@columncount_format
)

#' @rdname int_methods
#' @export
setMethod(
  "colcount_format", "LayoutColLeaf",
  function(obj) obj@columncount_format
)


#' @rdname int_methods
#' @export
setGeneric(
  "colcount_format<-",
  function(obj, value) standardGeneric("colcount_format<-")
)

#' @export
#' @rdname int_methods
setMethod(
  "colcount_format<-", "InstantiatedColumnInfo",
  function(obj, value) {
    obj@columncount_format <- value
    obj
  }
)

#' @rdname int_methods
#' @export
setMethod(
  "colcount_format<-", "VTableNodeInfo",
  function(obj, value) {
    cinfo <- col_info(obj)
    colcount_format(cinfo) <- value
    col_info(obj) <- cinfo
    obj
  }
)

#' @rdname int_methods
#' @export
setMethod(
  "colcount_format<-", "PreDataColLayout",
  function(obj, value) {
    obj@columncount_format <- value
    obj
  }
)

#' @rdname int_methods
#' @export
setMethod(
  "colcount_format<-", "PreDataTableLayouts",
  function(obj, value) {
    clyt <- clayout(obj)
    colcount_format(clyt) <- value
    clayout(obj) <- clyt
    obj
  }
)

## It'd probably be better if this had the full set of methods as above
## but its not currently modelled in the class and probably isn't needed
## super much
#' @rdname int_methods
#' @export
setGeneric("colcount_na_str", function(obj) standardGeneric("colcount_na_str"))

#' @rdname int_methods
#' @export
setMethod(
  "colcount_na_str", "InstantiatedColumnInfo",
  function(obj) obj@columncount_na_str
)

#' @rdname int_methods
#' @export
setMethod(
  "colcount_na_str", "VTableNodeInfo",
  function(obj) colcount_na_str(col_info(obj))
)

#' @rdname int_methods
#' @export
setGeneric(
  "colcount_na_str<-",
  function(obj, value) standardGeneric("colcount_na_str<-")
)

#' @export
#' @rdname int_methods
setMethod(
  "colcount_na_str<-", "InstantiatedColumnInfo",
  function(obj, value) {
    obj@columncount_na_str <- value
    obj
  }
)

#' @rdname int_methods
#' @export
setMethod(
  "colcount_na_str<-", "VTableNodeInfo",
  function(obj, value) {
    cinfo <- col_info(obj)
    colcount_na_str(cinfo) <- value
    col_info(obj) <- cinfo
    obj
  }
)

#' Exported for use in `tern`
#'
#' Does the `table`/`row`/`InstantiatedColumnInfo` object contain no column structure information?
#'
#' @inheritParams gen_args
#'
#' @return `TRUE` if the object has no/empty instantiated column information, `FALSE` otherwise.
#'
#' @rdname no_info
#' @export
setGeneric("no_colinfo", function(obj) standardGeneric("no_colinfo"))

#' @exportMethod no_colinfo
#' @rdname no_info
setMethod(
  "no_colinfo", "VTableNodeInfo",
  function(obj) no_colinfo(col_info(obj))
)

#' @exportMethod no_colinfo
#' @rdname no_info
setMethod(
  "no_colinfo", "InstantiatedColumnInfo",
  function(obj) length(obj@subset_exprs) == 0
) ## identical(obj, EmptyColInfo))

#' Names of a `TableTree`
#'
#' @param x (`TableTree`)\cr the object.
#'
#' @details
#' For `TableTree`s with more than one level of splitting in columns, the names are defined to be the top-level
#' split values repped out across the columns that they span.
#'
#' @return The column names of `x`, as defined in the details above.
#'
#' @exportMethod names
#' @rdname names
setMethod(
  "names", "VTableNodeInfo",
  function(x) names(col_info(x))
)

#' @rdname names
#' @exportMethod names
setMethod(
  "names", "InstantiatedColumnInfo",
  function(x) names(coltree(x))
)

#' @rdname names
#' @exportMethod names
setMethod(
  "names", "LayoutColTree",
  function(x) {
    unname(unlist(lapply(
      tree_children(x),
      function(obj) {
        nm <- obj_name(obj)
        rep(nm, n_leaves(obj))
      }
    )))
  }
)

#' @rdname names
#' @exportMethod row.names
setMethod(
  "row.names", "VTableTree",
  function(x) {
    unname(sapply(collect_leaves(x, add.labrows = TRUE),
      obj_label,
      USE.NAMES = FALSE
    )) ## XXXX this should probably be obj_name???
  }
)

#' Convert to a vector
#'
#' Convert an `rtables` framework object into a vector, if possible. This is unlikely to be useful in
#' realistic scenarios.
#'
#' @param x (`ANY`)\cr the object to be converted to a vector.
#' @param mode (`string`)\cr passed on to [as.vector()].
#'
#' @return A vector of the chosen mode (or an error is raised if more than one row was present).
#'
#' @note This only works for a table with a single row or a row object.
#'
#' @name asvec
#' @aliases as.vector,VTableTree-method
#' @exportMethod as.vector
setMethod("as.vector", "VTableTree", function(x, mode) {
  stopifnot(nrow(x) == 1L)
  if (nrow(content_table(x)) == 1L) {
    tab <- content_table(x)
  } else {
    tab <- x
  }
  as.vector(tree_children(tab)[[1]], mode = mode)
})

#' @inheritParams asvec
#'
#' @rdname int_methods
#' @exportMethod as.vector
setMethod("as.vector", "TableRow", function(x, mode) as.vector(unlist(row_values(x)), mode = mode))

#' @rdname int_methods
#' @exportMethod as.vector
setMethod("as.vector", "ElementaryTable", function(x, mode) {
  stopifnot(nrow(x) == 1L)
  as.vector(tree_children(x)[[1]], mode = mode)
})

## cuts ----

#' @rdname int_methods
setGeneric("spl_cuts", function(obj) standardGeneric("spl_cuts"))

#' @rdname int_methods
setMethod(
  "spl_cuts", "VarStaticCutSplit",
  function(obj) obj@cuts
)

#' @rdname int_methods
setGeneric("spl_cutlabels", function(obj) standardGeneric("spl_cutlabels"))

#' @rdname int_methods
setMethod(
  "spl_cutlabels", "VarStaticCutSplit",
  function(obj) obj@cut_labels
)

#' @rdname int_methods
setGeneric("spl_cutfun", function(obj) standardGeneric("spl_cutfun"))

#' @rdname int_methods
setMethod(
  "spl_cutfun", "VarDynCutSplit",
  function(obj) obj@cut_fun
)

#' @rdname int_methods
setGeneric("spl_cutlabelfun", function(obj) standardGeneric("spl_cutlabelfun"))

#' @rdname int_methods
setMethod(
  "spl_cutlabelfun", "VarDynCutSplit",
  function(obj) obj@cut_label_fun
)

#' @rdname int_methods
setGeneric("spl_is_cmlcuts", function(obj) standardGeneric("spl_is_cmlcuts"))

#' @rdname int_methods
setMethod(
  "spl_is_cmlcuts", "VarDynCutSplit",
  function(obj) obj@cumulative_cuts
)

#' @rdname int_methods
setGeneric(
  "spl_varnames",
  function(obj) standardGeneric("spl_varnames")
)

#' @rdname int_methods
setMethod(
  "spl_varnames", "MultiVarSplit",
  function(obj) obj@var_names
)

#' @rdname int_methods
setGeneric(
  "spl_varnames<-",
  function(object, value) standardGeneric("spl_varnames<-")
)

#' @rdname int_methods
setMethod(
  "spl_varnames<-", "MultiVarSplit",
  function(object, value) {
    oldvnms <- spl_varnames(object)
    oldvlbls <- spl_varlabels(object)
    object@var_names <- value
    if (identical(oldvnms, oldvlbls)) {
      spl_varlabels(object) <- value
    }
    object
  }
)

#' Top left material
#'
#' A `TableTree` object can have *top left material* which is a sequence of strings which are printed in the
#' area of the table between the column header display and the label of the first row. These functions access
#' and modify that material.
#'
#' @inheritParams gen_args
#'
#' @return A character vector representing the top-left material of `obj` (or `obj` after modification, in the
#'   case of the setter).
#'
#' @export
#' @rdname top_left
setGeneric("top_left", function(obj) standardGeneric("top_left"))

#' @export
#' @rdname top_left
setMethod("top_left", "VTableTree", function(obj) top_left(col_info(obj)))

#' @export
#' @rdname top_left
setMethod("top_left", "InstantiatedColumnInfo", function(obj) obj@top_left)

#' @export
#' @rdname top_left
setMethod("top_left", "PreDataTableLayouts", function(obj) obj@top_left)

#' @export
#' @rdname top_left
setGeneric("top_left<-", function(obj, value) standardGeneric("top_left<-"))

#' @export
#' @rdname top_left
setMethod("top_left<-", "VTableTree", function(obj, value) {
  cinfo <- col_info(obj)
  top_left(cinfo) <- value
  col_info(obj) <- cinfo
  obj
})

#' @export
#' @rdname top_left
setMethod("top_left<-", "InstantiatedColumnInfo", function(obj, value) {
  obj@top_left <- value
  obj
})

#' @export
#' @rdname top_left
setMethod("top_left<-", "PreDataTableLayouts", function(obj, value) {
  obj@top_left <- value
  obj
})

vil_collapse <- function(x) {
  x <- unlist(x)
  x <- x[!is.na(x)]
  x <- unique(x)
  x[nzchar(x)]
}

#' List variables required by a pre-data table layout
#'
#' @param lyt (`PreDataTableLayouts`)\cr the layout (or a component thereof).
#'
#' @details
#' This will walk the layout declaration and return a vector of the names of the unique variables that are used
#' in any of the following ways:
#'
#'   * Variable being split on (directly or via cuts)
#'   * Element of a Multi-variable column split
#'   * Content variable
#'   * Value-label variable
#'
#' @return A character vector containing the unique variables explicitly used in the layout (see the notes below).
#'
#' @note
#' * This function will not detect dependencies implicit in analysis or summary functions which accept `x`
#'   or `df` and then rely on the existence of particular variables not being split on/analyzed.
#' * The order these variable names appear within the return vector is undefined and should not be relied upon.
#'
#' @examples
#' lyt <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   split_cols_by("SEX") %>%
#'   summarize_row_groups(label_fstr = "Overall (N)") %>%
#'   split_rows_by("RACE",
#'     split_label = "Ethnicity", labels_var = "ethn_lab",
#'     split_fun = drop_split_levels
#'   ) %>%
#'   summarize_row_groups("RACE", label_fstr = "%s (n)") %>%
#'   analyze("AGE", var_labels = "Age", afun = mean, format = "xx.xx")
#'
#' vars_in_layout(lyt)
#'
#' @export
#' @rdname vil
setGeneric("vars_in_layout", function(lyt) standardGeneric("vars_in_layout"))

#' @rdname vil
setMethod(
  "vars_in_layout", "PreDataTableLayouts",
  function(lyt) {
    vil_collapse(c(
      vars_in_layout(clayout(lyt)),
      vars_in_layout(rlayout(lyt))
    ))
  }
)

#' @rdname vil
setMethod(
  "vars_in_layout", "PreDataAxisLayout",
  function(lyt) {
    vil_collapse(lapply(lyt, vars_in_layout))
  }
)

#' @rdname vil
setMethod(
  "vars_in_layout", "SplitVector",
  function(lyt) {
    vil_collapse(lapply(lyt, vars_in_layout))
  }
)

#' @rdname vil
setMethod(
  "vars_in_layout", "Split",
  function(lyt) {
    vil_collapse(c(
      spl_payload(lyt),
      ## for an AllSplit/RootSplit
      ## doesn't have to be same as payload
      content_var(lyt),
      spl_label_var(lyt)
    ))
  }
)

#' @rdname vil
setMethod(
  "vars_in_layout", "CompoundSplit",
  function(lyt) vil_collapse(lapply(spl_payload(lyt), vars_in_layout))
)

#' @rdname vil
setMethod(
  "vars_in_layout", "ManualSplit",
  function(lyt) character()
)

## Titles and footers ----

# ##' Titles and Footers
# ##'
# ##' Get or set the titles and footers on an object
# ##'
# ##' @inheritParams gen_args
# ##'
# ##' @rdname title_footer
# ##' @export
#' @rdname formatters_methods
#' @export
setMethod(
  "main_title", "VTitleFooter",
  function(obj) obj@main_title
)

##' @rdname formatters_methods
##' @export
setMethod(
  "main_title<-", "VTitleFooter",
  function(obj, value) {
    stopifnot(length(value) == 1)
    obj@main_title <- value
    obj
  }
)

# Getters for TableRow is here for convenience for binding (no need of setters)
#' @rdname formatters_methods
#' @export
setMethod(
  "main_title", "TableRow",
  function(obj) ""
)

#' @rdname formatters_methods
#' @export
setMethod(
  "subtitles", "VTitleFooter",
  function(obj) obj@subtitles
)

#' @rdname formatters_methods
#' @export
setMethod(
  "subtitles<-", "VTitleFooter",
  function(obj, value) {
    obj@subtitles <- value
    obj
  }
)

#' @rdname formatters_methods
#' @export
setMethod(
  "subtitles", "TableRow", # Only getter: see main_title for TableRow
  function(obj) character()
)

#' @rdname formatters_methods
#' @export
setMethod(
  "main_footer", "VTitleFooter",
  function(obj) obj@main_footer
)

#' @rdname formatters_methods
#' @export
setMethod(
  "main_footer<-", "VTitleFooter",
  function(obj, value) {
    obj@main_footer <- value
    obj
  }
)

#' @rdname formatters_methods
#' @export
setMethod(
  "main_footer", "TableRow", # Only getter: see main_title for TableRow
  function(obj) character()
)

#' @rdname formatters_methods
#' @export
setMethod(
  "prov_footer", "VTitleFooter",
  function(obj) obj@provenance_footer
)

#' @rdname formatters_methods
#' @export
setMethod(
  "prov_footer<-", "VTitleFooter",
  function(obj, value) {
    obj@provenance_footer <- value
    obj
  }
)

#' @rdname formatters_methods
#' @export
setMethod(
  "prov_footer", "TableRow", # Only getter: see main_title for TableRow
  function(obj) character()
)

make_ref_value <- function(value) {
  if (is(value, "RefFootnote")) {
    value <- list(value)
  } else if (!is.list(value) || any(!sapply(value, is, "RefFootnote"))) {
    value <- lapply(value, RefFootnote)
  }
  value
}

#' Referential footnote accessors
#'
#' Access and set the referential footnotes aspects of a built table.
#'
#' @inheritParams gen_args
#'
#' @export
#' @rdname ref_fnotes
setGeneric("row_footnotes", function(obj) standardGeneric("row_footnotes"))

#' @export
#' @rdname int_methods
setMethod(
  "row_footnotes", "TableRow",
  function(obj) obj@row_footnotes
)

#' @export
#' @rdname int_methods
setMethod(
  "row_footnotes", "RowsVerticalSection",
  function(obj) attr(obj, "row_footnotes", exact = TRUE) %||% list()
)

#' @export
#' @rdname ref_fnotes
setGeneric("row_footnotes<-", function(obj, value) standardGeneric("row_footnotes<-"))

#' @export
#' @rdname int_methods
setMethod(
  "row_footnotes<-", "TableRow",
  function(obj, value) {
    obj@row_footnotes <- make_ref_value(value)
    obj
  }
)

#' @export
#' @rdname int_methods
setMethod(
  "row_footnotes", "VTableTree",
  function(obj) {
    rws <- collect_leaves(obj, TRUE, TRUE)
    cells <- lapply(rws, row_footnotes)
    cells
  }
)

#' @export
#' @rdname ref_fnotes
setGeneric("cell_footnotes", function(obj) standardGeneric("cell_footnotes"))

#' @export
#' @rdname int_methods
setMethod(
  "cell_footnotes", "CellValue",
  function(obj) attr(obj, "footnotes", exact = TRUE) %||% list()
)

#' @export
#' @rdname int_methods
setMethod(
  "cell_footnotes", "TableRow",
  function(obj) {
    ret <- lapply(row_cells(obj), cell_footnotes)
    if (length(ret) != ncol(obj)) {
      ret <- rep(ret, row_cspans(obj))
    }
    ret
  }
)

#' @export
#' @rdname int_methods
setMethod(
  "cell_footnotes", "LabelRow",
  function(obj) {
    rep(list(list()), ncol(obj))
  }
)

#' @export
#' @rdname int_methods
setMethod(
  "cell_footnotes", "VTableTree",
  function(obj) {
    rws <- collect_leaves(obj, TRUE, TRUE)
    cells <- lapply(rws, cell_footnotes)
    do.call(rbind, cells)
  }
)

#' @export
#' @rdname ref_fnotes
setGeneric("cell_footnotes<-", function(obj, value) standardGeneric("cell_footnotes<-"))

#' @export
#' @rdname int_methods
setMethod(
  "cell_footnotes<-", "CellValue",
  function(obj, value) {
    attr(obj, "footnotes") <- make_ref_value(value)
    obj
  }
)

.cfn_set_helper <- function(obj, value) {
  if (length(value) != ncol(obj)) {
    stop("Did not get the right number of footnote ref values for cell_footnotes<- on a full row.")
  }

  row_cells(obj) <- mapply(
    function(cell, fns) {
      if (is.list(fns)) {
        cell_footnotes(cell) <- lapply(fns, RefFootnote)
      } else {
        cell_footnotes(cell) <- list(RefFootnote(fns))
      }
      cell
    },
    cell = row_cells(obj),
    fns = value, SIMPLIFY = FALSE
  )
  obj
}

#' @export
#' @rdname int_methods
setMethod("cell_footnotes<-", "DataRow",
  definition = .cfn_set_helper
)

#' @export
#' @rdname int_methods
setMethod("cell_footnotes<-", "ContentRow",
  definition = .cfn_set_helper
)

# Deprecated methods ----

#' @export
#' @rdname ref_fnotes
setGeneric("col_fnotes_here", function(obj) standardGeneric("col_fnotes_here"))

#' @export
#' @rdname ref_fnotes
setMethod("col_fnotes_here", "ANY", function(obj) {
  lifecycle::deprecate_warn(
    when = "0.6.6",
    what = "col_fnotes_here()",
    with = "col_footnotes()"
  )
  col_footnotes(obj)
})

#' @export
#' @rdname ref_fnotes
setGeneric("col_fnotes_here<-", function(obj, value) standardGeneric("col_fnotes_here<-"))

#' @export
#' @rdname int_methods
setMethod("col_fnotes_here<-", "ANY", function(obj, value) {
  lifecycle::deprecate_warn(
    when = "0.6.6",
    what = I("col_fnotes_here()<-"),
    with = I("col_footnotes()<-")
  )
  col_footnotes(obj) <- value
})

#' @export
#' @rdname ref_fnotes
setGeneric("col_footnotes", function(obj) standardGeneric("col_footnotes"))

#' @export
#' @rdname int_methods
setMethod("col_footnotes", "LayoutColTree", function(obj) obj@col_footnotes)

#' @export
#' @rdname int_methods
setMethod("col_footnotes", "LayoutColLeaf", function(obj) obj@col_footnotes)

#' @export
#' @rdname ref_fnotes
setGeneric("col_footnotes<-", function(obj, value) standardGeneric("col_footnotes<-"))

#' @export
#' @rdname int_methods
setMethod("col_footnotes<-", "LayoutColTree", function(obj, value) {
  obj@col_footnotes <- make_ref_value(value)
  obj
})

#' @export
#' @rdname int_methods
setMethod("col_footnotes<-", "LayoutColLeaf", function(obj, value) {
  obj@col_footnotes <- make_ref_value(value)
  obj
})

#' @export
#' @rdname int_methods
setMethod(
  "col_footnotes", "VTableTree",
  function(obj) {
    ctree <- coltree(obj)
    cols <- tree_children(ctree)
    while (all(sapply(cols, is, "LayoutColTree"))) {
      cols <- lapply(cols, tree_children)
      cols <- unlist(cols, recursive = FALSE)
    }
    all_col_fnotes <- lapply(cols, col_footnotes)
    if (is.null(unlist(all_col_fnotes))) {
      return(NULL)
    }

    all_col_fnotes
  }
)

#' @export
#' @rdname ref_fnotes
setGeneric("ref_index", function(obj) standardGeneric("ref_index"))

#' @export
#' @rdname int_methods
setMethod(
  "ref_index", "RefFootnote",
  function(obj) obj@index
)

#' @export
#' @rdname ref_fnotes
setGeneric("ref_index<-", function(obj, value) standardGeneric("ref_index<-"))

#' @export
#' @rdname int_methods
setMethod(
  "ref_index<-", "RefFootnote",
  function(obj, value) {
    obj@index <- value
    obj
  }
)

#' @export
#' @rdname ref_fnotes
setGeneric("ref_symbol", function(obj) standardGeneric("ref_symbol"))

#' @export
#' @rdname int_methods
setMethod(
  "ref_symbol", "RefFootnote",
  function(obj) obj@symbol
)

#' @export
#' @rdname ref_fnotes
setGeneric("ref_symbol<-", function(obj, value) standardGeneric("ref_symbol<-"))

#' @export
#' @rdname int_methods
setMethod(
  "ref_symbol<-", "RefFootnote",
  function(obj, value) {
    obj@symbol <- value
    obj
  }
)

#' @export
#' @rdname ref_fnotes
setGeneric("ref_msg", function(obj) standardGeneric("ref_msg"))

#' @export
#' @rdname int_methods
setMethod(
  "ref_msg", "RefFootnote",
  function(obj) obj@value
)

setGeneric(".fnote_set_inner<-", function(ttrp, colpath, value) standardGeneric(".fnote_set_inner<-"))

setMethod(
  ".fnote_set_inner<-", c("TableRow", "NULL"),
  function(ttrp, colpath, value) {
    row_footnotes(ttrp) <- value
    ttrp
  }
)

setMethod(
  ".fnote_set_inner<-", c("TableRow", "character"),
  function(ttrp, colpath, value) {
    ind <- .path_to_pos(path = colpath, tt = ttrp, cols = TRUE)
    cfns <- cell_footnotes(ttrp)
    cfns[[ind]] <- value
    cell_footnotes(ttrp) <- cfns
    ttrp
  }
)

setMethod(
  ".fnote_set_inner<-", c("InstantiatedColumnInfo", "character"),
  function(ttrp, colpath, value) {
    ctree <- col_fnotes_at_path(coltree(ttrp), colpath, fnotes = value)
    coltree(ttrp) <- ctree
    ttrp
  }
)

setMethod(
  ".fnote_set_inner<-", c("VTableTree", "ANY"),
  function(ttrp, colpath, value) {
    if (labelrow_visible(ttrp) && !is.null(value)) {
      lblrw <- tt_labelrow(ttrp)
      row_footnotes(lblrw) <- value
      tt_labelrow(ttrp) <- lblrw
    } else if (NROW(content_table(ttrp)) == 1L) {
      ctbl <- content_table(ttrp)
      pth <- make_row_df(ctbl)$path[[1]]
      fnotes_at_path(ctbl, pth, colpath) <- value
      content_table(ttrp) <- ctbl
    } else {
      stop("an error occurred. this shouldn't happen. please contact the maintainer") # nocov
    }
    ttrp
  }
)

#' @param rowpath (`character` or `NULL`)\cr path within row structure. `NULL` indicates the footnote should
#'   go on the column rather than cell.
#' @param colpath (`character` or `NULL`)\cr path within column structure. `NULL` indicates footnote should go
#'   on the row rather than cell.
#' @param reset_idx (`flag`)\cr whether the numbering for referential footnotes should be immediately
#'   recalculated. Defaults to `TRUE`.
#'
#' @examples
#' # How to add referencial footnotes after having created a table
#' lyt <- basic_table() %>%
#'   split_rows_by("SEX", page_by = TRUE) %>%
#'   analyze("AGE")
#'
#' tbl <- build_table(lyt, DM)
#' tbl <- trim_rows(tbl)
#' # Check the row and col structure to add precise references
#' # row_paths(tbl)
#' # col_paths(t)
#' # row_paths_summary(tbl)
#' # col_paths_summary(tbl)
#'
#' # Add the citation numbers on the table and relative references in the footnotes
#' fnotes_at_path(tbl, rowpath = c("SEX", "F", "AGE", "Mean")) <- "Famous paper 1"
#' fnotes_at_path(tbl, rowpath = c("SEX", "UNDIFFERENTIATED")) <- "Unfamous paper 2"
#' # tbl
#'
#' @seealso [row_paths()], [col_paths()], [row_paths_summary()], [col_paths_summary()]
#'
#' @export
#' @rdname ref_fnotes
setGeneric("fnotes_at_path<-", function(obj,
                                        rowpath = NULL,
                                        colpath = NULL,
                                        reset_idx = TRUE,
                                        value) {
  standardGeneric("fnotes_at_path<-")
})

## non-null rowpath, null or non-null colpath
#' @inheritParams fnotes_at_path<-
#'
#' @export
#' @rdname int_methods
setMethod(
  "fnotes_at_path<-", c("VTableTree", "character"),
  function(obj,
           rowpath = NULL,
           colpath = NULL,
           reset_idx = TRUE,
           value) {
    rw <- tt_at_path(obj, rowpath)
    .fnote_set_inner(rw, colpath) <- value
    tt_at_path(obj, rowpath) <- rw
    if (reset_idx) {
      obj <- update_ref_indexing(obj)
    }
    obj
  }
)

#' @export
#' @rdname int_methods
setMethod(
  "fnotes_at_path<-", c("VTableTree", "NULL"),
  function(obj, rowpath = NULL, colpath = NULL, reset_idx = TRUE, value) {
    cinfo <- col_info(obj)
    .fnote_set_inner(cinfo, colpath) <- value
    col_info(obj) <- cinfo
    if (reset_idx) {
      obj <- update_ref_indexing(obj)
    }
    obj
  }
)

#' @export
#' @rdname int_methods
setGeneric("has_force_pag", function(obj) standardGeneric("has_force_pag"))

#' @exportMethod has_force_pag
#' @rdname int_methods
setMethod("has_force_pag", "TableTree", function(obj) !is.na(ptitle_prefix(obj)))

#' @exportMethod has_force_pag
#' @rdname int_methods
setMethod("has_force_pag", "Split", function(obj) !is.na(ptitle_prefix(obj)))

#' @exportMethod has_force_pag
#' @rdname int_methods
setMethod("has_force_pag", "VTableNodeInfo", function(obj) FALSE)

setGeneric("ptitle_prefix", function(obj) standardGeneric("ptitle_prefix"))

setMethod("ptitle_prefix", "TableTree", function(obj) obj@page_title_prefix)

setMethod("ptitle_prefix", "Split", function(obj) obj@page_title_prefix)

setMethod("ptitle_prefix", "ANY", function(obj) NULL)

setMethod("page_titles", "VTableTree", function(obj) obj@page_titles)

setMethod("page_titles<-", "VTableTree", function(obj, value) {
  obj@page_titles <- value
  obj
})

## Horizontal separator --------------------------------------------------------

#' Access or recursively set header-body separator for tables
#'
#' @inheritParams gen_args
#' @param value (`string`)\cr string to use as new header/body separator.
#'
#' @return
#' * `horizontal_sep` returns the string acting as the header separator.
#' * `horizontal_sep<-` returns `obj`, with the new header separator applied recursively to it and all its
#'   subtables.
#'
#' @export
setGeneric("horizontal_sep", function(obj) standardGeneric("horizontal_sep"))

#' @rdname horizontal_sep
#' @export
setMethod(
  "horizontal_sep", "VTableTree",
  function(obj) obj@horizontal_sep
)

#' @rdname horizontal_sep
#' @export
setGeneric("horizontal_sep<-", function(obj, value) standardGeneric("horizontal_sep<-"))

#' @rdname horizontal_sep
#' @export
setMethod(
  "horizontal_sep<-", "VTableTree",
  function(obj, value) {
    cont <- content_table(obj)
    if (NROW(cont) > 0) {
      horizontal_sep(cont) <- value
      content_table(obj) <- cont
    }

    kids <- lapply(tree_children(obj),
      `horizontal_sep<-`,
      value = value
    )

    tree_children(obj) <- kids
    obj@horizontal_sep <- value
    obj
  }
)

#' @rdname horizontal_sep
#' @export
setMethod(
  "horizontal_sep<-", "TableRow",
  function(obj, value) obj
)

## Section dividers ------------------------------------------------------------

# Used for splits
setGeneric("spl_section_div", function(obj) standardGeneric("spl_section_div"))

setMethod(
  "spl_section_div", "Split",
  function(obj) obj@child_section_div
)

setGeneric("spl_section_div<-", function(obj, value) standardGeneric("spl_section_div<-"))

setMethod(
  "spl_section_div<-", "Split",
  function(obj, value) {
    obj@child_section_div <- value
    obj
  }
)

# Used for table object parts
setGeneric("trailing_section_div", function(obj) standardGeneric("trailing_section_div"))
setMethod("trailing_section_div", "VTableTree", function(obj) obj@trailing_section_div)
setMethod("trailing_section_div", "LabelRow", function(obj) obj@trailing_section_div)
setMethod("trailing_section_div", "TableRow", function(obj) obj@trailing_section_div)

setGeneric("trailing_section_div<-", function(obj, value) standardGeneric("trailing_section_div<-"))
setMethod("trailing_section_div<-", "VTableTree", function(obj, value) {
  obj@trailing_section_div <- value
  obj
})
setMethod("trailing_section_div<-", "LabelRow", function(obj, value) {
  obj@trailing_section_div <- value
  obj
})
setMethod("trailing_section_div<-", "TableRow", function(obj, value) {
  obj@trailing_section_div <- value
  obj
})

#' Section dividers accessor and setter
#'
#' `section_div` can be used to set or get the section divider for a table object
#' produced by [build_table()]. When assigned in post-processing (`section_div<-`)
#' the table can have a section divider after every row, each assigned independently.
#' If assigning during layout creation, only [split_rows_by()] (and its related row-wise
#' splits) and [analyze()] have a `section_div` parameter that will produce separators
#' between split sections and data subgroups, respectively. These two approaches
#' generally should not be mixed (see Details).
#'
#' @inheritParams gen_args
#' @param obj (`VTableTree`)\cr table object. This can be of any class that inherits from `VTableTree`
#'   or `TableRow`/`LabelRow`.
#' @param only_sep_sections (`flag`)\cr defaults to `FALSE` for `section_div<-`. Allows
#'   you to set the section divider only for sections that are splits or analyses if the number of
#'   values is less than the number of rows in the table. If `TRUE`, the section divider will
#'   be set for all rows of the table.
#' @param value (`character`)\cr vector of strings to use as section dividers
#'   (a single string for `section_div_at_path<-`). Each string's character(s)
#'   are repeated to the full width of the printed table. Non-`NA` strings
#'   will result in a trailing separator at the associated location (see Details);
#'   values of `NA_character_` result in no visible divider when the table is printed/exported.
#'   For `section_div<-`, `value`'s length should the number of rows in `obj`,
#'   when    `only_sep_sections` is `FALSE` and should be less than or equal to
#'   the maximum number of nested split/analyze steps anywhere in the
#'   layout corresponding to the table when `only_sep_sections` is `TRUE`.
#'   See the Details section below for more information.
#'
#' @return The section divider string. Each line that does not have a trailing separator
#'   will have `NA_character_` as section divider.
#'
#' @seealso [basic_table()] parameter `header_section_div` and `top_level_section_div` for global
#'   section dividers.
#'
#' @details
#'
#' Section dividers provide visual breaks between structural elements
#'   of a table in row space. They are repeated to fill a full line of
#'   the table and printed after the element (row, subtable) they are
#'   associated with. Use a value of `" "` to display a blank line
#'   section divider in the table. A section divider of
#'   `NA_character_` indicates no visible divider (i.e., no line at all)
#'   should be printed for that row or section when rendering the table.
#'
#' When multiple section dividers would appear consecutively with no
#'  rows between them (e.g., a subtable and its last row both having a
#'  section divider set), only the *least specific* section divider
#'  (the subtable divider in this example) will be displayed when
#'  rendering the table. This is to avoid multiple non-informative
#'  lines of consecutive dividers when there is nested splitting in
#'  the row structure of a table.
#'
#' `section_div_at_path<-` accepts a single path (which can include
#'   the `'*'` wildcard), and a single string in `value` and sets the
#'   section divider on the element(s) of `obj` that the path resolve
#'   to.
#'
#' For `section_div<-` `value` should be a character vector. When you
#'   want to only affect sections or splits, please use
#'   `only_sep_sections` or provide a shorter vector than the number
#'   of rows.  Ideally, the length of the vector should be less than
#'   the number of splits with, eventually, the leaf-level,
#'   i.e. `DataRow` where analyze results are. Note that if only one
#'   value is inserted, only the first split will be affected.  If
#'   `only_sep_sections = TRUE`, which is the default for
#'   `section_div()` produced from the table construction, the section
#'   divider will be set for all the splits and eventually analyses,
#'   but not for the header or each row of the table. This can be set
#'   with `header_section_div` in [basic_table()] or, eventually, with
#'   `hsep` in [build_table()]. If `only_sep_sections` is `FALSE`,
#'   "section" dividers will be set for each row in the table
#'   *including content and label rows*.
#'
#' In `section_div<-`, when `only_sep_sections` is `FALSE`
#'   *all higher order section divs are removed, even when new value
#'   for a row that they would apply to is `NA`*.
#'
#' @note Section dividers which would appear after the last row of the
#'     table (ie those on the last row or last elementary subtable in
#'     the table) are never printed when rendering the table.
#'
#' @note when called on an individual row object, `section_div` and
#'   `section_div<-` get and set the trialing divider for that row.
#'   In generally this is to be avoided; when manually constructing
#'   row objects, the `trailing_section_div` argument can set the
#'   trailing divider directly during creation.
#'
#' @examples
#' # Data
#' df <- data.frame(
#'   cat = c(
#'     "really long thing its so ", "long"
#'   ),
#'   value = c(6, 3, 10, 1)
#' )
#' fast_afun <- function(x) list("m" = rcell(mean(x), format = "xx."), "m/2" = max(x) / 2)
#'
#' tbl <- basic_table() %>%
#'   split_rows_by("cat", section_div = "~") %>%
#'   analyze("value", afun = fast_afun, section_div = " ") %>%
#'   build_table(df)
#'
#' # Getter
#' section_div(tbl)
#'
#' # Setter
#' section_div(tbl) <- letters[seq_len(nrow(tbl))]
#' tbl
#'
#' # last letter can appear if there is another table
#' rbind(tbl, tbl)
#'
#' # header_section_div
#' header_section_div(tbl) <- "+"
#' tbl
#'
#' @docType methods
#' @rdname section_div
#' @export
setGeneric("section_div", function(obj) standardGeneric("section_div"))

#' @rdname section_div
#' @aliases section_div,VTableTree-method
setMethod("section_div", "VTableTree", function(obj) {
  ## simpler but slower because it currently calls make_row_df then subsets
  ## section_div_info(obj)$trailing_sep
  ## TODO reimplement section_div_info based on logic here then
  ## replace code below with single call above
  content_row_tbl <- content_table(obj)
  is_content_table <- isS4(content_row_tbl) && nrow(content_row_tbl) > 0 # otherwise NA or NULL
  if (labelrow_visible(obj)) {
    lrdiv <- trailing_section_div(tt_labelrow(obj))
  } else {
    lrdiv <- NULL
  }

  if (is_content_table) {
    ctdivs <- section_div(content_row_tbl)
  } else {
    ctdivs <- NULL
  }
  section_div <- trailing_section_div(obj)
  rest_of_tree <- section_div(tree_children(obj))
  ## Case it is the section itself and not the labels to have a trailing sep
  if (!is.na(section_div)) {
    rest_of_tree[length(rest_of_tree)] <- section_div
  }
  unname(c(lrdiv, ctdivs, rest_of_tree))
})

#' @rdname section_div
#' @aliases section_div,list-method
setMethod("section_div", "list", function(obj) {
  unlist(lapply(obj, section_div))
})

#' @rdname section_div
#' @aliases section_div,TableRow-method
setMethod("section_div", "TableRow", function(obj) {
  trailing_section_div(obj)
})


# section_div setter from table object
#' @rdname section_div
#' @export
setGeneric("section_div<-", function(obj, only_sep_sections = FALSE, value) {
  standardGeneric("section_div<-")
})

#' @rdname section_div
#' @aliases section_div<-,VTableTree-method
setMethod("section_div<-", "VTableTree", function(obj, only_sep_sections = FALSE, value) {
  sdf <- section_div_info(obj)
  value <- as.character(value)
  pths <- sdf$path
  if (length(value) < length(pths)) {
    only_sep_sections <- TRUE
  }
  ## I really don't like this but it should be the correct generalization
  ## of the previous behavior :(
  if (only_sep_sections) {
    curpth <- c(if (grepl("root", obj_name(obj))) "*", "*") # root split and val)
    for (i in seq_along(value)) {
      v <- value[i]
      found <- FALSE
      ## split-value pairs (or multi-analysis analysis pairs...)
      if (tt_row_path_exists(obj, curpth, tt_type = "table")) {
        section_div_at_path(obj, curpth, tt_type = "table") <- v
        found <- TRUE
      }
      ## last step was an analysis instead of another split_value pair
      ## remember, currently only analyze and summarize_row_groups
      ## create elementary tables, and an odd number of *s will never
      ## resolve to a content table, so this tt_type means analysis
      ## table in this context
      if (tt_row_path_exists(obj, head(curpth, -1), tt_type = "elemtable")) {
        section_div_at_path(obj, head(curpth, -1), tt_type = "elemtable") <- v
        found <- TRUE
      }
      if (!found) {
        warning(
          "Unable to find ", ceiling(length(curpth) / 2), " levels of nesting",
          " in table structure. Ignoring remaining ", length(value) - i,
          " section_div values."
        )
        break
      }
      curpth <- c(curpth, "*", "*") ## add another split/value pair level of nesting
    }
  } else { ## guaranteed length(value) >= nrow(obj)
    if (length(value) > nrow(obj)) {
      warning(
        "Got more section_div values than rows. Ignoring ",
        nrow(obj) - length(value), " values."
      )
      value <- value[seq_len(nrow(obj))]
    }
    ## clear out the structural (ie from layout) section divs so all
    ## the row divs take effect. Not sure this is right but its the existing behavior
    obj <- clear_subtable_sectdivs(obj)
    for (i in seq_along(pths)) {
      section_div_at_path(obj, labelrow = TRUE, pths[[i]], tt_type = "row") <- value[i]
    }
  }
  obj
})

#' @rdname section_div
#' @aliases section_div<-,TableRow-method
setMethod("section_div<-", "TableRow", function(obj, only_sep_sections = FALSE, value) {
  trailing_section_div(obj) <- value
  obj
})

#' @rdname section_div
#' @export
setGeneric("header_section_div", function(obj) standardGeneric("header_section_div"))

#' @rdname section_div
#' @aliases header_section_div,PreDataTableLayouts-method
setMethod(
  "header_section_div", "PreDataTableLayouts",
  function(obj) obj@header_section_div
)

#' @rdname section_div
#' @aliases header_section_div,PreDataTableLayouts-method
setMethod(
  "header_section_div", "VTableTree",
  function(obj) obj@header_section_div
)

#' @rdname section_div
#' @export
setGeneric("header_section_div<-", function(obj, value) standardGeneric("header_section_div<-"))

#' @rdname section_div
#' @aliases header_section_div<-,PreDataTableLayouts-method
setMethod(
  "header_section_div<-", "PreDataTableLayouts",
  function(obj, value) {
    .check_header_section_div(value)
    obj@header_section_div <- value
    obj
  }
)

#' @rdname section_div
#' @aliases header_section_div<-,PreDataTableLayouts-method
setMethod(
  "header_section_div<-", "VTableTree",
  function(obj, value) {
    .check_header_section_div(value)
    obj@header_section_div <- value
    obj
  }
)

.check_header_section_div <- function(chr) {
  if (!is.na(chr) && (!is.character(chr) || length(chr) > 1 || nchar(chr) > 1 || nchar(chr) == 0)) {
    stop("header_section_div must be a single character or NA_character_ if not used")
  }
  invisible(TRUE)
}

#' @rdname section_div
#' @export
setGeneric("top_level_section_div", function(obj) standardGeneric("top_level_section_div"))

#' @rdname section_div
#' @aliases top_level_section_div,PreDataTableLayouts-method
setMethod(
  "top_level_section_div", "PreDataTableLayouts",
  function(obj) obj@top_level_section_div
)

#' @rdname section_div
#' @export
setGeneric("top_level_section_div<-", function(obj, value) standardGeneric("top_level_section_div<-"))

#' @rdname section_div
#' @aliases top_level_section_div<-,PreDataTableLayouts-method
setMethod(
  "top_level_section_div<-", "PreDataTableLayouts",
  function(obj, value) {
    checkmate::assert_character(value, len = 1, n.chars = 1)
    obj@top_level_section_div <- value
    obj
  }
)

#' @rdname section_div
#' @details A `section_div` -> modify -> `section_div<-` workflow will
#'     not work to modify section dividers declared in a layout (i.e.,
#'     with `split_rows_by*(., section_div=)` or
#'     `analyze(.,section_div=)`) after the table has been built. In
#'     that case a row 'inherits' its section divider behavior from
#'     the largest subtable that has a section divider set and for
#'     which it is the final row. Instead it clears the higher-order
#'     section dividers and sets an individual divider on each row
#'     (setting `NA_character_` for rows that had no divider after them
#'     when rendering). This means that if pruning is done after
#'     the above process and the last row in a "section" is pruned,
#'     the last remaining row *will not inherit the section's divider*
#'     the way it would before the modification by `section_div<-`.
#'
#' Generally it is advisable to use `section_div_at_path<-` - often
#'    with `"*"` wildcards in the path - to modify
#'    dividers declared in the layout instead of `section_div<-`.
#'    Alternatively, pruning should be done *before* calling
#'    `section_div<-` (when passing a a vector of length `nrow(tt)`),
#'    when a script or function will do both operations on a table.
#'
#' Setting section_dividers for rows which do not currently inherit
#'     section divider behavior from a containing subtable will work
#'     as expected.
#'
#' `section_div_info` returns a data.frame of section divider
#'     info (a subset of the result of `make_row_df` when called on a
#'     table tree or row object).  This information can be used to reset
#'     section dividers at the correct path via `section_div_at_path` for
#'     tables which have section dividers deriving from their layout (
#'     which will be attached to subtables, rather than rows).
#' @return For `section_div_info`, a dataframe containing `label`,
#'     `name`, "node_class", `path`, `trailing_sep` (the effective divider, whether
#'     inherited or not), `self_section_div` (the divider set on the
#'     row itself), and `sect_div_from_path` (the path to the table
#'     element the value in `trailing_sep` is inherited from, or
#'     `NA_character_` for label rows, which are not pathable).
#' @export
section_div_info <- function(obj) {
  ## default fontspec is already NULL so no speedup here
  make_row_df(obj)[, c(
    "label",
    "name",
    "node_class",
    "path",
    "trailing_sep",
    "self_section_div",
    "sect_div_from_path"
  )]
}

#' @rdname section_div
#' @param path (`character`)\cr The path of the element(s) to
#' set section_div(s) on. Can include `'*'` wildcards for
#' `section_div_at_path<-` only.
#' @param labelrow (`logical(1)`)\cr For `section_div_at_path`,
#' when `path` leads to a subtable, indicates whether the section
#' div be set/retrieved for the subtable (`FALSE`, the default) or the
#' subtable's label row (`TRUE`). Ignored when `path` resolves to an
#' individual row.
#' @export
section_div_at_path <- function(obj, path, labelrow = FALSE) {
  tt <- tt_at_path(obj, path)
  if (is(tt, "VTableTree") && labelrow) {
    tt <- tt_labelrow(tt)
  }
  trailing_section_div(tt)
}

clear_subtable_sectdivs <- function(obj) {
  rdf <- make_row_df(obj, visible_only = FALSE)
  rdf <- rdf[grepl("Table", rdf$node_class), ]
  for (pth in rdf$path) {
    section_div_at_path(obj, pth, labelrow = FALSE, tt_type = "table") <- NA_character_
  }
  obj
}

#' @rdname section_div
#' @param .prev_path (`character`)\cr Internal detail, do not manually set.
#' @export
`section_div_at_path<-` <- function(obj,
                                    path,
                                    .prev_path = character(),
                                    labelrow = FALSE,
                                    tt_type = c("any", "row", "table", "elemtable"),
                                    value = " ") {
  tt_type <- match.arg(tt_type)
  if (labelrow && tt_type == "any") {
    tt_type <- "table"
  }
  if (NROW(obj) == 0) {
    return(character())
  }

  if (path[1] == "root") {
    if (obj_name(obj) == "root") {
      .prev_path <- c(.prev_path, path[1])
    }
    path <- path[-1]
  }
  if (identical(obj_name(obj), path[1])) {
    .prev_path <- c(.prev_path, path[1])
    path <- path[-1]
  }
  curpath <- path
  subtree <- obj
  backpath <- c()
  count <- 0
  while (length(curpath) > 0) {
    curname <- curpath[1]
    if (!is(subtree, "VTableTree")) {
      stop(
        "Path continues after resolving to individual row.\n\tOccurred at path: ",
        paste(c(.prev_path, path[seq_len(count)]), collapse = " -> "),
        "\n\tRemaining unresolved path: ",
        paste(tail(path, -1 * count), collapse = "->"),
        "\nUse 'make_row_df(obj, visible_only = TRUE)[, c(\"label\", \"path\", \"node_class\")]' or \n",
        "'table_structure(obj)' to explore valid paths."
      )
    }
    oldkids <- tree_children(subtree)
    if (curname == "*") {
      oldnames <- vapply(oldkids, obj_name, "")
      if (length(curpath) > 1) {
        ## look ahead and only step into kids where the remaining path will
        ## successfully resolve
        kidmatches <- which(vapply(oldkids, tt_row_path_exists, TRUE, path = curpath[-1], tt_type = tt_type))
        if (length(kidmatches) == 0) {
          stop(
            "Unable to resolve * in path. \n\tOccurred at path: ",
            paste(c(.prev_path, path[seq_len(count + 1)]), collapse = " -> "),
            "\n\tLookahead found no matches (type ", tt_type, ") for the remaining path: ",
            paste(path[-1 * seq_len(count + 1)], collapse = "->"),
            "\nUse 'make_row_df(obj, visible_only = TRUE)[, c(\"label\", \"path\", \"node_class\")]' or \n",
            "'table_structure(obj)' to explore valid paths."
          )
        }
        newkids <- lapply(seq_along(oldkids), function(i) {
          kid <- oldkids[[i]]
          if (i %in% kidmatches) {
            new_prev_path <- c(
              .prev_path, backpath,
              paste0("* (", oldnames[i], ")")
            )
            section_div_at_path(kid,
              path = curpath[-1],
              .prev_path = new_prev_path
            ) <- value
          }
          kid
        })
      } else {
        newkids <- lapply(oldkids, function(kdi) {
          trailing_section_div(kdi) <- value
          kdi
        })
      }
      names(newkids) <- oldnames
      newtab <- subtree
      tree_children(newtab) <- newkids
      if (length(backpath) > 0) {
        ret <- recursive_replace(obj, backpath, value = newtab)
      } else {
        ret <- newtab
      }
      return(ret)
    } else if (curname == "@content") {
      ctab <- content_table(subtree)
      # curpath is just 'content' resolve to content table
      if (length(curpath) == 1) {
        trailing_section_div(ctab) <- value
        ## weird to set section divs on content rows but that is what the
        ## section_div()<- <full vector> behavior calls for
      } else if (length(curpath) == 2 && tt_row_path_exists(ctab, curpath[2])) {
        section_div_at_path(ctab, curpath[2], tt_type = "row") <- value
      } else {
        stop(
          "Unable to resolve path step involving @content \n\t occurred at path: ",
          paste(c(.prev_path, path[seq_len(count)]), collapse = " -> "),
          "\nUse 'make_row_df(obj, visible_only = TRUE)[, c(\"label\", \"path\", \"node_class\")]' or \n",
          "'table_structure(obj)' to explore valid paths."
        )
      }
      content_table(subtree) <- ctab
      if (length(backpath) > 0) {
        ret <- recursive_replace(obj, backpath, value = subtree)
      } else {
        ret <- subtree
      }
      return(ret)
    } else if (!(curname %in% names(oldkids))) {
      stop(
        "Unable to find child(ren) '", curname, "'\n\t occurred at path: ",
        paste(c(.prev_path, path[seq_len(count)]), collapse = " -> "),
        "\n  Use 'make_row_df(obj, visible_only = TRUE)[, c(\"label\", \"path\", \"node_class\")]' or \n",
        "'table_structure(obj)' to explore valid paths."
      )
    }
    subtree <- tree_children(subtree)[[curname]]
    backpath <- c(backpath, curpath[1])
    curpath <- curpath[-1]
    count <- count + 1
  }
  ## ElementaryTables have 2 modes, label row which
  ## puts the section div after the label row (weird
  ## but necessary for the replacing every row's section div
  ## case), or tree, where we set trailing div
  ## **on the subtable itself**
  ##
  ## womp womp. tt_type_ok fails for subtables when we want their label row.
  if (!tt_type_ok(subtree, tt_type) && !(labelrow && is(subtree, "VTableTree") && tt_type == "row")) {
    stop(
      "Path ",
      paste(c(.prev_path, path[seq_len(count)]), collapse = " -> "),
      " lead to an element of the wrong tt_type (got ", class(subtree),
      " expected ", tt_type
    )
  } else if (is(subtree, "TableRow") || !labelrow) {
    ## rows can only set it on themselves
    ## if its a table (and tables are allowed by tt_type) it sets it on
    ## itself iff labelrow is FALSE

    trailing_section_div(subtree) <- value
    newtree <- subtree
  } else if (labelrow && is(subtree, "VTableTree")) {
    lr <- tt_labelrow(subtree)
    trailing_section_div(lr) <- value
    tt_labelrow(subtree) <- lr
    newtree <- subtree
  }
  tt_at_path(obj, path) <- newtree
  obj
}

## table_inset ----------------------------------------------------------

#' @rdname formatters_methods
#' @export
setMethod(
  "table_inset", "VTableNodeInfo", ## VTableTree",
  function(obj) obj@table_inset
)

#' @rdname formatters_methods
#' @export
setMethod(
  "table_inset", "PreDataTableLayouts",
  function(obj) obj@table_inset
)

## #' @rdname formatters_methods
## #' @export
## setMethod("table_inset", "InstantiatedColumnInfo",
##           function(obj) obj@table_inset)

#' @rdname formatters_methods
#' @export
setMethod(
  "table_inset<-", "VTableNodeInfo", ## "VTableTree",
  function(obj, value) {
    if (!is.integer(value)) {
      value <- as.integer(value)
    }
    if (is.na(value) || value < 0) {
      stop("Got invalid table_inset value, must be an integer > 0")
    }
    cont <- content_table(obj)
    if (NROW(cont) > 0) {
      table_inset(cont) <- value
      content_table(obj) <- cont
    }

    if (length(tree_children(obj)) > 0) {
      kids <- lapply(tree_children(obj),
        `table_inset<-`,
        value = value
      )
      tree_children(obj) <- kids
    }
    obj@table_inset <- value
    obj
  }
)

#' @rdname formatters_methods
#' @export
setMethod(
  "table_inset<-", "PreDataTableLayouts",
  function(obj, value) {
    if (!is.integer(value)) {
      value <- as.integer(value)
    }
    if (is.na(value) || value < 0) {
      stop("Got invalid table_inset value, must be an integer > 0")
    }

    obj@table_inset <- value
    obj
  }
)

#' @rdname formatters_methods
#' @export
setMethod(
  "table_inset<-", "InstantiatedColumnInfo",
  function(obj, value) {
    if (!is.integer(value)) {
      value <- as.integer(value)
    }
    if (is.na(value) || value < 0) {
      stop("Got invalid table_inset value, must be an integer > 0")
    }
    obj@table_inset <- value
    obj
  }
)

# stat_names for ARD -----------------------------------------------------------
#
#' @rdname int_methods
#' @export
setGeneric("obj_stat_names", function(obj) standardGeneric("obj_stat_names"))
#
#' @rdname int_methods
#' @export
setGeneric("obj_stat_names<-", function(obj, value) standardGeneric("obj_stat_names<-"))

#' @rdname int_methods
#' @export
setMethod("obj_stat_names<-", "CellValue", function(obj, value) {
  attr(obj, "stat_names") <- value
  obj
})

#' @rdname int_methods
#' @export
setMethod("obj_stat_names", "CellValue", function(obj) attr(obj, "stat_names"))

#' @rdname int_methods
#' @export
setMethod(
  "obj_stat_names", "RowsVerticalSection",
  function(obj) lapply(obj, obj_stat_names)
)

# obj_round_type getter ---------------------------------------------------------------
#' @rdname formatters_methods
#' @exportMethod obj_round_type
setMethod("obj_round_type", "ANY", function(obj) attr(obj, "round_type", exact = TRUE))

#' generics and methods for obj_round_type
#'
#' These are internal methods that are documented only to satisfy `R CMD check`. End users should pay no
#' attention to this documentation, except for the few exported methods.
#'
#' @rdname formatters_methods
#' @exportMethod obj_round_type
#' @export
setMethod("obj_round_type", "PreDataTableLayouts", function(obj) obj@round_type)

#' @rdname formatters_methods
#' @exportMethod obj_round_type
#' @export
setMethod("obj_round_type", "VTableTree", function(obj) obj@round_type)

#' @rdname formatters_methods
#' @exportMethod obj_round_type
setMethod("obj_round_type", "TableRow", function(obj) obj@round_type)

#' @rdname formatters_methods
#' @exportMethod obj_round_type
setMethod("obj_round_type", "CellValue", function(obj) attr(obj, "round_type", exact = TRUE))

# obj_round_type setter ---------------------------------------------------------------
#' @rdname formatters_methods
#' @exportMethod obj_round_type<-
#' @export
setMethod("obj_round_type<-", "VTableTree", function(obj, value) {
  stopifnot(length(value) == 1)
  checkmate::assert_subset(value, valid_round_type)
  obj@round_type <- value
  # also set round_type to slot in children class
  tree_children(obj) <- lapply(tree_children(obj), `obj_round_type<-`, value = value)
  if (!is.null(content_table(obj))) {
    ctab <- content_table(obj)
    obj_round_type(ctab) <- value
  }
  obj
})

#' @rdname formatters_methods
#' @exportMethod obj_round_type<-
# not useful for end user, needed for recursive approach
setMethod("obj_round_type<-", "TableRow", function(obj, value) {
  obj@round_type <- value
  row_cells(obj) <- lapply(row_cells(obj), `obj_round_type<-`, value = value)
  obj
})


#' @rdname formatters_methods
#' @exportMethod obj_round_type<-
# not useful for end user, needed for recursive approach
setMethod("obj_round_type<-", "LabelRow", function(obj, value) {
  obj
})


#' @rdname formatters_methods
#' @exportMethod obj_round_type<-
setMethod("obj_round_type<-", "CellValue", function(obj, value) {
  attr(obj, "round_type") <- value
  obj
})

#' Create an `rtable` row
#'
#' @inheritParams compat_args
#' @param ... cell values.
#' @param round_type (`"iec"`, `"iec_mod"` or `"sas"`)\cr the type of rounding to perform.
#' See [round_fmt()] for details.
#'
#' @return A row object of the context-appropriate type (label or data).
#'
#' @examples
#' rrow("ABC", c(1, 2), c(3, 2), format = "xx (xx.%)")
#' rrow("")
#'
#' @family compatibility
#' @export
rrow <- function(row.name = "", ..., format = NULL, indent = 0, inset = 0L, round_type = valid_round_type) {
  round_type <- match.arg(round_type)
  vals <- list(...)
  if (is.null(row.name)) {
    row.name <- ""
  } else if (!is(row.name, "character")) {
    stop("row.name must be NULL or a character string")
  }
  if (length(vals) == 0L) {
    LabelRow(
      lev = as.integer(indent),
      label = row.name,
      name = row.name,
      vis = TRUE,
      table_inset = 0L
    )
  } else {
    csps <- as.integer(sapply(vals, function(x) {
      attr(x, "colspan", exact = TRUE) %||% 1L
    }))
    ## we have to leave the formats on the cells and NOT the row unless we were
    ## already told to do so, because row formats get clobbered  when cbinding
    ## but cell formats do not.
    ## formats = sapply(vals, obj_format)
    ## if(is.character(formats) && length(unique(formats)) == 1L && is.null(format))
    ##     format = unique(formats)
    DataRow(
      vals = vals, lev = as.integer(indent), label = row.name,
      name = row.name, ## XXX TODO
      cspan = csps,
      format = format,
      table_inset = as.integer(inset),
      round_type = round_type
    )
  }
}

#' Create an `rtable` row from a vector or list of values
#'
#' @inheritParams compat_args
#' @param ... values in vector/list form.
#' @param round_type (`"iec"`, `"iec_mod"` or `"sas"`)\cr the type of rounding to perform.
#' See [round_fmt()] for details.
#'
#' @inherit rrow return
#'
#' @examples
#' rrowl("a", c(1, 2, 3), format = "xx")
#' rrowl("a", c(1, 2, 3), c(4, 5, 6), format = "xx")
#'
#'
#' rrowl("N", table(iris$Species))
#' rrowl("N", table(iris$Species), format = "xx")
#'
#' x <- tapply(iris$Sepal.Length, iris$Species, mean, simplify = FALSE)
#'
#' rrow(row.name = "row 1", x)
#' rrow("ABC", 2, 3)
#'
#' rrowl(row.name = "row 1", c(1, 2), c(3, 4))
#' rrow(row.name = "row 2", c(1, 2), c(3, 4))
#'
#' @family compatibility
#' @export
rrowl <- function(row.name, ..., format = NULL, indent = 0, inset = 0L, round_type = valid_round_type) {
  dots <- list(...)
  args_list <- c(list(
    row.name = row.name, format = format,
    indent = indent, inset = inset,
    round_type = round_type
  ), val = unlist(lapply(dots, as.list), recursive = FALSE))
  do.call(rrow, args_list)
}

## rcell moved to tt_afun_utils.R

## inefficient trash
paste_em_n <- function(lst, n, sep = ".") {
  ret <- lst[[1]]
  if (n > 1) {
    for (i in 2:n) {
      ret <- paste(ret, lst[[i]], sep = sep)
    }
  }
  ret
}

hrows_to_colinfo <- function(rows) {
  nr <- length(rows)
  stopifnot(nr > 0)
  cspans <- lapply(rows, row_cspans)
  vals <- lapply(rows, function(x) unlist(row_values(x)))
  unqvals <- lapply(vals, unique)
  formats <- lapply(rows, obj_format)
  counts <- NULL
  if (formats[nr] == "(N=xx)" || all(sapply(row_cells(rows[[nr]]), obj_format) == "(N=xx)")) { ## count row
    counts <- vals[[nr]]
    vals <- vals[-nr]
    cspans <- cspans[-nr]
    nr <- nr - 1
  }
  ## easiest case, one header row no counts. we're done
  ## XXX could one row but cspan ever make sense????
  ## I don't think so?
  if (nr == 1) { ## && all(cspans == 1L)) {
    ret <- manual_cols(unlist(vals[[1]]))
    if (!is.null(counts)) {
      col_counts(ret) <- counts
      disp_ccounts(ret) <- TRUE
    }
    return(ret)
  }
  ## second easiest case full repeated nestin
  repvals <- mapply(function(v, csp) rep(v, times = csp),
    v = vals, csp = cspans, SIMPLIFY = FALSE
  )

  ## nr > 1 here
  fullnest <- TRUE
  for (i in 2:nr) {
    psted <- paste_em_n(repvals, i - 1)
    spl <- split(repvals[[i]], psted)
    if (!all(sapply(spl, function(x) identical(x, spl[[1]])))) {
      fullnest <- FALSE
      break
    }
  }

  ## if its full nesting we're done, so put
  ## the counts on as necessary and return.
  if (fullnest) {
    ret <- manual_cols(.lst = unqvals)
    if (!is.null(counts)) {
      col_counts(ret) <- counts
      disp_ccounts(ret) <- TRUE
    }
    return(ret)
  }

  ## booo. the fully complex case where the multiple rows
  ## really don't represent nesting at all, each top level
  ## can have different sub labels

  ## we will build it up as if it were full nesting and then prune
  ## based on the columns we actually want.

  fullcolinfo <- manual_cols(.lst = unqvals)
  fullbusiness <- names(collect_leaves(coltree(fullcolinfo)))
  wanted <- paste_em_n(repvals, nr)
  wantcols <- match(wanted, fullbusiness)
  stopifnot(all(!is.na(wantcols)))

  subset_cols(fullcolinfo, wantcols)
}

#' Create a header
#'
#' @inheritParams compat_args
#' @param ... row specifications, either as character vectors or the output from [rrow()], [DataRow()],
#'   [LabelRow()], etc.
#'
#' @return A `InstantiatedColumnInfo` object.
#'
#' @examples
#' h1 <- rheader(c("A", "B", "C"))
#' h1
#'
#' h2 <- rheader(
#'   rrow(NULL, rcell("group 1", colspan = 2), rcell("group 2", colspan = 2)),
#'   rrow(NULL, "A", "B", "A", "B")
#' )
#' h2
#'
#' @family compatibility
#' @export
rheader <- function(..., format = "xx", .lst = NULL) {
  if (!is.null(.lst)) {
    args <- .lst
  } else {
    args <- list(...)
  }
  rrows <- if (length(args) == 1 && !is(args[[1]], "TableRow")) {
    list(rrowl(row.name = NULL, val = args[[1]], format = format))
  } else if (are(args, "TableRow")) {
    args
  }

  hrows_to_colinfo(rrows)
}

.char_to_hrows <- function(hdr) {
  nlfnd <- grep("\n", hdr, fixed = TRUE)
  if (length(nlfnd) == 0) {
    return(list(rrowl(NULL, hdr)))
  }

  stopifnot(length(nlfnd) == length(hdr))
  raw <- strsplit(hdr, "\n", fixed = TRUE)
  lens <- unique(sapply(raw, length))
  stopifnot(length(lens) == 1L)
  lapply(
    seq(1, lens),
    function(i) {
      rrowl(NULL, vapply(raw, `[`, NA_character_, i = i))
    }
  )
}

#' Create a table
#'
#' @inheritParams compat_args
#' @inheritParams gen_args
#' @param header (`TableRow`, `character`, or `InstantiatedColumnInfo`)\cr information defining the header
#'   (column structure) of the table. This can be as row objects (legacy), character vectors, or an
#'   `InstantiatedColumnInfo` object.
#' @param ... rows to place in the table.
#' @param round_type (`"iec"`, `"iec_mod"` or `"sas"`)\cr the type of rounding to perform.
#' See [round_fmt()] for details.
#'
#' @return A formal table object of the appropriate type (`ElementaryTable` or `TableTree`).
#'
#' @examples
#' rtable(
#'   header = LETTERS[1:3],
#'   rrow("one to three", 1, 2, 3),
#'   rrow("more stuff", rcell(pi, format = "xx.xx"), "test", "and more")
#' )
#'
#' # Table with multirow header
#'
#' sel <- iris$Species == "setosa"
#' mtbl <- rtable(
#'   header = rheader(
#'     rrow(
#'       row.name = NULL, rcell("Sepal.Length", colspan = 2),
#'       rcell("Petal.Length", colspan = 2)
#'     ),
#'     rrow(NULL, "mean", "median", "mean", "median")
#'   ),
#'   rrow(
#'     row.name = "All Species",
#'     mean(iris$Sepal.Length), median(iris$Sepal.Length),
#'     mean(iris$Petal.Length), median(iris$Petal.Length),
#'     format = "xx.xx"
#'   ),
#'   rrow(
#'     row.name = "Setosa",
#'     mean(iris$Sepal.Length[sel]), median(iris$Sepal.Length[sel]),
#'     mean(iris$Petal.Length[sel]), median(iris$Petal.Length[sel])
#'   )
#' )
#'
#' mtbl
#'
#' names(mtbl) # always first row of header
#'
#' # Single row header
#'
#' tbl <- rtable(
#'   header = c("Treatement\nN=100", "Comparison\nN=300"),
#'   format = "xx (xx.xx%)",
#'   rrow("A", c(104, .2), c(100, .4)),
#'   rrow("B", c(23, .4), c(43, .5)),
#'   rrow(""),
#'   rrow("this is a very long section header"),
#'   rrow("estimate", rcell(55.23, "xx.xx", colspan = 2)),
#'   rrow("95% CI", indent = 1, rcell(c(44.8, 67.4), format = "(xx.x, xx.x)", colspan = 2))
#' )
#' tbl
#'
#' row.names(tbl)
#' names(tbl)
#'
#' # Subsetting
#'
#' tbl[1, ]
#' tbl[, 1]
#'
#' tbl[1, 2]
#' tbl[2, 1]
#'
#' tbl[3, 2]
#' tbl[5, 1]
#' tbl[5, 2]
#'
#' # Data Structure methods
#'
#' dim(tbl)
#' nrow(tbl)
#' ncol(tbl)
#' names(tbl)
#'
#' # Colspans
#'
#' tbl2 <- rtable(
#'   c("A", "B", "C", "D", "E"),
#'   format = "xx",
#'   rrow("r1", 1, 2, 3, 4, 5),
#'   rrow("r2", rcell("sp2", colspan = 2), "sp1", rcell("sp2-2", colspan = 2))
#' )
#' tbl2
#'
#' @family compatibility
#' @export
rtable <- function(header, ..., format = NULL, hsep = default_hsep(),
                   inset = 0L, round_type = valid_round_type) {
  round_type <- match.arg(round_type)
  if (is.character(header)) {
    header <- .char_to_hrows(header)
  } # list(rrowl(NULL, header))
  if (is.list(header)) {
    if (are(header, "TableRow")) {
      colinfo <- hrows_to_colinfo(header)
    } else if (are(header, "list")) {
      colinfo <- do.call(rheader, header)
    }
  } else if (is(header, "InstantiatedColumnInfo")) {
    colinfo <- header
  } else if (is(header, "TableRow")) {
    colinfo <- hrows_to_colinfo(list(header))
  } else {
    stop("problems")
  }

  body <- list(...)
  ## XXX this shouldn't be needed. hacky
  if (length(body) == 1 && is.list(body[[1]])) {
    body <- body[[1]]
  }
  if (are(body, "ElementaryTable") &&
    all(sapply(body, function(tb) {
      nrow(tb) == 1 && obj_name(tb) == ""
    }))) {
    body <- lapply(body, function(tb) tree_children(tb)[[1]])
  }

  TableTree(
    kids = body, format = format, cinfo = colinfo,
    labelrow = LabelRow(lev = 0L, label = "", vis = FALSE),
    hsep = hsep, inset = inset, round_type = round_type
  )
}

#' @rdname rtable
#' @export
rtablel <- function(header, ..., format = NULL, hsep = default_hsep(), inset = 0L) {
  dots <- list(...)
  args_list <- c(list(header = header, format = format, hsep = hsep, inset = inset), unlist(lapply(
    dots,
    as.list
  ), recursive = FALSE))
  do.call(rtable, args_list)
}

# All object annotations are identical (and exist)
all_annots_identical <- function(all_annots) {
  if (!is.list(all_annots)) {
    all_annots[1] != "" && length(unique(all_annots)) == 1
  } else {
    length(all_annots[[1]]) > 0 && Reduce(identical, all_annots)
  }
}

# Only first object has annotations
only_first_annot <- function(all_annots) {
  if (!is.list(all_annots)) {
    all_annots[1] != "" && all(all_annots[-1] == "")
  } else {
    length(all_annots[[1]]) > 0 && all(sapply(all_annots, length)[-1] == 0)
  }
}

#' @param gap `r lifecycle::badge("deprecated")` ignored.
#' @param check_headers `r lifecycle::badge("deprecated")` ignored.
#'
#' @return A formal table object.
#'
#' @rdname rbind
#' @aliases rbind
#' @export
rbindl_rtables <- function(x, gap = lifecycle::deprecated(), check_headers = lifecycle::deprecated()) {
  ## nocov start
  if (lifecycle::is_present(gap)) {
    lifecycle::deprecate_warn(
      when = "0.3.2",
      what = "rbindl_rtables(gap)"
    )
  }
  if (lifecycle::is_present(check_headers)) {
    lifecycle::deprecate_warn(
      when = "0.3.2",
      what = "rbindl_rtables(check_headers)"
    )
  }
  ## nocov end

  firstcols <- col_info(x[[1]])
  i <- 1
  while (no_colinfo(firstcols) && i <= length(x)) {
    firstcols <- col_info(x[[i]])
    i <- i + 1
  }

  lapply(x, function(xi) chk_compat_cinfos(x[[1]], xi)) ## col_info(xi)))

  rbind_annot <- list(
    main_title = "",
    subtitles = character(),
    main_footer = character(),
    prov_footer = character()
  )

  # Titles/footer info are (independently) retained from first object if
  # identical or missing in all other objects
  all_titles <- sapply(x, main_title)
  if (all_annots_identical(all_titles) || only_first_annot(all_titles)) {
    rbind_annot[["main_title"]] <- all_titles[[1]]
  }

  all_sts <- lapply(x, subtitles)
  if (all_annots_identical(all_sts) || only_first_annot(all_sts)) {
    rbind_annot[["subtitles"]] <- all_sts[[1]]
  }

  all_ftrs <- lapply(x, main_footer)
  if (all_annots_identical(all_ftrs) || only_first_annot(all_ftrs)) {
    rbind_annot[["main_footer"]] <- all_ftrs[[1]]
  }

  all_pfs <- lapply(x, prov_footer)
  if (all_annots_identical(all_pfs) || only_first_annot(all_pfs)) {
    rbind_annot[["prov_footer"]] <- all_pfs[[1]]
  }

  ## if we got only ElementaryTable and
  ## TableRow objects, construct a new
  ## elementary table with all the rows
  ## instead of adding nesting.

  ## we used to check for xi not being a lable row, why?? XXX
  if (all(sapply(x, function(xi) {
    (is(xi, "ElementaryTable") && !labelrow_visible(xi)) ||
      is(xi, "TableRow")
  }))) { ## && !is(xi, "LabelRow")}))) {
    x <- unlist(lapply(x, function(xi) {
      if (is(xi, "TableRow")) {
        xi
      } else {
        lst <- tree_children(xi)
        lapply(lst, indent,
          by = indent_mod(xi)
        )
      }
    }))
  }

  TableTree(
    kids = x,
    cinfo = firstcols,
    name = "rbind_root",
    label = "",
    title = rbind_annot[["main_title"]],
    subtitles = rbind_annot[["subtitles"]],
    main_footer = rbind_annot[["main_footer"]],
    prov_footer = rbind_annot[["prov_footer"]]
  )
}

#' Row-bind `TableTree` and related objects
#'
#' @param deparse.level (`numeric(1)`)\cr currently ignored.
#' @param ... (`ANY`)\cr elements to be stacked.
#'
#' @note
#' When objects are row-bound, titles and footer information is retained from the first object (if any exists) if all
#' other objects have no titles/footers or have identical titles/footers. Otherwise, all titles/footers are removed
#' and must be set for the bound table via the [formatters::main_title()], [formatters::subtitles()],
#' [formatters::main_footer()], and [formatters::prov_footer()] functions.
#'
#' @examples
#' mtbl <- rtable(
#'   header = rheader(
#'     rrow(row.name = NULL, rcell("Sepal.Length", colspan = 2), rcell("Petal.Length", colspan = 2)),
#'     rrow(NULL, "mean", "median", "mean", "median")
#'   ),
#'   rrow(
#'     row.name = "All Species",
#'     mean(iris$Sepal.Length), median(iris$Sepal.Length),
#'     mean(iris$Petal.Length), median(iris$Petal.Length),
#'     format = "xx.xx"
#'   )
#' )
#'
#' mtbl2 <- with(subset(iris, Species == "setosa"), rtable(
#'   header = rheader(
#'     rrow(row.name = NULL, rcell("Sepal.Length", colspan = 2), rcell("Petal.Length", colspan = 2)),
#'     rrow(NULL, "mean", "median", "mean", "median")
#'   ),
#'   rrow(
#'     row.name = "Setosa",
#'     mean(Sepal.Length), median(Sepal.Length),
#'     mean(Petal.Length), median(Petal.Length),
#'     format = "xx.xx"
#'   )
#' ))
#'
#' rbind(mtbl, mtbl2)
#' rbind(mtbl, rrow(), mtbl2)
#' rbind(mtbl, rrow("aaa"), indent(mtbl2))
#'
#' @exportMethod rbind
#' @rdname rbind
setMethod(
  "rbind", "VTableNodeInfo",
  function(..., deparse.level = 1) {
    rbindl_rtables(list(...))
  }
)

#' @param y (`ANY`)\cr second element to be row-bound via `rbind2`.
#'
#' @exportMethod rbind2
#' @rdname int_methods
setMethod(
  "rbind2", c("VTableNodeInfo", "missing"),
  function(x, y) {
    TableTree(kids = list(x), cinfo = col_info(x), name = "rbind_root", label = "")
  }
)

#' @param x (`VTableNodeInfo`)\cr `TableTree`, `ElementaryTable`, or `TableRow` object.
#' @param y (`VTableNodeInfo`)\cr `TableTree`, `ElementaryTable`, or `TableRow` object.
#'
#' @exportMethod rbind2
#' @rdname rbind
setMethod(
  "rbind2", "VTableNodeInfo",
  function(x, y) {
    rbindl_rtables(list(x, y))
  }
)

EmptyTreePos <- TreePos()

## this is painful to do right but we were doing it wrong
## before and it now matters because count display information
## is in the tree which means all points in the structure
## must be pathable, which they aren't if siblings have
## identical names
fix_col_nm_recursive <- function(ct, newname, rename_obj = TRUE, oldnm) {
  if (rename_obj) {
    obj_name(ct) <- newname
  }
  if (is(ct, "LayoutColTree")) {
    kids <- tree_children(ct)
    kidnms <- names(kids)
    newkids <- lapply(kids, fix_col_nm_recursive,
      newname = newname,
      rename_obj = FALSE,
      oldnm = oldnm
    )
    names(newkids) <- kidnms
    tree_children(ct) <- newkids
  }
  mypos <- tree_pos(ct)
  if (!identical(mypos, EmptyTreePos)) {
    spls <- pos_splits(mypos)
    firstspl <- spls[[1]]
    if (obj_name(firstspl) == oldnm) {
      obj_name(firstspl) <- newname
      spls[[1]] <- firstspl
      pos_splits(mypos) <- spls
      tree_pos(ct) <- mypos
    }
  }
  if (!rename_obj) {
    spls <- pos_splits(mypos)
    splvals <- pos_splvals(mypos)
    pos_splits(mypos) <- c(
      list(AllSplit(split_name = newname)),
      spls
    )
    pos_splvals(mypos) <- c(
      list(SplitValue(NA_character_,
        sub_expr = quote(TRUE)
      )),
      splvals
    )
    tree_pos(ct) <- mypos
  }
  ct
}

fix_nms <- function(ct) {
  if (is(ct, "LayoutColLeaf")) {
    return(ct)
  }
  kids <- lapply(tree_children(ct), fix_nms)
  names(kids) <- vapply(kids, obj_name, "")
  tree_children(ct) <- kids
  ct
}

make_cbind_names <- function(num, tokens) {
  cbind_tokens <- grep("^(new_)*cbind_tbl", tokens, value = TRUE)
  ret <- paste0("cbind_tbl_", seq_len(num))
  if (length(cbind_tokens) == 0) {
    return(ret)
  }
  oldprefixes <- gsub("cbind_tbl.*", "", cbind_tokens)
  oldprefix <- oldprefixes[which.max(nchar(oldprefixes))]
  paste0("new_", oldprefix, ret)
}

combine_cinfo <- function(..., new_total = NULL, sync_count_vis) {
  tabs <- list(...)
  chk_cbindable_many(tabs)
  cinfs <- lapply(tabs, col_info)
  stopifnot(are(cinfs, "InstantiatedColumnInfo"))

  ctrees <- lapply(cinfs, coltree)
  oldnms <- nms <- vapply(ctrees, obj_name, "")
  path_els <- unique(unlist(lapply(ctrees, col_paths), recursive = TRUE))
  nms <- make_cbind_names(num = length(oldnms), tokens = path_els)

  ctrees <- mapply(function(ct, nm, oldnm) {
    ct <- fix_col_nm_recursive(ct, nm, rename_obj = TRUE, oldnm = "") # oldnm)
    ct
  }, ct = ctrees, nm = nms, oldnm = oldnms, SIMPLIFY = FALSE)
  names(ctrees) <- nms

  newctree <- LayoutColTree(kids = ctrees, colcount = NA_integer_, name = "cbind_root")
  newctree <- fix_nms(newctree)
  newcounts <- unlist(lapply(cinfs, col_counts))
  if (is.null(new_total)) {
    new_total <- sum(newcounts)
  }
  newexprs <- unlist(lapply(cinfs, col_exprs), recursive = FALSE)
  newexargs <- unlist(lapply(cinfs, col_extra_args), recursive = FALSE) %||% vector("list", length(newcounts))
  if (!sync_count_vis) {
    newdisp <- NA
  } else {
    newdisp <- any(vapply(cinfs, disp_ccounts, NA))
  }
  alltls <- lapply(cinfs, top_left)
  newtl <- character()
  if (!are(tabs, "TableRow")) {
    alltls <- alltls[vapply(alltls, function(x) length(x) > 0, NA)] ## these are already enforced to all be the same
    if (length(alltls) > 0) {
      newtl <- alltls[[1]]
    }
  }
  InstantiatedColumnInfo(
    treelyt = newctree,
    csubs = newexprs,
    extras = newexargs,
    cnts = newcounts,
    dispcounts = newdisp,
    countformat = colcount_format(cinfs[[1]]),
    total_cnt = new_total,
    topleft = newtl
  )
}

nz_len_els <- function(lst) {
  if (is(lst, "list")) {
    lst[vapply(lst, function(x) length(x) > 0, NA)]
  } else if (is(lst, "character")) {
    lst[nzchar(lst)]
  } else {
    lst
  }
}

has_one_unq <- function(x) {
  length(unique(nz_len_els(x))) <= 1
}

classvec <- function(lst, enforce_one = TRUE) {
  if (enforce_one) {
    vapply(lst, class, "")
  } else {
    lapply(lst, class)
  }
}

chk_cbindable_many <- function(lst) {
  ## we actually want is/inherits there but no easy way
  ## to figure out what the lowest base class is
  ## that I can think of right now, so we do the
  ## broken wrong thing instead :(
  if (are(lst, "TableRow")) {
    if (!has_one_unq(classvec(lst))) {
      stop("Cannot cbind different types of TableRow objects together")
    }
    return(TRUE)
  }
  ## if(!are(lst, "VTableTree")
  ##     stop("Not all elements to be bound are TableTrees or TableRows")

  nrs <- vapply(lst, NROW, 1L)
  if (!has_one_unq(nrs)) {
    stop("Not all elements to be bound have matching numbers of rows")
  }

  tls <- lapply(lst, top_left)
  if (!has_one_unq(tls[vapply(tls, function(x) length(x) > 0, NA)])) {
    stop(
      "Elements to be bound have differing top-left content: ",
      paste(which(!duplicated(tls)), collapse = " ")
    )
  }

  if (all(vapply(lst, function(x) nrow(x) == 0, NA))) {
    return(TRUE)
  }

  rns <- matrix(vapply(lst, row.names, rep("", nrs[[1]])),
    nrow = nrs[[1]]
  )
  rnsok <- apply(rns, 1, has_one_unq)
  if (!all(rnsok)) {
    stop(
      "Mismatching, non-empty row names detected in rows ",
      paste(which(!rnsok), collapse = " ")
    )
  }

  rws <- lapply(lst, collect_leaves, add.labrows = TRUE)
  rwclsmat <- matrix(unlist(lapply(rws, classvec)),
    ncol = length(lst)
  )

  rwsok <- apply(rwclsmat, 1, has_one_unq)
  if (!all(rwsok)) {
    stop(
      "Mismatching row classes found for rows: ",
      paste(which(!rwsok), collapse = " ")
    )
  }
  TRUE
}

#' Column-bind two `TableTree` objects
#'
#' @param x (`TableTree` or `TableRow`)\cr a table or row object.
#' @param ... one or more further objects of the same class as `x`.
#' @param sync_count_vis (`logical(1)`)\cr should column count
#'   visibility be synced across the new and existing columns.
#'   Currently defaults to `TRUE` for backwards compatibility but
#'   this may change in future releases.
#'
#' @inherit rbindl_rtables return
#'
#' @examples
#' x <- rtable(c("A", "B"), rrow("row 1", 1, 2), rrow("row 2", 3, 4))
#' y <- rtable("C", rrow("row 1", 5), rrow("row 2", 6))
#' z <- rtable("D", rrow("row 1", 9), rrow("row 2", 10))
#'
#' t1 <- cbind_rtables(x, y)
#' t1
#'
#' t2 <- cbind_rtables(x, y, z)
#' t2
#'
#' col_paths_summary(t1)
#' col_paths_summary(t2)
#'
#' @export
cbind_rtables <- function(x, ..., sync_count_vis = TRUE) {
  lst <- list(...)
  newcinfo <- combine_cinfo(x, ..., sync_count_vis = sync_count_vis)
  recurse_cbindl(x, cinfo = newcinfo, .list = lst)
}

setGeneric("recurse_cbindl", function(x, cinfo, .list = NULL) standardGeneric("recurse_cbindl"))

setMethod(
  "recurse_cbindl", c(
    x = "VTableNodeInfo",
    cinfo = "NULL"
  ),
  function(x, cinfo, .list = NULL) {
    recurse_cbindl(x, cinfo = combine_cinfo(.list), .list = .list)
  }
)

setMethod(
  "recurse_cbindl", c(
    x = "TableTree",
    cinfo = "InstantiatedColumnInfo"
  ),
  function(x, cinfo, .list = NULL) {
    stopifnot(are(.list, "VTableTree"))
    ## chk_cbindable(x, y)
    xcont <- content_table(x)
    lstconts <- lapply(.list, content_table)
    lcontnrows <- vapply(lstconts, NROW, 1L)
    unqnrcont <- unique(c(NROW(xcont), lcontnrows))
    if (length(unqnrcont) > 1) {
      stop(
        "Got differing numbers of content rows [",
        paste(unqnrcont, collapse = ", "),
        "]. Unable to cbind these rtables"
      )
    }

    if (unqnrcont == 0) {
      cont <- ElementaryTable(cinfo = cinfo)
    } else {
      cont <- recurse_cbindl(xcont,
        .list = lstconts,
        cinfo = cinfo
      )
    }

    kids <- lapply(
      seq_along(tree_children(x)),
      function(i) {
        recurse_cbindl(
          x = tree_children(x)[[i]],
          cinfo = cinfo,
          .list = lapply(.list, function(tt) tree_children(tt)[[i]])
        )
      }
    )
    names(kids) <- names(tree_children(x))
    TableTree(
      kids = kids, labelrow = recurse_cbindl(tt_labelrow(x),
        cinfo = cinfo,
        .list = lapply(.list, tt_labelrow)
      ),
      cont = cont,
      name = obj_name(x),
      lev = tt_level(x),
      cinfo = cinfo,
      format = obj_format(x)
    )
  }
)

setMethod(
  "recurse_cbindl", c(
    x = "ElementaryTable",
    cinfo = "InstantiatedColumnInfo"
  ),
  function(x, cinfo, .list) {
    stopifnot(are(.list, class(x)))
    ##   chk_cbindable(x,y)
    if (nrow(x) == 0 && all(vapply(.list, nrow, 1L) == 0)) {
      col_info(x) <- cinfo
      return(x) ## this needs testing... I was right, it did #136
    }
    kids <- lapply(
      seq_along(tree_children(x)),
      function(i) {
        recurse_cbindl(
          x = tree_children(x)[[i]],
          cinfo = cinfo,
          .list = lapply(.list, function(tt) tree_children(tt)[[i]])
        )
      }
    )
    names(kids) <- names(tree_children(x))

    ElementaryTable(
      kids = kids,
      labelrow = recurse_cbindl(tt_labelrow(x),
        .list = lapply(.list, tt_labelrow),
        cinfo
      ),
      name = obj_name(x),
      lev = tt_level(x),
      cinfo = cinfo,
      format = obj_format(x),
      var = obj_avar(x)
    )
  }
)

.combine_rows <- function(x, cinfo = NULL, .list) {
  stopifnot(are(.list, class(x)))

  avars <- c(obj_avar(x), unlist(lapply(.list, obj_avar), recursive = FALSE))
  avars <- avars[!is.na(avars)]

  if (length(unique(avars)) > 1) {
    stop("Got rows that don't analyze the same variable")
  }

  xlst <- c(list(x), .list)

  ncols <- vapply(xlst, ncol, 1L)
  totcols <- sum(ncols)
  cumncols <- cumsum(ncols)
  strtncols <- c(0L, head(cumncols, -1)) + 1L
  vals <- vector("list", totcols)
  cspans <- integer(totcols)
  ## vals[1:ncol(x)] <- row_values(x)
  ## cpans[1:ncol(x)] <- row_cspans(x)

  for (i in seq_along(xlst)) {
    strt <- strtncols[i]
    end <- cumncols[i]
    ## full vars are here for debugging purposes
    fullvy <- vy <- row_cells(xlst[[i]]) # nolint
    fullcspy <- cspy <- row_cspans(xlst[[i]]) # nolint

    if (
      i > 1 &&
        identical(rawvalues(vy[[1]]), rawvalues(lastval)) &&
        ##  cspy[1] == lastspn &&
        lastspn > 1
    ) {
      vy <- vy[-1]
      cspans[strt - 1L] <- lastspn + cspy[1]
      cspy <- cspy[-1]
      strt <- strt + 1L
    }
    if (length(vy) > 0) {
      vals[strt:end] <- vy
      cspans[strt:end] <- cspy
      lastval <- vy[[length(vy)]]
      lastspn <- cspy[[length(cspy)]]
    } else {
      ## lastval stays the same
      lastspn <- cspans[strtncols[i] - 1] ## already updated
    }
  }

  ## Could be DataRow or ContentRow
  ## This is ok because LabelRow is special cased
  constr_fun <- get(class(x), mode = "function")
  constr_fun(
    vals = vals,
    cspan = cspans,
    cinfo = cinfo,
    var = obj_avar(x),
    format = obj_format(x),
    name = obj_name(x),
    label = obj_label(x)
  )
}

setMethod(
  "recurse_cbindl", c(
    "TableRow",
    "InstantiatedColumnInfo"
  ),
  function(x, cinfo = NULL, .list) {
    .combine_rows(x, cinfo, .list)
  }
)

setMethod(
  "recurse_cbindl", c(
    x = "LabelRow",
    cinfo = "InstantiatedColumnInfo"
  ),
  function(x, cinfo = NULL, .list) {
    col_info(x) <- cinfo
    x
  }
)

## we don't care about the following discrepencies:
## - ci2  having NA counts when ci1 doesn't
## - mismatching display_ccounts values
## - mismatching colcount formats
##

# chk_compat_cinfos <- function(ci1, ci2) {
chk_compat_cinfos <- function(tt1, tt2) {
  nc1 <- ncol(tt1)
  nc2 <- ncol(tt2)
  if (nc1 != nc2 && nc1 > 0 && nc2 > 0) {
    stop("Column structures contain different non-zero numbers of columns: ", nc1, ", ", nc2)
  }
  if (no_colinfo(tt1) || no_colinfo(tt2)) {
    return(TRUE)
  }
  ci1 <- col_info(tt1)
  ci2 <- col_info(tt2)
  ## this will enforce same length and
  ## same names, in addition to same
  ## expressions so we dont need
  ## to check those separateley
  if (!identical(col_exprs(ci1), col_exprs(ci2))) {
    stop("Column structures not compatible: subset expression lists not identical")
  }

  if (any(!is.na(col_counts(ci2))) &&
    !identical(
      col_counts(ci1),
      col_counts(ci2)
    )) {
    stop("Column structures not compatible: 2nd column structure has non-matching, non-null column counts")
  }

  if (any(sapply(
    col_extra_args(ci2),
    function(x) length(x) > 0
  )) &&
    !identical(
      col_extra_args(ci1),
      col_extra_args(ci2)
    )) {
    stop(
      "Column structures not compatible: 2nd column structure has ",
      "non-matching, non-null extra args"
    )
  }

  if (any(nzchar(top_left(ci1))) && any(nzchar(top_left(ci2))) && !identical(top_left(ci1), top_left(ci2))) {
    stop(
      "Top-left materials not compatible: Got non-empty, non-matching ",
      "top-left materials. Clear them using top_left(x)<-character() ",
      "before binding to force compatibility."
    )
  }
  TRUE
}


#' Insert `rrow`s at (before) a specific location
#'
#' `r lifecycle::badge("deprecated")`
#'
#' This function is deprecated and will be removed in a future release of `rtables`. Please use
#' [insert_row_at_path()] or [label_at_path()] instead.
#'
#' @param tbl (`VTableTree`)\cr a `rtable` object.
#' @param rrow (`TableRow`)\cr an `rrow` to append to `tbl`.
#' @param at (`integer(1)`)\cr position into which to put the `rrow`, defaults to beginning (i.e. row 1).
#' @param ascontent (`flag`)\cr currently ignored.
#'
#' @return A `TableTree` of the same specific class as `tbl`.
#'
#' @note
#' Label rows (i.e. a row with no data values, only a `row.name`) can only be inserted at positions which do
#' not already contain a label row when there is a non-trivial nested row structure in `tbl`.
#'
#' @examples
#' o <- options(warn = 0)
#' lyt <- basic_table() %>%
#'   split_cols_by("Species") %>%
#'   analyze("Sepal.Length")
#'
#' tbl <- build_table(lyt, iris)
#'
#' insert_rrow(tbl, rrow("Hello World"))
#' insert_rrow(tbl, rrow("Hello World"), at = 2)
#'
#' lyt2 <- basic_table() %>%
#'   split_cols_by("Species") %>%
#'   split_rows_by("Species") %>%
#'   analyze("Sepal.Length")
#'
#' tbl2 <- build_table(lyt2, iris)
#'
#' insert_rrow(tbl2, rrow("Hello World"))
#' insert_rrow(tbl2, rrow("Hello World"), at = 2)
#' insert_rrow(tbl2, rrow("Hello World"), at = 4)
#'
#' insert_rrow(tbl2, rrow("new row", 5, 6, 7))
#'
#' insert_rrow(tbl2, rrow("new row", 5, 6, 7), at = 3)
#'
#' options(o)
#'
#' @export
insert_rrow <- function(tbl, rrow, at = 1,
                        ascontent = FALSE) {
  lifecycle::deprecate_warn(
    when = "0.4.0",
    what = "insert_rrow()",
    with = I("insert_row_at_path() or label_at_path()")
  )
  stopifnot(
    is(tbl, "VTableTree"),
    is(rrow, "TableRow"),
    at >= 1 && at <= nrow(tbl) + 1
  )
  chk_compat_cinfos(tbl, rrow)
  if (no_colinfo(rrow)) {
    col_info(rrow) <- col_info(tbl)
  }

  if (at == 1) {
    return(rbindl_rtables(list(rrow, tbl)))
  } else if (at == nrow(tbl) + 1) {
    return(rbind2(tbl, rrow))
  }

  ret <- recurse_insert(tbl, rrow,
    at = at,
    pos = 0,
    ascontent = ascontent
  )
  ret
}

.insert_helper <- function(tt, row, at, pos,
                           ascontent = FALSE) {
  islab <- is(row, "LabelRow")
  kids <- tree_children(tt)
  numkids <- length(kids)
  kidnrs <- sapply(kids, nrow)
  cumpos <- pos + cumsum(kidnrs)
  contnr <- if (is(tt, "TableTree")) {
    nrow(content_table(tt))
  } else {
    0
  }
  contnr <- contnr + as.numeric(labelrow_visible(tt))

  totnr <- nrow(tt)
  endpos <- pos + totnr
  atend <- !islab && endpos == at - 1
  if (at == pos + 1 && islab) {
    if (labelrow_visible(tt)) {
      stop("Inserting a label row at a position that already has a label row is not currently supported")
    }
    tt_labelrow(tt) <- row
    return(tt)
  }

  if (numkids == 0) {
    kids <- list(row)
  } else if (atend) {
    if (are(kids, "TableRow")) {
      kids <- c(kids, list(row))
    } else {
      kids[[numkids]] <- recurse_insert(
        kids[[numkids]],
        row = row,
        at = at,
        pos = pos + contnr + sum(kidnrs[-numkids]),
        ascontent = ascontent
      )
    }
  } else { # have >0 kids
    kidnrs <- sapply(kids, nrow)
    cumpos <- pos + cumsum(kidnrs)

    ## data rows go in the end of the
    ## preceding subtable (if applicable)
    ## label rows go in the beginning of
    ##  one at at
    ind <- min(
      which((cumpos + !islab) >= at),
      numkids
    )
    thekid <- kids[[ind]]

    if (is(thekid, "TableRow")) {
      tt_level(row) <- tt_level(thekid)
      if (ind == 1) {
        bef <- integer()
        aft <- 1:numkids
      } else if (ind == numkids) {
        bef <- 1:(ind - 1)
        aft <- ind
      } else {
        bef <- 1:ind
        aft <- (ind + 1):numkids
      }
      kids <- c(
        kids[bef], list(row),
        kids[aft]
      )
    } else { # kid is not a table row
      newpos <- if (ind == 1) {
        pos + contnr
      } else {
        cumpos[ind - 1]
      }

      kids[[ind]] <- recurse_insert(thekid,
        row,
        at,
        pos = newpos,
        ascontent = ascontent
      )
    } # end kid is not table row
  }
  tree_children(tt) <- kids
  tt
}

setGeneric("recurse_insert", function(tt, row, at, pos, ascontent = FALSE) standardGeneric("recurse_insert"))

setMethod(
  "recurse_insert", "TableTree",
  function(tt, row, at, pos, ascontent = FALSE) {
    ctab <- content_table(tt)
    contnr <- nrow(ctab)
    contpos <- pos + contnr
    islab <- is(row, "LabelRow")
    ## this will NOT insert it as
    if ((contnr > 0 || islab) && contpos > at) {
      content_table(tt) <- recurse_insert(ctab, row, at, pos, TRUE)
      return(tt)
    }

    .insert_helper(tt, row,
      at = at, pos = pos + contnr,
      ascontent = ascontent
    )
  }
)

setMethod(
  "recurse_insert", "ElementaryTable",
  function(tt, row, at, pos, ascontent = FALSE) {
    .insert_helper(tt, row,
      at = at, pos = pos,
      ascontent = FALSE
    )
  }
)

#' Trimming and pruning criteria
#'
#' Criteria functions (and constructors thereof) for trimming and pruning tables.
#'
#' @inheritParams gen_args
#'
#' @return A logical value indicating whether `tr` should be included (`TRUE`) or pruned (`FALSE`) during pruning.
#'
#' @seealso [prune_table()], [trim_rows()]
#'
#' @details `all_zero_or_na` returns `TRUE` (and thus indicates trimming/pruning) for any *non-`LabelRow`*
#'   `TableRow` which contain only any mix of `NA` (including `NaN`), `0`, `Inf` and `-Inf` values.
#'
#' @examples
#' adsl <- ex_adsl
#' levels(adsl$SEX) <- c(levels(ex_adsl$SEX), "OTHER")
#' adsl$AGE[adsl$SEX == "UNDIFFERENTIATED"] <- 0
#' adsl$BMRKR1 <- 0
#'
#' tbl_to_prune <- basic_table() %>%
#'   analyze("BMRKR1") %>%
#'   split_cols_by("ARM") %>%
#'   split_rows_by("SEX") %>%
#'   summarize_row_groups() %>%
#'   split_rows_by("STRATA1") %>%
#'   summarize_row_groups() %>%
#'   analyze("AGE") %>%
#'   build_table(adsl)
#'
#' tbl_to_prune %>% prune_table(all_zero_or_na)
#'
#' @rdname trim_prune_funs
#' @export
all_zero_or_na <- function(tr) {
  if (!is(tr, "TableRow") || is(tr, "LabelRow")) {
    return(FALSE)
  }
  rvs <- unlist(unname(row_values(tr)))
  all(is.na(rvs) | rvs == 0 | !is.finite(rvs))
}

#' @details `all_zero` returns `TRUE` for any non-`LabelRow` which contains only (non-missing) zero values.
#'
#' @examples
#' tbl_to_prune %>% prune_table(all_zero)
#'
#' @rdname trim_prune_funs
#' @export
all_zero <- function(tr) {
  if (!is(tr, "TableRow") || is(tr, "LabelRow")) {
    return(FALSE)
  }
  rvs <- unlist(unname(row_values(tr)))
  isTRUE(all(rvs == 0))
}

#' Trim rows from a populated table without regard for table structure
#'
#' @inheritParams gen_args
#' @param criteria (`function`)\cr function which takes a `TableRow` object and returns `TRUE` if that row
#'   should be removed. Defaults to [all_zero_or_na()].
#'
#' @return The table with rows that have only `NA` or 0 cell values removed.
#'
#' @note
#' Visible `LabelRow`s are including in this trimming, which can lead to either all label rows being trimmed or
#' label rows remaining when all data rows have been trimmed, depending on what `criteria` returns when called on
#' a `LabelRow` object. To avoid this, use the structurally-aware [prune_table()] machinery instead.
#'
#' @details
#' This function will be deprecated in the future in favor of the more elegant and versatile [prune_table()]
#' function which can perform the same function as `trim_rows()` but is more powerful as it takes table structure
#' into account.
#'
#' @seealso [prune_table()]
#'
#' @examples
#' adsl <- ex_adsl
#' levels(adsl$SEX) <- c(levels(ex_adsl$SEX), "OTHER")
#'
#' tbl_to_trim <- basic_table() %>%
#'   analyze("BMRKR1") %>%
#'   split_cols_by("ARM") %>%
#'   split_rows_by("SEX") %>%
#'   summarize_row_groups() %>%
#'   split_rows_by("STRATA1") %>%
#'   summarize_row_groups() %>%
#'   analyze("AGE") %>%
#'   build_table(adsl)
#'
#' tbl_to_trim %>% trim_rows()
#'
#' tbl_to_trim %>% trim_rows(all_zero)
#'
#' @export
trim_rows <- function(tt, criteria = all_zero_or_na) {
  rows <- collect_leaves(tt, TRUE, TRUE)
  torm <- vapply(rows, criteria,
    NA,
    USE.NAMES = FALSE
  )
  tt[!torm, ,
    keep_topleft = TRUE,
    keep_titles = TRUE,
    keep_footers = TRUE,
    reindex_refs = TRUE
  ]
}

#' @inheritParams trim_rows
#'
#' @details
#' `content_all_zeros_nas` prunes a subtable if both of the following are true:
#'
#'   * It has a content table with exactly one row in it.
#'   * `all_zero_or_na` returns `TRUE` for that single content row. In practice, when the default summary/content
#'     function is used, this represents pruning any subtable which corresponds to an empty set of the input data
#'     (e.g. because a factor variable was used in [split_rows_by()] but not all levels were present in the data).
#'
#' @examples
#' tbl_to_prune %>% prune_table(content_all_zeros_nas)
#'
#' @rdname trim_prune_funs
#' @export
content_all_zeros_nas <- function(tt, criteria = all_zero_or_na) {
  ## this will be NULL if
  ## tt is something that doesn't have a content table
  ct <- content_table(tt)
  ## NROW returns 0 for NULL.
  if (NROW(ct) == 0 || nrow(ct) > 1) {
    return(FALSE)
  }

  cr <- tree_children(ct)[[1]]
  criteria(cr)
}

#' @details
#' `prune_empty_level` combines `all_zero_or_na` behavior for `TableRow` objects, `content_all_zeros_nas` on
#' `content_table(tt)` for `TableTree` objects, and an additional check that returns `TRUE` if the `tt` has no
#' children.
#'
#' @examples
#' tbl_to_prune %>% prune_table(prune_empty_level)
#'
#' @rdname trim_prune_funs
#' @export
prune_empty_level <- function(tt) {
  if (is(tt, "TableRow")) {
    return(all_zero_or_na(tt))
  }

  if (content_all_zeros_nas(tt)) {
    return(TRUE)
  }
  kids <- tree_children(tt)
  length(kids) == 0
}

#' @details `prune_zeros_only` behaves as `prune_empty_level` does, except that like `all_zero` it prunes
#'   only in the case of all non-missing zero values.
#'
#' @examples
#' tbl_to_prune %>% prune_table(prune_zeros_only)
#'
#' @rdname trim_prune_funs
#' @export
prune_zeros_only <- function(tt) {
  if (is(tt, "TableRow")) {
    return(all_zero(tt))
  }

  if (content_all_zeros_nas(tt, criteria = all_zero)) {
    return(TRUE)
  }
  kids <- tree_children(tt)
  length(kids) == 0
}

#' @param min (`numeric(1)`)\cr (used by `low_obs_pruner` only). Minimum aggregate count value.
#'   Subtables whose combined/average count are below this threshold will be pruned.
#' @param type (`string`)\cr how count values should be aggregated. Must be `"sum"` (the default) or `"mean"`.
#'
#' @details
#' `low_obs_pruner` is a *constructor function* which, when called, returns a pruning criteria function which
#' will prune on content rows by comparing sum or mean (dictated by `type`) of the count portions of the cell
#' values (defined as the first value per cell regardless of how many values per cell there are) against `min`.
#'
#' @examples
#' min_prune <- low_obs_pruner(70, "sum")
#' tbl_to_prune %>% prune_table(min_prune)
#'
#' @rdname trim_prune_funs
#' @export
low_obs_pruner <- function(min, type = c("sum", "mean")) {
  type <- match.arg(type)
  function(tt) {
    if (is(tt, "TableRow") || NROW(ctab <- content_table(tt)) != 1) { ## note the <- in there!!!
      return(FALSE) ## only trimming on count content rows
    }
    ctr <- tree_children(ctab)[[1]]
    vals <- sapply(row_values(ctr), function(v) v[[1]])
    sumvals <- sum(vals)
    if (type == "mean") {
      sumvals <- sumvals / length(vals)
    }
    sumvals < min
  }
}

#' Recursively prune a `TableTree`
#'
#' @inheritParams gen_args
#' @param prune_func (`function`)\cr a function to be called on each subtree which returns `TRUE` if the
#'   entire subtree should be removed.
#' @param stop_depth (`numeric(1)`)\cr the depth after which subtrees should not be checked for pruning.
#'   Defaults to `NA` which indicates pruning should happen at all levels.
#' @param depth (`numeric(1)`)\cr used internally, not intended to be set by the end user.
#' @param ... named arguments to optionally be passed down to `prune_func` if it
#'   accepts them (or `...`)
#'
#' @return A `TableTree` pruned via recursive application of `prune_func`.
#'
#' @seealso [prune_empty_level()] for details on this and several other basic pruning functions included
#'   in the `rtables` package.
#'
#' @examples
#' adsl <- ex_adsl
#' levels(adsl$SEX) <- c(levels(ex_adsl$SEX), "OTHER")
#'
#' tbl_to_prune <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   split_rows_by("SEX") %>%
#'   summarize_row_groups() %>%
#'   split_rows_by("STRATA1") %>%
#'   summarize_row_groups() %>%
#'   analyze("AGE") %>%
#'   build_table(adsl)
#'
#' tbl_to_prune %>% prune_table()
#'
#' @export
prune_table <- function(tt,
                        prune_func = prune_empty_level,
                        stop_depth = NA_real_,
                        depth = 0,
                        ...) {
  if (!is.na(stop_depth) && depth > stop_depth) {
    return(tt)
  }
  if (is(tt, "TableRow")) {
    if (prune_func(tt)) {
      tt <- NULL
    }
    return(tt)
  }

  kids <- tree_children(tt)

  more_args <- match_fun_args(prune_func, depth = depth, ...)
  torm <- vapply(kids, function(tb) {
    !is.null(tb) && do.call(prune_func, c(list(tb), more_args))
  }, NA)

  keepkids <- kids[!torm]
  keepkids <- lapply(keepkids, prune_table,
    prune_func = prune_func,
    stop_depth = stop_depth,
    depth = depth + 1,
    ...
  )

  keepkids <- keepkids[!vapply(keepkids, is.null, NA)]
  if (length(keepkids) > 0) {
    tree_children(tt) <- keepkids
  } else {
    tt <- NULL
  }
  tt
}

match_extra_args <- function(f,
                             .N_col,
                             .N_total,
                             .all_col_exprs,
                             .all_col_counts,
                             .var,
                             .ref_group = NULL,
                             .alt_df_row = NULL,
                             .alt_df = NULL,
                             .alt_df_full = NULL,
                             .ref_full = NULL,
                             .in_ref_col = NULL,
                             .spl_context = NULL,
                             .N_row,
                             .df_row,
                             extras) {
  # This list is always present
  possargs <- c(
    list(
      .N_col = .N_col,
      .N_total = .N_total,
      .N_row = .N_row,
      .df_row = .df_row,
      .all_col_exprs = .all_col_exprs,
      .all_col_counts = .all_col_counts
    ),
    extras
  )

  ## specialized arguments that must be named in formals, cannot go
  ## anonymously into ...
  if (!is.null(.var) && nzchar(.var)) {
    possargs <- c(possargs, list(.var = .var))
  }
  if (!is.null(.ref_group)) {
    possargs <- c(possargs, list(.ref_group = .ref_group))
  }
  if (!is.null(.alt_df_row)) {
    possargs <- c(possargs, list(.alt_df_row = .alt_df_row))
  }
  if (!is.null(.alt_df)) {
    possargs <- c(possargs, list(.alt_df = .alt_df))
  }

  if (!is.null(.alt_df_full)) {
    possargs <- c(possargs, list(.alt_df_full = .alt_df_full))
  }

  if (!is.null(.ref_full)) {
    possargs <- c(possargs, list(.ref_full = .ref_full))
  }
  if (!is.null(.in_ref_col)) {
    possargs <- c(possargs, list(.in_ref_col = .in_ref_col))
  }

  # Special case: .spl_context
  if (!is.null(.spl_context) && !(".spl_context" %in% names(possargs))) {
    possargs <- c(possargs, list(.spl_context = .spl_context))
  } else {
    possargs$.spl_context <- NULL
  }

  # Extra args handling
  formargs <- formals(f)
  formnms <- names(formargs)
  exnms <- names(extras)
  if (is.null(formargs)) {
    return(NULL)
  } else if ("..." %in% names(formargs)) {
    formnms <- c(formnms, exnms[nzchar(exnms)])
  }
  possargs[names(possargs) %in% formnms]
}

#' @noRd
#' @return A `RowsVerticalSection` object representing the `k x 1` section of the
#'   table being generated, with `k` the number of rows the analysis function
#'   generates.
gen_onerv <- function(csub, col, count, cextr, cpath,
                      dfpart, func, totcount, splextra,
                      all_col_exprs,
                      all_col_counts,
                      takesdf = .takes_df(func),
                      baselinedf,
                      alt_dfpart,
                      alt_df_full,
                      inclNAs,
                      col_parent_inds,
                      spl_context) {
  if (NROW(spl_context) > 0) {
    spl_context$cur_col_id <- paste(cpath[seq(2, length(cpath), 2)], collapse = ".")
    spl_context$cur_col_subset <- col_parent_inds
    spl_context$cur_col_expr <- list(csub)
    spl_context$cur_col_n <- vapply(col_parent_inds, sum, 1L)
    spl_context$cur_col_split <- list(cpath[seq(1, length(cpath), 2)])
    spl_context$cur_col_split_val <- list(cpath[seq(2, length(cpath), 2)])
  }

  # Making .alt_df from alt_dfpart (i.e. .alt_df_row)
  if (NROW(alt_dfpart) > 0) {
    alt_dfpart_fil <- alt_dfpart[eval(csub, envir = alt_dfpart), , drop = FALSE]
    if (!is.null(col) && col %in% names(alt_dfpart_fil) && !inclNAs) {
      alt_dfpart_fil <- alt_dfpart_fil[!is.na(alt_dfpart_fil[[col]]), ,
        drop = FALSE
      ]
    }
  } else {
    alt_dfpart_fil <- alt_dfpart
  }

  ## workaround for https://github.com/insightsengineering/rtables/issues/159
  if (NROW(dfpart) > 0) {
    inds <- eval(csub, envir = dfpart)
    dat <- dfpart[inds, , drop = FALSE]
  } else {
    dat <- dfpart
  }
  if (!is.null(col) && !inclNAs) {
    dat <- dat[!is.na(dat[[col]]), , drop = FALSE]
  }

  fullrefcoldat <- cextr$.ref_full
  if (!is.null(fullrefcoldat)) {
    cextr$.ref_full <- NULL
  }
  inrefcol <- cextr$.in_ref_col
  if (!is.null(fullrefcoldat)) {
    cextr$.in_ref_col <- NULL
  }

  exargs <- c(cextr, splextra)

  ## behavior for x/df and ref-data (full and group)
  ## match
  if (!is.null(col) && !takesdf) {
    dat <- dat[[col]]
    fullrefcoldat <- fullrefcoldat[[col]]
    baselinedf <- baselinedf[[col]]
  }
  args <- list(dat)

  names(all_col_counts) <- names(all_col_exprs)

  exargs <- match_extra_args(func,
    .N_col = count,
    .N_total = totcount,
    .all_col_exprs = all_col_exprs,
    .all_col_counts = all_col_counts,
    .var = col,
    .ref_group = baselinedf,
    .alt_df_row = alt_dfpart,
    .alt_df = alt_dfpart_fil,
    .alt_df_full = alt_df_full,
    .ref_full = fullrefcoldat,
    .in_ref_col = inrefcol,
    .N_row = NROW(dfpart),
    .df_row = dfpart,
    .spl_context = spl_context,
    extras = c(
      cextr,
      splextra
    )
  )

  args <- c(args, exargs)

  val <- do.call(func, args)
  if (!is(val, "RowsVerticalSection")) {
    if (!is(val, "list")) {
      val <- list(val)
    }
    ret <- in_rows(
      .list = val,
      .labels = unlist(value_labels(val)),
      .names = names(val)
    )
  } else {
    ret <- val
  }
  ret
}

strip_multivar_suffix <- function(x) {
  gsub("\\._\\[\\[[0-9]\\]\\]_\\.$", "", x)
}

## Generate all values (one for each column) for one or more rows
## by calling func once per column (as defined by cinfo)
#' @noRd
#' @return A list of `m` `RowsVerticalSection` objects, one for each (leaf) column in the table.
gen_rowvalues <- function(dfpart,
                          datcol,
                          cinfo,
                          func,
                          splextra,
                          takesdf = NULL,
                          baselines,
                          alt_dfpart,
                          alt_df_full,
                          inclNAs,
                          spl_context) {
  colexprs <- col_exprs(cinfo)
  colcounts <- col_counts(cinfo)
  colextras <- col_extra_args(cinfo, NULL)
  cpaths <- col_paths(cinfo)
  ## XXX I don't think this is used anywhere???
  ## splextra = c(splextra, list(.spl_context = spl_context))
  totcount <- col_total(cinfo)

  colleaves <- collect_leaves(cinfo@tree_layout)

  gotflist <- is.list(func)

  ## one set of named args to be applied to all columns
  if (!is.null(names(splextra))) {
    splextra <- list(splextra)
  } else {
    length(splextra) <- ncol(cinfo)
  }

  if (!gotflist) {
    func <- list(func)
  } else if (length(splextra) == 1) {
    splextra <- rep(splextra, length.out = length(func))
  }
  ## if(length(func)) == 1 && names(spl)
  ##     splextra = list(splextra)

  ## we are in analyze_colvars, so we have to match
  ## the exargs value by position for each column repeatedly
  ## across the higher level col splits.
  if (!is.null(datcol) && is.na(datcol)) {
    datcol <- character(length(colleaves))
    exargs <- vector("list", length(colleaves))
    for (i in seq_along(colleaves)) {
      x <- colleaves[[i]]

      pos <- tree_pos(x)
      spls <- pos_splits(pos)
      ## values have the suffix but we are populating datacol
      ## so it has to match var numbers so strip the suffixes back off
      splvals <- strip_multivar_suffix(rawvalues(pos))
      n <- length(spls)
      datcol[i] <- if (is(spls[[n]], "MultiVarSplit")) {
        splvals[n]
      } else {
        NA_character_
      }
      argpos <- match(datcol[i], spl_payload(spls[[n]]))
      ## single bracket here because assigning NULL into a list removes
      ## the position entirely
      exargs[i] <- if (argpos <= length(splextra)) {
        splextra[argpos]
      } else {
        list(NULL)
      }
    }
    ## })
    if (all(is.na(datcol))) {
      datcol <- list(NULL)
    } else if (any(is.na(datcol))) {
      stop("mix of var and non-var columns with NA analysis rowvara")
    }
  } else {
    exargs <- splextra
    if (is.null(datcol)) {
      datcol <- list(NULL)
    }
    datcol <- rep(datcol, length(colexprs))
    ## if(gotflist)
    ##     length(exargs) <- length(func) ## func is a list
    exargs <- rep(exargs, length.out = length(colexprs))
  }
  allfuncs <- rep(func, length.out = length(colexprs))

  if (is.null(takesdf)) {
    takesdf <- .takes_df(allfuncs)
  }

  rawvals <- mapply(gen_onerv,
    csub = colexprs,
    col = datcol,
    count = colcounts,
    cextr = colextras,
    cpath = cpaths,
    baselinedf = baselines,
    alt_dfpart = list(alt_dfpart),
    func = allfuncs,
    takesdf = takesdf,
    col_parent_inds = spl_context[, names(colexprs),
      drop = FALSE
    ],
    all_col_exprs = list(colexprs),
    all_col_counts = list(colcounts),
    splextra = exargs,
    MoreArgs = list(
      dfpart = dfpart,
      alt_df_full = alt_df_full,
      totcount = totcount,
      inclNAs = inclNAs,
      spl_context = spl_context
    ),
    SIMPLIFY = FALSE
  )

  names(rawvals) <- names(colexprs)
  rawvals
}

.strip_lst_rvals <- function(lst) {
  lapply(lst, rawvalues)
}

#' @noRd
#' @return A list of table rows, even when only one is generated.
.make_tablerows <- function(dfpart,
                            alt_dfpart,
                            alt_df_full,
                            func,
                            cinfo,
                            datcol = NULL,
                            lev = 1L,
                            rvlab = NA_character_,
                            format = NULL,
                            defrowlabs = NULL,
                            rowconstr = DataRow,
                            splextra = list(),
                            takesdf = NULL,
                            baselines = replicate(
                              length(col_exprs(cinfo)),
                              list(dfpart[0, ])
                            ),
                            inclNAs,
                            spl_context = context_df_row(cinfo = cinfo)) {
  if (is.null(datcol) && !is.na(rvlab)) {
    stop("NULL datcol but non-na rowvar label")
  }
  if (!is.null(datcol) && !is.na(datcol)) {
    if (!all(datcol %in% names(dfpart))) {
      stop(
        "specified analysis variable (", datcol,
        ") not present in data"
      )
    }

    rowvar <- datcol
  } else {
    rowvar <- NA_character_
  }

  rawvals <- gen_rowvalues(dfpart,
    alt_dfpart = alt_dfpart,
    alt_df_full = alt_df_full,
    datcol = datcol,
    cinfo = cinfo,
    func = func,
    splextra = splextra,
    takesdf = takesdf,
    baselines = baselines,
    inclNAs = inclNAs,
    spl_context = spl_context
  )

  ## if(is.null(rvtypes))
  ##     rvtypes = rep(NA_character_, length(rawvals))
  lens <- vapply(rawvals, length, NA_integer_)
  unqlens <- unique(lens)
  ## length 0 returns are ok to not match cause they are
  ## just empty space we can fill in as needed.
  if (length(unqlens[unqlens > 0]) != 1L) { ## length(unqlens) != 1 &&
    ## (0 %in% unqlens && length(unqlens) != 2)) {
    stop(
      "Number of rows generated by analysis function do not match ",
      "across all columns. ",
      if (!is.na(datcol) && is.character(dfpart[[datcol]])) {
        paste(
          "\nPerhaps convert analysis variable", datcol,
          "to a factor?"
        )
      }
    )
  }
  maxind <- match(max(unqlens), lens)

  ## look if we got labels, if not apply the
  ## default row labels
  ## this is guaranteed to be a RowsVerticalSection object.
  rv1col <- rawvals[[maxind]]
  ## nocov start
  if (!is(rv1col, "RowsVerticalSection")) {
    stop(
      "gen_rowvalues appears to have generated something that was not ",
      "a RowsVerticalSection object. Please contact the maintainer."
    )
  }
  # nocov end

  labels <- value_labels(rv1col)

  ncrows <- max(unqlens)
  if (ncrows == 0) {
    return(list())
  }
  stopifnot(ncrows > 0)

  if (is.null(labels)) {
    if (length(rawvals[[maxind]]) == length(defrowlabs)) {
      labels <- defrowlabs
    } else {
      labels <- rep("", ncrows)
    }
  }

  rfootnotes <- rep(list(list(), length(rv1col)))
  nms <- value_names(rv1col)
  rfootnotes <- row_footnotes(rv1col)

  imods <- indent_mod(rv1col) ## rv1col@indent_mods
  unwrapped_vals <- lapply(rawvals, as, Class = "list", strict = TRUE)

  formatvec <- NULL
  if (!is.null(format)) {
    if (is.function(format)) {
      format <- list(format)
    }
    formatvec <- rep(format, length.out = ncrows)
  }

  trows <- lapply(1:ncrows, function(i) {
    rowvals <- lapply(unwrapped_vals, function(colvals) {
      colvals[[i]]
    })
    imod <- unique(vapply(rowvals, indent_mod, 0L))
    if (length(imod) != 1) {
      stop(
        "Different cells in the same row appear to have been given ",
        "different indent_mod values"
      )
    }
    rowconstr(
      vals = rowvals,
      cinfo = cinfo,
      lev = lev,
      label = labels[i],
      name = nms[i], ## labels[i], ## XXX this is probably wrong?!
      var = rowvar,
      format = formatvec[[i]],
      indent_mod = imods[[i]] %||% 0L,
      footnotes = rfootnotes[[i]] ## one bracket so list
    )
  })
  trows
}

.make_caller <- function(parent_cfun, clabelstr = "") {
  formalnms <- names(formals(parent_cfun))
  ## note the <- here
  if (!is.na(dotspos <- match("...", formalnms))) {
    toremove <- dotspos
  } else {
    toremove <- NULL
  }

  labelstrpos <- match("labelstr", names(formals(parent_cfun)))
  if (is.na(labelstrpos)) {
    stop(
      "content function does not appear to accept the labelstr",
      "arguent"
    )
  }
  toremove <- c(toremove, labelstrpos)
  formalnms <- formalnms[-1 * toremove]

  caller <- eval(parser_helper(text = paste(
    "function() { parent_cfun(",
    paste(formalnms, "=",
      formalnms,
      collapse = ", "
    ),
    ", labelstr = clabelstr, ...)}"
  )))
  formals(caller) <- c(
    formals(parent_cfun)[-labelstrpos],
    alist("..." = )
  ) # nolint
  caller
}

# Makes content table xxx renaming
.make_ctab <- function(df,
                       lvl, ## treepos,
                       name,
                       label,
                       cinfo,
                       parent_cfun = NULL,
                       format = NULL,
                       na_str = NA_character_,
                       indent_mod = 0L,
                       cvar = NULL,
                       inclNAs,
                       alt_df,
                       alt_df_full,
                       extra_args,
                       spl_context = context_df_row(cinfo = cinfo)) {
  if (length(cvar) == 0 || is.na(cvar) || identical(nchar(cvar), 0L)) {
    cvar <- NULL
  }
  if (!is.null(parent_cfun)) {
    ## cfunc <- .make_caller(parent_cfun, label)
    cfunc <- lapply(parent_cfun, .make_caller, clabelstr = label)
    contkids <- tryCatch(
      .make_tablerows(df,
        lev = lvl,
        func = cfunc,
        cinfo = cinfo,
        rowconstr = ContentRow,
        datcol = cvar,
        takesdf = rep(.takes_df(cfunc),
          length.out = ncol(cinfo)
        ),
        inclNAs = FALSE,
        alt_dfpart = alt_df,
        alt_df_full = alt_df_full,
        splextra = extra_args,
        spl_context = spl_context
      ),
      error = function(e) e
    )
    if (is(contkids, "error")) {
      stop("Error in content (summary) function: ", contkids$message,
        "\n\toccured at path: ",
        spl_context_to_disp_path(spl_context),
        call. = FALSE
      )
    }
  } else {
    contkids <- list()
  }
  ctab <- ElementaryTable(
    kids = contkids,
    name = paste0(name, "@content"),
    lev = lvl,
    labelrow = LabelRow(),
    cinfo = cinfo,
    iscontent = TRUE,
    format = format,
    indent_mod = indent_mod,
    na_str = na_str
  )
  ctab
}

## return index in tbl that has best partial match to str
## or NA_integer_ if none do
inv_pmatch <- function(str, tbl) {
  inds <- pmatch(tbl, str, duplicates.ok = TRUE)
  found_inds <- which(!is.na(inds))
  ret <- NA_integer_
  if (length(found_inds) == 1) {
    ret <- found_inds
  } else if (length(found_inds) > 1) {
    ncs <- nchar(tbl[found_inds])
    chosen <- which.max(ncs)
    ret <- found_inds[chosen]
  }
  ret
}

.got_noname_single <- function(lst) {
  is.list(lst) && length(lst) == 1 && is.null(names(lst))
}
.apply_default_formats <- function(kidlst, fmtlst, nastrlst = character()) {
  if (length(fmtlst) == 0 && length(nastrlst) == 0) {
    return(kidlst)
  }

  if (is.null(names(kidlst))) {
    names(kidlst) <- vapply(kidlst, obj_name, "")
  }

  if (identical(nastrlst, character())) {
    nastrlst <- NA_character_
  }

  if (is.character(nastrlst) && length(nastrlst) >= 1) {
    missing_nastr_val <- nastrlst
    nastrlst <- list()
  } else if (.got_noname_single(nastrlst)) {
    missing_nastr_val <- nastrlst[[1]]
    natsrlst <- list()
  } else {
    missing_nastr_val <- NA_character_
  }

  if (!is.list(fmtlst)) { ## appears impossible??
    missing_fmt_val <- fmtlst
    fmtlst <- list()
  } else if (.got_noname_single(fmtlst)) {
    stopifnot(is(fmtlst[[1]], "FormatSpec"))
    missing_fmt_val <- fmtlst[[1]]
    fmtlst <- list()
  } else {
    missing_fmt_val <- NULL
  }

  if (length(names(fmtlst)) > 0 || length(names(nastrlst)) > 0) {
    missing_nastrs <- setdiff(names(fmtlst), names(nastrlst))
    missing_fmts <- setdiff(names(nastrlst), names(fmtlst))
  } else {
    missing_nastrs <- names(kidlst)
    missing_fmts <- names(kidlst)
  }

  if (length(missing_nastrs) > 0) {
    nastrlst[missing_nastrs] <- missing_nastr_val
  }
  if (length(missing_fmts) > 0) {
    fmtlst[missing_fmts] <- list(missing_fmt_val)
  }

  ## they may be in different orders, if so fix it
  stopifnot(intersect(names(fmtlst), names(nastrlst)) == names(fmtlst))
  nastrlst <- nastrlst[names(fmtlst)]

  ## checks for exact matches first then (inverse) partial matches
  fmt_match <- match(names(kidlst), names(fmtlst))
  no_exact_inds <- which(is.na(fmt_match))
  fmt_match[no_exact_inds] <- vapply(
    names(kidlst)[no_exact_inds],
    inv_pmatch,
    tbl = names(fmtlst),
    1L
  )

  toset <- which(!is.na(fmt_match))

  fmts <- fmtlst[fmt_match[toset]]
  na_strs <- nastrlst[names(fmts)]

  kidlst[toset] <- mapply(function(kid, fmt, na_str) {
    if (fmt_can_inherit(kid)) {
      kid <- set_format_recursive(kid, fmt, na_str, override = FALSE)
    }
    kid
  }, kid = kidlst[toset], fmt = fmts, na_str = na_strs, SIMPLIFY = FALSE)

  kidlst
}


.make_analyzed_tab <- function(df,
                               alt_df,
                               alt_df_full,
                               spl,
                               cinfo,
                               partlabel = "",
                               dolab = TRUE,
                               lvl,
                               baselines,
                               spl_context) {
  stopifnot(is(spl, "VAnalyzeSplit"))
  check_validsplit(spl, df)
  defrlabel <- spl@default_rowlabel
  if (nchar(defrlabel) == 0 && !missing(partlabel) && nchar(partlabel) > 0) {
    defrlabel <- partlabel
  }

  fmt <- obj_format(spl)
  have_fmt_lst <- FALSE
  if (is(fmt, "FormatList")) {
    ## list for diff vars but each has one format case
    if (length(fmt) == 1 && is.null(names(fmt))) {
      fmt <- unlist(fmt)
      stopifnot(is(fmt, "FormatSpec"))
    } else { ## real format list case
      fmt <- NULL
      have_fmt_lst <- TRUE
    }
  }

  kids <- tryCatch(
    .make_tablerows(df,
      func = analysis_fun(spl),
      defrowlabs = defrlabel, # XXX
      cinfo = cinfo,
      datcol = spl_payload(spl),
      lev = lvl + 1L,
      format = fmt, # obj_format(spl),
      splextra = split_exargs(spl),
      baselines = baselines,
      alt_dfpart = alt_df,
      alt_df_full = alt_df_full,
      inclNAs = avar_inclNAs(spl),
      spl_context = spl_context
    ),
    error = function(e) e
  )

  # Adding section_div for DataRows (analyze leaves)
  # kids <- .set_kids_section_div(kids, spl_section_div(spl), "DataRow")

  if (is(kids, "error")) {
    stop("Error applying analysis function (var - ",
      spl_payload(spl) %||% "colvars", "): ", kids$message,
      "\n\toccured at (row) path: ",
      spl_context_to_disp_path(spl_context),
      call. = FALSE
    )
  }

  fmtlist <- NULL
  if (!is.null(spl_formats_var(spl))) {
    if (is.null(spl_na_strs_var(spl))) {
      na_strs <- character() ## case handled in .apply_default_formats
    } else {
      na_strs <- df[[spl_na_strs_var(spl)]][[1]]
    }
    fmtlist <- df[[spl_formats_var(spl)]][[1]]
  } else if (have_fmt_lst) {
    fmtlist <- obj_format(spl)
    na_strs <- obj_na_str(spl)
    if (is.character(na_strs)) {
      na_strs <- lapply(fmtlist, function(nm) na_strs)
      names(na_strs) <- names(fmtlist)
    }
  }

  if (!is.null(fmtlist)) {
    kids <- .apply_default_formats(
      kids,
      fmtlist,
      na_strs
    )
  }

  lab <- obj_label(spl)
  if (is.character(obj_na_str(spl))) {
    final_na_str <- obj_na_str(spl)
  } else {
    final_na_str <- NA_character_
  }
  ret <- TableTree(
    kids = kids,
    name = obj_name(spl),
    label = lab,
    lev = lvl,
    cinfo = cinfo,
    format = if (is.null(fmtlist)) obj_format(spl) else NULL,
    na_str = final_na_str,
    indent_mod = indent_mod(spl),
    trailing_section_div = spl_section_div(spl)
  )

  labelrow_visible(ret) <- dolab
  ret
}

#' @param ... all arguments to `recurse_applysplit`, methods may only use some of them.
#' @return A `list` of children to place at this level.
#'
#' @noRd
setGeneric(".make_split_kids", function(spl, have_controws, make_lrow, ...) {
  standardGeneric(".make_split_kids")
})

## single AnalyzeSplit
setMethod(
  ".make_split_kids", "VAnalyzeSplit",
  function(spl,
           have_controws, ## unused here
           make_lrow, ## unused here
           ...,
           df,
           alt_df,
           alt_df_full,
           lvl,
           name,
           cinfo,
           baselines,
           spl_context,
           nsibs = 0) {
    spvis <- labelrow_visible(spl)
    if (is.na(spvis)) {
      spvis <- nsibs > 0
    }

    ret <- .make_analyzed_tab(
      df = df,
      alt_df,
      alt_df_full = alt_df_full,
      spl = spl,
      cinfo = cinfo,
      lvl = lvl + 1L,
      dolab = spvis,
      partlabel = obj_label(spl),
      baselines = baselines,
      spl_context = spl_context
    )
    indent_mod(ret) <- indent_mod(spl)

    kids <- list(ret)
    names(kids) <- obj_name(ret)
    kids
  }
)

# Adding section_divisors to TableRow
.set_kids_section_div <- function(lst, trailing_section_div_char, allowed_class = "VTableTree") {
  if (!is.na(trailing_section_div_char)) {
    lst <- lapply(
      lst,
      function(k) {
        if (is(k, allowed_class)) {
          trailing_section_div(k) <- trailing_section_div_char
        }
        k
      }
    )
  }
  lst
}

## 1 or more AnalyzeSplits
setMethod(
  ".make_split_kids", "AnalyzeMultiVars",
  function(spl,
           have_controws,
           make_lrow, ## used here
           spl_context,
           ...) { ## all passed directly down to VAnalyzeSplit method
    avspls <- spl_payload(spl)

    nspl <- length(avspls)

    kids <- unlist(lapply(avspls,
      .make_split_kids,
      nsibs = nspl - 1,
      have_controws = have_controws,
      make_lrow = make_lrow,
      spl_context = spl_context,
      ...
    ))

    kids <- .set_kids_section_div(kids, spl_section_div(spl), "VTableTree")

    ## XXX this seems like it should be identical not !identical
    ## TODO FIXME
    if (!identical(make_lrow, FALSE) && !have_controws && length(kids) == 1) {
      ## we only analyzed one var so
      ## we don't need an extra wrapper table
      ## in the structure
      stopifnot(identical(
        obj_name(kids[[1]]),
        spl_payload(spl)
      ))
      return(kids[[1]])
    }
    ## this will be the variables
    ## nms = sapply(spl_payload(spl), spl_payload)

    nms <- vapply(kids, obj_name, "")
    labs <- vapply(kids, obj_label, "")
    if (length(unique(nms)) != length(nms) && length(unique(nms)) != length(nms)) {
      warning("Non-unique sibling analysis table names. Using Labels ",
        "instead. Use the table_names argument to analyze to avoid ",
        "this when analyzing the same variable multiple times.",
        "\n\toccured at (row) path: ",
        spl_context_to_disp_path(spl_context),
        call. = FALSE
      )
      kids <- mapply(function(k, nm) {
        obj_name(k) <- nm
        k
      }, k = kids, nm = labs, SIMPLIFY = FALSE)
      nms <- labs
    }

    nms[is.na(nms)] <- ""

    names(kids) <- nms
    kids
  }
)

setMethod(
  ".make_split_kids", "Split",
  function(spl,
           have_controws,
           make_lrow,
           ...,
           splvec, ## passed to recursive_applysplit
           df, ## used to apply split
           alt_df, ## used to apply split for alternative df
           alt_df_full, ## passed to recursive_applysplit
           lvl, ## used to calculate innerlev
           cinfo, ## used for sanity check
           baselines, ## used to calc new baselines
           spl_context) {
    ## do the core splitting of data into children for this split
    rawpart <- do_split(spl, df, spl_context = spl_context)
    dataspl <- rawpart[["datasplit"]]
    ## these are SplitValue objects
    splvals <- rawpart[["values"]]
    partlabels <- rawpart[["labels"]]
    if (is.factor(partlabels)) {
      partlabels <- as.character(partlabels)
    }
    nms <- unlist(value_names(splvals))
    if (is.factor(nms)) {
      nms <- as.character(nms)
    }

    ## Get new baseline values
    ##
    ## XXX this is a lot of data churn, if it proves too slow
    ## we can
    ## a) check if any of the analyses (i.e. the afuns) need the baseline in this
    ##    splitvec and not do any of this if not, or
    ## b) refactor row splitting to behave like column splitting
    ##
    ## (b) seems the better design but is a major reworking of the guts of how
    ## rtables tabulation works
    ## (a) will only help if analyses that use baseline
    ## info are mixed with those who don't.
    newbl_raw <- lapply(baselines, function(dat) {
      # If no ref_group is specified
      if (is.null(dat)) {
        return(NULL)
      }

      ## apply the same splitting on the
      bldataspl <- tryCatch(do_split(spl, dat, spl_context = spl_context)[["datasplit"]],
        error = function(e) e
      )

      # Error localization
      if (is(bldataspl, "error")) {
        stop("Following error encountered in splitting .ref_group (baselines): ",
          bldataspl$message,
          call. = FALSE
        )
      }

      ## we only keep the ones corresponding with actual data splits
      res <- lapply(
        names(dataspl),
        function(nm) {
          if (nm %in% names(bldataspl)) {
            bldataspl[[nm]]
          } else {
            dataspl[[1]][0, ]
          }
        }
      )

      names(res) <- names(dataspl)
      res
    })

    newbaselines <- lapply(names(dataspl), function(nm) {
      lapply(newbl_raw, function(rawdat) {
        if (nm %in% names(rawdat)) {
          rawdat[[nm]]
        } else {
          rawdat[[1]][0, ]
        }
      })
    })

    if (length(newbaselines) != length(dataspl)) {
      stop(
        "Baselines (ref_group) after row split does not have",
        " the same number of levels of input data split. ",
        "Contact the maintainer."
      ) # nocov
    }
    if (!(length(newbaselines) == 0 ||
      identical(
        unique(sapply(newbaselines, length)),
        length(col_exprs(cinfo))
      ))) {
      stop(
        "Baselines (ref_group) do not have the same number of columns",
        " in each split. Contact the maintainer."
      ) # nocov
    }

    # If params are not present do not do the calculation
    acdf_param <- check_afun_cfun_params(
      SplitVector(spl, splvec),
      c(".alt_df", ".alt_df_row")
    )

    # Apply same split for alt_counts_df
    if (!is.null(alt_df) && any(acdf_param)) {
      alt_dfpart <- tryCatch(
        do_split(spl, alt_df,
          spl_context = spl_context
        )[["datasplit"]],
        error = function(e) e
      )

      # Removing NA rows - to explore why this happens at all in a split
      # This would be a fix but it is done in post-processing instead of pre-proc -> xxx
      # x alt_dfpart <- lapply(alt_dfpart, function(data) {
      # x    data[!apply(is.na(data), 1, all), ]
      # x })

      # Error localization
      if (is(alt_dfpart, "error")) {
        stop("Following error encountered in splitting alt_counts_df: ",
          alt_dfpart$message,
          call. = FALSE
        )
      }
      # Error if split does not have the same values in the alt_df (and order)
      # The following breaks if there are different levels (do_split returns empty list)
      # or if there are different number of the same levels. Added handling of NAs
      # in the values of the factor when is all only NAs
      is_all_na <- all(is.na(alt_df[[spl_payload(spl)]]))

      if (!all(names(dataspl) %in% names(alt_dfpart)) || length(alt_dfpart) != length(dataspl) || is_all_na) {
        alt_df_spl_vals <- unique(alt_df[[spl_payload(spl)]])
        end_part <- ""

        if (!all(alt_df_spl_vals %in% levels(alt_df_spl_vals))) {
          end_part <- paste0(
            " and following levels: ",
            paste_vec(levels(alt_df_spl_vals))
          )
        }

        if (is_all_na) {
          end_part <- ". Found only NAs in alt_counts_df split"
        }

        stop(
          "alt_counts_df split variable(s) [", spl_payload(spl),
          "] (in split ", as.character(class(spl)),
          ") does not have the same factor levels of df.\ndf has c(", '"',
          paste(names(dataspl), collapse = '", "'), '"', ") levels while alt_counts_df has ",
          ifelse(length(alt_df_spl_vals) > 0, paste_vec(alt_df_spl_vals), ""),
          " unique values", end_part
        )
      }
    } else {
      alt_dfpart <- setNames(rep(list(NULL), length(dataspl)), names(dataspl))
    }


    innerlev <- lvl + (have_controws || is.na(make_lrow) || make_lrow)
    ## do full recursive_applysplit on each part of the split defined by spl
    inner <- unlist(mapply(
      function(dfpart, alt_dfpart, nm, label, baselines, splval) {
        rsplval <- context_df_row(
          split = obj_name(spl),
          value = value_names(splval),
          full_parent_df = list(dfpart),
          cinfo = cinfo
        )

        ## if(length(rsplval) > 0)
        ##     rsplval <- setNames(rsplval, obj_name(spl))
        recursive_applysplit(
          df = dfpart,
          alt_df = alt_dfpart,
          alt_df_full = alt_df_full,
          name = nm,
          lvl = innerlev,
          splvec = splvec,
          cinfo = cinfo,
          make_lrow = label_kids(spl),
          parent_cfun = content_fun(spl),
          cformat = content_format(spl),
          cna_str = content_na_str(spl),
          partlabel = label,
          cindent_mod = content_indent_mod(spl),
          cvar = content_var(spl),
          baselines = baselines,
          cextra_args = content_extra_args(spl),
          ## splval should still be retaining its name
          spl_context = rbind(spl_context, rsplval)
        )
      },
      dfpart = dataspl,
      alt_dfpart = alt_dfpart,
      label = partlabels,
      nm = nms,
      baselines = newbaselines,
      splval = splvals,
      SIMPLIFY = FALSE
    ))

    # Setting the kids section separator if they inherits VTableTree
    inner <- .set_kids_section_div(
      inner,
      trailing_section_div_char = spl_section_div(spl),
      allowed_class = "VTableTree"
    )

    ## This is where we need to build the structural tables
    ## even if they are invisible because their labels are not
    ## not shown.
    innertab <- TableTree(
      kids = inner,
      name = obj_name(spl),
      labelrow = LabelRow(
        label = obj_label(spl),
        vis = isTRUE(vis_label(spl))
      ),
      cinfo = cinfo,
      iscontent = FALSE,
      indent_mod = indent_mod(spl),
      page_title = ptitle_prefix(spl)
    )
    ## kids = inner
    kids <- list(innertab)
    kids
  }
)

context_df_row <- function(split = character(),
                           value = character(),
                           full_parent_df = list(),
                           cinfo = NULL) {
  ret <- data.frame(
    split = split,
    value = value,
    full_parent_df = I(full_parent_df),
    #     parent_cold_inds = I(parent_col_inds),
    stringsAsFactors = FALSE
  )
  if (nrow(ret) > 0) {
    ret$all_cols_n <- nrow(full_parent_df[[1]])
  } else {
    ret$all_cols_n <- integer() ## should this be numeric??? This never happens
  }

  if (!is.null(cinfo)) {
    if (nrow(ret) > 0) {
      colcols <- as.data.frame(lapply(col_exprs(cinfo), function(e) {
        vals <- eval(e, envir = full_parent_df[[1]])
        if (identical(vals, TRUE)) {
          vals <- rep(vals, length.out = nrow(full_parent_df[[1]]))
        }
        I(list(vals))
      }))
    } else {
      colcols <- as.data.frame(rep(list(logical()), ncol(cinfo)))
    }
    names(colcols) <- names(col_exprs(cinfo))
    ret <- cbind(ret, colcols)
  }
  ret
}

recursive_applysplit <- function(df,
                                 lvl = 0L,
                                 alt_df,
                                 alt_df_full,
                                 splvec,
                                 name,
                                 #         label,
                                 make_lrow = NA,
                                 partlabel = "",
                                 cinfo,
                                 parent_cfun = NULL,
                                 cformat = NULL,
                                 cna_str = NA_character_,
                                 cindent_mod = 0L,
                                 cextra_args = list(),
                                 cvar = NULL,
                                 baselines = lapply(
                                   col_extra_args(cinfo),
                                   function(x) x$.ref_full
                                 ),
                                 spl_context = context_df_row(cinfo = cinfo),
                                 no_outer_tbl = FALSE,
                                 parent_sect_split = NA_character_) {
  ## pre-existing table was added to the layout
  if (length(splvec) == 1L && is(splvec[[1]], "VTableNodeInfo")) {
    return(splvec[[1]])
  }

  ## the content function is the one from the PREVIOUS
  ## split, i.e. the one whose children we are now constructing
  ## this is a bit annoying but makes the semantics for
  ## declaring layouts much more sane.
  ctab <- .make_ctab(df,
    lvl = lvl,
    name = name,
    label = partlabel,
    cinfo = cinfo,
    parent_cfun = parent_cfun,
    format = cformat,
    na_str = cna_str,
    indent_mod = cindent_mod,
    cvar = cvar,
    alt_df = alt_df,
    alt_df_full = alt_df_full,
    extra_args = cextra_args,
    spl_context = spl_context
  )

  nonroot <- lvl != 0L

  if (is.na(make_lrow)) {
    make_lrow <- if (nrow(ctab) > 0 || !nzchar(partlabel)) FALSE else TRUE
  }
  ## never print an empty row label for root.
  if (make_lrow && partlabel == "" && !nonroot) {
    make_lrow <- FALSE
  }

  if (length(splvec) == 0L) {
    kids <- list()
    imod <- 0L
    spl <- NULL
  } else {
    spl <- splvec[[1]]
    splvec <- splvec[-1]

    ## we pass this everything recursive_applysplit received and
    ## it all gets passed around through ... as needed
    ## to the various methods of .make_split_kids
    kids <- .make_split_kids(
      spl = spl,
      df = df,
      alt_df = alt_df,
      alt_df_full = alt_df_full,
      lvl = lvl,
      splvec = splvec,
      name = name,
      make_lrow = make_lrow,
      partlabel = partlabel,
      cinfo = cinfo,
      parent_cfun = parent_cfun,
      cformat = cformat,
      cindent_mod = cindent_mod,
      cextra_args = cextra_args, cvar = cvar,
      baselines = baselines,
      spl_context = spl_context,
      have_controws = nrow(ctab) > 0
    )
    imod <- 0L
  } ## end length(splvec)

  if (is.na(make_lrow)) {
    make_lrow <- if (nrow(ctab) > 0 || !nzchar(partlabel)) FALSE else TRUE
  }
  ## never print an empty row label for root.
  if (make_lrow && partlabel == "" && !nonroot) {
    make_lrow <- FALSE
  }

  ## this is only true when called from build_table and the first split
  ## in (one of the) SplitVector is NOT an AnalyzeMultiVars split.
  ## in that case we would be "double creating" the structural
  ## subtable
  if (no_outer_tbl) {
    ret <- kids[[1]]
    indent_mod(ret) <- indent_mod(spl)
  } else if (nrow(ctab) > 0L || length(kids) > 0L) {
    ## previously we checked if the child had an identical label
    ## but I don't think thats needed anymore.
    tlabel <- partlabel
    ret <- TableTree(
      cont = ctab,
      kids = kids,
      name = name,
      label = tlabel, # partlabel,
      lev = lvl,
      iscontent = FALSE,
      labelrow = LabelRow(
        lev = lvl,
        label = tlabel,
        cinfo = cinfo,
        vis = make_lrow
      ),
      cinfo = cinfo,
      indent_mod = imod
    )
  } else {
    ret <- NULL
  }

  ## if(!is.null(spl) && !is.na(spl_section_sep(spl)))
  ##     ret <- apply_kids_section_sep(ret, spl_section_sep(spl))
  ## ## message(sprintf("indent modifier: %d", indentmod))
  ## if(!is.null(ret))
  ##     indent_mod(ret) = indentmod
  ret
}

#' Create a table from a layout and data
#'
#' Layouts are used to describe a table pre-data. `build_table` is used to create a table
#' using a layout and a dataset.
#'
#' @inheritParams gen_args
#' @inheritParams lyt_args
#' @param col_counts (`numeric` or `NULL`)\cr `r lifecycle::badge("deprecated")` if non-`NULL`, column counts
#'   *for leaf-columns only* which override those calculated automatically during tabulation. Must specify
#'   "counts" for *all* leaf-columns if non-`NULL`. `NA` elements will be replaced with the automatically
#'   calculated counts. Turns on display of leaf-column counts when non-`NULL`.
#' @param col_total (`integer(1)`)\cr the total observations across all columns. Defaults to `nrow(df)`.
#' @param ... ignored.
#'
#' @details
#' When `alt_counts_df` is specified, column counts are calculated by applying the exact column subsetting
#' expressions determined when applying column splitting to the main data (`df`) to `alt_counts_df` and
#' counting the observations in each resulting subset.
#'
#' In particular, this means that in the case of splitting based on cuts of the data, any dynamic cuts will have
#' been calculated based on `df` and simply re-used for the count calculation.
#'
#' @note
#' When overriding the column counts or totals care must be taken that, e.g., `length()` or `nrow()` are not called
#' within tabulation functions, because those will NOT give the overridden counts. Writing/using tabulation
#' functions which accept `.N_col` and `.N_total` or do not rely on column counts at all (even implicitly) is the
#' only way to ensure overridden counts are fully respected.
#'
#' @return A `TableTree` or `ElementaryTable` object representing the table created by performing the tabulations
#'   declared in `lyt` to the data `df`.
#'
#' @examples
#' lyt <- basic_table() %>%
#'   split_cols_by("Species") %>%
#'   analyze("Sepal.Length", afun = function(x) {
#'     list(
#'       "mean (sd)" = rcell(c(mean(x), sd(x)), format = "xx.xx (xx.xx)"),
#'       "range" = diff(range(x))
#'     )
#'   })
#' lyt
#'
#' tbl <- build_table(lyt, iris)
#' tbl
#'
#' # analyze multiple variables
#' lyt2 <- basic_table() %>%
#'   split_cols_by("Species") %>%
#'   analyze(c("Sepal.Length", "Petal.Width"), afun = function(x) {
#'     list(
#'       "mean (sd)" = rcell(c(mean(x), sd(x)), format = "xx.xx (xx.xx)"),
#'       "range" = diff(range(x))
#'     )
#'   })
#'
#' tbl2 <- build_table(lyt2, iris)
#' tbl2
#'
#' # an example more relevant for clinical trials with column counts
#' lyt3 <- basic_table(show_colcounts = TRUE) %>%
#'   split_cols_by("ARM") %>%
#'   analyze("AGE", afun = function(x) {
#'     setNames(as.list(fivenum(x)), c(
#'       "minimum", "lower-hinge", "median",
#'       "upper-hinge", "maximum"
#'     ))
#'   })
#'
#' tbl3 <- build_table(lyt3, DM)
#' tbl3
#'
#' tbl4 <- build_table(lyt3, subset(DM, AGE > 40))
#' tbl4
#'
#' # with column counts calculated based on different data
#' miniDM <- DM[sample(1:NROW(DM), 100), ]
#' tbl5 <- build_table(lyt3, DM, alt_counts_df = miniDM)
#' tbl5
#'
#' tbl6 <- build_table(lyt3, DM, col_counts = 1:3)
#' tbl6
#'
#' @author Gabriel Becker
#' @export
build_table <- function(lyt, df,
                        alt_counts_df = NULL,
                        col_counts = NULL,
                        col_total = if (is.null(alt_counts_df)) nrow(df) else nrow(alt_counts_df),
                        topleft = NULL,
                        hsep = default_hsep(),
                        round_type = if (is(lyt, "PreDataTableLayouts")) obj_round_type(lyt) else valid_round_type,
                        ...) {
  if (!is(lyt, "PreDataTableLayouts")) {
    stop(
      "lyt must be a PreDataTableLayouts object. Got object of class ",
      class(lyt)
    )
  }

  ## if no columns are defined (e.g. because lyt is NULL)
  ## add a single overall column as the "most basic"
  ## table column structure that makes sense
  clyt <- clayout(lyt)
  if (length(clyt) == 1 && length(clyt[[1]]) == 0) {
    clyt[[1]] <- add_overall_col(clyt[[1]], "")
    clayout(lyt) <- clyt
  }

  ## do checks and defensive programming now that we have the data
  lyt <- fix_dyncuts(lyt, df)
  lyt <- set_def_child_ord(lyt, df)
  lyt <- fix_analyze_vis(lyt)
  df <- fix_split_vars(lyt, df, char_ok = is.null(col_counts))
  alt_params <- check_afun_cfun_params(lyt, c(".alt_df", ".alt_df_row"))
  if (any(alt_params) && is.null(alt_counts_df)) {
    stop(
      "Layout contains afun/cfun functions that have optional parameters ",
      ".alt_df and/or .alt_df_row, but no alt_counts_df was provided in ",
      "build_table()."
    )
  }

  rtpos <- TreePos()
  cinfo <- create_colinfo(lyt, df, rtpos,
    counts = col_counts,
    alt_counts_df = alt_counts_df,
    total = col_total,
    topleft
  )
  if (!is.null(col_counts)) {
    toreplace <- !is.na(col_counts)
    newccs <- col_counts(cinfo) ## old actual counts
    newccs[toreplace] <- col_counts[toreplace]
    col_counts(cinfo) <- newccs
    leaf_paths <- col_paths(cinfo)
    for (pth in leaf_paths) {
      colcount_visible(cinfo, pth) <- TRUE
    }
  }
  rlyt <- rlayout(lyt)
  rtspl <- root_spl(rlyt)
  ctab <- .make_ctab(df, 0L,
    alt_df = NULL,
    alt_df_full = alt_counts_df,
    name = "root",
    label = "",
    cinfo = cinfo, ## cexprs, ctree,
    parent_cfun = content_fun(rtspl),
    format = content_format(rtspl),
    na_str = content_na_str(rtspl),
    indent_mod = 0L,
    cvar = content_var(rtspl),
    extra_args = content_extra_args(rtspl)
  )

  kids <- lapply(seq_along(rlyt), function(i) {
    splvec <- rlyt[[i]]
    if (length(splvec) == 0) {
      return(NULL)
    }
    firstspl <- splvec[[1]]
    nm <- obj_name(firstspl)
    ## XXX unused, probably shouldn't be?
    ## this seems to be covered by grabbing the partlabel
    ## TODO confirm this
    ## lab <- obj_label(firstspl)
    recursive_applysplit(
      df = df, lvl = 0L,
      alt_df = alt_counts_df,
      alt_df_full = alt_counts_df,
      name = nm,
      splvec = splvec,
      cinfo = cinfo,
      ## XXX are these ALWAYS right?
      make_lrow = label_kids(firstspl),
      parent_cfun = NULL,
      cformat = content_format(firstspl),
      cna_str = content_na_str(firstspl),
      cvar = content_var(firstspl),
      cextra_args = content_extra_args(firstspl),
      spl_context = context_df_row(
        split = "root", value = "root",
        full_parent_df = list(df),
        cinfo = cinfo
      ),
      ## we DO want the 'outer table' if the first
      ## one is a multi-analyze
      no_outer_tbl = !is(firstspl, "AnalyzeMultiVars")
    )
  })
  kids <- kids[!sapply(kids, is.null)]
  if (length(kids) > 0) names(kids) <- sapply(kids, obj_name)

  # top level divisor
  if (!is.na(top_level_section_div(lyt))) {
    kids <- lapply(kids, function(first_level_kids) {
      trailing_section_div(first_level_kids) <- top_level_section_div(lyt)
      first_level_kids
    })
  }

  if (nrow(ctab) == 0L && length(kids) == 1L && is(kids[[1]], "VTableTree")) {
    tab <- kids[[1]]
    main_title(tab) <- main_title(lyt)
    subtitles(tab) <- subtitles(lyt)
    main_footer(tab) <- main_footer(lyt)
    prov_footer(tab) <- prov_footer(lyt)
    header_section_div(tab) <- header_section_div(lyt)
    obj_round_type(tab) <- round_type
  } else {
    tab <- TableTree(
      cont = ctab,
      kids = kids,
      lev = 0L,
      name = "root",
      label = "",
      iscontent = FALSE,
      cinfo = cinfo,
      format = obj_format(rtspl),
      na_str = obj_na_str(rtspl),
      title = main_title(lyt),
      subtitles = subtitles(lyt),
      main_footer = main_footer(lyt),
      prov_footer = prov_footer(lyt),
      header_section_div = header_section_div(lyt),
      round_type = round_type
    )
  }

  ## This seems to be unneeded, not clear what 'top_left' check it refers to
  ## but both top_left taller than column headers and very long topleft are now
  ## allowed, so this is just wasted computation.

  ## ## this is where the top_left check lives right now. refactor later maybe
  ## ## but now just call it so the error gets thrown when I want it to
  ## unused <- matrix_form(tab)
  tab <- update_ref_indexing(tab)
  horizontal_sep(tab) <- hsep
  if (table_inset(lyt) > 0) {
    table_inset(tab) <- table_inset(lyt)
  }
  tab
}

# fix_split_vars ----
# These checks guarantee that all the split variables are present in the data.
# No generic is needed because it is not dependent on the input layout but
# on the df.
fix_one_split_var <- function(spl, df, char_ok = TRUE) {
  var <- spl_payload(spl)
  if (!(var %in% names(df))) {
    stop("Split variable [", var, "] not found in data being tabulated.")
  }
  varvec <- df[[var]]
  if (!is(varvec, "character") && !is.factor(varvec)) {
    message(sprintf(
      paste(
        "Split var [%s] was not character or factor.",
        "Converting to factor"
      ),
      var
    ))
    varvec <- factor(varvec)
    df[[var]] <- varvec
  } else if (is(varvec, "character") && !char_ok) {
    stop(
      "Overriding column counts is not supported when splitting on ",
      "character variables.\n Please convert all column split variables to ",
      "factors."
    )
  }

  if (is.factor(varvec)) {
    levs <- levels(varvec)
  } else {
    levs <- unique(varvec)
  }
  if (!all(nzchar(levs))) {
    stop(
      "Got empty string level in splitting variable ", var,
      " This is not supported.\nIf display as an empty level is ",
      "desired use a value-labeling variable."
    )
  }

  ## handle label var
  lblvar <- spl_label_var(spl)
  have_lblvar <- !identical(var, lblvar)
  if (have_lblvar) {
    if (!(lblvar %in% names(df))) {
      stop(
        "Value label variable [", lblvar,
        "] not found in data being tabulated."
      )
    }
    lblvec <- df[[lblvar]]
    tab <- table(varvec, lblvec)

    if (any(rowSums(tab > 0) > 1) || any(colSums(tab > 0) > 1)) {
      stop(sprintf(
        paste(
          "There does not appear to be a 1-1",
          "correspondence between values in split var",
          "[%s] and label var [%s]"
        ),
        var, lblvar
      ))
    }

    if (!is(lblvec, "character") && !is.factor(lblvec)) {
      message(sprintf(
        paste(
          "Split label var [%s] was not character or",
          "factor. Converting to factor"
        ),
        var
      ))
      lblvec <- factor(lblvec)
      df[[lblvar]] <- lblvec
    }
  }

  df
}

fix_split_vars <- function(lyt, df, char_ok) {
  df <- fix_split_vars_inner(clayout(lyt), df, char_ok = char_ok)
  df <- fix_split_vars_inner(rlayout(lyt), df, char_ok = TRUE)
  df

  ## clyt <- clayout(lyt)
  ## rlyt <- rlayout(lyt)

  ## allspls <- unlist(list(clyt, rlyt))
  ## VarLevelSplit includes sublclass VarLevWBaselineSplit
}

fix_split_vars_inner <- function(lyt, df, char_ok) {
  stopifnot(is(lyt, "PreDataAxisLayout"))
  allspls <- unlist(lyt)
  varspls <- allspls[sapply(allspls, is, "VarLevelSplit")]
  unqvarinds <- !duplicated(sapply(varspls, spl_payload))
  unqvarspls <- varspls[unqvarinds]
  for (spl in unqvarspls) df <- fix_one_split_var(spl, df, char_ok = char_ok)

  df
}

# set_def_child_ord ----
## the table is built by recursively splitting the data and doing things to each
## piece. The order (or even values) of unique(df[[col]]) is not guaranteed to
## be the same in all the different partitions. This addresses that.
setGeneric(
  "set_def_child_ord",
  function(lyt, df) standardGeneric("set_def_child_ord")
)

setMethod(
  "set_def_child_ord", "PreDataTableLayouts",
  function(lyt, df) {
    clayout(lyt) <- set_def_child_ord(clayout(lyt), df)
    rlayout(lyt) <- set_def_child_ord(rlayout(lyt), df)
    lyt
  }
)

setMethod(
  "set_def_child_ord", "PreDataAxisLayout",
  function(lyt, df) {
    lyt@.Data <- lapply(lyt, set_def_child_ord, df = df)
    lyt
  }
)

setMethod(
  "set_def_child_ord", "SplitVector",
  function(lyt, df) {
    lyt[] <- lapply(lyt, set_def_child_ord, df = df)
    lyt
  }
)

## for most split types, don't do anything
## becuause their ordering already isn't data-based
setMethod(
  "set_def_child_ord", "ANY",
  function(lyt, df) lyt
)

setMethod(
  "set_def_child_ord", "VarLevelSplit",
  function(lyt, df) {
    if (!is.null(spl_child_order(lyt))) {
      return(lyt)
    }

    vec <- df[[spl_payload(lyt)]]
    vals <- if (is.factor(vec)) {
      levels(vec)
    } else {
      unique(vec)
    }
    spl_child_order(lyt) <- vals
    lyt
  }
)

setMethod(
  "set_def_child_ord", "VarLevWBaselineSplit",
  function(lyt, df) {
    bline <- spl_ref_group(lyt)
    if (!is.null(spl_child_order(lyt)) && match(bline, spl_child_order(lyt), nomatch = -1) == 1L) {
      return(lyt)
    }

    if (!is.null(split_fun(lyt))) {
      ## expensive but sadly necessary, I think
      pinfo <- do_split(lyt, df, spl_context = context_df_row())
      vals <- sort(unlist(value_names(pinfo$values)))
    } else {
      vec <- df[[spl_payload(lyt)]]
      vals <- if (is.factor(vec)) {
        levels(vec)
      } else {
        unique(vec)
      }
    }
    if (!bline %in% vals) {
      stop(paste0(
        'Reference group "', bline, '"', " was not present in the levels of ", spl_payload(lyt), " in the data."
      ))
    }
    spl_child_order(lyt) <- vals
    lyt
  }
)

splitvec_to_coltree <- function(df, splvec, pos = NULL,
                                lvl = 1L, label = "",
                                spl_context = context_df_row(cinfo = NULL),
                                alt_counts_df = df,
                                global_cc_format) {
  stopifnot(
    lvl <= length(splvec) + 1L,
    is(splvec, "SplitVector")
  )


  if (lvl == length(splvec) + 1L) {
    ## XXX this should be a LayoutColree I Think.
    nm <- unlist(tail(value_names(pos), 1)) %||% ""
    spl <- tail(pos_splits(pos), 1)[[1]]
    fmt <- colcount_format(spl) %||% global_cc_format
    LayoutColLeaf(
      lev = lvl - 1L,
      label = label,
      tpos = pos,
      name = nm,
      colcount = NROW(alt_counts_df),
      disp_ccounts = disp_ccounts(spl),
      colcount_format = fmt
    )
  } else {
    spl <- splvec[[lvl]]
    nm <- if (is.null(pos) || length(pos_splits(pos)) == 0) {
      obj_name(spl)
    } else {
      unlist(tail(
        value_names(pos),
        1
      ))
    }
    rawpart <- do_split(spl, df,
      trim = FALSE,
      spl_context = spl_context
    )
    datparts <- rawpart[["datasplit"]]
    vals <- rawpart[["values"]]
    labs <- rawpart[["labels"]]

    force(alt_counts_df)
    kids <- mapply(
      function(dfpart, value, partlab) {
        ## we could pass subset expression in here but the spec
        ## currently doesn't call for it in column space
        newprev <- context_df_row(
          split = obj_name(spl),
          value = value_names(value),
          full_parent_df = list(dfpart),
          cinfo = NULL
        )
        ## subset expressions handled inside make_child_pos,
        ## value is (optionally, for the moment) carrying it around
        newpos <- make_child_pos(pos, spl, value, partlab)
        acdf_subset_expr <- make_subset_expr(spl, value)
        new_acdf_subset <- try(eval(acdf_subset_expr, alt_counts_df), silent = TRUE)
        if (is(new_acdf_subset, "try-error")) {
          stop(sprintf(
            paste(
              ifelse(identical(df, alt_counts_df), "df", "alt_counts_df"),
              "appears incompatible with column-split",
              "structure. Offending column subset",
              "expression: %s\nOriginal error",
              "message: %s"
            ), deparse(acdf_subset_expr[[1]]),
            conditionMessage(attr(new_acdf_subset, "condition"))
          ))
        }

        splitvec_to_coltree(dfpart, splvec, newpos,
          lvl + 1L, partlab,
          spl_context = rbind(spl_context, newprev),
          alt_counts_df = alt_counts_df[new_acdf_subset, , drop = FALSE],
          global_cc_format = global_cc_format
        )
      },
      dfpart = datparts, value = vals,
      partlab = labs, SIMPLIFY = FALSE
    )
    disp_cc <- FALSE
    cc_format <- global_cc_format # this doesn't matter probably, but its technically more correct
    if (lvl > 1) {
      disp_cc <- disp_ccounts(splvec[[lvl - 1]])
      cc_format <- colcount_format(splvec[[lvl - 1]]) %||% global_cc_format
    }

    names(kids) <- value_names(vals)
    LayoutColTree(
      lev = lvl, label = label,
      spl = spl,
      kids = kids, tpos = pos,
      name = nm,
      summary_function = content_fun(spl),
      colcount = NROW(alt_counts_df),
      disp_ccounts = disp_cc,
      colcount_format = cc_format
    )
  }
}

# fix_analyze_vis ----
## now that we know for sure the number of siblings
## collaplse NAs to TRUE/FALSE for whether
## labelrows should be visible for ElementaryTables
## generatead from analyzing a single variable
setGeneric("fix_analyze_vis", function(lyt) standardGeneric("fix_analyze_vis"))

setMethod(
  "fix_analyze_vis", "PreDataTableLayouts",
  function(lyt) {
    rlayout(lyt) <- fix_analyze_vis(rlayout(lyt))
    lyt
  }
)

setMethod(
  "fix_analyze_vis", "PreDataRowLayout",
  function(lyt) {
    splvecs <- lapply(lyt, fix_analyze_vis)
    PreDataRowLayout(
      root = root_spl(lyt),
      lst = splvecs
    )
  }
)

setMethod(
  "fix_analyze_vis", "SplitVector",
  function(lyt) {
    len <- length(lyt)
    if (len == 0) {
      return(lyt)
    }
    lastspl <- lyt[[len]]
    if (!(is(lastspl, "VAnalyzeSplit") || is(lastspl, "AnalyzeMultivar"))) {
      return(lyt)
    }

    if (is(lastspl, "VAnalyzeSplit") && is.na(labelrow_visible(lastspl))) {
      ##  labelrow_visible(lastspl) = FALSE
      labelrow_visible(lastspl) <- "hidden"
    } else if (is(lastspl, "AnalyzeMultiVar")) {
      pld <- spl_payload(lastspl)
      newpld <- lapply(pld, function(sp, havesibs) {
        if (is.na(labelrow_visible(sp))) {
          labelrow_visible(sp) <- havesibs
        }
      }, havesibs = len > 1)
      spl_payload(lastspl) <- newpld
      ## pretty sure this isn't needed...
      if (is.na(label_kids(lastspl))) {
        label_kids(lastspl) <- len > 1
      }
    }
    lyt[[len]] <- lastspl
    lyt
  }
)

# check_afun_cfun_params ----

# This checks if the input params are used anywhere in cfun/afun
setGeneric("check_afun_cfun_params", function(lyt, params) {
  standardGeneric("check_afun_cfun_params")
})

setMethod(
  "check_afun_cfun_params", "PreDataTableLayouts",
  function(lyt, params) {
    # clayout does not have analysis functions
    check_afun_cfun_params(rlayout(lyt), params)
  }
)

setMethod(
  "check_afun_cfun_params", "PreDataRowLayout",
  function(lyt, params) {
    ro_spl_parm_l <- check_afun_cfun_params(root_spl(lyt), params)
    r_spl_parm_l <- lapply(lyt, check_afun_cfun_params, params = params)
    Reduce(`|`, c(list(ro_spl_parm_l), r_spl_parm_l))
  }
)

# Main function for checking parameters
setMethod(
  "check_afun_cfun_params", "SplitVector",
  function(lyt, params) {
    param_l <- lapply(lyt, check_afun_cfun_params, params = params)
    Reduce(`|`, param_l)
  }
)

# Helper function for check_afun_cfun_params
.afun_cfun_switch <- function(spl_i) {
  if (is(spl_i, "VAnalyzeSplit")) {
    analysis_fun(spl_i)
  } else {
    content_fun(spl_i)
  }
}

# Extreme case that happens only when using add_existing_table
setMethod(
  "check_afun_cfun_params", "VTableTree",
  function(lyt, params) {
    setNames(logical(length(params)), params) # All FALSE
  }
)

setMethod(
  "check_afun_cfun_params", "Split",
  function(lyt, params) {
    # Extract function in the split
    fnc <- .afun_cfun_switch(lyt)

    # For each parameter, check if it is called
    sapply(params, function(pai) any(unlist(func_takes(fnc, pai))))
  }
)

# Helper functions ----

count <- function(df, ...) NROW(df)

guess_format <- function(val) {
  if (length(val) == 1) {
    if (is.integer(val) || !is.numeric(val)) {
      "xx"
    } else {
      "xx.xx"
    }
  } else if (length(val) == 2) {
    "xx.x / xx.x"
  } else if (length(val) == 3) {
    "xx.x (xx.x - xx.x)"
  } else {
    stop("got value of length > 3")
  }
}

.quick_afun <- function(afun, lbls) {
  if (.takes_df(afun)) {
    function(df, .spl_context, ...) {
      if (!is.null(lbls) && length(lbls) == 1 && is.na(lbls)) {
        lbls <- tail(.spl_context$value, 1)
      }
      if (".spl_context" %in% names(formals(afun))) {
        res <- afun(df = df, .spl_context = .spl_context, ...)
      } else {
        res <- afun(df = df, ...)
      }
      if (is(res, "RowsVerticalSection")) {
        ret <- res
      } else {
        if (!is.list(res)) {
          ret <- rcell(res, label = lbls, format = guess_format(res))
        } else {
          if (!is.null(lbls) && length(lbls) == length(res) && all(!is.na(lbls))) {
            names(res) <- lbls
          }
          ret <- in_rows(.list = res, .labels = names(res), .formats = vapply(res, guess_format, ""))
        }
      }
      ret
    }
  } else {
    function(x, .spl_context, ...) {
      if (!is.null(lbls) && length(lbls) == 1 && is.na(lbls)) {
        lbls <- tail(.spl_context$value, 1)
      }
      if (".spl_context" %in% names(formals(afun))) {
        res <- afun(x = x, .spl_context = .spl_context, ...)
      } else {
        res <- afun(x = x, ...)
      }
      if (is(res, "RowsVerticalSection")) {
        ret <- res
      } else {
        if (!is.list(res)) {
          ret <- rcell(res, label = lbls, format = guess_format(res))
        } else {
          if (!is.null(lbls) && length(lbls) == length(res) && all(!is.na(lbls))) {
            names(res) <- lbls
          }
          ret <- in_rows(.list = res, .labels = names(res), .formats = vapply(res, guess_format, ""))
        }
      }
      ret
    }
  }
}

# qtable ----

n_cells_res <- function(res) {
  ans <- 1L
  if (is.list(res)) {
    ans <- length(res)
  } else if (is(res, "RowsVerticalSection")) {
    ans <- length(res$values)
  } # XXX penetrating the abstraction
  ans
}

#' Generalized frequency table
#'
#' This function provides a convenience interface for generating generalizations of a 2-way frequency table. Row and
#' column space can be facetted by variables, and an analysis function can be specified. The function then builds a
#' layout with the specified layout and applies it to the data provided.
#'
#' @inheritParams constr_args
#' @inheritParams basic_table
#' @param row_vars (`character`)\cr the names of variables to be used in row facetting.
#' @param col_vars (`character`)\cr the names of variables to be used in column facetting.
#' @param data (`data.frame`)\cr the data to tabulate.
#' @param avar (`string`)\cr the variable to be analyzed. Defaults to the first variable in `data`.
#' @param row_labels (`character` or `NULL`)\cr row label(s) which should be applied to the analysis rows. Length must
#'   match the number of rows generated by `afun`.
#' @param afun (`function`)\cr the function to generate the analysis row cell values. This can be a proper analysis
#'   function, or a function which returns a vector or list. Vectors are taken as multi-valued single cells, whereas
#'   lists are interpreted as multiple cells.
#' @param drop_levels (`flag`)\cr whether unobserved factor levels should be dropped during facetting. Defaults to
#'   `TRUE`.
#' @param summarize_groups (`flag`)\cr whether each level of nesting should include marginal summary rows. Defaults to
#'   `FALSE`.
#' @param ... additional arguments passed to `afun`.
#' @param .default_rlabel (`string`)\cr this is an implementation detail that should not be set by end users.
#'
#' @details
#' This function creates a table with a single top-level structure in both row and column dimensions involving faceting
#' by 0 or more variables in each dimension.
#'
#' The display of the table depends on certain details of the tabulation. In the case of an `afun` which returns a
#' single cell's contents (either a scalar or a vector of 2 or 3 elements), the label rows for the deepest-nested row
#' facets will be hidden and the labels used there will be used as the analysis row labels. In the case of an `afun`
#' which returns a list (corresponding to multiple cells), the names of the list will be used as the analysis row
#' labels and the deepest-nested facet row labels will be visible.
#'
#' The table will be annotated in the top-left area with an informative label displaying the analysis variable
#' (`avar`), if set, and the function used (captured via substitute) where possible, or 'count' if not. One exception
#' where the user may directly modify the top-left area (via `row_labels`) is the case of a table with row facets and
#' an `afun` which returns a single row.
#'
#' @return
#' * `qtable` returns a built `TableTree` object representing the desired table
#' * `qtable_layout` returns a `PreDataTableLayouts` object declaring the structure of the desired table, suitable for
#'   passing to [build_table()].
#'
#' @examples
#' qtable(ex_adsl)
#' qtable(ex_adsl, row_vars = "ARM")
#' qtable(ex_adsl, col_vars = "ARM")
#' qtable(ex_adsl, row_vars = "SEX", col_vars = "ARM")
#' qtable(ex_adsl, row_vars = c("COUNTRY", "SEX"), col_vars = c("ARM", "STRATA1"))
#' qtable(ex_adsl,
#'   row_vars = c("COUNTRY", "SEX"),
#'   col_vars = c("ARM", "STRATA1"), avar = "AGE", afun = mean
#' )
#' summary_list <- function(x, ...) as.list(summary(x))
#' qtable(ex_adsl, row_vars = "SEX", col_vars = "ARM", avar = "AGE", afun = summary_list)
#' suppressWarnings(qtable(ex_adsl,
#'   row_vars = "SEX",
#'   col_vars = "ARM", avar = "AGE", afun = range
#' ))
#'
#' @export
qtable_layout <- function(data,
                          row_vars = character(),
                          col_vars = character(),
                          avar = NULL,
                          row_labels = NULL,
                          afun = NULL,
                          summarize_groups = FALSE,
                          title = "",
                          subtitles = character(),
                          main_footer = character(),
                          prov_footer = character(),
                          show_colcounts = TRUE,
                          drop_levels = TRUE,
                          ...,
                          .default_rlabel = NULL) {
  subafun <- substitute(afun)
  if (!is.null(.default_rlabel)) {
    dflt_row_lbl <- .default_rlabel
  } else if (
    is.name(subafun) &&
      is.function(afun) &&
      ## this is gross. basically testing
      ## if the symbol we have corresponds
      ## in some meaningful way to the function
      ## we will be calling.
      identical(
        mget(
          as.character(subafun),
          mode = "function",
          envir = parent.frame(1),
          ifnotfound = list(NULL),
          inherits = TRUE
        )[[1]],
        afun
      )
  ) {
    dflt_row_lbl <- paste(avar, as.character(subafun), sep = " - ")
  } else {
    dflt_row_lbl <- if (is.null(avar)) "count" else avar
  }

  if (is.null(afun)) {
    afun <- count
  }

  if (is.null(avar)) {
    avar <- names(data)[1]
  }
  fakeres <- afun(data[[avar]], ...)
  multirow <- is.list(fakeres) || is(fakeres, "RowsVerticalSection") || summarize_groups
  ## this is before we plug in the default so if not specified by the user
  ## explicitly, row_labels is NULL at this point.
  if (!is.null(row_labels) && length(row_labels) != n_cells_res(fakeres)) {
    stop(
      "Length of row_labels (",
      length(row_labels),
      ") does not agree with number of rows generated by analysis function (",
      n_cells_res(fakeres),
      ")."
    )
  }

  if (is.null(row_labels)) {
    row_labels <- dflt_row_lbl
  }

  lyt <- basic_table(
    title = title,
    subtitles = subtitles,
    main_footer = main_footer,
    prov_footer = prov_footer,
    show_colcounts = show_colcounts
  )

  for (var in col_vars) lyt <- split_cols_by(lyt, var)

  for (var in head(row_vars, -1)) {
    lyt <- split_rows_by(lyt, var, split_fun = if (drop_levels) drop_split_levels else NULL)
    if (summarize_groups) {
      lyt <- summarize_row_groups(lyt)
    }
  }

  tleft <- if (multirow || length(row_vars) > 0) dflt_row_lbl else character()
  if (length(row_vars) > 0) {
    if (!multirow) {
      ## in the single row in splitting case, we use the row label as the topleft
      ## and the split values as the row labels for a more compact apeparance
      tleft <- row_labels
      row_labels <- NA_character_
      lyt <- split_rows_by(
        lyt, tail(row_vars, 1),
        split_fun = if (drop_levels) drop_split_levels else NULL, child_labels = "hidden"
      )
    } else {
      lyt <- split_rows_by(lyt, tail(row_vars, 1), split_fun = if (drop_levels) drop_split_levels else NULL)
    }
    if (summarize_groups) {
      lyt <- summarize_row_groups(lyt)
    }
  }
  inner_afun <- .quick_afun(afun, row_labels)
  lyt <- analyze(lyt, avar, afun = inner_afun, extra_args = list(...))
  lyt <- append_topleft(lyt, tleft)
}

#' @rdname qtable_layout
#' @export
qtable <- function(data,
                   row_vars = character(),
                   col_vars = character(),
                   avar = NULL,
                   row_labels = NULL,
                   afun = NULL,
                   summarize_groups = FALSE,
                   title = "",
                   subtitles = character(),
                   main_footer = character(),
                   prov_footer = character(),
                   show_colcounts = TRUE,
                   drop_levels = TRUE,
                   ...) {
  ## this involves substitution so it needs to appear in both functions. Gross but true.
  subafun <- substitute(afun)
  if (
    is.name(subafun) && is.function(afun) &&
      ## this is gross. basically testing
      ## if the symbol we have corresponds
      ## in some meaningful way to the function
      ## we will be calling.
      identical(
        mget(
          as.character(subafun),
          mode = "function", envir = parent.frame(1), ifnotfound = list(NULL), inherits = TRUE
        )[[1]],
        afun
      )
  ) {
    dflt_row_lbl <- paste(avar, as.character(subafun), sep = " - ")
  } else {
    dflt_row_lbl <- if (is.null(avar)) "count" else avar
  }

  lyt <- qtable_layout(
    data = data,
    row_vars = row_vars,
    col_vars = col_vars,
    avar = avar,
    row_labels = row_labels,
    afun = afun,
    summarize_groups = summarize_groups,
    title = title,
    subtitles = subtitles,
    main_footer = main_footer,
    prov_footer = prov_footer,
    show_colcounts = show_colcounts,
    drop_levels = drop_levels,
    ...,
    .default_rlabel = dflt_row_lbl
  )
  build_table(lyt, data)
}

#' Compare two rtables
#'
#' Prints a matrix where `.` means cell matches, `X` means cell does
#' not match, `+` cell (row) is missing, and `-` cell (row)
#' should not be there. If `structure` is set to `TRUE`, `C` indicates
#' column-structure mismatch, `R` indicates row-structure mismatch, and
#' `S` indicates mismatch in both row and column structure.
#'
#' @param object (`VTableTree`)\cr `rtable` to test.
#' @param expected (`VTableTree`)\cr expected `rtable`.
#' @param tol (`numeric(1)`)\cr tolerance.
#' @param comp.attr (`flag`)\cr whether to compare cell formats. Other attributes are
#'   silently ignored.
#' @param structure (`flag`)\cr whether structures (in the form of column and row
#'   paths to cells) should be compared. Currently defaults to `FALSE`, but this is
#'   subject to change in future versions.
#'
#' @note In its current form, `compare_rtables` does not take structure into
#'   account, only row and cell position.
#'
#' @return A matrix of class `rtables_diff` representing the differences
#'  between `object` and `expected` as described above.
#'
#' @examples
#' t1 <- rtable(header = c("A", "B"), format = "xx", rrow("row 1", 1, 2))
#' t2 <- rtable(header = c("A", "B", "C"), format = "xx", rrow("row 1", 1, 2, 3))
#'
#' compare_rtables(object = t1, expected = t2)
#'
#' if (interactive()) {
#'   Viewer(t1, t2)
#' }
#'
#' expected <- rtable(
#'   header = c("ARM A\nN=100", "ARM B\nN=200"),
#'   format = "xx",
#'   rrow("row 1", 10, 15),
#'   rrow(),
#'   rrow("section title"),
#'   rrow("row colspan", rcell(c(.345543, .4432423), colspan = 2, format = "(xx.xx, xx.xx)"))
#' )
#'
#' expected
#'
#' object <- rtable(
#'   header = c("ARM A\nN=100", "ARM B\nN=200"),
#'   format = "xx",
#'   rrow("row 1", 10, 15),
#'   rrow("section title"),
#'   rrow("row colspan", rcell(c(.345543, .4432423), colspan = 2, format = "(xx.xx, xx.xx)"))
#' )
#'
#' compare_rtables(object, expected, comp.attr = FALSE)
#'
#' object <- rtable(
#'   header = c("ARM A\nN=100", "ARM B\nN=200"),
#'   format = "xx",
#'   rrow("row 1", 10, 15),
#'   rrow(),
#'   rrow("section title")
#' )
#'
#' compare_rtables(object, expected)
#'
#' object <- rtable(
#'   header = c("ARM A\nN=100", "ARM B\nN=200"),
#'   format = "xx",
#'   rrow("row 1", 14, 15.03),
#'   rrow(),
#'   rrow("section title"),
#'   rrow("row colspan", rcell(c(.345543, .4432423), colspan = 2, format = "(xx.xx, xx.xx)"))
#' )
#'
#' compare_rtables(object, expected)
#'
#' object <- rtable(
#'   header = c("ARM A\nN=100", "ARM B\nN=200"),
#'   format = "xx",
#'   rrow("row 1", 10, 15),
#'   rrow(),
#'   rrow("section title"),
#'   rrow("row colspan", rcell(c(.345543, .4432423), colspan = 2, format = "(xx.x, xx.x)"))
#' )
#'
#' compare_rtables(object, expected)
#'
#' @export
compare_rtables <- function(object, expected, tol = 0.1, comp.attr = TRUE,
                            structure = FALSE) {
  # if (identical(object, expected)) return(invisible(TRUE))

  if (!is(object, "VTableTree")) {
    stop(
      "argument object is expected to be of class TableTree or ",
      "ElementaryTable"
    )
  }
  if (!is(expected, "VTableTree")) {
    stop(
      "argument expected is expected to be of class TableTree or ",
      "ElementaryTable"
    )
  }
  dim_out <- apply(rbind(dim(object), dim(expected)), 2, max)

  X <- matrix(rep(".", dim_out[1] * dim_out[2]), ncol = dim_out[2])
  row.names(X) <- as.character(1:dim_out[1])
  colnames(X) <- as.character(1:dim_out[2])

  if (!identical(names(object), names(expected))) {
    attr(X, "info") <- "column names are not the same"
  }

  if (!comp.attr) {
    attr(X, "info") <- c(
      attr(X, "info"),
      "cell attributes have not been compared"
    )
  }
  if (!identical(row.names(object), row.names(expected))) {
    attr(X, "info") <- c(attr(X, "info"), "row labels are not the same")
  }

  nro <- nrow(object)
  nre <- nrow(expected)
  nco <- ncol(object)
  nce <- ncol(expected)

  if (nco < nce) {
    X[, seq(nco + 1, nce)] <- "-"
  } else if (nce < nco) {
    X[, seq(nce + 1, nco)] <- "+"
  }
  if (nro < nre) {
    X[seq(nro + 1, nre), ] <- "-"
  } else if (nre < nro) {
    X[seq(nre + 1, nro), ] <- "+"
  }

  orig_object <- object # nolint
  orig_expected <- expected # nolint
  if (nro != nre || nco != nce) {
    object <- object[1:min(nro, nre), 1:min(nco, nce), drop = FALSE]
    expected <- expected[1:min(nro, nre), 1:min(nco, nce), drop = FALSE]
    inner <- compare_rtables(object, expected, tol = tol, comp.attr = comp.attr, structure = structure)
    X[seq_len(nrow(object)), seq_len(ncol(object))] <- inner
    class(X) <- c("rtables_diff", class(X))
    return(X)
  }

  ## from here dimensions match!

  orows <- cell_values(object, omit_labrows = FALSE)
  erows <- cell_values(expected, omit_labrows = FALSE)
  if (nrow(object) == 1) {
    orows <- list(orows)
    erows <- list(erows)
  }
  res <- mapply(compare_rrows,
    row1 = orows, row2 = erows, tol = tol, ncol = ncol(object),
    USE.NAMES = FALSE, SIMPLIFY = FALSE
  )
  X <- do.call(rbind, res)
  rpo <- row_paths(object)
  rpe <- row_paths(expected)

  if (comp.attr) {
    ofmts <- value_formats(object)
    efmts <- value_formats(expected)
    ## dim(ofmts) <- NULL
    ## dim(efmts) <- NULL

    fmt_mismatch <- which(!mapply(identical, x = ofmts, y = efmts)) ## inherently ignores dim


    ## note the single index here!!!, no comma!!!!
    X[fmt_mismatch] <- "X"
  }


  if (structure) {
    rp_mismatches <- !mapply(identical, x = rpo, y = rpe)
    cpo <- col_paths(object)
    cpe <- col_paths(expected)
    cp_mismatches <- !mapply(identical, x = cpo, y = cpe)

    if (any(rp_mismatches)) { # P for (row or column) path do not match
      X[rp_mismatches, ] <- "R"
    }
    if (any(cp_mismatches)) {
      crep <- rep("C", nrow(X))
      if (any(rp_mismatches)) {
        crep[rp_mismatches] <- "P"
      }
      X[, cp_mismatches] <- rep(crep, sum(cp_mismatches))
    }
  }
  class(X) <- c("rtables_diff", class(X))
  X
}

## for (i in 1:dim(X)[1]) {
##   for (j in 1:dim(X)[2]) {

##     is_equivalent <- TRUE
##     if (i <= nro && i <= nre && j <= nco && j <= nce) {
##       x <- object[i,j, drop = TRUE]
##       y <- expected[i,j, drop = TRUE]

##       attr_x <- attributes(x)
##       attr_y <- attributes(y)

##       attr_x_sorted <- if (is.null(attr_x)) NULL else attr_x[order(names(attr_x))]
##       attr_y_sorted <- if (is.null(attr_y)) NULL else attr_y[order(names(attr_y))]

##       if (comp.attr && !identical(attr_x_sorted, attr_y_sorted)) {
##         is_equivalent <- FALSE
##       } else if (is.numeric(x) && is.numeric(y)) {
##         if (any(abs(na.omit(x - y)) > tol)) {
##           is_equivalent <- FALSE
##         }
##       } else {
##         if (!identical(x, y)) {
##           is_equivalent <- FALSE
##         }
##       }

##       if (!is_equivalent) {
##         X[i,j] <- "X"
##       }
##     } else if (i > nro || j > nco) {
##       ## missing in object
##       X[i, j] <- "+"
##     } else {
##       ## too many elements
##       X[i, j] <- "-"
##     }
##   }
## }
## class(X) <- c("rtable_diff", class(X))
## X
## }

compare_value <- function(x, y, tol) {
  if (identical(x, y) || (is.numeric(x) && is.numeric(y) && max(abs(x - y)) <= tol)) {
    "."
  } else {
    "X"
  }
}

compare_rrows <- function(row1, row2, tol, ncol) {
  if (length(row1) == ncol && length(row2) == ncol) {
    mapply(compare_value, x = row1, y = row2, tol = tol, USE.NAMES = FALSE)
  } else if (length(row1) == 0 && length(row2) == 0) {
    rep(".", ncol)
  } else {
    rep("X", ncol)
  }
}

## #' @export
## print.rtable_diff <- function(x, ...) {
##   print.default(unclass(x), quote = FALSE, ...)
## }

# Split functions --------------------------------------------------------------
#' Split functions
#'
#' @description
#' This is a collection of useful, default split function that can help you in dividing the data, hence the
#' table rows or columns, into different parts or groups (splits). You can also create your own split function if you
#' need to create a custom division as specific as you need. Please consider reading [custom_split_funs] if
#' this is the case. Beyond this list of functions, you can also use [add_overall_level()] and [add_combo_levels()]
#' for adding or modifying levels and [trim_levels_to_map()] to provide possible level combinations to filter the split
#' with.
#'
#' @inheritParams sf_args
#' @inheritParams gen_args
#' @param vals (`ANY`)\cr for internal use only.
#' @param labels (`character`)\cr labels to use for the remaining levels instead of the existing ones.
#'
#' @returns A function that can be used to split the data accordingly. The actual function signature
#'   is similar to the one you can define when creating a fully custom one. For more details see [custom_split_funs].
#'
#' @note
#' The following parameters are also documented here but they are only the default
#' signature of a split function: `df` (data to be split), `spl` (split object), and `vals = NULL`,
#' `labels = NULL`, `trim = FALSE` (last three only for internal use). See [custom_split_funs] for more details
#' and [make_split_fun()] for a more advanced API.
#'
#' @seealso [custom_split_funs], [add_overall_level()], [add_combo_levels()], and [trim_levels_to_map()].
#'
#' @name split_funcs
NULL

# helper fncs
.get_unique_levels <- function(vec) {
  out <- if (is.factor(vec)) {
    levels(vec)
  } else {
    unique(vec)
  }

  out
}

.print_setdiff_error <- function(provided, existing) {
  paste(setdiff(provided, existing), collapse = ", ")
}

#' @describeIn split_funcs keeps only specified levels (`only`) in the split variable. If any of the specified
#'   levels is not present, an error is returned. `reorder = TRUE` (the default) orders the split levels
#'   according to the order of `only`.
#'
#' @param only (`character`)\cr levels to retain (all others will be dropped). If none of the levels is present
#'   an empty table is returned.
#' @param reorder (`flag`)\cr whether the order of `only` should be used as the order of the children of the
#'   split. Defaults to `TRUE`.
#'
#' @examples
#' # keep_split_levels keeps specified levels (reorder = TRUE by default)
#' lyt <- basic_table() %>%
#'   split_rows_by("COUNTRY",
#'     split_fun = keep_split_levels(c("USA", "CAN", "BRA"))
#'   ) %>%
#'   analyze("AGE")
#'
#' tbl <- build_table(lyt, DM)
#' tbl
#'
#' @export
keep_split_levels <- function(only, reorder = TRUE) {
  function(df, spl, vals = NULL, labels = NULL, trim = FALSE) {
    var <- spl_payload(spl)
    varvec <- df[[var]]

    # Unique values from the split variable
    unique_vals <- .get_unique_levels(varvec)

    # Error in case not all levels are present
    if (length(varvec) > 0 && !all(only %in% unique_vals)) {
      what <- ifelse(is.factor(varvec), "factor level(s)", "character value(s)")
      stop(
        "Attempted to keep ", what, " in split that are not present in data: \n",
        .print_setdiff_error(only, unique_vals)
      )
    }

    df2 <- df[varvec %in% only, ]
    if (reorder) {
      df2[[var]] <- factor(df2[[var]], levels = only)
    } else {
      # Find original order of only
      only <- unique_vals[sort(match(only, unique_vals))]
    }

    spl_child_order(spl) <- only
    .apply_split_inner(spl, df2,
      vals = only,
      labels = labels,
      trim = trim
    )
  }
}

#' @describeIn split_funcs Removes specified levels (`excl`) from the split variable. Nothing done if not in data.
#'
#' @param excl (`character`)\cr levels to be excluded (they will not be reflected in the resulting table structure
#'   regardless of presence in the data).
#'
#' @examples
#' # remove_split_levels removes specified split levels
#' lyt <- basic_table() %>%
#'   split_rows_by("COUNTRY",
#'     split_fun = remove_split_levels(c(
#'       "USA", "CAN",
#'       "CHE", "BRA"
#'     ))
#'   ) %>%
#'   analyze("AGE")
#'
#' tbl <- build_table(lyt, DM)
#' tbl
#'
#' @export
remove_split_levels <- function(excl) {
  stopifnot(is.character(excl))
  function(df, spl, vals = NULL, labels = NULL, trim = FALSE) {
    var <- spl_payload(spl)
    df2 <- df[!(df[[var]] %in% excl), ]
    if (is.factor(df2[[var]])) {
      levels <- levels(df2[[var]])
      levels <- levels[!(levels %in% excl)]
      df2[[var]] <- factor(df2[[var]], levels = levels)
    }
    .apply_split_inner(spl, df2,
      vals = vals,
      labels = labels,
      trim = trim
    )
  }
}

#' @describeIn split_funcs Drops levels that have no representation in the data.
#'
#' @examples
#' # drop_split_levels drops levels that are not present in the data
#' lyt <- basic_table() %>%
#'   split_rows_by("SEX", split_fun = drop_split_levels) %>%
#'   analyze("AGE")
#'
#' tbl <- build_table(lyt, DM)
#' tbl
#'
#' @export
drop_split_levels <- function(df,
                              spl,
                              vals = NULL,
                              labels = NULL,
                              trim = FALSE) {
  var <- spl_payload(spl)
  df2 <- df
  df2[[var]] <- factor(df[[var]])
  lblvar <- spl_label_var(spl)
  if (!is.null(lblvar)) {
    df2[[lblvar]] <- factor(df[[lblvar]])
  }

  .apply_split_inner(spl, df2,
    vals = vals,
    labels = labels,
    trim = trim
  )
}

#' @describeIn split_funcs Removes specified levels `excl` and drops all levels that are
#'   not in the data.
#'
#' @examples
#' # Removing "M" and "U" directly, then "UNDIFFERENTIATED" because not in data
#' lyt <- basic_table() %>%
#'   split_rows_by("SEX", split_fun = drop_and_remove_levels(c("M", "U"))) %>%
#'   analyze("AGE")
#'
#' tbl <- build_table(lyt, DM)
#' tbl
#'
#' @export
drop_and_remove_levels <- function(excl) {
  stopifnot(is.character(excl))
  function(df, spl, vals = NULL, labels = NULL, trim = FALSE) {
    var <- spl_payload(spl)
    df2 <- df[!(df[[var]] %in% excl), ]
    df2[[var]] <- factor(df2[[var]])
    .apply_split_inner(
      spl,
      df2,
      vals = vals,
      labels = labels,
      trim = trim
    )
  }
}

#' @describeIn split_funcs Reorders split levels following `neworder`, which needs to be of
#'   same size as the levels in data.
#'
#' @param neworder (`character`)\cr new order of factor levels. All need to be present in the data.
#'   To add empty levels, rely on pre-processing or create your [custom_split_funs].
#' @param newlabels (`character`)\cr labels for (new order of) factor levels. If named, the levels are matched.
#'   Otherwise, the order of `neworder` is used.
#' @param drlevels (`flag`)\cr whether levels that are not in `neworder` should be dropped.
#'   Default is `TRUE`. Note: `drlevels = TRUE` does not drop levels that are not originally in the data.
#'   Rely on pre-processing or use a combination of split functions with [make_split_fun()] to also drop
#'   unused levels.
#'
#' @examples
#' # Reordering levels in split variable
#' lyt <- basic_table() %>%
#'   split_rows_by(
#'     "SEX",
#'     split_fun = reorder_split_levels(
#'       neworder = c("U", "F"),
#'       newlabels = c(U = "Uu", `F` = "Female")
#'     )
#'   ) %>%
#'   analyze("AGE")
#'
#' tbl <- build_table(lyt, DM)
#' tbl
#'
#' # Reordering levels in split variable but keeping all the levels
#' lyt <- basic_table() %>%
#'   split_rows_by(
#'     "SEX",
#'     split_fun = reorder_split_levels(
#'       neworder = c("U", "F"),
#'       newlabels = c("Uu", "Female"),
#'       drlevels = FALSE
#'     )
#'   ) %>%
#'   analyze("AGE")
#'
#' tbl <- build_table(lyt, DM)
#' tbl
#'
#' @export
reorder_split_levels <- function(neworder,
                                 newlabels = neworder,
                                 drlevels = TRUE) {
  function(df, spl, trim, ...) {
    df2 <- df
    valvec <- df2[[spl_payload(spl)]]

    uni_vals <- .get_unique_levels(valvec)

    # No sense adding things that are not present -> creating unexpected NAs
    if (!all(neworder %in% uni_vals)) {
      stop(
        "Attempted to reorder factor levels in split that are not present in data:\n",
        .print_setdiff_error(neworder, uni_vals)
      )
    }

    # Keeping all levels also from before if not dropped
    diff_with_uni_vals <- setdiff(uni_vals, neworder)
    if (!drlevels && length(diff_with_uni_vals) > 0) {
      if (length(newlabels) > length(neworder)) {
        stop(
          "When keeping levels not in neworder (drlevels = FALSE), newlabels can ",
          "affect only selected neworder, and not other levels.\n",
          "Add labels for current neworder: ", paste0(neworder, collapse = ", ")
        )
      }
      neworder <- c(neworder, diff_with_uni_vals)
      if (is.null(names(newlabels))) {
        newlabels <- c(newlabels, diff_with_uni_vals)
      } else {
        newlabels <- c(newlabels, setNames(diff_with_uni_vals, diff_with_uni_vals))
      }
    }

    valvec <- factor(valvec, levels = neworder)

    # Labels
    if (!is.null(names(newlabels))) {
      if (any(!names(newlabels) %in% neworder)) {
        stop(
          "Got labels' names for levels that are not present:\n",
          setdiff(names(newlabels), neworder)
        )
      }
      # To be safe: sorting by neworder
      newlabels <- newlabels[sapply(names(newlabels), function(x) which(x == neworder))]
    } else if (length(neworder) != length(newlabels)) {
      stop(
        "Got unnamed newlabels with different length than neworder. ",
        "Please provide names or make sure they are of the same length.\n",
        "Current neworder: ", paste0(neworder, collapse = ", ")
      )
    }

    # Final values
    spl_child_order(spl) <- neworder
    df2[[spl_payload(spl)]] <- valvec
    .apply_split_inner(spl, df2,
      vals = neworder,
      labels = newlabels,
      trim = trim
    )
  }
}

#' @describeIn split_funcs Takes the split groups and removes levels of `innervar` if not present in
#'   those split groups. If you want to specify a filter of possible combinations, please
#'   consider using [trim_levels_to_map()].
#'
#' @param innervar (`string`)\cr variable whose factor levels should be trimmed (e.g. empty levels dropped)
#'   *separately within each grouping defined at this point in the structure*.
#' @param drop_outlevs (`flag`)\cr whether empty levels in the variable being split on (i.e. the "outer"
#'   variable, not `innervar`) should be dropped. Defaults to `TRUE`.
#'
#' @examples
#' # trim_levels_in_group() trims levels within each group defined by the split variable
#' dat <- data.frame(
#'   col1 = factor(c("A", "B", "C"), levels = c("A", "B", "C", "N")),
#'   col2 = factor(c("a", "b", "c"), levels = c("a", "b", "c", "x"))
#' ) # N is removed if drop_outlevs = TRUE, x is removed always
#'
#' tbl <- basic_table() %>%
#'   split_rows_by("col1", split_fun = trim_levels_in_group("col2")) %>%
#'   analyze("col2") %>%
#'   build_table(dat)
#' tbl
#'
#' @export
trim_levels_in_group <- function(innervar, drop_outlevs = TRUE) {
  myfun <- function(df, spl, vals = NULL, labels = NULL, trim = FALSE) {
    if (!drop_outlevs) {
      ret <- .apply_split_inner(spl, df,
        vals = vals,
        labels = labels, trim = trim
      )
    } else {
      ret <- drop_split_levels(
        df = df, spl = spl, vals = vals,
        labels = labels, trim = trim
      )
    }

    ret$datasplit <- lapply(ret$datasplit, function(x) {
      coldat <- x[[innervar]]
      if (is(coldat, "character")) {
        if (!is.null(vals)) {
          lvs <- vals
        } else {
          lvs <- unique(coldat)
        }
        coldat <- factor(coldat, levels = lvs) ## otherwise
      } else {
        coldat <- droplevels(coldat)
      }
      x[[innervar]] <- coldat
      x
    })
    ret$labels <- as.character(ret$labels) # TODO
    ret
  }
  myfun
}

# add_combo_levels -------------------------------------------------------------
# Dedicated docs are attached to default split functions
.add_combo_part_info <- function(part,
                                 df,
                                 valuename,
                                 levels,
                                 label,
                                 extras,
                                 first = TRUE) {
  value <- LevelComboSplitValue(valuename, extras,
    combolevels = levels,
    label = label
  )
  newdat <- setNames(list(df), valuename)
  newval <- setNames(list(value), valuename)
  newextra <- setNames(list(extras), valuename)
  if (first) {
    part$datasplit <- c(newdat, part$datasplit)
    part$values <- c(newval, part$values)
    part$labels <- c(setNames(label, valuename), part$labels)
    part$extras <- c(newextra, part$extras)
  } else {
    part$datasplit <- c(part$datasplit, newdat)
    part$values <- c(part$values, newval)
    part$labels <- c(part$labels, setNames(label, valuename))
    part$extras <- c(part$extras, newextra)
  }
  ## not needed even in custom split function case.
  ##   part = .fixupvals(part)
  part
}

#' Add overall or combination levels to split groups
#'
#' @description
#' `add_overall_level` is a split function that adds a global level to the current levels in the split. Similarly,
#' `add_combo_levels` uses a user-provided `data.frame` to define the combine the levels to be added. If you need a
#' single overall column, after all splits, please check [add_overall_col()]. Consider also defining
#' your custom split function if you need more flexibility (see [custom_split_funs]).
#'
#' @inheritParams lyt_args
#' @inheritParams sf_args
#' @param valname (`string`)\cr value to be assigned to the implicit all-observations split level. Defaults to
#'   `"Overall"`.
#' @param first (`flag`)\cr whether the implicit level should appear first (`TRUE`) or last (`FALSE`). Defaults
#'   to `TRUE`.
#'
#' @return A splitting function (`splfun`) that adds or changes the levels of a split.
#'
#' @seealso [custom_split_funs] and [split_funcs].
#'
#' @examples
#' lyt <- basic_table() %>%
#'   split_cols_by("ARM", split_fun = add_overall_level("All Patients",
#'     first = FALSE
#'   )) %>%
#'   analyze("AGE")
#'
#' tbl <- build_table(lyt, DM)
#' tbl
#'
#' lyt2 <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   split_rows_by("RACE",
#'     split_fun = add_overall_level("All Ethnicities")
#'   ) %>%
#'   summarize_row_groups(label_fstr = "%s (n)") %>%
#'   analyze("AGE")
#' lyt2
#'
#' tbl2 <- build_table(lyt2, DM)
#' tbl2
#'
#' @export
add_overall_level <- function(valname = "Overall",
                              label = valname,
                              extra_args = list(),
                              first = TRUE,
                              trim = FALSE) {
  combodf <- data.frame(
    valname = valname,
    label = label,
    levelcombo = I(list(select_all_levels)),
    exargs = I(list(extra_args)),
    stringsAsFactors = FALSE
  )
  add_combo_levels(combodf,
    trim = trim, first = first
  )
}

setClass("AllLevelsSentinel", contains = "character")

# nocov start
#' @rdname add_overall_level
#' @export
select_all_levels <- new("AllLevelsSentinel")
# nocov end

#' @param combosdf (`data.frame` or `tbl_df`)\cr a data frame with columns `valname`, `label`, `levelcombo`, and
#'   `exargs`. `levelcombo` and `exargs` should be list columns. Passing the `select_all_levels` object as a value in
#'   `comblevels` column indicates that an overall/all-observations level should be created.
#' @param keep_levels (`character` or `NULL`)\cr if non-`NULL`, the levels to retain across both combination and
#'   individual levels.
#'
#' @inherit add_overall_level return
#'
#' @note
#' Analysis or summary functions for which the order matters should never be used within the tabulation framework.
#'
#' @examplesIf require(tibble)
#'
#' library(tibble)
#' combodf <- tribble(
#'   ~valname, ~label, ~levelcombo, ~exargs,
#'   "A_B", "Arms A+B", c("A: Drug X", "B: Placebo"), list(),
#'   "A_C", "Arms A+C", c("A: Drug X", "C: Combination"), list()
#' )
#'
#' lyt <- basic_table(show_colcounts = TRUE) %>%
#'   split_cols_by("ARM", split_fun = add_combo_levels(combodf)) %>%
#'   analyze("AGE")
#'
#' tbl <- build_table(lyt, DM)
#' tbl
#'
#' lyt1 <- basic_table(show_colcounts = TRUE) %>%
#'   split_cols_by("ARM",
#'     split_fun = add_combo_levels(combodf,
#'       keep_levels = c(
#'         "A_B",
#'         "A_C"
#'       )
#'     )
#'   ) %>%
#'   analyze("AGE")
#'
#' tbl1 <- build_table(lyt1, DM)
#' tbl1
#'
#' smallerDM <- droplevels(subset(DM, SEX %in% c("M", "F") &
#'   grepl("^(A|B)", ARM)))
#' lyt2 <- basic_table(show_colcounts = TRUE) %>%
#'   split_cols_by("ARM", split_fun = add_combo_levels(combodf[1, ])) %>%
#'   split_cols_by("SEX",
#'     split_fun = add_overall_level("SEX_ALL", "All Genders")
#'   ) %>%
#'   analyze("AGE")
#'
#' lyt3 <- basic_table(show_colcounts = TRUE) %>%
#'   split_cols_by("ARM", split_fun = add_combo_levels(combodf)) %>%
#'   split_rows_by("SEX",
#'     split_fun = add_overall_level("SEX_ALL", "All Genders")
#'   ) %>%
#'   summarize_row_groups() %>%
#'   analyze("AGE")
#'
#' tbl3 <- build_table(lyt3, smallerDM)
#' tbl3
#'
#' @rdname add_overall_level
#' @export
add_combo_levels <- function(combosdf,
                             trim = FALSE,
                             first = FALSE,
                             keep_levels = NULL) {
  myfun <- function(df, spl, vals = NULL, labels = NULL, ...) {
    if (is(spl, "MultiVarSplit")) {
      stop("Combining levels of a MultiVarSplit does not make sense.",
        call. = FALSE
      )
    } # nocov
    ret <- .apply_split_inner(spl, df,
      vals = vals,
      labels = labels, trim = trim
    )
    for (i in seq_len(nrow(combosdf))) {
      lcombo <- combosdf[i, "levelcombo", drop = TRUE][[1]]
      spld <- spl_payload(spl)
      if (is(lcombo, "AllLevelsSentinel")) {
        subdf <- df
      } else if (is(spl, "VarLevelSplit")) {
        subdf <- df[df[[spld]] %in% lcombo, ]
      } else { ## this covers non-var splits, e.g. Cut-based splits
        stopifnot(all(lcombo %in% c(ret$labels, ret$vals)))
        subdf <- do.call(
          rbind,
          ret$datasplit[names(ret$datasplit) %in% lcombo | ret$vals %in% lcombo]
        )
      }
      ret <- .add_combo_part_info(
        ret, subdf,
        combosdf[i, "valname", drop = TRUE],
        lcombo,
        combosdf[i, "label", drop = TRUE],
        combosdf[i, "exargs", drop = TRUE][[1]],
        first
      )
    }
    if (!is.null(keep_levels)) {
      keep_inds <- value_names(ret$values) %in% keep_levels
      ret <- lapply(ret, function(x) x[keep_inds])
    }

    ret
  }
  myfun
}

#' Trim levels to map
#'
#' This split function constructor creates a split function which trims levels of a variable to reflect restrictions
#' on the possible combinations of two or more variables which the data is split by (along the same axis) within a
#' layout.
#'
#' @param map data.frame. A data.frame defining allowed combinations of
#'   variables. Any combination at the level of this split not present in the
#'   map will be removed from the data, both for the variable being split and
#'   those present in the data but not associated with this split or any parents
#'   of it.
#'
#' @details
#' When splitting occurs, the map is subset to the values of all previously performed splits. The levels of the
#' variable being split are then pruned to only those still present within this subset of the map representing the
#' current hierarchical splitting context.
#'
#' Splitting is then performed via the [keep_split_levels()] split function.
#'
#' Each resulting element of the partition is then further trimmed by pruning values of any remaining variables
#' specified in the map to those values allowed under the combination of the previous and current split.
#'
#' @return A function that can be used as a split function.
#'
#' @seealso [trim_levels_in_group()].
#'
#' @examples
#' map <- data.frame(
#'   LBCAT = c("CHEMISTRY", "CHEMISTRY", "CHEMISTRY", "IMMUNOLOGY"),
#'   PARAMCD = c("ALT", "CRP", "CRP", "IGA"),
#'   ANRIND = c("LOW", "LOW", "HIGH", "HIGH"),
#'   stringsAsFactors = FALSE
#' )
#'
#' lyt <- basic_table() %>%
#'   split_rows_by("LBCAT") %>%
#'   split_rows_by("PARAMCD", split_fun = trim_levels_to_map(map = map)) %>%
#'   analyze("ANRIND")
#' tbl <- build_table(lyt, ex_adlb)
#'
#' @export
trim_levels_to_map <- function(map = NULL) {
  if (is.null(map) || any(sapply(map, class) != "character")) {
    stop(
      "No map dataframe was provided or not all of the columns are of ",
      "type character."
    )
  }

  myfun <- function(df,
                    spl,
                    vals = NULL,
                    labels = NULL,
                    trim = FALSE,
                    .spl_context) {
    allvars <- colnames(map)
    splvar <- spl_payload(spl)

    allvmatches <- match(.spl_context$split, allvars)
    outvars <- allvars[na.omit(allvmatches)]
    ## invars are variables present in data, but not in
    ## previous or current splits
    invars <- intersect(
      setdiff(allvars, c(outvars, splvar)),
      names(df)
    )
    ## allvarord <- c(na.omit(allvmatches), ## appear in prior splits
    ##                which(allvars == splvar), ## this split
    ##                allvars[-1*na.omit(allvmatches)]) ## "outvars"

    ## allvars <- allvars[allvarord]
    ## outvars <- allvars[-(which(allvars == splvar):length(allvars))]
    if (length(outvars) > 0) {
      indfilters <- vapply(outvars, function(ivar) {
        obsval <- .spl_context$value[match(ivar, .spl_context$split)]
        sprintf("%s == '%s'", ivar, obsval)
      }, "")

      allfilters <- paste(indfilters, collapse = " & ")
      map <- map[eval(parse(text = allfilters), envir = map), ]
    }
    map_splvarpos <- which(names(map) == splvar)
    nondup <- !duplicated(map[[splvar]])
    ksl_fun <- keep_split_levels(
      only = map[[splvar]][nondup],
      reorder = TRUE
    )
    ret <- ksl_fun(df, spl, vals, labels, trim = trim)

    if (length(ret$datasplit) == 0) {
      msg <- paste(sprintf("%s[%s]", .spl_context$split, .spl_context$value),
        collapse = "->"
      )
      stop(
        "map does not allow any values present in data for split ",
        "variable ", splvar,
        " under the following parent splits:\n\t", msg
      )
    }

    ## keep non-split (inner) variables levels
    ret$datasplit <- lapply(ret$values, function(splvar_lev) {
      df3 <- ret$datasplit[[splvar_lev]]
      curmap <- map[map[[map_splvarpos]] == splvar_lev, ]
      ## loop through inner variables
      for (iv in invars) { ## setdiff(colnames(map), splvar)) {
        iv_lev <- df3[[iv]]
        levkeep <- as.character(unique(curmap[[iv]]))
        if (is.factor(iv_lev) && !all(levkeep %in% levels(iv_lev))) {
          stop(
            "Attempted to keep invalid factor level(s) in split ",
            setdiff(levkeep, levels(iv_lev))
          )
        }

        df3 <- df3[iv_lev %in% levkeep, , drop = FALSE]

        if (is.factor(iv_lev)) {
          df3[[iv]] <- factor(as.character(df3[[iv]]),
            levels = levkeep
          )
        }
      }

      df3
    })
    names(ret$datasplit) <- ret$values
    ret
  }

  myfun
}

## Split types -----------------------------------------------------------------
## variable: split on distinct values of a variable
## all: include all observations (root 'split')
## rawcut: cut on static values of a variable
## quantilecut: cut on quantiles of observed values for a variable
## missing: split obs based on missingness of a variable/observation. This could be used for compare to ref_group??
## multicolumn: each child analyzes a different column
## arbitrary: children are not related to each other in any systematic fashion.

## null is ok here.
check_ok_label <- function(lbl, multi_ok = FALSE) {
  if (length(lbl) == 0) {
    return(TRUE)
  }

  if (length(lbl) > 1) {
    if (multi_ok) {
      return(all(vapply(lbl, check_ok_label, TRUE)))
    }
    stop("got a label of length > 1")
  }

  if (grepl("([{}])", lbl)) {
    stop("Labels cannot contain { or } due to their use for indicating referential footnotes")
  }
  invisible(TRUE)
}

valid_lbl_pos <- c("default", "visible", "hidden", "topleft")
.labelkids_helper <- function(charval) {
  ret <- switch(charval,
    "default" = NA,
    "visible" = TRUE,
    "hidden" = FALSE,
    "topleft" = FALSE,
    stop(
      "unrecognized charval in .labelkids_helper. ",
      "this shouldn't ever happen"
    )
  )
  ret
}

setOldClass("expression")
setClassUnion("SubsetDef", c("expression", "logical", "integer", "numeric"))

setClassUnion("integerOrNULL", c("NULL", "integer"))
setClassUnion("characterOrNULL", c("NULL", "character"))
setClassUnion("characterOrList", c("list", "character"))

## should XXX [splits, s_values, sval_labels, subset(?)] be a data.frame?
setClass("TreePos", representation(
  splits = "list",
  s_values = "list",
  sval_labels = "character",
  subset = "SubsetDef"
),
validity = function(object) {
  nspl <- length(object@splits)
  length(object@s_values) == nspl && length(object@sval_labels) == nspl
}
)

setOldClass(c("FormatList", "list"))

FormatList <- function(..., .list = list(...)) {
  if (!is.list(.list)) {
    .list <- list(.list)
  }
  valid <- vapply(.list, is, class2 = "FormatSpec", TRUE)
  if (!are(.list, "FormatSpec")) {
    stop(
      "Attempted to construct FormatList with elements that are not ",
      "FormatSpec compatible. This should not happen, please contact ",
      "the maintainers."
    )
  }

  class(.list) <- c("FormatList", "list")
  .list
}

setClassUnion("functionOrNULL", c("NULL", "function"))
setClassUnion("listOrNULL", c("NULL", "list"))
## TODO (?) make "list" more specific, e.g FormatList, or FunctionList?
setClassUnion("FormatSpec", c("NULL", "character", "function", "list", "FormatList"))
setClassUnion("ExprOrNULL", c("NULL", "expression"))

setClass("ValueWrapper", representation(
  value = "ANY",
  label = "characterOrNULL",
  subset_expression = "ExprOrNULL"
),
contains = "VIRTUAL"
)
## heavier-weight than I'd like but I think we need
## this to carry around thee subsets for
## comparison-based splits

setClass("SplitValue",
  contains = "ValueWrapper",
  representation(extra = "list")
)

SplitValue <- function(val, extr = list(), label = val, sub_expr = NULL) {
  if (is(val, "SplitValue")) {
    if (length(splv_extra(val)) > 0) {
      extr <- c(splv_extra(val), extr)
    }
    splv_extra(val) <- extr
    return(val)
  }
  if (!is(extr, "list")) {
    extr <- list(extr)
  }
  if (!is(label, "character")) {
    label <- as.character(label)
  }

  if (!is.null(sub_expr) && !is.expression(sub_expr)) {
    sub_expr <- as.expression(sub_expr)
  } ## sometimes they will be "call" objects, etc
  check_ok_label(label)
  new("SplitValue",
    value = val,
    extra = extr,
    label = label,
    subset_expression = sub_expr
  )
}

setClass("LevelComboSplitValue",
  contains = "SplitValue",
  representation(combolevels = "character")
)

## wrapped in user-facing `add_combo_facet`
LevelComboSplitValue <- function(val, extr, combolevels, label = val, sub_expr = NULL) {
  check_ok_label(label)
  new("LevelComboSplitValue",
    value = val,
    extra = extr,
    combolevels = combolevels,
    label = label,
    subset_expression = sub_expr
  )
}

setClass("Split",
  contains = "VIRTUAL",
  representation(
    payload = "ANY",
    name = "character",
    split_label = "character",
    split_format = "FormatSpec",
    split_na_str = "characterOrList",
    split_label_position = "character",
    ## NB this is the function which is applied to
    ## get the content rows for the CHILDREN of this
    ## split!!!
    content_fun = "listOrNULL", ## functionOrNULL",
    content_format = "FormatSpec",
    content_na_str = "character",
    content_var = "character",
    label_children = "logical",
    extra_args = "list",
    indent_modifier = "integer",
    content_indent_modifier = "integer",
    content_extra_args = "list",
    page_title_prefix = "character",
    child_section_div = "character",
    child_show_colcounts = "logical",
    child_colcount_format = "FormatSpec"
  )
)

setClass("CustomizableSplit",
  contains = "Split",
  representation(split_fun = "functionOrNULL")
)

#' @author Gabriel Becker
#' @exportClass VarLevelSplit
#' @rdname VarLevelSplit
setClass("VarLevelSplit",
  contains = "CustomizableSplit",
  representation(
    value_label_var = "character",
    value_order = "ANY"
  )
)
#' Split on levels within a variable
#'
#' @inheritParams lyt_args
#' @inheritParams constr_args
#'
#' @return a `VarLevelSplit` object.
#'
#' @export
VarLevelSplit <- function(var,
                          split_label,
                          labels_var = NULL,
                          cfun = NULL,
                          cformat = NULL,
                          cna_str = NA_character_,
                          split_fun = NULL,
                          split_format = NULL,
                          split_na_str = NA_character_,
                          valorder = NULL,
                          split_name = var,
                          child_labels = c("default", "visible", "hidden"),
                          extra_args = list(),
                          indent_mod = 0L,
                          label_pos = c("topleft", "hidden", "visible"),
                          cindent_mod = 0L,
                          cvar = "",
                          cextra_args = list(),
                          page_prefix = NA_character_,
                          section_div = NA_character_,
                          show_colcounts = FALSE,
                          colcount_format = NULL) {
  child_labels <- match.arg(child_labels)
  if (is.null(labels_var)) {
    labels_var <- var
  }
  check_ok_label(split_label)
  new("VarLevelSplit",
    payload = var,
    split_label = split_label,
    name = split_name,
    value_label_var = labels_var,
    content_fun = cfun,
    content_format = cformat,
    content_na_str = cna_str,
    split_fun = split_fun,
    split_format = split_format,
    split_na_str = split_na_str,
    value_order = NULL,
    label_children = .labelkids_helper(child_labels),
    extra_args = extra_args,
    indent_modifier = as.integer(indent_mod),
    content_indent_modifier = as.integer(cindent_mod),
    content_var = cvar,
    split_label_position = label_pos,
    content_extra_args = cextra_args,
    page_title_prefix = page_prefix,
    child_section_div = section_div,
    child_show_colcounts = show_colcounts,
    child_colcount_format = colcount_format
  )
}

setClass("AllSplit", contains = "Split")

AllSplit <- function(split_label = "",
                     cfun = NULL,
                     cformat = NULL,
                     cna_str = NA_character_,
                     split_format = NULL,
                     split_na_str = NA_character_,
                     split_name = NULL,
                     extra_args = list(),
                     indent_mod = 0L,
                     cindent_mod = 0L,
                     cvar = "",
                     cextra_args = list(),
                     show_colcounts = FALSE,
                     colcount_format = NULL,
                     ...) {
  if (is.null(split_name)) {
    if (nzchar(split_label)) {
      split_name <- split_label
    } else {
      split_name <- "all obs"
    }
  }
  check_ok_label(split_label)
  new("AllSplit",
    split_label = split_label,
    content_fun = cfun,
    content_format = cformat,
    content_na_str = cna_str,
    split_format = split_format,
    split_na_str = split_na_str,
    name = split_name,
    label_children = FALSE,
    extra_args = extra_args,
    indent_modifier = as.integer(indent_mod),
    content_indent_modifier = as.integer(cindent_mod),
    content_var = cvar,
    split_label_position = "hidden",
    content_extra_args = cextra_args,
    page_title_prefix = NA_character_,
    child_section_div = NA_character_,
    child_show_colcounts = show_colcounts,
    child_colcount_format = colcount_format
  )
}

setClass("RootSplit", contains = "AllSplit")

RootSplit <- function(split_label = "", cfun = NULL, cformat = NULL, cna_str = NA_character_, cvar = "",
                      split_format = NULL, split_na_str = NA_character_, cextra_args = list(), ...) {
  check_ok_label(split_label)
  new("RootSplit",
    split_label = split_label,
    content_fun = cfun,
    content_format = cformat,
    content_na_str = cna_str,
    split_format = split_format,
    split_na_str = split_na_str,
    name = "root",
    label_children = FALSE,
    indent_modifier = 0L,
    content_indent_modifier = 0L,
    content_var = cvar,
    split_label_position = "hidden",
    content_extra_args = cextra_args,
    child_section_div = NA_character_,
    child_show_colcounts = FALSE,
    child_colcount_format = "(N=xx)"
  )
}

setClass("ManualSplit",
  contains = "AllSplit",
  representation(levels = "character")
)

#' Manually defined split
#'
#' @inheritParams lyt_args
#' @inheritParams constr_args
#' @inheritParams gen_args
#' @param levels (`character`)\cr levels of the split (i.e. the children of the manual split).
#'
#' @return A `ManualSplit` object.
#'
#' @author Gabriel Becker
#' @export
ManualSplit <- function(levels, label, name = "manual",
                        extra_args = list(),
                        indent_mod = 0L,
                        cindent_mod = 0L,
                        cvar = "",
                        cextra_args = list(),
                        label_pos = "visible",
                        page_prefix = NA_character_,
                        section_div = NA_character_) {
  label_pos <- match.arg(label_pos, label_pos_values)
  check_ok_label(label, multi_ok = TRUE)
  new("ManualSplit",
    split_label = label,
    levels = levels,
    name = name,
    label_children = FALSE,
    extra_args = extra_args,
    indent_modifier = 0L,
    content_indent_modifier = as.integer(cindent_mod),
    content_var = cvar,
    split_format = NULL,
    split_na_str = NA_character_,
    split_label_position = label_pos,
    page_title_prefix = page_prefix,
    child_section_div = section_div,
    child_show_colcounts = FALSE,
    child_colcount_format = "(N=xx)"
  )
}

## splits across which variables are being analynzed
setClass("MultiVarSplit",
  contains = "CustomizableSplit", ## "Split",
  representation(
    var_labels = "character",
    var_names = "character"
  ),
  validity = function(object) {
    length(object@payload) >= 1 &&
      all(!is.na(object@payload)) &&
      (length(object@var_labels) == 0 || length(object@payload) == length(object@var_labels))
  }
)

.make_suffix_vec <- function(n) {
  c(
    "",
    sprintf(
      "._[[%d]]_.",
      seq_len(n - 1) + 1L
    )
  )
}

.make_multivar_names <- function(vars) {
  dups <- duplicated(vars)
  if (!any(dups)) {
    return(vars)
  }
  dupvars <- unique(vars[dups])
  ret <- vars
  for (v in dupvars) {
    pos <- which(ret == v)
    ret[pos] <- paste0(
      ret[pos],
      .make_suffix_vec(length(pos))
    )
  }
  ret
}

#' Split between two or more different variables
#'
#' @inheritParams lyt_args
#' @inheritParams constr_args
#'
#' @return A `MultiVarSplit` object.
#'
#' @author Gabriel Becker
#' @export
MultiVarSplit <- function(vars,
                          split_label = "",
                          varlabels = NULL,
                          varnames = NULL,
                          cfun = NULL,
                          cformat = NULL,
                          cna_str = NA_character_,
                          split_format = NULL,
                          split_na_str = NA_character_,
                          split_name = "multivars",
                          child_labels = c("default", "visible", "hidden"),
                          extra_args = list(),
                          indent_mod = 0L,
                          cindent_mod = 0L,
                          cvar = "",
                          cextra_args = list(),
                          label_pos = "visible",
                          split_fun = NULL,
                          page_prefix = NA_character_,
                          section_div = NA_character_,
                          show_colcounts = FALSE,
                          colcount_format = NULL) {
  check_ok_label(split_label)
  ## no topleft allowed
  label_pos <- match.arg(label_pos, label_pos_values[-3])
  child_labels <- match.arg(child_labels)
  if (length(vars) == 1 && grepl(":", vars)) {
    vars <- strsplit(vars, ":")[[1]]
  }
  if (length(varlabels) == 0) { ## covers NULL and character()
    varlabels <- vars
  }
  vnames <- varnames %||% .make_multivar_names(vars)
  stopifnot(length(vnames) == length(vars))
  new("MultiVarSplit",
    payload = vars,
    split_label = split_label,
    var_labels = varlabels,
    var_names = vnames,
    content_fun = cfun,
    content_format = cformat,
    content_na_str = cna_str,
    split_format = split_format,
    split_na_str = split_na_str,
    label_children = .labelkids_helper(child_labels),
    name = split_name,
    extra_args = extra_args,
    indent_modifier = as.integer(indent_mod),
    content_indent_modifier = as.integer(cindent_mod),
    content_var = cvar,
    split_label_position = label_pos,
    content_extra_args = cextra_args,
    split_fun = split_fun,
    page_title_prefix = page_prefix,
    child_section_div = section_div,
    child_show_colcounts = show_colcounts,
    child_colcount_format = colcount_format
  )
}

#' Splits for cutting by values of a numeric variable
#'
#' @inheritParams lyt_args
#' @inheritParams constr_args
#'
#' @exportClass VarStaticCutSplit
#' @rdname cutsplits
setClass("VarStaticCutSplit",
  contains = "Split",
  representation(
    cuts = "numeric",
    cut_labels = "character"
  )
)

.is_cut_lab_lst <- function(cuts) {
  is.list(cuts) && is.numeric(cuts[[1]]) &&
    is.character(cuts[[2]]) &&
    length(cuts[[1]]) == length(cuts[[2]])
}

#' Create static cut or static cumulative cut split
#'
#' @inheritParams lyt_args
#' @inheritParams constr_args
#'
#' @return A `VarStaticCutSplit`, `CumulativeCutSplit` object for `make_static_cut_split`, or a `VarDynCutSplit`
#'   object for [VarDynCutSplit()].
#'
#' @rdname cutsplits
make_static_cut_split <- function(var,
                                  split_label,
                                  cuts,
                                  cutlabels = NULL,
                                  cfun = NULL,
                                  cformat = NULL,
                                  cna_str = NA_character_,
                                  split_format = NULL,
                                  split_na_str = NA_character_,
                                  split_name = var,
                                  child_labels = c("default", "visible", "hidden"),
                                  extra_args = list(),
                                  indent_mod = 0L,
                                  cindent_mod = 0L,
                                  cvar = "",
                                  cextra_args = list(),
                                  label_pos = "visible",
                                  cumulative = FALSE,
                                  page_prefix = NA_character_,
                                  section_div = NA_character_,
                                  show_colcounts = FALSE,
                                  colcount_format = NULL) {
  cls <- if (cumulative) "CumulativeCutSplit" else "VarStaticCutSplit"
  check_ok_label(split_label)

  label_pos <- match.arg(label_pos, label_pos_values)
  child_labels <- match.arg(child_labels)
  if (.is_cut_lab_lst(cuts)) {
    cutlabels <- cuts[[2]]
    cuts <- cuts[[1]]
  }
  if (is.unsorted(cuts, strictly = TRUE)) {
    stop("invalid cuts vector. not sorted unique values.")
  }

  if (is.null(cutlabels) && !is.null(names(cuts))) {
    cutlabels <- names(cuts)[-1]
  } ## XXX is this always right?

  new(cls,
    payload = var,
    split_label = split_label,
    cuts = cuts,
    cut_labels = cutlabels,
    content_fun = cfun,
    content_format = cformat,
    content_na_str = cna_str,
    split_format = split_format,
    split_na_str = split_na_str,
    name = split_name,
    label_children = .labelkids_helper(child_labels),
    extra_args = extra_args,
    indent_modifier = as.integer(indent_mod),
    content_indent_modifier = as.integer(cindent_mod),
    content_var = cvar,
    split_label_position = label_pos,
    content_extra_args = cextra_args,
    page_title_prefix = page_prefix,
    child_section_div = section_div,
    child_show_colcounts = show_colcounts,
    child_colcount_format = colcount_format
  )
}

#' @exportClass CumulativeCutSplit
#' @rdname cutsplits
setClass("CumulativeCutSplit", contains = "VarStaticCutSplit")

## make_static_cut_split with cumulative=TRUE is the constructor
## for CumulativeCutSplit

## do we want this to be a CustomizableSplit instead of
## taking cut_fun?
## cut_funct must take avector and no other arguments
## and return a named vector of cut points
#' @exportClass VarDynCutSplit
#' @rdname cutsplits
setClass("VarDynCutSplit",
  contains = "Split",
  representation(
    cut_fun = "function",
    cut_label_fun = "function",
    cumulative_cuts = "logical"
  )
)

#' @export
#' @rdname cutsplits
VarDynCutSplit <- function(var,
                           split_label,
                           cutfun,
                           cutlabelfun = function(x) NULL,
                           cfun = NULL,
                           cformat = NULL,
                           cna_str = NA_character_,
                           split_format = NULL,
                           split_na_str = NA_character_,
                           split_name = var,
                           child_labels = c("default", "visible", "hidden"),
                           extra_args = list(),
                           cumulative = FALSE,
                           indent_mod = 0L,
                           cindent_mod = 0L,
                           cvar = "",
                           cextra_args = list(),
                           label_pos = "visible",
                           page_prefix = NA_character_,
                           section_div = NA_character_,
                           show_colcounts = FALSE,
                           colcount_format = NULL) {
  check_ok_label(split_label)
  label_pos <- match.arg(label_pos, label_pos_values)
  child_labels <- match.arg(child_labels)
  new("VarDynCutSplit",
    payload = var,
    split_label = split_label,
    cut_fun = cutfun,
    cumulative_cuts = cumulative,
    cut_label_fun = cutlabelfun,
    content_fun = cfun,
    content_format = cformat,
    content_na_str = cna_str,
    split_format = split_format,
    split_na_str = split_na_str,
    name = split_name,
    label_children = .labelkids_helper(child_labels),
    extra_args = extra_args,
    indent_modifier = as.integer(indent_mod),
    content_indent_modifier = as.integer(cindent_mod),
    content_var = cvar,
    split_label_position = label_pos,
    content_extra_args = cextra_args,
    page_title_prefix = page_prefix,
    child_section_div = section_div,
    child_show_colcounts = show_colcounts,
    child_colcount_format = colcount_format
  )
}

## NB analyze splits can't have content-related things
setClass("VAnalyzeSplit",
  contains = "Split",
  representation(
    default_rowlabel = "character",
    include_NAs = "logical",
    var_label_position = "character",
    row_formats_var = "characterOrNULL",
    row_na_strs_var = "characterOrNULL"
  )
)

setClass("AnalyzeVarSplit",
  contains = "VAnalyzeSplit",
  representation(analysis_fun = "function")
)

setClass("AnalyzeColVarSplit",
  contains = "VAnalyzeSplit",
  representation(analysis_fun = "list")
)

#' Define a subset tabulation/analysis
#'
#' @inheritParams lyt_args
#' @inheritParams constr_args
#' @param defrowlab (`character`)\cr default row labels, if not specified by the return value of `afun`.
#'
#' @return An `AnalyzeVarSplit` object.
#'
#' @author Gabriel Becker
#' @export
#' @rdname avarspl
AnalyzeVarSplit <- function(var,
                            split_label = var,
                            afun,
                            defrowlab = "",
                            cfun = NULL,
                            cformat = NULL,
                            split_format = NULL,
                            split_na_str = NA_character_,
                            inclNAs = FALSE,
                            split_name = var,
                            extra_args = list(),
                            indent_mod = 0L,
                            label_pos = "default",
                            cvar = "",
                            section_div = NA_character_,
                            formats_var = NULL,
                            na_strs_var = NULL) {
  check_ok_label(split_label)
  label_pos <- match.arg(label_pos, c("default", label_pos_values))
  if (!any(nzchar(defrowlab))) {
    defrowlab <- as.character(substitute(afun))
    if (length(defrowlab) > 1 || startsWith(defrowlab, "function(")) {
      defrowlab <- ""
    }
  }
  new("AnalyzeVarSplit",
    payload = var,
    split_label = split_label,
    content_fun = cfun,
    analysis_fun = afun,
    content_format = cformat,
    split_format = split_format,
    split_na_str = split_na_str,
    default_rowlabel = defrowlab,
    include_NAs = inclNAs,
    name = split_name,
    label_children = FALSE,
    extra_args = extra_args,
    indent_modifier = as.integer(indent_mod),
    content_indent_modifier = 0L,
    var_label_position = label_pos,
    content_var = cvar,
    page_title_prefix = NA_character_,
    child_section_div = section_div,
    child_show_colcounts = FALSE,
    child_colcount_format = NA_character_,
    row_formats_var = formats_var,
    row_na_strs_var = na_strs_var
  ) ## no content_extra_args
}

#' Define a subset tabulation/analysis
#'
#' @inheritParams lyt_args
#' @inheritParams constr_args
#'
#' @author Gabriel Becker
#' @export
#' @rdname avarspl
AnalyzeColVarSplit <- function(afun,
                               defrowlab = "",
                               cfun = NULL,
                               cformat = NULL,
                               split_format = NULL,
                               split_na_str = NA_character_,
                               inclNAs = FALSE,
                               split_name = "",
                               extra_args = list(),
                               indent_mod = 0L,
                               label_pos = "default",
                               cvar = "",
                               section_div = NA_character_) {
  label_pos <- match.arg(label_pos, c("default", label_pos_values))
  new("AnalyzeColVarSplit",
    payload = NA_character_,
    split_label = "",
    content_fun = cfun,
    analysis_fun = afun,
    content_format = cformat,
    split_format = split_format,
    split_na_str = split_na_str,
    default_rowlabel = defrowlab,
    include_NAs = inclNAs,
    name = split_name,
    label_children = FALSE,
    extra_args = extra_args,
    indent_modifier = as.integer(indent_mod),
    content_indent_modifier = 0L,
    var_label_position = label_pos,
    content_var = cvar,
    page_title_prefix = NA_character_,
    child_section_div = section_div,
    child_show_colcounts = FALSE,
    child_colcount_format = NA_character_
  ) ## no content_extra_args
}

setClass("CompoundSplit",
  contains = "Split",
  validity = function(object) are(object@payload, "Split")
)

setClass("AnalyzeMultiVars", contains = "CompoundSplit")

.repoutlst <- function(x, nv) {
  if (!is.function(x) && length(x) == nv) {
    return(x)
  }
  if (!is(x, "list")) {
    x <- list(x)
  }
  rep(x, length.out = nv)
}

.uncompound <- function(csplit) {
  if (is(csplit, "list")) {
    return(unlist(lapply(csplit, .uncompound)))
  }

  if (!is(csplit, "CompoundSplit")) {
    return(csplit)
  }

  pld <- spl_payload(csplit)
  done <- all(!vapply(pld, is, TRUE, class2 = "CompoundSplit"))
  if (done) {
    pld
  } else {
    unlist(lapply(pld, .uncompound))
  }
}

strip_compound_name <- function(obj) {
  nm <- obj_name(obj)
  gsub("^ma_", "", nm)
}

make_ma_name <- function(spl, pld = spl_payload(spl)) {
  paste(
    c(
      "ma",
      vapply(pld, strip_compound_name, "")
    ),
    collapse = "_"
  )
}

#' @param .payload (`list`)\cr used internally, not intended to be set by end users.
#'
#' @return An `AnalyzeMultiVars` split object.
#'
#' @export
#' @rdname avarspl
AnalyzeMultiVars <- function(var,
                             split_label = "",
                             afun,
                             defrowlab = "",
                             cfun = NULL,
                             cformat = NULL,
                             split_format = NULL,
                             split_na_str = NA_character_,
                             inclNAs = FALSE,
                             .payload = NULL,
                             split_name = NULL,
                             extra_args = list(),
                             indent_mod = 0L,
                             child_labels = c("default", "topleft", "visible", "hidden"),
                             child_names = var,
                             cvar = "",
                             section_div = NA_character_,
                             formats_var = NULL,
                             na_strs_var = NULL) {
  ## NB we used to resolve to strict TRUE/FALSE for label visibillity
  ## in this function but that was too greedy for repeated
  ## analyze calls, so that now occurs in the tabulation machinery
  ## when the table is actually being built.
  ##  show_kidlabs = .labelkids_helper(match.arg(child_labels))
  child_labels <- match.arg(child_labels)
  show_kidlabs <- child_labels
  if (is.null(.payload)) {
    nv <- length(var)
    defrowlab <- .repoutlst(defrowlab, nv)
    afun <- .repoutlst(afun, nv)
    split_label <- .repoutlst(split_label, nv)
    check_ok_label(split_label, multi_ok = TRUE)
    cfun <- .repoutlst(cfun, nv)
    cformat <- .repoutlst(cformat, nv)
    ##        split_format = .repoutlst(split_format, nv)
    inclNAs <- .repoutlst(inclNAs, nv)
    section_div_if_multivar <- if (length(var) > 1) NA_character_ else section_div

    moreargs <- list(
      extra_args = extra_args,
      indent_mod = indent_mod,
      label_pos = show_kidlabs,
      section_div = section_div_if_multivar,
      formats_var = formats_var,
      na_strs_var = na_strs_var
    )
    mv_list_case <- is.list(split_format) &&
      all(var %in% names(split_format)) &&
      all(vapply(split_format, is, class2 = "FormatList", TRUE))
    if (mv_list_case) { # diff format list for each var
      stopifnot(all(var %in% names(split_na_str)))
      ## split_value does *not* go  in more args, not constant across vars
      pld <- mapply(
        AnalyzeVarSplit,
        var = var,
        split_name = child_names,
        split_label = split_label,
        afun = afun,
        defrowlab = defrowlab,
        cfun = cfun,
        cformat = cformat,
        ## in case they're in the wrong order for some insane reason
        split_format = split_format[var],
        split_na_str = split_na_str[var],
        inclNAs = inclNAs,
        MoreArgs = moreargs, ## rvis),
        SIMPLIFY = FALSE
      )
    } else { # not diff lists for each var
      ## split format goes in more args because its constant across vars
      pld <- mapply(
        AnalyzeVarSplit,
        var = var,
        split_name = child_names,
        split_label = split_label,
        afun = afun,
        defrowlab = defrowlab,
        cfun = cfun,
        cformat = cformat,
        inclNAs = inclNAs,
        MoreArgs = c(
          moreargs,
          list(
            split_format = split_format,
            split_na_str = split_na_str
          )
        ), ## rvis),
        SIMPLIFY = FALSE
      )
    }
  } else {
    ## we're combining existing splits here
    pld <- unlist(lapply(.payload, .uncompound))

    ## only override the childen being combined if the constructor
    ## was passed a non-default value for child_labels
    ## and the child was at NA before
    pld <- lapply(
      pld,
      function(x) {
        rvis <- label_position(x) ## labelrow_visible(x)
        if (!identical(show_kidlabs, "default")) { ## is.na(show_kidlabs)) {
          if (identical(rvis, "default")) { ## ois.na(rvis))
            rvis <- show_kidlabs
          }
        }
        label_position(x) <- rvis
        x
      }
    )
  }
  if (length(pld) == 1) {
    ret <- pld[[1]]
  } else {
    if (is.null(split_name)) {
      split_name <- paste(c("ma", vapply(pld, obj_name, "")),
        collapse = "_"
      )
    }
    ret <- new("AnalyzeMultiVars",
      payload = pld,
      split_label = "",
      split_format = NULL,
      split_na_str = split_na_str,
      content_fun = NULL,
      content_format = NULL,
      ## I beleive this is superfluous now
      ## the payloads carry aroudn the real instructions
      ## XXX
      label_children = .labelkids_helper(show_kidlabs),
      split_label_position = "hidden", ## XXX is this right?
      name = split_name,
      extra_args = extra_args,
      ## modifier applied on splits in payload
      indent_modifier = 0L,
      content_indent_modifier = 0L,
      content_var = cvar,
      page_title_prefix = NA_character_,
      child_section_div = section_div
    )
  }
  ret
}

setClass("VarLevWBaselineSplit",
  contains = "VarLevelSplit",
  representation(
    var = "character",
    ref_group_value = "character"
  )
)

#' @rdname VarLevelSplit
#' @export
VarLevWBaselineSplit <- function(var,
                                 ref_group,
                                 labels_var = var,
                                 split_label,
                                 split_fun = NULL,
                                 label_fstr = "%s - %s",
                                 ## not needed I Think...
                                 cfun = NULL,
                                 cformat = NULL,
                                 cna_str = NA_character_,
                                 cvar = "",
                                 split_format = NULL,
                                 split_na_str = NA_character_,
                                 valorder = NULL,
                                 split_name = var,
                                 extra_args = list(),
                                 show_colcounts = FALSE,
                                 colcount_format = NULL) {
  check_ok_label(split_label)
  new("VarLevWBaselineSplit",
    payload = var,
    ref_group_value = ref_group,
    ## This will occur at the row level not on the column split, for now
    ## TODO revisit this to confirm its right
    ##        comparison_func = comparison,
    #      label_format = label_fstr,
    value_label_var = labels_var,
    split_label = split_label,
    content_fun = cfun,
    content_format = cformat,
    content_na_str = cna_str,
    split_format = split_format,
    split_na_str = split_na_str,
    split_fun = split_fun,
    name = split_name,
    label_children = FALSE,
    extra_args = extra_args,
    ## this is always a column split
    indent_modifier = 0L,
    content_indent_modifier = 0L,
    content_var = cvar,
    ## so long as this is columnspace only
    page_title_prefix = NA_character_,
    child_section_div = NA_character_,
    child_show_colcounts = show_colcounts,
    child_colcount_format = colcount_format
  )
}

.chkname <- function(nm) {
  if (is.null(nm)) {
    nm <- ""
  }
  if (length(nm) != 1) {
    stop("name is not of length one")
  } else if (is.na(nm)) {
    warning("Got missing value for name, converting to characters '<NA>'")
    nm <- "<NA>"
  }
  nm
}

### Tree Position Representation
###
### Class(es) that represent position with in a
### tree as parallel vectors of Split objects and
### values chosen at that split, plus labeling info
TreePos <- function(spls = list(),
                    svals = list(),
                    svlabels = character(),
                    sub = NULL) {
  check_ok_label(svlabels, multi_ok = TRUE)
  svals <- make_splvalue_vec(vals = svals, subset_exprs = lapply(svals, value_expr))
  if (is.null(sub)) {
    if (length(spls) > 0) {
      sub <- make_pos_subset(
        spls = spls,
        svals = svals
      )
    } else {
      sub <- expression(TRUE)
    }
  }
  new("TreePos",
    splits = spls, s_values = svals,
    sval_labels = svlabels,
    subset = sub
  )
}

## Tree position convenience functions
##
make_child_pos <- function(parpos,
                           newspl,
                           newval,
                           newlab = newval,
                           newextra = list()) {
  if (!is(newval, "SplitValue")) {
    nsplitval <- SplitValue(newval, extr = newextra, label = newlab)
  } else {
    nsplitval <- newval
  }
  check_ok_label(newlab)
  newpos <- TreePos(
    spls = c(pos_splits(parpos), newspl),
    svals = c(pos_splvals(parpos), nsplitval),
    svlabels = c(pos_splval_labels(parpos), newlab),
    sub = .combine_subset_exprs(
      pos_subset(parpos),
      ## this will grab the value's custom subset expression if present
      make_subset_expr(newspl, nsplitval)
    )
  )
  newpos
}

## Virtual Classes for Tree Nodes and Layouts =================================
##
## Virtual class hiearchy for the various types of trees in use in the S4
## implementation of the TableTree machinery

## core basics
setClass("VNodeInfo",
  contains = "VIRTUAL",
  representation(
    level = "integer",
    name = "character" ## ,
    ## label = "character"
  )
)

setClass("VTree",
  contains = c("VIRTUAL", "VNodeInfo"),
  representation(children = "list")
)

setClass("VLeaf", contains = c("VIRTUAL", "VNodeInfo"))

## Layout trees =================================

# setClass("VLayoutNode", contains= c("VIRTUAL", "VNodeInfo"))

setClass("VLayoutLeaf",
  contains = c("VIRTUAL", "VLeaf"),
  representation(
    pos_in_tree = "TreePos",
    label = "character"
  )
)

setClass("VLayoutTree",
  contains = c("VIRTUAL", "VTree"),
  representation(
    split = "Split",
    pos_in_tree = "TreePos",
    label = "character"
  )
)

setClassUnion("VLayoutNode", c("VLayoutLeaf", "VLayoutTree"))

## LayoutAxisTree classes =================================

setOldClass("function")
setOldClass("NULL")
setClassUnion("FunctionOrNULL", c("function", "NULL"))

setClass("LayoutAxisTree",
  contains = "VLayoutTree",
  representation(summary_func = "FunctionOrNULL"),
  validity = function(object) {
    all(sapply(object@children, function(x) is(x, "LayoutAxisTree") || is(x, "LayoutAxisLeaf")))
  }
)

## this is only used for columns!!!!
setClass("LayoutAxisLeaf",
  contains = "VLayoutLeaf", ## "VNodeInfo",
  representation(
    func = "function",
    display_columncounts = "logical",
    columncount_format = "FormatSpec", # character",
    col_footnotes = "list",
    column_count = "integer"
  )
)

setClass("LayoutColTree",
  contains = "LayoutAxisTree",
  representation(
    display_columncounts = "logical",
    columncount_format = "FormatSpec", # "character",
    col_footnotes = "list",
    column_count = "integer"
  )
)

setClass("LayoutColLeaf", contains = "LayoutAxisLeaf")
LayoutColTree <- function(lev = 0L,
                          name = obj_name(spl),
                          label = obj_label(spl),
                          kids = list(),
                          spl = EmptyAllSplit,
                          tpos = TreePos(),
                          summary_function = NULL,
                          disp_ccounts = FALSE,
                          colcount_format = NULL,
                          footnotes = list(),
                          colcount) { ## ,
  ## sub = expression(TRUE),
  ## svar = NA_character_,
  ## slab = NA_character_) {
  if (is.null(spl)) {
    stop(
      "LayoutColTree constructor got NULL for spl. ", # nocov
      "This should never happen. Please contact the maintainer."
    )
  } # nocov
  footnotes <- make_ref_value(footnotes)
  check_ok_label(label)
  new("LayoutColTree",
    level = lev, children = kids,
    name = .chkname(name),
    summary_func = summary_function,
    pos_in_tree = tpos,
    split = spl,
    ## subset = sub,
    ## splitvar = svar,
    label = label,
    display_columncounts = disp_ccounts,
    columncount_format = colcount_format,
    col_footnotes = footnotes,
    column_count = colcount
  )
}

LayoutColLeaf <- function(lev = 0L,
                          name = label,
                          label = "",
                          tpos = TreePos(),
                          colcount,
                          disp_ccounts = FALSE,
                          colcount_format = NULL) {
  check_ok_label(label)
  new("LayoutColLeaf",
    level = lev, name = .chkname(name), label = label,
    pos_in_tree = tpos,
    column_count = colcount,
    display_columncounts = disp_ccounts,
    columncount_format = colcount_format
  )
}

## Instantiated column info class ==============================================
##
## This is so we don't need multiple arguments
## in the recursive functions that track
## various aspects of the column layout
## once its applied to the data.

#' Instantiated column info
#'
#' @inheritParams gen_args
#'
#' @exportClass InstantiatedColumnInfo
#' @rdname cinfo
setClass(
  "InstantiatedColumnInfo",
  representation(
    tree_layout = "VLayoutNode", ## LayoutColTree",
    subset_exprs = "list",
    cextra_args = "list",
    counts = "integer",
    total_count = "integer",
    display_columncounts = "logical",
    columncount_format = "FormatSpec",
    columncount_na_str = "character",
    top_left = "character"
  )
)

#' @param treelyt (`LayoutColTree`)\cr a `LayoutColTree` object.
#' @param csubs (`list`)\cr a list of subsetting expressions.
#' @param extras (`list`)\cr extra arguments associated with the columns.
#' @param cnts (`integer`)\cr counts.
#' @param total_cnt (`integer(1)`)\cr total observations represented across all columns.
#' @param dispcounts (`flag`)\cr whether the counts should be displayed as header info when the associated
#'   table is printed.
#' @param countformat (`string`)\cr format for the counts if they are displayed.
#' @param count_na_str (`character`)\cr string to use in place of missing values when formatting counts. Defaults
#'   to `""`.
#'
#' @return An `InstantiateadColumnInfo` object.
#'
#' @export
#' @rdname cinfo
InstantiatedColumnInfo <- function(treelyt = LayoutColTree(colcount = total_cnt),
                                   csubs = list(expression(TRUE)),
                                   extras = list(list()),
                                   cnts = NA_integer_,
                                   total_cnt = NA_integer_,
                                   dispcounts = FALSE,
                                   countformat = "(N=xx)",
                                   count_na_str = "",
                                   topleft = character()) {
  leaves <- collect_leaves(treelyt)
  nl <- length(leaves)
  extras <- rep(extras, length.out = nl)
  cnts <- rep(cnts, length.out = nl)
  csubs <- rep(csubs, length.out = nl)

  nleaves <- length(leaves)
  snas <- sum(is.na(cnts))
  if (length(csubs) != nleaves || length(extras) != nleaves || length(cnts) != nleaves) {
    stop(
      "Mismatching number of columns indicated by: csubs [",
      length(csubs), "], ",
      "treelyt [", nl, "], extras [", length(extras),
      "] and counts [", cnts, "]."
    )
  }
  if (snas != 0 && snas != nleaves) {
    warning(
      "Mixture of missing and non-missing column counts when ",
      "creating column info."
    )
  }

  if (!is.na(dispcounts)) {
    pths <- col_paths(treelyt)
    for (path in pths) {
      colcount_visible(treelyt, path) <- dispcounts
    }
  } else { ## na leaves the children as they are and dispcols goes to whether any of them are displayed for the leaves
    dispcounts <- any(vapply(leaves, disp_ccounts, NA))
  }

  new("InstantiatedColumnInfo",
    tree_layout = treelyt,
    subset_exprs = csubs,
    cextra_args = extras,
    counts = cnts,
    total_count = total_cnt,
    display_columncounts = dispcounts,
    columncount_format = countformat,
    columncount_na_str = count_na_str,
    top_left = topleft
  )
}

## TableTrees and row classes ==================================================
## XXX Rowspans as implemented dont really work
## they're aren't attached to the right data structures
## during conversions.

## FIXME: if we ever actually need row spanning
setClass("VTableNodeInfo",
  contains = c("VNodeInfo", "VIRTUAL"),
  representation(
    ## col_layout = "VLayoutNode",
    col_info = "InstantiatedColumnInfo",
    format = "FormatSpec",
    na_str = "character",
    indent_modifier = "integer",
    table_inset = "integer",
    round_type = "character"
  )
)

setClass("TableRow",
  contains = c("VIRTUAL", "VLeaf", "VTableNodeInfo"),
  representation(
    leaf_value = "ANY",
    var_analyzed = "character",
    ##         var_label = "character",
    label = "character",
    row_footnotes = "list",
    trailing_section_div = "character"
  )
)

## TableTree Core Non-Virtual Classes ==============
##
#' Row classes and constructors
#'
#' @inheritParams constr_args
#' @inheritParams lyt_args
#' @param vis (`flag`)\cr whether the row should be visible (`LabelRow` only).
#' @param round_type (`"iec"`, `"iec_mod"` or `"sas"`)\cr the type of rounding to perform.
#' See [round_fmt()] for details.
#' @return A formal object representing a table row of the constructed type.
#'
#' @author Gabriel Becker
#' @export
#' @rdname rowclasses
LabelRow <- function(lev = 1L,
                     label = "",
                     name = label,
                     vis = !is.na(label) && nzchar(label),
                     cinfo = EmptyColInfo,
                     indent_mod = 0L,
                     table_inset = 0L,
                     trailing_section_div = NA_character_,
                     round_type = valid_round_type) {
  round_type <- match.arg(round_type)
  check_ok_label(label)
  new("LabelRow",
    leaf_value = list(),
    level = lev,
    label = label,
    ## XXX this means that a label row and its talbe can have the same name....
    ## XXX that is bad but how bad remains to be seen
    ## XXX
    name = .chkname(name),
    col_info = cinfo,
    visible = vis,
    indent_modifier = as.integer(indent_mod),
    table_inset = as.integer(table_inset),
    trailing_section_div = trailing_section_div,
    round_type = round_type
  )
}

#' Row constructors and classes
#'
#' @rdname rowclasses
#' @exportClass DataRow
setClass("DataRow",
  contains = "TableRow",
  representation(colspans = "integer") ## ,
  ## pos_in_tree = "TableRowPos"),
  ##      validity = function(object) {
  ## lcsp = length(object@colspans)
  ## length(lcsp ==  0) || lcsp == length(object@leaf_value)
  ## }
)

#' @rdname rowclasses
#' @exportClass ContentRow
setClass("ContentRow",
  contains = "TableRow",
  representation(colspans = "integer") ## ,
  ## pos_in_tree = "TableRowPos"),
  ##      validity = function(object) {
  ## lcsp = length(object@colspans)
  ## length(lcsp ==  0) || lcsp == length(object@leaf_value)
  ## }
)

#' @rdname rowclasses
#' @exportClass LabelRow
setClass("LabelRow",
  contains = "TableRow",
  representation(visible = "logical")
)

#' @param klass (`character`)\cr internal detail.
#'
#' @export
#' @rdname rowclasses
.tablerow <- function(vals = list(),
                      name = "",
                      lev = 1L,
                      label = name,
                      cspan = rep(1L, length(vals)),
                      cinfo = EmptyColInfo,
                      var = NA_character_,
                      format = NULL,
                      na_str = NA_character_,
                      klass,
                      indent_mod = 0L,
                      footnotes = list(),
                      table_inset = 0L,
                      trailing_section_div = NA_character_,
                      round_type = valid_round_type) {
  round_type <- match.arg(round_type)
  if ((missing(name) || is.null(name) || is.na(name) || nchar(name) == 0) && !missing(label)) {
    name <- label
  }
  vals <- lapply(vals, rcell, round_type = round_type)
  rlabels <- unique(unlist(lapply(vals, obj_label)))
  if ((missing(label) || is.null(label) || identical(label, "")) && sum(nzchar(rlabels)) == 1) {
    label <- rlabels[nzchar(rlabels)]
  }
  if (missing(cspan) && !is.null(unlist(lapply(vals, cell_cspan)))) {
    cspan <- vapply(vals, cell_cspan, 0L)
  }

  check_ok_label(label)
  rw <- new(klass,
    leaf_value = vals,
    name = .chkname(name),
    level = lev,
    label = .chkname(label),
    colspans = cspan,
    col_info = cinfo,
    var_analyzed = var,
    ## these are set in set_format_recursive below
    format = NULL,
    na_str = NA_character_,
    indent_modifier = indent_mod,
    row_footnotes = footnotes,
    table_inset = table_inset,
    trailing_section_div = trailing_section_div,
    round_type = round_type
  )
  rw <- set_format_recursive(rw, format, na_str, FALSE)
  rw
}

#' @param ... additional parameters passed to shared constructor (`.tablerow`).
#'
#' @export
#' @rdname rowclasses
DataRow <- function(...) .tablerow(..., klass = "DataRow")

#' @export
#' @rdname rowclasses
ContentRow <- function(...) .tablerow(..., klass = "ContentRow")

setClass("VTitleFooter",
  contains = "VIRTUAL",
  representation(
    main_title = "character",
    subtitles = "character",
    main_footer = "character",
    provenance_footer = "character"
  )
)

setClass("VTableTree",
  contains = c("VIRTUAL", "VTableNodeInfo", "VTree", "VTitleFooter"),
  representation(
    children = "list",
    rowspans = "data.frame",
    labelrow = "LabelRow",
    page_titles = "character",
    horizontal_sep = "character",
    header_section_div = "character",
    trailing_section_div = "character"
  )
)

setClassUnion("IntegerOrNull", c("integer", "NULL"))
## covered because it's ElementaryTable's validity method but covr misses it
## nocov start
etable_validity <- function(object) {
  kids <- tree_children(object)
  all(sapply(
    kids,
    function(k) {
      (is(k, "DataRow") || is(k, "ContentRow"))
    }
  )) ###  &&
}
## nocov end

#' `TableTree` classes
#'
#' @return A formal object representing a populated table.
#'
#' @author Gabriel Becker
#' @exportClass ElementaryTable
#' @rdname tabclasses
setClass("ElementaryTable",
  contains = "VTableTree",
  representation(var_analyzed = "character"),
  validity = etable_validity ## function(object) {
)

.enforce_valid_kids <- function(lst, colinfo) {
  ## colinfo
  if (!no_colinfo(colinfo)) {
    lst <- lapply(
      lst,
      function(x) {
        if (no_colinfo(x)) {
          col_info(x) <- colinfo
        } else if (!identical(colinfo, col_info(x), ignore.environment = TRUE)) {
          ## split functions from function factories (e.g. add_combo_levels)
          ## have different environments so we can't use identical here
          ## all.equal requires the **values within the closures** to be the
          ## same but not the actual enclosing environments.
          stop(
            "attempted to add child with non-matching, non-empty ",
            "column info to an existing table"
          )
        }
        x
      }
    )
  }

  if (are(lst, "ElementaryTable") &&
    all(sapply(lst, function(tb) {
      nrow(tb) <= 1 && identical(obj_name(tb), "")
    }))) {
    lst <- unlist(lapply(lst, function(tb) tree_children(tb)[[1]]))
  }
  if (length(lst) == 0) {
    return(list())
  }
  ## names
  realnames <- sapply(lst, obj_name)
  lstnames <- names(lst)
  if (is.null(lstnames)) {
    names(lst) <- realnames
  } else if (!identical(realnames, lstnames)) {
    names(lst) <- realnames
  }
  if (any(duplicated(realnames))) {
    lst <- uniqify_child_names(lst)
  }
  lst
}

## assumes that list names match obj_names before calling this
uniqify_child_names <- function(kidlst) {
  while (any(duplicated(names(kidlst)))) {
    oldnms <- names(kidlst)
    val_to_fix <- oldnms[duplicated(oldnms)][1]
    inds <- which(oldnms == val_to_fix)[-1] ## don'tneed to change first one
    newnms <- paste0(val_to_fix, "[", seq_along(inds) + 1, "]")
    kidlst[inds] <- lapply(
      seq_along(inds),
      function(i) {
        kid <- kidlst[[inds[i]]]
        c_tt <- content_table(kid)
        ## match existing behavior which is unfortunately somewhat inconsistent
        ## if the content table has a name update it, otherwise leave it as ""
        ## this is so tables created with parent_name = in the layout pass
        ## identicality checks with ones we're automatically uniqifying names in
        if (!is.null(c_tt) && nzchar(obj_name(c_tt))) {
          obj_name(c_tt) <- gsub(oldnms[i], newnms[i], obj_name(c_tt), fixed = TRUE)
          content_table(kid) <- c_tt
        }
        obj_name(kid) <- newnms[i]
        kid
      }
    )
    message(
      "Modifying subtable (or row) names to ensure uniqueness among direct siblings\n[",
      paste(val_to_fix, " -> {", paste(c(val_to_fix, newnms), collapse = ", "), "}]\n"),
      "  To control table names use split_rows_by*(, parent_name =.) or ",
      " analyze(., table_names = .) when analyzing a single variable, or ",
      "analyze(., parent_name = .) when analyzing multiple variables in a single call.",
      call. = FALSE
    )
    names(kidlst)[inds] <- newnms
  }
  kidlst
}

# if input round_type is not defined (length 0) retrieve round_type from kids
# and check all kids have the same round_type
.determine_round_type <- function(round_type, kids) {
  if (length(round_type) == 0) {
    if ((length(kids) > 0)) {
      round_type <- unique(vapply(kids, obj_round_type, ""))
      stopifnot(length(round_type) == 1)
    } else {
      # no kids and round_type not set
      ## continue with default value iec
      round_type <- valid_round_type[1] # iec
    }
  }
  round_type
}


#' Table constructors and classes
#'
#' @inheritParams constr_args
#' @inheritParams gen_args
#' @inheritParams lyt_args
#' @param rspans (`data.frame`)\cr currently stored but otherwise ignored.
#'
#' @author Gabriel Becker
#' @export
#' @rdname tabclasses
ElementaryTable <- function(kids = list(),
                            name = "",
                            lev = 1L,
                            label = "",
                            labelrow = LabelRow(
                              lev = lev,
                              label = label,
                              vis = !isTRUE(iscontent) &&
                                !is.na(label) &&
                                nzchar(label)
                            ),
                            rspans = data.frame(),
                            cinfo = NULL,
                            iscontent = NA,
                            var = NA_character_,
                            format = NULL,
                            na_str = NA_character_,
                            indent_mod = 0L,
                            title = "",
                            subtitles = character(),
                            main_footer = character(),
                            prov_footer = character(),
                            header_section_div = NA_character_,
                            hsep = default_hsep(),
                            trailing_section_div = NA_character_,
                            inset = 0L,
                            round_type = valid_round_type) {
  round_type <- match.arg(round_type)
  check_ok_label(label)
  if (is.null(cinfo)) {
    if (length(kids) > 0) {
      cinfo <- col_info(kids[[1]])
    } else {
      cinfo <- EmptyColInfo
    }
  }

  if (no_colinfo(labelrow)) {
    col_info(labelrow) <- cinfo
  }
  kids <- .enforce_valid_kids(kids, cinfo)
  tab <- new("ElementaryTable",
    children = kids,
    name = .chkname(name),
    level = lev,
    labelrow = labelrow,
    rowspans = rspans,
    col_info = cinfo,
    var_analyzed = var,
    ## XXX these are hardcoded, because they both get set during
    ## set_format_recursive anyway
    format = NULL,
    na_str = NA_character_,
    table_inset = 0L,
    indent_modifier = as.integer(indent_mod),
    main_title = title,
    subtitles = subtitles,
    main_footer = main_footer,
    provenance_footer = prov_footer,
    horizontal_sep = hsep,
    header_section_div = header_section_div,
    trailing_section_div = trailing_section_div,
    round_type = round_type
  )
  tab <- set_format_recursive(tab, format, na_str, FALSE)
  table_inset(tab) <- as.integer(inset)
  tab
}

ttable_validity <- function(object) {
  all(sapply(
    tree_children(object),
    function(x) is(x, "VTableTree") || is(x, "TableRow")
  ))
}

.calc_cinfo <- function(cinfo, cont, kids) {
  if (!is.null(cinfo)) {
    cinfo
  } else if (!is.null(cont)) {
    col_info(cont)
  } else if (length(kids) >= 1) {
    col_info(kids[[1]])
  } else {
    EmptyColInfo
  }
}

## under this model, non-leaf nodes can have a content table where rollup
## analyses live
#' @exportClass TableTree
#' @rdname tabclasses
setClass("TableTree",
  contains = c("VTableTree"),
  representation(
    content = "ElementaryTable",
    page_title_prefix = "character"
  ),
  validity = ttable_validity
)

#' @export
#' @rdname tabclasses
TableTree <- function(kids = list(),
                      name = if (!is.na(var)) var else "",
                      cont = EmptyElTable,
                      lev = 1L,
                      label = name,
                      labelrow = LabelRow(
                        lev = lev,
                        label = label,
                        vis = nrow(cont) == 0 && !is.na(label) &&
                          nzchar(label)
                      ),
                      rspans = data.frame(),
                      iscontent = NA,
                      var = NA_character_,
                      cinfo = NULL,
                      format = NULL,
                      na_str = NA_character_,
                      indent_mod = 0L,
                      title = "",
                      subtitles = character(),
                      main_footer = character(),
                      prov_footer = character(),
                      page_title = NA_character_,
                      hsep = default_hsep(),
                      header_section_div = NA_character_,
                      trailing_section_div = NA_character_,
                      inset = 0L,
                      round_type = NULL) {
  check_ok_label(label)
  cinfo <- .calc_cinfo(cinfo, cont, kids)

  # derive appropriate round_type to use
  # either from input or retrieved from kids
  round_type <- .determine_round_type(round_type, kids)
  # also set this round_type to direct kids
  # note that (some/most) obj_round_type setters will also set round_type of kids
  # this will ensure only 1 round_type is present on all slots in the resulting tabletree
  kids <- lapply(kids, `obj_round_type<-`, value = round_type)

  kids <- .enforce_valid_kids(kids, cinfo)
  if (isTRUE(iscontent) && !is.null(cont) && nrow(cont) > 0) {
    stop("Got table tree with content table and content position")
  }
  if (no_colinfo(labelrow)) {
    col_info(labelrow) <- cinfo
  }
  if ((is.null(cont) || nrow(cont) == 0) && all(sapply(kids, is, "DataRow"))) {
    if (!is.na(page_title)) {
      stop("Got a page title prefix for an Elementary Table")
    }
    ## constructor takes care of recursive format application
    ElementaryTable(
      kids = kids,
      name = .chkname(name),
      lev = lev,
      labelrow = labelrow,
      rspans = rspans,
      cinfo = cinfo,
      var = var,
      format = format,
      na_str = na_str,
      indent_mod = indent_mod,
      title = title,
      subtitles = subtitles,
      main_footer = main_footer,
      prov_footer = prov_footer,
      hsep = hsep,
      header_section_div = header_section_div,
      trailing_section_div = trailing_section_div,
      inset = inset,
      round_type = round_type
    )
  } else {
    tab <- new("TableTree",
      content = cont,
      children = kids,
      name = .chkname(name),
      level = lev,
      labelrow = labelrow,
      rowspans = rspans,
      col_info = cinfo,
      format = NULL,
      na_str = na_str,
      table_inset = 0L,
      indent_modifier = as.integer(indent_mod),
      main_title = title,
      subtitles = subtitles,
      main_footer = main_footer,
      provenance_footer = prov_footer,
      page_title_prefix = page_title,
      horizontal_sep = "-",
      header_section_div = header_section_div,
      trailing_section_div = trailing_section_div,
      round_type = round_type
    ) ## this is overridden below to get recursiveness
    tab <- set_format_recursive(tab, format, na_str, FALSE)

    ## these is recursive
    ## XXX combine these probably
    horizontal_sep(tab) <- hsep
    table_inset(tab) <- as.integer(inset)
    tab
  }
}

### Pre-Data Layout Declaration Classes
###
### Notably these are NOT represented as trees
### because without data we cannot know what the
### children should be.

## Vector (ordered list) of splits.
##
## This is a vector (ordered list) of splits to be
## applied recursively to the data when provided.
##
## For convenience, if this is length 1, it can contain
## a pre-existing TableTree/ElementaryTable.
## This is used for add_existing_table in colby_constructors.R

setClass("SplitVector",
  contains = "list",
  validity = function(object) {
    if (length(object) >= 1) {
      lst <- tail(object, 1)[[1]]
    } else {
      lst <- NULL
    }
    all(sapply(head(object, -1), is, "Split")) &&
      (is.null(lst) || is(lst, "Split") || is(lst, "VTableNodeInfo"))
  }
)

SplitVector <- function(x = NULL,
                        ...,
                        lst = list(...)) {
  if (!is.null(x)) {
    lst <- unlist(c(list(x), lst), recursive = FALSE)
  }
  new("SplitVector", lst)
}

avar_noneorlast <- function(vec) {
  if (!is(vec, "SplitVector")) {
    return(FALSE)
  }
  if (length(vec) == 0) {
    return(TRUE)
  }
  isavar <- which(sapply(vec, is, "AnalyzeVarSplit"))
  (length(isavar) == 0) || (length(isavar) == 1 && isavar == length(vec))
}

setClass("PreDataAxisLayout",
  contains = "list",
  representation(root_split = "ANY"),
  validity = function(object) {
    allleafs <- unlist(object, recursive = TRUE)
    all(sapply(object, avar_noneorlast)) &&
      all(sapply(
        allleafs,
        ## remember existing table trees can be added to layouts
        ## for now...
        function(x) is(x, "Split") || is(x, "VTableTree")
      ))
  }
)

setClass("PreDataColLayout",
  contains = "PreDataAxisLayout",
  representation(
    display_columncounts = "logical",
    columncount_format = "FormatSpec" # "character"
  )
)

setClass("PreDataRowLayout", contains = "PreDataAxisLayout")

PreDataColLayout <- function(x = SplitVector(),
                             rtsp = RootSplit(),
                             ...,
                             lst = list(x, ...),
                             disp_colcounts = NA,
                             colcount_format = "(N=xx)") {
  ret <- new("PreDataColLayout", lst,
    display_columncounts = disp_colcounts,
    columncount_format = colcount_format
  )
  ret@root_split <- rtsp
  ret
}

PreDataRowLayout <- function(x = SplitVector(),
                             root = RootSplit(),
                             ...,
                             lst = list(x, ...)) {
  new("PreDataRowLayout", lst, root_split = root)
}

setClass("PreDataTableLayouts",
  contains = "VTitleFooter",
  representation(
    row_layout = "PreDataRowLayout",
    col_layout = "PreDataColLayout",
    top_left = "character",
    header_section_div = "character",
    top_level_section_div = "character",
    table_inset = "integer",
    round_type = "character"
  )
)

PreDataTableLayouts <- function(rlayout = PreDataRowLayout(),
                                clayout = PreDataColLayout(),
                                topleft = character(),
                                title = "",
                                subtitles = character(),
                                main_footer = character(),
                                prov_footer = character(),
                                header_section_div = NA_character_,
                                top_level_section_div = NA_character_,
                                table_inset = 0L,
                                round_type = valid_round_type) {
  round_type <- match.arg(round_type)
  new("PreDataTableLayouts",
    row_layout = rlayout,
    col_layout = clayout,
    top_left = topleft,
    main_title = title,
    subtitles = subtitles,
    main_footer = main_footer,
    provenance_footer = prov_footer,
    header_section_div = header_section_div,
    top_level_section_div = top_level_section_div,
    table_inset = table_inset,
    round_type = round_type
  )
}

## setClass("CellValue", contains = "ValueWrapper",
##          representation(format = "FormatSpec",
##                         colspan = "integerOrNULL",
##                         label = "characterOrNULL"),
##          prototype = list(label ="", colspan = NULL, format = NULL))

setOldClass("CellValue")

#' Length of a Cell value
#'
#' @param x (`CellValue`)\cr a `CellValue` object.
#'
#' @return Always returns `1L`.
#'
#' @exportMethod length
setMethod(
  "length", "CellValue",
  function(x) 1L
)

setClass("RefFootnote", representation(
  value = "character",
  index = "integer",
  symbol = "character"
))

RefFootnote <- function(note, index = NA_integer_, symbol = NA_character_) {
  if (is(note, "RefFootnote")) {
    return(note)
  } else if (length(note) == 0) {
    return(NULL)
  }
  if (length(symbol) != 1L) {
    stop(
      "Referential footnote can only have a single string as its index.",
      " Got char vector of length ", length(index)
    )
  }
  if (!is.na(symbol) && (index == "NA" || grepl("[{}]", index))) {
    stop(
      "The string 'NA' and strings containing '{' or '}' cannot be used as ",
      "referential footnote index symbols. Got string '", index, "'."
    )
  }

  new("RefFootnote", value = note, index = index, symbol = symbol)
}

#' Constructor for Cell Value
#'
#' @inheritParams lyt_args
#' @inheritParams rcell
#' @inheritParams gen_args
#' @param val (`ANY`)\cr value in the cell exactly as it should be passed to a formatter or returned when extracted.
#'
#' @return An object representing the value within a single cell within a populated table. The underlying structure
#'   of this object is an implementation detail and should not be relied upon beyond calling accessors for the class.
#'
#' @export

## Class definition
## [[1]] list: cell value
## format : format for cell
## colspan: column span info for cell
## label: row label to be used for parent row
## indent_mod: indent modifier to be used for parent row
CellValue <- function(val, format = NULL, colspan = 1L, label = NULL,
                      indent_mod = NULL, footnotes = NULL,
                      align = NULL, format_na_str = NULL, stat_names = NA_character_,
                      round_type = valid_round_type) {
  round_type <- match.arg(round_type)
  if (is.null(colspan)) {
    colspan <- 1L
  }
  if (!is.null(colspan) && !is(colspan, "integer")) {
    colspan <- as.integer(colspan)
  }
  ## if we're not given a label but the value has one associated with
  ## it we use that.
  ## NB: we need to be able to override a non-empty label with an empty one
  ## so we can't have "" mean "not given a label" here
  if ((is.null(label) || is.na(label)) && !is.null(obj_label(val))) {
    label <- obj_label(val)
  }
  if (!is.list(footnotes)) {
    footnotes <- lapply(footnotes, RefFootnote)
  }
  check_ok_label(label)
  ret <- structure(list(val),
    format = format, colspan = colspan,
    label = label,
    indent_mod = indent_mod, footnotes = footnotes,
    align = align,
    format_na_str = format_na_str,
    stat_names = stat_names,
    round_type = round_type,
    class = "CellValue"
  )
  ret
}

#' @method print CellValue
#'
#' @export
print.CellValue <- function(x, ...) {
  cat(paste("rcell:", format_rcell(x), "\n"))
  invisible(x)
}

## too slow
# setClass("RowsVerticalSection", contains = "list",
#          representation = list(row_names = "characterOrNULL",
#                                row_labels = "characterOrNULL",
#                                row_formats = "ANY",
#                                indent_mods = "integerOrNULL"))

setOldClass("RowsVerticalSection")
RowsVerticalSection <- function(values,
                                names = names(values),
                                labels = NULL,
                                indent_mods = NULL,
                                formats = NULL,
                                footnotes = NULL,
                                format_na_strs = NULL) {
  stopifnot(is(values, "list"))
  ##    innernms <- value_names(values)

  if (is.null(labels)) {
    labels <- names(values)
  }
  if (is.null(names) && all(nzchar(labels))) {
    names <- labels
  } else if (is.null(labels) && !is.null(names)) {
    labels <- names
  }

  if (!is.null(indent_mods)) {
    indent_mods <- as.integer(indent_mods)
  }
  check_ok_label(labels, multi_ok = TRUE)
  structure(values,
    class = "RowsVerticalSection", row_names = names,
    row_labels = labels, indent_mods = indent_mods,
    row_formats = formats,
    row_na_strs = format_na_strs,
    row_footnotes = lapply(
      footnotes,
      ## cause each row needs to accept
      ## a *list* of row footnotes
      function(fns) lapply(fns, RefFootnote)
    )
  )
}

#' @method print RowsVerticalSection
#'
#' @export
print.RowsVerticalSection <- function(x, ...) {
  cat("RowsVerticalSection (in_rows) object print method:\n-------------------",
    "---------\n",
    sep = ""
  )
  print(data.frame(
    row_name = attr(x, "row_names", exact = TRUE),
    formatted_cell = vapply(x, format_rcell, character(1)),
    indent_mod = indent_mod(x), ## vapply(x, indent_mod, numeric(1)),
    row_label = attr(x, "row_labels", exact = TRUE),
    stringsAsFactors = FALSE,
    row.names = NULL
  ), row.names = TRUE)
  invisible(x)
}

#### Empty default objects to avoid repeated calls
## EmptyColInfo <- InstantiatedColumnInfo()
## EmptyElTable <- ElementaryTable()
## EmptyRootSplit <- RootSplit()
## EmptyAllSplit <- AllSplit()

label_pos_values <- c("hidden", "visible", "topleft")

#' @name internal_methods
#' @rdname int_methods
NULL

#' Combine `SplitVector` objects
#'
#' @param x (`SplitVector`)\cr a `SplitVector` object.
#' @param ... splits or `SplitVector` objects.
#'
#' @return Various, but should be considered implementation details.
#'
#' @rdname int_methods
#' @exportMethod c
setMethod("c", "SplitVector", function(x, ...) {
  arglst <- list(...)
  stopifnot(all(sapply(arglst, is, "Split")))
  tmp <- c(unclass(x), arglst)
  SplitVector(lst = tmp)
})

## split_rows and split_cols are "recursive method stacks" which follow
## the general pattern of accept object -> call add_*_split on slot of object ->
## update object with value returned from slot method, return object.
##
## Thus each of the methods is idempotent, returning an updated object of the
## same class it was passed. The exception for idempotency is the NULL method
## which constructs a PreDataTableLayouts object with the specified split in the
## correct place.

## The cascading (by class) in this case is as follows for the row case:
## PreDataTableLayouts -> PreDataRowLayout -> SplitVector
#' @param cmpnd_fun (`function`)\cr intended for internal use.
#' @param pos (`numeric(1)`)\cr intended for internal use.
#' @param spl (`Split`)\cr the split.
#'
#' @rdname int_methods
setGeneric(
  "split_rows",
  function(lyt = NULL, spl, pos,
           cmpnd_fun = AnalyzeMultiVars) {
    standardGeneric("split_rows")
  }
)

#' @rdname int_methods
setMethod("split_rows", "NULL", function(lyt, spl, pos, cmpnd_fun = AnalyzeMultiVars) {
  lifecycle::deprecate_warn(
    when = "0.3.8",
    what = I("split_rows(NULL)"),
    with = "basic_table()",
    details = "Initializing layouts via `NULL` is no longer supported."
  )
  rl <- PreDataRowLayout(SplitVector(spl))
  cl <- PreDataColLayout()
  PreDataTableLayouts(rlayout = rl, clayout = cl)
})

#' @rdname int_methods
setMethod(
  "split_rows", "PreDataRowLayout",
  function(lyt, spl, pos, cmpnd_fun = AnalyzeMultiVars) {
    stopifnot(pos > 0 && pos <= length(lyt) + 1)
    tmp <- if (pos <= length(lyt)) {
      split_rows(lyt[[pos]], spl, pos, cmpnd_fun)
    } else {
      if (pos != 1 && has_force_pag(spl)) {
        stop("page_by splits cannot have top-level siblings",
          call. = FALSE
        )
      }
      SplitVector(spl)
    }
    lyt[[pos]] <- tmp
    lyt
  }
)

is_analysis_spl <- function(spl) {
  is(spl, "VAnalyzeSplit") || is(spl, "AnalyzeMultiVars")
}

## note "pos" is ignored here because it is for which nest-chain
## spl should be placed in, NOIT for where in that chain it should go
#' @rdname int_methods
setMethod(
  "split_rows", "SplitVector",
  function(lyt, spl, pos, cmpnd_fun = AnalyzeMultiVars) {
    ## if(is_analysis_spl(spl) &&
    ##    is_analysis_spl(last_rowsplit(lyt))) {
    ##     return(cmpnd_last_rowsplit(lyt, spl, cmpnd_fun))
    ## }

    if (has_force_pag(spl) && length(lyt) > 0 && !has_force_pag(lyt[[length(lyt)]])) {
      stop("page_by splits cannot be nested within non-page_by splits",
        call. = FALSE
      )
    }
    tmp <- c(unclass(lyt), spl)
    SplitVector(lst = tmp)
  }
)

#' @rdname int_methods
setMethod(
  "split_rows", "PreDataTableLayouts",
  function(lyt, spl, pos) {
    rlyt <- rlayout(lyt)
    addtl <- FALSE
    split_label <- obj_label(spl)
    if (
      is(spl, "Split") && ## exclude existing tables that are being tacked in
        identical(label_position(spl), "topleft") &&
        length(split_label) == 1 && nzchar(split_label)
    ) {
      addtl <- TRUE
      ##        label_position(spl) <- "hidden"
    }

    rlyt <- split_rows(rlyt, spl, pos)
    rlayout(lyt) <- rlyt
    if (addtl) {
      lyt <- append_topleft(lyt, indent_string(split_label, .tl_indent(lyt)))
    }
    lyt
  }
)

#' @rdname int_methods
setMethod(
  "split_rows", "ANY",
  function(lyt, spl, pos) {
    stop("nope. can't add a row split to that (", class(lyt), "). contact the maintaner.")
  }
)

## cmpnd_last_rowsplit =====

#' @rdname int_methods
#'
#' @param constructor (`function`)\cr constructor function.
setGeneric("cmpnd_last_rowsplit", function(lyt, spl, constructor) standardGeneric("cmpnd_last_rowsplit"))

#' @rdname int_methods
setMethod("cmpnd_last_rowsplit", "NULL", function(lyt, spl, constructor) {
  stop("no existing splits to compound with. contact the maintainer") # nocov
})

#' @rdname int_methods
setMethod(
  "cmpnd_last_rowsplit", "PreDataRowLayout",
  function(lyt, spl, constructor) {
    pos <- length(lyt)
    tmp <- cmpnd_last_rowsplit(lyt[[pos]], spl, constructor)
    lyt[[pos]] <- tmp
    lyt
  }
)
#' @rdname int_methods
setMethod(
  "cmpnd_last_rowsplit", "SplitVector",
  function(lyt, spl, constructor) {
    pos <- length(lyt)
    lst <- lyt[[pos]]
    tmp <- if (is(lst, "CompoundSplit")) {
      spl_payload(lst) <- c(
        .uncompound(spl_payload(lst)),
        .uncompound(spl)
      )
      obj_name(lst) <- make_ma_name(spl = lst)
      lst
      ## XXX never reached because AnalzyeMultiVars inherits from
      ## CompoundSplit???
    } else {
      constructor(.payload = list(lst, spl))
    }
    lyt[[pos]] <- tmp
    lyt
  }
)

#' @rdname int_methods
setMethod(
  "cmpnd_last_rowsplit", "PreDataTableLayouts",
  function(lyt, spl, constructor) {
    rlyt <- rlayout(lyt)
    rlyt <- cmpnd_last_rowsplit(rlyt, spl, constructor)
    rlayout(lyt) <- rlyt
    lyt
  }
)
#' @rdname int_methods
setMethod(
  "cmpnd_last_rowsplit", "ANY",
  function(lyt, spl, constructor) {
    stop(
      "nope. can't do cmpnd_last_rowsplit to that (",
      class(lyt), "). contact the maintaner."
    )
  }
)

## split_cols ====

#' @rdname int_methods
setGeneric(
  "split_cols",
  function(lyt = NULL, spl, pos) {
    standardGeneric("split_cols")
  }
)

#' @rdname int_methods
setMethod("split_cols", "NULL", function(lyt, spl, pos) {
  lifecycle::deprecate_warn(
    when = "0.3.8",
    what = I("split_cols(NULL)"),
    with = "basic_table()",
    details = "Initializing layouts via `NULL` is no longer supported."
  )
  cl <- PreDataColLayout(SplitVector(spl))
  rl <- PreDataRowLayout()
  PreDataTableLayouts(rlayout = rl, clayout = cl)
})

#' @rdname int_methods
setMethod(
  "split_cols", "PreDataColLayout",
  function(lyt, spl, pos) {
    stopifnot(pos > 0 && pos <= length(lyt) + 1)
    tmp <- if (pos <= length(lyt)) {
      split_cols(lyt[[pos]], spl, pos)
    } else {
      SplitVector(spl)
    }

    lyt[[pos]] <- tmp
    lyt
  }
)

#' @rdname int_methods
setMethod(
  "split_cols", "SplitVector",
  function(lyt, spl, pos) {
    tmp <- c(lyt, spl)
    SplitVector(lst = tmp)
  }
)

#' @rdname int_methods
setMethod(
  "split_cols", "PreDataTableLayouts",
  function(lyt, spl, pos) {
    rlyt <- lyt@col_layout
    rlyt <- split_cols(rlyt, spl, pos)
    lyt@col_layout <- rlyt
    lyt
  }
)

#' @rdname int_methods
setMethod(
  "split_cols", "ANY",
  function(lyt, spl, pos) {
    stop(
      "nope. can't add a col split to that (", class(lyt),
      "). contact the maintaner."
    )
  }
)

# Constructors =====

## Pipe-able functions to add the various types of splits to the current layout
## for both row and column.  These all act as wrappers to the split_cols and
## split_rows method stacks.

#' Declaring a column-split based on levels of a variable
#'
#' Will generate children for each subset of a categorical variable.
#'
#' @inheritParams lyt_args
#' @param ref_group (`string` or `NULL`)\cr level of `var` that should be considered `ref_group`/reference.
#'
#' @return A `PreDataTableLayouts` object suitable for passing to further layouting functions, and to [build_table()].
#'
#' @inheritSection custom_split_funs Custom Splitting Function Details
#'
#' @examples
#' lyt <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   analyze(c("AGE", "BMRKR2"))
#'
#' tbl <- build_table(lyt, ex_adsl)
#' tbl
#'
#' # Let's look at the splits in more detail
#'
#' lyt1 <- basic_table() %>% split_cols_by("ARM")
#' lyt1
#'
#' # add an analysis (summary)
#' lyt2 <- lyt1 %>%
#'   analyze(c("AGE", "COUNTRY"),
#'     afun = list_wrap_x(summary),
#'     format = "xx.xx"
#'   )
#' lyt2
#'
#' tbl2 <- build_table(lyt2, DM)
#' tbl2
#'
#' @examplesIf require(dplyr)
#' # By default sequentially adding layouts results in nesting
#' library(dplyr)
#'
#' DM_MF <- DM %>%
#'   filter(SEX %in% c("M", "F")) %>%
#'   mutate(SEX = droplevels(SEX))
#'
#' lyt3 <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   split_cols_by("SEX") %>%
#'   analyze(c("AGE", "COUNTRY"),
#'     afun = list_wrap_x(summary),
#'     format = "xx.xx"
#'   )
#' lyt3
#'
#' tbl3 <- build_table(lyt3, DM_MF)
#' tbl3
#'
#' # nested=TRUE vs not
#' lyt4 <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   split_rows_by("SEX", split_fun = drop_split_levels) %>%
#'   split_rows_by("RACE", split_fun = drop_split_levels) %>%
#'   analyze("AGE")
#' lyt4
#'
#' tbl4 <- build_table(lyt4, DM)
#' tbl4
#'
#' lyt5 <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   split_rows_by("SEX", split_fun = drop_split_levels) %>%
#'   analyze("AGE") %>%
#'   split_rows_by("RACE", nested = FALSE, split_fun = drop_split_levels) %>%
#'   analyze("AGE")
#' lyt5
#'
#' tbl5 <- build_table(lyt5, DM)
#' tbl5
#'
#' @author Gabriel Becker
#' @export
split_cols_by <- function(lyt,
                          var,
                          labels_var = var,
                          split_label = var,
                          split_fun = NULL,
                          format = NULL,
                          nested = TRUE,
                          child_labels = c("default", "visible", "hidden"),
                          extra_args = list(),
                          ref_group = NULL,
                          show_colcounts = FALSE,
                          colcount_format = NULL) { ## ,
  if (is.null(ref_group)) {
    spl <- VarLevelSplit(
      var = var,
      split_label = split_label,
      labels_var = labels_var,
      split_format = format,
      child_labels = child_labels,
      split_fun = split_fun,
      extra_args = extra_args,
      show_colcounts = show_colcounts,
      colcount_format = colcount_format
    )
  } else {
    spl <- VarLevWBaselineSplit(
      var = var,
      ref_group = ref_group,
      split_label = split_label,
      split_fun = split_fun,
      labels_var = labels_var,
      split_format = format,
      show_colcounts = show_colcounts,
      colcount_format = colcount_format
    )
  }
  pos <- next_cpos(lyt, nested)
  split_cols(lyt, spl, pos)
}

## .tl_indent ====

setGeneric(".tl_indent_inner", function(lyt) standardGeneric(".tl_indent_inner"))

setMethod(
  ".tl_indent_inner", "PreDataTableLayouts",
  function(lyt) .tl_indent_inner(rlayout(lyt))
)
setMethod(
  ".tl_indent_inner", "PreDataRowLayout",
  function(lyt) {
    if (length(lyt) == 0 || length(lyt[[1]]) == 0) {
      0L
    } else {
      .tl_indent_inner(lyt[[length(lyt)]])
    }
  }
)

setMethod(
  ".tl_indent_inner", "SplitVector",
  function(lyt) {
    sum(vapply(lyt, function(x) label_position(x) == "topleft", TRUE)) - 1L
  }
) ## length(lyt)  - 1L)

.tl_indent <- function(lyt, nested = TRUE) {
  if (!nested) {
    0L
  } else {
    .tl_indent_inner(lyt)
  }
}

#' Add rows according to levels of a variable
#'
#' @inheritParams lyt_args
#'
#' @inherit split_cols_by return
#'
#' @inheritSection custom_split_funs Custom Splitting Function Details
#'
#' @note
#' If `var` is a factor with empty unobserved levels and `labels_var` is specified, it must also be a factor
#' with the same number of levels as `var`. Currently the error that occurs when this is not the case is not very
#' informative, but that will change in the future.
#'
#' @examples
#' lyt <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   split_rows_by("RACE", split_fun = drop_split_levels) %>%
#'   analyze("AGE", mean, var_labels = "Age", format = "xx.xx")
#'
#' tbl <- build_table(lyt, DM)
#' tbl
#'
#' lyt2 <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   split_rows_by("RACE") %>%
#'   analyze("AGE", mean, var_labels = "Age", format = "xx.xx")
#'
#' tbl2 <- build_table(lyt2, DM)
#' tbl2
#'
#' lyt3 <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   split_cols_by("SEX") %>%
#'   summarize_row_groups(label_fstr = "Overall (N)") %>%
#'   split_rows_by("RACE",
#'     split_label = "Ethnicity", labels_var = "ethn_lab",
#'     split_fun = drop_split_levels
#'   ) %>%
#'   summarize_row_groups("RACE", label_fstr = "%s (n)") %>%
#'   analyze("AGE", var_labels = "Age", afun = mean, format = "xx.xx")
#'
#' lyt3
#'
#' @examplesIf require(dplyr)
#' library(dplyr)
#'
#' DM2 <- DM %>%
#'   filter(SEX %in% c("M", "F")) %>%
#'   mutate(
#'     SEX = droplevels(SEX),
#'     gender_lab = c(
#'       "F" = "Female", "M" = "Male",
#'       "U" = "Unknown",
#'       "UNDIFFERENTIATED" = "Undifferentiated"
#'     )[SEX],
#'     ethn_lab = c(
#'       "ASIAN" = "Asian",
#'       "BLACK OR AFRICAN AMERICAN" = "Black or African American",
#'       "WHITE" = "White",
#'       "AMERICAN INDIAN OR ALASKA NATIVE" = "American Indian or Alaska Native",
#'       "MULTIPLE" = "Multiple",
#'       "NATIVE HAWAIIAN OR OTHER PACIFIC ISLANDER" =
#'         "Native Hawaiian or Other Pacific Islander",
#'       "OTHER" = "Other", "UNKNOWN" = "Unknown"
#'     )[RACE]
#'   )
#'
#' tbl3 <- build_table(lyt3, DM2)
#' tbl3
#'
#' @author Gabriel Becker
#' @export
split_rows_by <- function(lyt,
                          var,
                          labels_var = var,
                          split_label = var,
                          split_fun = NULL,
                          parent_name = var,
                          format = NULL,
                          na_str = NA_character_,
                          nested = TRUE,
                          child_labels = c("default", "visible", "hidden"),
                          label_pos = "hidden",
                          indent_mod = 0L,
                          page_by = FALSE,
                          page_prefix = split_label,
                          section_div = NA_character_) {
  label_pos <- match.arg(label_pos, label_pos_values)
  child_labels <- match.arg(child_labels)
  spl <- VarLevelSplit(
    var = var,
    split_label = split_label,
    label_pos = label_pos,
    labels_var = labels_var,
    split_fun = split_fun,
    split_format = format,
    split_na_str = na_str,
    child_labels = child_labels,
    indent_mod = indent_mod,
    page_prefix = if (page_by) page_prefix else NA_character_,
    section_div = section_div,
    split_name = parent_name
  )

  pos <- next_rpos(lyt, nested)
  ret <- split_rows(lyt, spl, pos)

  ret
}

#' Associate multiple variables with columns
#'
#' In some cases, the variable to be ultimately analyzed is most naturally defined on a column, not a row, basis.
#' When we need columns to reflect different variables entirely, rather than different levels of a single
#' variable, we use `split_cols_by_multivar`.
#'
#' @inheritParams lyt_args
#'
#' @inherit split_cols_by return
#'
#' @seealso [analyze_colvars()]
#'
#' @examplesIf require(dplyr)
#' library(dplyr)
#'
#' ANL <- DM %>% mutate(value = rnorm(n()), pctdiff = runif(n()))
#'
#' ## toy example where we take the mean of the first variable and the
#' ## count of >.5 for the second.
#' colfuns <- list(
#'   function(x) in_rows(mean = mean(x), .formats = "xx.x"),
#'   function(x) in_rows("# x > 5" = sum(x > .5), .formats = "xx")
#' )
#'
#' lyt <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   split_cols_by_multivar(c("value", "pctdiff")) %>%
#'   split_rows_by("RACE",
#'     split_label = "ethnicity",
#'     split_fun = drop_split_levels
#'   ) %>%
#'   summarize_row_groups() %>%
#'   analyze_colvars(afun = colfuns)
#' lyt
#'
#' tbl <- build_table(lyt, ANL)
#' tbl
#'
#' @author Gabriel Becker
#' @export
split_cols_by_multivar <- function(lyt,
                                   vars,
                                   split_fun = NULL,
                                   varlabels = vars,
                                   varnames = NULL,
                                   nested = TRUE,
                                   extra_args = list(),
                                   ## for completeness even though it doesn't make sense
                                   show_colcounts = FALSE,
                                   colcount_format = NULL) {
  spl <- MultiVarSplit(
    vars = vars, split_label = "",
    varlabels = varlabels,
    varnames = varnames,
    split_fun = split_fun,
    extra_args = extra_args,
    show_colcounts = show_colcounts,
    colcount_format = colcount_format
  )
  pos <- next_cpos(lyt, nested)
  split_cols(lyt, spl, pos)
}

#' Associate multiple variables with rows
#'
#' When we need rows to reflect different variables rather than different
#' levels of a single variable, we use `split_rows_by_multivar`.
#'
#' @inheritParams lyt_args
#'
#' @inherit split_rows_by return
#'
#' @seealso [split_rows_by()] for typical row splitting, and [split_cols_by_multivar()] to perform the same type of
#'   split on a column basis.
#'
#' @examples
#' lyt <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   split_rows_by_multivar(c("SEX", "STRATA1")) %>%
#'   summarize_row_groups() %>%
#'   analyze(c("AGE", "SEX"))
#'
#' tbl <- build_table(lyt, DM)
#' tbl
#'
#' @export
split_rows_by_multivar <- function(lyt,
                                   vars,
                                   split_fun = NULL,
                                   split_label = "",
                                   varlabels = vars,
                                   parent_name = "multivars",
                                   format = NULL,
                                   na_str = NA_character_,
                                   nested = TRUE,
                                   child_labels = c("default", "visible", "hidden"),
                                   indent_mod = 0L,
                                   section_div = NA_character_,
                                   extra_args = list()) {
  child_labels <- match.arg(child_labels)
  spl <- MultiVarSplit(
    vars = vars, split_label = split_label, varlabels,
    split_format = format,
    split_na_str = na_str,
    child_labels = child_labels,
    indent_mod = indent_mod,
    split_fun = split_fun,
    section_div = section_div,
    extra_args = extra_args,
    split_name = parent_name
  )
  pos <- next_rpos(lyt, nested)
  split_rows(lyt, spl, pos)
}

#' Split on static or dynamic cuts of the data
#'
#' Create columns (or row splits) based on values (such as quartiles) of `var`.
#'
#' @inheritParams lyt_args
#'
#' @details For dynamic cuts, the cut is transformed into a static cut by [build_table()] *based on the full dataset*,
#' before proceeding. Thus even when nested within another split in column/row space, the resulting split will reflect
#' the overall values (e.g., quartiles) in the dataset, NOT the values for subset it is nested under.
#'
#' @inherit split_cols_by return
#'
#' @examplesIf require(dplyr)
#' library(dplyr)
#'
#' # split_cols_by_cuts
#' lyt <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   split_cols_by_cuts("AGE",
#'     split_label = "Age",
#'     cuts = c(0, 25, 35, 1000),
#'     cutlabels = c("young", "medium", "old")
#'   ) %>%
#'   analyze(c("BMRKR2", "STRATA2")) %>%
#'   append_topleft("counts")
#'
#' tbl <- build_table(lyt, ex_adsl)
#' tbl
#'
#' # split_rows_by_cuts
#' lyt2 <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   split_rows_by_cuts("AGE",
#'     split_label = "Age",
#'     cuts = c(0, 25, 35, 1000),
#'     cutlabels = c("young", "medium", "old")
#'   ) %>%
#'   analyze(c("BMRKR2", "STRATA2")) %>%
#'   append_topleft("counts")
#'
#'
#' tbl2 <- build_table(lyt2, ex_adsl)
#' tbl2
#'
#' # split_cols_by_quartiles
#'
#' lyt3 <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   split_cols_by_quartiles("AGE", split_label = "Age") %>%
#'   analyze(c("BMRKR2", "STRATA2")) %>%
#'   append_topleft("counts")
#'
#' tbl3 <- build_table(lyt3, ex_adsl)
#' tbl3
#'
#' # split_rows_by_quartiles
#' lyt4 <- basic_table(show_colcounts = TRUE) %>%
#'   split_cols_by("ARM") %>%
#'   split_rows_by_quartiles("AGE", split_label = "Age") %>%
#'   analyze("BMRKR2") %>%
#'   append_topleft(c("Age Quartiles", " Counts BMRKR2"))
#'
#' tbl4 <- build_table(lyt4, ex_adsl)
#' tbl4
#'
#' # split_cols_by_cutfun
#' cutfun <- function(x) {
#'   cutpoints <- c(
#'     min(x),
#'     mean(x),
#'     max(x)
#'   )
#'
#'   names(cutpoints) <- c("", "Younger", "Older")
#'   cutpoints
#' }
#'
#' lyt5 <- basic_table() %>%
#'   split_cols_by_cutfun("AGE", cutfun = cutfun) %>%
#'   analyze("SEX")
#'
#' tbl5 <- build_table(lyt5, ex_adsl)
#' tbl5
#'
#' # split_rows_by_cutfun
#' lyt6 <- basic_table() %>%
#'   split_cols_by("SEX") %>%
#'   split_rows_by_cutfun("AGE", cutfun = cutfun) %>%
#'   analyze("BMRKR2")
#'
#' tbl6 <- build_table(lyt6, ex_adsl)
#' tbl6
#'
#' @author Gabriel Becker
#' @export
#' @rdname varcuts
split_cols_by_cuts <- function(lyt, var, cuts,
                               cutlabels = NULL,
                               split_label = var,
                               nested = TRUE,
                               cumulative = FALSE,
                               show_colcounts = FALSE,
                               colcount_format = NULL) {
  spl <- make_static_cut_split(
    var = var,
    split_label = split_label,
    cuts = cuts,
    cutlabels = cutlabels,
    cumulative = cumulative,
    show_colcounts = show_colcounts,
    colcount_format = colcount_format
  )
  ## if(cumulative)
  ##     spl = as(spl, "CumulativeCutSplit")
  pos <- next_cpos(lyt, nested)
  split_cols(lyt, spl, pos)
}

#' @export
#' @rdname varcuts
split_rows_by_cuts <- function(lyt, var, cuts,
                               cutlabels = NULL,
                               split_label = var,
                               parent_name = var,
                               format = NULL,
                               na_str = NA_character_,
                               nested = TRUE,
                               cumulative = FALSE,
                               label_pos = "hidden",
                               section_div = NA_character_) {
  label_pos <- match.arg(label_pos, label_pos_values)
  ##    VarStaticCutSplit(
  spl <- make_static_cut_split(var, split_label,
    cuts = cuts,
    cutlabels = cutlabels,
    split_format = format,
    split_na_str = na_str,
    label_pos = label_pos,
    cumulative = cumulative,
    section_div = section_div,
    split_name = parent_name
  )
  ## if(cumulative)
  ##     spl = as(spl, "CumulativeCutSplit")
  pos <- next_rpos(lyt, nested)
  split_rows(lyt, spl, pos)
}

#' @export
#' @rdname varcuts
split_cols_by_cutfun <- function(lyt, var,
                                 cutfun = qtile_cuts,
                                 cutlabelfun = function(x) NULL,
                                 split_label = var,
                                 nested = TRUE,
                                 extra_args = list(),
                                 cumulative = FALSE,
                                 show_colcounts = FALSE,
                                 colcount_format = NULL) {
  spl <- VarDynCutSplit(var, split_label,
    cutfun = cutfun,
    cutlabelfun = cutlabelfun,
    extra_args = extra_args,
    cumulative = cumulative,
    label_pos = "hidden",
    show_colcounts = show_colcounts,
    colcount_format = colcount_format
  )
  pos <- next_cpos(lyt, nested)
  split_cols(lyt, spl, pos)
}

#' @export
#' @rdname varcuts
split_cols_by_quartiles <- function(lyt, var, split_label = var,
                                    nested = TRUE,
                                    extra_args = list(),
                                    cumulative = FALSE,
                                    show_colcounts = FALSE,
                                    colcount_format = NULL) {
  split_cols_by_cutfun(
    lyt = lyt,
    var = var,
    split_label = split_label,
    cutfun = qtile_cuts,
    cutlabelfun = function(x) {
      c(
        "[min, Q1]",
        "(Q1, Q2]",
        "(Q2, Q3]",
        "(Q3, max]"
      )
    },
    nested = nested,
    extra_args = extra_args,
    cumulative = cumulative,
    show_colcounts = show_colcounts,
    colcount_format = colcount_format
  )
  ## spl = VarDynCutSplit(var, split_label, cutfun = qtile_cuts,
  ##                      cutlabelfun = function(x) c("[min, Q1]",
  ##                                                "(Q1, Q2]",
  ##                                                "(Q2, Q3]",
  ##                                                "(Q3, max]"),
  ##                      split_format = format,
  ##                      extra_args = extra_args,
  ##                      cumulative = cumulative,
  ##                      label_pos = "hidden")
  ## pos = next_cpos(lyt, nested)
  ## split_cols(lyt, spl, pos)
}

#' @export
#' @rdname varcuts
split_rows_by_quartiles <- function(lyt, var, split_label = var,
                                    parent_name = var,
                                    format = NULL,
                                    na_str = NA_character_,
                                    nested = TRUE,
                                    child_labels = c("default", "visible", "hidden"),
                                    extra_args = list(),
                                    cumulative = FALSE,
                                    indent_mod = 0L,
                                    label_pos = "hidden",
                                    section_div = NA_character_) {
  split_rows_by_cutfun(
    lyt = lyt,
    var = var,
    split_label = split_label,
    parent_name = parent_name,
    format = format,
    na_str = na_str,
    cutfun = qtile_cuts,
    cutlabelfun = function(x) {
      c(
        "[min, Q1]",
        "(Q1, Q2]",
        "(Q2, Q3]",
        "(Q3, max]"
      )
    },
    nested = nested,
    child_labels = child_labels,
    extra_args = extra_args,
    cumulative = cumulative,
    indent_mod = indent_mod,
    label_pos = label_pos,
    section_div = section_div
  )

  ## label_pos <- match.arg(label_pos, label_pos_values)
  ## spl = VarDynCutSplit(var, split_label, cutfun = qtile_cuts,
  ##                      cutlabelfun = ,
  ##                      split_format = format,
  ##                      child_labels = child_labels,
  ##                      extra_args = extra_args,
  ##                      cumulative = cumulative,
  ##                      indent_mod = indent_mod,
  ##                      label_pos = label_pos)
  ## pos = next_rpos(lyt, nested)
  ## split_rows(lyt, spl, pos)
}

qtile_cuts <- function(x) {
  ret <- quantile(x)
  names(ret) <- c(
    "",
    "1st qrtile",
    "2nd qrtile",
    "3rd qrtile",
    "4th qrtile"
  )
  ret
}

#' @export
#' @rdname varcuts
split_rows_by_cutfun <- function(lyt, var,
                                 cutfun = qtile_cuts,
                                 cutlabelfun = function(x) NULL,
                                 split_label = var,
                                 parent_name = var,
                                 format = NULL,
                                 na_str = NA_character_,
                                 nested = TRUE,
                                 child_labels = c("default", "visible", "hidden"),
                                 extra_args = list(),
                                 cumulative = FALSE,
                                 indent_mod = 0L,
                                 label_pos = "hidden",
                                 section_div = NA_character_) {
  label_pos <- match.arg(label_pos, label_pos_values)
  child_labels <- match.arg(child_labels)
  spl <- VarDynCutSplit(var, split_label,
    cutfun = cutfun,
    cutlabelfun = cutlabelfun,
    split_format = format,
    split_na_str = na_str,
    child_labels = child_labels,
    extra_args = extra_args,
    cumulative = cumulative,
    indent_mod = indent_mod,
    label_pos = label_pos,
    section_div = section_div,
    split_name = parent_name
  )
  pos <- next_rpos(lyt, nested)
  split_rows(lyt, spl, pos)
}

#' .spl_context within analysis and split functions
#'
#' `.spl_context` is an optional parameter for any of rtables' special functions, i.e. `afun` (analysis function
#' in [analyze()]), `cfun` (content or label function in [summarize_row_groups()]), or `split_fun` (e.g. for
#' [split_rows_by()]).
#'
#' @details
#' The `.spl_context` `data.frame` gives information about the subsets of data corresponding to the splits within
#' which the current `analyze` action is nested. Taken together, these correspond to the path that the resulting (set
#' of) rows the analysis function is creating, although the information is in a slightly different form. Each split
#' (which correspond to groups of rows in the resulting table), as well as the initial 'root' "split", is represented
#' via the following columns:
#'
#' \describe{
#'   \item{split}{The name of the split (often the variable being split).}
#'   \item{value}{The string representation of the value at that split (`split`).}
#'   \item{full_parent_df}{A `data.frame` containing the full data (i.e. across all columns) corresponding to the path
#'     defined by the combination of `split` and `value` of this row *and all rows above this row*.}
#'   \item{all_cols_n}{The number of observations corresponding to the row grouping (union of all columns).}
#'   \item{column for each column in the table structure (*row-split and analyze contexts only*)}{These list columns
#'     (named the same as `names(col_exprs(tab))`) contain logical vectors corresponding to the subset of this row's
#'     `full_parent_df` corresponding to the column.}
#'   \item{cur_col_id}{Identifier of the current column. This may be an internal name, constructed by pasting the
#'     column path together.}
#'   \item{cur_col_subset}{List column containing logical vectors indicating the subset of this row's `full_parent_df`
#'     for the column currently being created by the analysis function.}
#'   \item{cur_col_expr}{List of current column expression. This may be used to filter `.alt_df_row`, or any external
#'     data, by column. Filtering `.alt_df_row` by columns produces `.alt_df`.}
#'   \item{cur_col_n}{Integer column containing the observation counts for that split.}
#'   \item{cur_col_split}{Current column split names. This is recovered from the current column path.}
#'   \item{cur_col_split_val}{Current column split values. This is recovered from the current column path.}
#' }
#'
#' @note
#' Within analysis functions that accept `.spl_context`, the `all_cols_n` and `cur_col_n` columns of the data frame
#' will contain the 'true' observation counts corresponding to the row-group and row-group x column subsets of the
#' data. These numbers will not, and currently cannot, reflect alternate column observation counts provided by the
#' `alt_counts_df`, `col_counts` or `col_total` arguments to [build_table()].
#'
#' @name spl_context
NULL

#' Additional parameters within analysis and content functions (`afun`/`cfun`)
#'
#' @description
#' It is possible to add specific parameters to `afun` and `cfun`, in [analyze()] and [summarize_row_groups()],
#' respectively. These parameters grant access to relevant information like the row split structure (see
#' [spl_context]) and the predefined baseline (`.ref_group`).
#'
#' @details
#' We list and describe all the parameters that can be added to a custom analysis function below:
#'
#' \describe{
#'   \item{.N_col}{Column-wise N (column count) for the full column being tabulated within.}
#'   \item{.N_total}{Overall N (all observation count, defined as sum of column counts) for the tabulation.}
#'   \item{.N_row}{Row-wise N (row group count) for the group of observations being analyzed (i.e. with no
#'     column-based subsetting).}
#'   \item{.df_row}{`data.frame` for observations in the row group being analyzed (i.e. with no column-based
#'     subsetting).}
#'   \item{.var}{Variable being analyzed.}
#'   \item{.ref_group}{`data.frame` or vector of subset corresponding to the `ref_group` column including subsetting
#'     defined by row-splitting. Only required/meaningful if a `ref_group` column has been defined.}
#'   \item{.ref_full}{`data.frame` or vector of subset corresponding to the `ref_group` column without subsetting
#'     defined by row-splitting. Only required/meaningful if a `ref_group` column has been defined.}
#'   \item{.in_ref_col}{Boolean indicating if calculation is done for cells within the reference column.}
#'   \item{.spl_context}{`data.frame` where each row gives information about a previous 'ancestor' split state.
#'     See [spl_context].}
#'   \item{.alt_df_row}{`data.frame`, i.e. the `alt_counts_df` after row splitting. It can be used with
#'     `.all_col_exprs` and `.spl_context` information to retrieve current faceting, but for `alt_count_df`.
#'     It can be an empty table if all the entries are filtered out.}
#'   \item{.alt_df}{`data.frame`, `.alt_df_row` but filtered by columns expression. This data present the same
#'     faceting of main data `df`. This also filters `NA`s out if related parameters are set to do so (e.g. `inclNAs`
#'     in [analyze()]). Similarly to `.alt_df_row`, it can be an empty data.frame if all the entries are filtered out.}
#'   \item{.alt_df_full}{`data.frame`, the full `alt_counts_df` as passed into `build_table`.
#'     Unlike `.alt_df` and `.alt_df_row`, this parameter can be used in cases
#'     where the variables required for row splitting are not present in `alt_counts_df`.}
#'   \item{.all_col_exprs}{List of expressions. Each of them represents a different column splitting.}
#'   \item{.all_col_counts}{Vector of integers. Each of them represents the global count for each column. It differs
#'     if `alt_counts_df` is used (see [build_table()]).}
#' }
#'
#' @note If any of these formals is specified incorrectly or not present in the tabulation machinery, it will be
#'   treated as if missing. For example, `.ref_group` will be missing if no baseline is previously defined during
#'   data splitting (via `ref_group` parameters in, e.g., [split_rows_by()]). Similarly, if no `alt_counts_df` is
#'   provided to [build_table()], `.alt_df_row` and `.alt_df` will not be present.
#'
#' @name additional_fun_params
NULL

#' Generate rows analyzing variables across columns
#'
#' Adding *analyzed variables* to our table layout defines the primary tabulation to be performed. We do this by
#' adding calls to `analyze` and/or [analyze_colvars()] into our layout pipeline. As with adding further splitting,
#' the tabulation will occur at the current/next level of nesting by default.
#'
#' @inheritParams lyt_args
#' @param section_div (`string`)\cr string which should be repeated as a section divider after the set of rows  defined
#'   by (each sub-analysis/variable) of this analyze instruction, or
#'   `NA_character_` (the default) for no section divider. This section
#'   divider will be overridden by a split-level section divider when
#'   both apply to the same position in the rendered output.
#'
#' @details When `length(vars) > 1` and when two calls to `analyze`
#'     are done in sequence (the second with the default `nested =
#'     TRUE`), the analyses will be combined into a multi-variable
#'     analysis that will be reflected in the row structure of the
#'     resulting table. In these cases, the default is to show the
#'     label describing the variable analyzed for each of the
#'     resulting subtables, while that is hidden by default in
#'     one-variable cases.
#'
#' # Specifying Default Formatting Behavior
#'
#' *Default* formatting behavior for rows generated by `afun` can be
#' specified by one of `format` or `formats_var`. In both cases, these
#' default formatting instructions *will not* supersede formatting
#' specified from within `afun` at either the `rcell` or `in_rows`
#' call levels; They will only apply to rows/cells whose formatting as
#' returned by `afun` is either `NULL` or `"default"`.  When
#' non-`NULL`, `format` is used to specify formats for all generated
#' rows, and can be a character vector, a function, or a list of
#' functions. It will be repped out to the number of rows once this is
#' calculated during the tabulation process, but will be overridden by
#' formats specified within `rcell` calls in `afun`.
#'
#' `format` can accept a format label string (see
#' [formatters::list_valid_format_labels()]), a formatting function, an
#' unnamed list, or a named list.
#'
#' When `format` is an unnamed list - or a named list where not all
#' values of `vars` appear in the names - its elements will be repped
#' out to the number of rows generated by `afun` (separately) within
#' each row facet `afun` is applied within. **This includes recycling
#' behavior, even in the case where the number of rows is not cleanly
#' divisible by the number of specified formats**. This behavior is
#' retained largely for legacy reasons and switching to the new
#' named-list behavior is advised where applicable.
#'
#' When `format` is a named list whose names contain all values in
#' `vars`, the elements of `format` are taken to be specific to the
#' analysis of the corresponding variable; this allows us to specify a
#' multi-variable analysis where e.g., the different variables are
#' analyzed by the same `afun` but have different levels of
#' measurement precision (and thus different formatting needs). In
#' this case the var-specific formatting can be a single format (label
#' string or function) or can be a named list whose names will be
#' matched up to those of the rows generated by applying `afun` in
#' each row facet. Matching of formats to rows is performed the same
#' as in the `formats_var` case and is described below.
#'
#' When `formats_var` is non-`NULL`, it specifies the name of a list
#' column containing formatting instructions for one or more rows
#' `afun` will generate when applied within a row facet. This can be
#' used when the analysis results for a single variable (e.g., `value`
#' or `AVAL` in long-form data) should be formatted differently within
#' different row facets (e.g., when faceting on `statistic` or
#' `PARAMCD`). The value of `df[[formats_var]]` is assumed without
#' verification to be constant within each row facet `afun` is applied
#' within, and the first (list) value of the column within the row
#' facet data will be used.
#'
#' In the `formats_var` case as well as the case of `format` being a
#' named list containing the values of `vars`, after rows are created
#' during tabulation, the default formats are matched and applied to
#' them as follows:
#'
#' 1. When the generated row's name (as given by `obj_name`) matches
#'   a name in the list, the corresponding default format is applied,
#' 2. for those without exact matches, the default format whose name
#'   provides *the best partial match* to each row name is applied,
#' 3. For those without default format names that partially match
#'   the row name, no default format is applied.
#'
#' Note carefully that in (2), it is the names of the list of formats
#' that are partially matching the row names not the other way around.
#'
#' # The Analysis Function
#'
#' The analysis function (`afun`) should take as its first parameter either `x` or `df`. Whichever of these the
#' function accepts will change the behavior when tabulation is performed as follows:
#'
#' - If `afun`'s first parameter is `x`, it will receive the corresponding subset *vector* of data from the relevant
#'   column (from `var` here) of the raw data being used to build the table.
#' - If `afun`'s first parameter is `df`, it will receive the corresponding subset *data frame* (i.e. all columns) of
#'   the raw data being tabulated.
#'
#' In addition to differentiation on the first argument, the analysis function can optionally accept a number of
#' other parameters which, *if and only if* present in the formals, will be passed to the function by the tabulation
#' machinery. These are listed and described in [additional_fun_params].
#'
#' @inherit split_cols_by return
#'
#' @note None of the arguments described in [additional_fun_params] can be overridden via `extra_args` or when calling
#'   [make_afun()]. `.N_col` and `.N_total` can be overridden via the `col_counts` argument to [build_table()].
#'   Alternative values for the others must be calculated within `afun` based on a combination of extra arguments and
#'   the unmodified values provided by the tabulation framework.
#'
#' @examples
#' lyt <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   analyze("AGE", afun = list_wrap_x(summary), format = "xx.xx")
#' lyt
#'
#' tbl <- build_table(lyt, DM)
#' tbl
#'
#' lyt2 <- basic_table() %>%
#'   split_cols_by("Species") %>%
#'   analyze(head(names(iris), -1), afun = function(x) {
#'     list(
#'       "mean / sd" = rcell(c(mean(x), sd(x)), format = "xx.xx (xx.xx)"),
#'       "range" = rcell(diff(range(x)), format = "xx.xx")
#'     )
#'   })
#' lyt2
#'
#' tbl2 <- build_table(lyt2, iris)
#' tbl2
#'
#' @author Gabriel Becker
#' @export
analyze <- function(lyt,
                    vars,
                    afun = simple_analysis,
                    var_labels = vars,
                    ## really wish I hadn't named this table_names
                    ## but can't break backwards compat :(
                    table_names = vars,
                    parent_name = NULL,
                    format = NULL,
                    formats_var = NULL,
                    na_str = NA_character_,
                    na_strs_var = NULL,
                    nested = TRUE,
                    ## can't name this na_rm symbol conflict with possible afuns!!
                    inclNAs = FALSE,
                    extra_args = list(),
                    show_labels = c("default", "visible", "hidden"),
                    indent_mod = 0L,
                    section_div = NA_character_) {
  show_labels <- match.arg(show_labels)
  subafun <- substitute(afun)
  if (!is.null(format) && !is.null(formats_var)) {
    stop(
      "Cannot use 'format' and 'formats_var' arguments at ",
      "the same time. Please choose one method for specifying ",
      "default formatting."
    )
  } else if (is.null(formats_var) && !is.null(na_strs_var)) {
    stop(
      "Cannot use 'na_strs_var' (got ",
      na_strs_var,
      ") without using 'formats_var'."
    )
  }
  # R treats a single NA value as a logical atomic. The below
  # maps all the NAs in `var_labels` to NA_character_ required by `Split`
  # and avoids the error when `var_labels` is just c(NA).
  var_labels <- vapply(var_labels, function(label) ifelse(is.na(label), NA_character_, label), character(1))
  if (
    is.name(subafun) &&
      is.function(afun) &&
      ## this is gross. basically testing
      ## if the symbol we have corresponds
      ## in some meaningful way to the function
      ## we will be calling.
      identical(
        mget(
          as.character(subafun),
          mode = "function",
          ifnotfound = list(NULL),
          inherits = TRUE
        )[[1]], afun
      )
  ) {
    defrowlab <- as.character(subafun)
  } else {
    defrowlab <- var_labels
  }

  ## hook up the new hotness
  var_format_lists <- length(vars) > 1 &&
    is.list(format) &&
    all(vars %in% names(format))

  if (var_format_lists) {
    format <- lapply(format, function(x) FormatList(.list = x))
    if (is.character(na_str)) {
      na_str <- lapply(format, function(x) na_str)
    }
  }
  spl <- AnalyzeMultiVars(vars, var_labels,
    afun = afun,
    split_format = format,
    split_na_str = na_str,
    defrowlab = defrowlab,
    inclNAs = inclNAs,
    extra_args = extra_args,
    indent_mod = indent_mod,
    child_names = table_names,
    child_labels = show_labels,
    section_div = section_div,
    split_name = parent_name,
    formats_var = formats_var,
    na_strs_var = na_strs_var
  )

  if (nested && (is(last_rowsplit(lyt), "VAnalyzeSplit") || is(last_rowsplit(lyt), "AnalyzeMultiVars"))) {
    cmpnd_last_rowsplit(lyt, spl, AnalyzeMultiVars)
  } else {
    ## analysis compounding now done in split_rows
    pos <- next_rpos(lyt, nested)
    split_rows(lyt, spl, pos)
  }
}

get_acolvar_name <- function(lyt) {
  ## clyt <- clayout(lyt)
  ## stopifnot(length(clyt) == 1L)
  ## vec = clyt[[1]]
  ## vcls = vapply(vec, class, "")
  ## pos = max(which(vcls ==  "MultiVarSplit"))
  paste(c("ac", get_acolvar_vars(lyt)), collapse = "_")
}

get_acolvar_vars <- function(lyt) {
  clyt <- clayout(lyt)
  stopifnot(length(clyt) == 1L)
  vec <- clyt[[1]]
  vcls <- vapply(vec, class, "")
  pos <- which(vcls == "MultiVarSplit")
  if (length(pos) > 0) {
    spl_payload(vec[[pos]])
  } else {
    "non_multivar"
  }
}

#' Generate rows analyzing different variables across columns
#'
#' @inheritParams lyt_args
#' @param afun (`function` or `list`)\cr function(s) to be used to calculate the values in each column. The list
#'   will be repped out as needed and matched by position with the columns during tabulation. This functions
#'   accepts the same parameters as [analyze()] like `afun` and `format`. For further information see
#'   [additional_fun_params].
#'
#' @inherit split_cols_by return
#'
#' @seealso [split_cols_by_multivar()]
#'
#' @examplesIf require(dplyr)
#' library(dplyr)
#'
#' ANL <- DM %>% mutate(value = rnorm(n()), pctdiff = runif(n()))
#'
#' ## toy example where we take the mean of the first variable and the
#' ## count of >.5 for the second.
#' colfuns <- list(
#'   function(x) rcell(mean(x), format = "xx.x"),
#'   function(x) rcell(sum(x > .5), format = "xx")
#' )
#'
#' lyt <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   split_cols_by_multivar(c("value", "pctdiff")) %>%
#'   split_rows_by("RACE",
#'     split_label = "ethnicity",
#'     split_fun = drop_split_levels
#'   ) %>%
#'   summarize_row_groups() %>%
#'   analyze_colvars(afun = colfuns)
#' lyt
#'
#' tbl <- build_table(lyt, ANL)
#' tbl
#'
#' lyt2 <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   split_cols_by_multivar(c("value", "pctdiff"),
#'     varlabels = c("Measurement", "Pct Diff")
#'   ) %>%
#'   split_rows_by("RACE",
#'     split_label = "ethnicity",
#'     split_fun = drop_split_levels
#'   ) %>%
#'   summarize_row_groups() %>%
#'   analyze_colvars(afun = mean, format = "xx.xx")
#'
#' tbl2 <- build_table(lyt2, ANL)
#' tbl2
#'
#' @author Gabriel Becker
#' @export
analyze_colvars <- function(lyt,
                            afun,
                            parent_name = get_acolvar_name(lyt),
                            format = NULL,
                            na_str = NA_character_,
                            nested = TRUE,
                            extra_args = list(),
                            indent_mod = 0L,
                            inclNAs = FALSE) {
  if (is.function(afun)) {
    subafun <- substitute(afun)
    if (
      is.name(subafun) &&
        is.function(afun) &&
        ## this is gross. basically testing
        ## if the symbol we have corresponds
        ## in some meaningful way to the function
        ## we will be calling.
        identical(
          mget(
            as.character(subafun),
            mode = "function",
            ifnotfound = list(NULL),
            inherits = TRUE
          )[[1]],
          afun
        )
    ) {
      defrowlab <- as.character(subafun)
    } else {
      defrowlab <- ""
    }
    afun <- lapply(
      get_acolvar_vars(lyt),
      function(x) afun
    )
  } else {
    defrowlab <- ""
  }
  spl <- AnalyzeColVarSplit(
    afun = afun,
    defrowlab = defrowlab,
    split_format = format,
    split_na_str = na_str,
    split_name = parent_name,
    indent_mod = indent_mod,
    extra_args = extra_args,
    inclNAs = inclNAs
  )
  pos <- next_rpos(lyt, nested, for_analyze = TRUE)
  split_rows(lyt, spl, pos)
}

## Add a total column at the next **top level** spot in
## the column layout.

#' Add overall column
#'
#' This function will *only* add an overall column at the *top* level of splitting, NOT within existing column splits.
#' See [add_overall_level()] for the recommended way to add overall columns more generally within existing splits.
#'
#' @inheritParams lyt_args
#'
#' @inherit split_cols_by return
#'
#' @seealso [add_overall_level()]
#'
#' @examples
#' lyt <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   add_overall_col("All Patients") %>%
#'   analyze("AGE")
#' lyt
#'
#' tbl <- build_table(lyt, DM)
#' tbl
#'
#' @export
add_overall_col <- function(lyt, label) {
  spl <- AllSplit(label)
  split_cols(
    lyt,
    spl,
    next_cpos(lyt, FALSE)
  )
}

## add_row_summary ====

#' @inheritParams lyt_args
#'
#' @export
#'
#' @rdname int_methods
setGeneric(
  ".add_row_summary",
  function(lyt,
           label,
           cfun,
           child_labels = c("default", "visible", "hidden"),
           cformat = NULL,
           cna_str = "-",
           indent_mod = 0L,
           cvar = "",
           extra_args = list()) {
    standardGeneric(".add_row_summary")
  }
)

#' @rdname int_methods
setMethod(
  ".add_row_summary", "PreDataTableLayouts",
  function(lyt,
           label,
           cfun,
           child_labels = c("default", "visible", "hidden"),
           cformat = NULL,
           cna_str = "-",
           indent_mod = 0L,
           cvar = "",
           extra_args = list()) {
    child_labels <- match.arg(child_labels)
    tmp <- .add_row_summary(rlayout(lyt), label, cfun,
      child_labels = child_labels,
      cformat = cformat,
      cna_str = cna_str,
      indent_mod = indent_mod,
      cvar = cvar,
      extra_args = extra_args
    )
    rlayout(lyt) <- tmp
    lyt
  }
)

#' @rdname int_methods
setMethod(
  ".add_row_summary", "PreDataRowLayout",
  function(lyt,
           label,
           cfun,
           child_labels = c("default", "visible", "hidden"),
           cformat = NULL,
           cna_str = "-",
           indent_mod = 0L,
           cvar = "",
           extra_args = list()) {
    child_labels <- match.arg(child_labels)
    if (length(lyt) == 0 || (length(lyt) == 1 && length(lyt[[1]]) == 0)) {
      ## XXX ignoring indent mod here
      rt <- root_spl(lyt)
      rt <- .add_row_summary(rt,
        label,
        cfun,
        child_labels = child_labels,
        cformat = cformat,
        cna_str = cna_str,
        cvar = cvar,
        extra_args = extra_args
      )
      root_spl(lyt) <- rt
    } else {
      ind <- length(lyt)
      tmp <- .add_row_summary(lyt[[ind]], label, cfun,
        child_labels = child_labels,
        cformat = cformat,
        cna_str = cna_str,
        indent_mod = indent_mod,
        cvar = cvar,
        extra_args = extra_args
      )
      lyt[[ind]] <- tmp
    }
    lyt
  }
)

#' @rdname int_methods
setMethod(
  ".add_row_summary", "SplitVector",
  function(lyt,
           label,
           cfun,
           child_labels = c("default", "visible", "hidden"),
           cformat = NULL,
           cna_str = "-",
           indent_mod = 0L,
           cvar = "",
           extra_args = list()) {
    child_labels <- match.arg(child_labels)
    ind <- length(lyt)
    if (ind == 0) stop("no split to add content rows at")
    spl <- lyt[[ind]]
    # if(is(spl, "AnalyzeVarSplit"))
    #     stop("can't add content rows to analyze variable split")
    tmp <- .add_row_summary(spl,
      label,
      cfun,
      child_labels = child_labels,
      cformat = cformat,
      cna_str = cna_str,
      indent_mod = indent_mod,
      cvar = cvar,
      extra_args = extra_args
    )
    lyt[[ind]] <- tmp
    lyt
  }
)

#' @rdname int_methods
setMethod(
  ".add_row_summary", "Split",
  function(lyt,
           label,
           cfun,
           child_labels = c("default", "visible", "hidden"),
           cformat = NULL,
           cna_str = "-",
           indent_mod = 0L,
           cvar = "",
           extra_args = list()) {
    child_labels <- match.arg(child_labels)
    #   lbl_kids = .labelkids_helper(child_labels)
    content_fun(lyt) <- cfun
    content_indent_mod(lyt) <- indent_mod
    content_var(lyt) <- cvar
    ## obj_format(lyt) = cformat
    content_format(lyt) <- cformat
    if (!identical(child_labels, "default") && !identical(child_labels, label_kids(lyt))) {
      label_kids(lyt) <- child_labels
    }
    content_na_str <- cna_str
    content_extra_args(lyt) <- extra_args
    lyt
  }
)

.count_raw_constr <- function(var, format, label_fstr) {
  function(df, labelstr = "") {
    if (grepl("%s", label_fstr, fixed = TRUE)) {
      label <- sprintf(label_fstr, labelstr)
    } else {
      label <- label_fstr
    }
    if (is(df, "data.frame")) {
      if (!is.null(var) && nzchar(var)) {
        cnt <- sum(!is.na(df[[var]]))
      } else {
        cnt <- nrow(df)
      }
    } else { # df is the data column vector
      cnt <- sum(!is.na(df))
    }
    ret <- rcell(cnt,
      format = format,
      label = label,
      stat_names = "n"
    )
    ret
  }
}

.count_wpcts_constr <- function(var, format, label_fstr) {
  function(df, labelstr = "", .N_col) {
    if (grepl("%s", label_fstr, fixed = TRUE)) {
      label <- sprintf(label_fstr, labelstr)
    } else {
      label <- label_fstr
    }
    if (is(df, "data.frame")) {
      if (!is.null(var) && nzchar(var)) {
        cnt <- sum(!is.na(df[[var]]))
      } else {
        cnt <- nrow(df)
      }
    } else { # df is the data column vector
      cnt <- sum(!is.na(df))
    }
    ## the formatter does the *100 so we don't here.
    ## Elements are named with stat_names so that ARD generation has access to them
    ret <- rcell(c(cnt, cnt / .N_col),
      format = format,
      label = label,
      stat_names = c("n", "p")
    )
    ret
  }
}

.validate_cfuns <- function(fun) {
  if (is.list(fun)) {
    return(unlist(lapply(fun, .validate_cfuns)))
  }

  frmls <- formals(fun)
  ls_pos <- match("labelstr", names(frmls))
  if (is.na(ls_pos)) {
    stop("content functions must explicitly accept a 'labelstr' argument")
  }

  list(fun)
}

#' Analysis function to count levels of a factor with percentage of the column total
#'
#' @param x (`factor`)\cr a vector of data, provided by rtables pagination machinery.
#' @param .N_col (`integer(1)`)\cr total count for the column, provided by rtables pagination machinery.
#'
#' @return A `RowsVerticalSection` object with counts (and percents) for each level of the factor.
#'
#' @examples
#' counts_wpcts(DM$SEX, 400)
#'
#' @export
counts_wpcts <- function(x, .N_col) {
  if (!is.factor(x)) {
    stop(
      "using the 'counts_wpcts' analysis function requires factor data ",
      "to guarantee equal numbers of rows across all collumns, got class ",
      class(x), "."
    )
  }
  ret <- table(x)
  in_rows(.list = lapply(ret, function(y) rcell(y * c(1, 1 / .N_col), format = "xx (xx.x%)")))
}

#' Add a content row of summary counts
#'
#' @inheritParams lyt_args
#'
#' @inherit split_cols_by return
#'
#' @details
#' If `format` expects 1 value (i.e. it is specified as a format string and `xx` appears for two values
#' (i.e. `xx` appears twice in the format string) or is specified as a function, then both raw and percent of
#' column total counts are calculated. If `format` is a format string where `xx` appears only one time, only
#' raw counts are used.
#'
#' `cfun` must accept `x` or `df` as its first argument. For the `df` argument `cfun` will receive the subset
#' `data.frame` corresponding with the row- and column-splitting for the cell being calculated. Must accept
#' `labelstr` as the second parameter, which accepts the `label` of the level of the parent split currently
#' being summarized. Can additionally take any optional argument supported by analysis functions. (see [analyze()]).
#'
#' In addition, if complex custom functions are needed, we suggest checking the available [additional_fun_params]
#' that can be used in `cfun`.
#'
#' @examples
#' DM2 <- subset(DM, COUNTRY %in% c("USA", "CAN", "CHN"))
#'
#' lyt <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   split_rows_by("COUNTRY", split_fun = drop_split_levels) %>%
#'   summarize_row_groups(label_fstr = "%s (n)") %>%
#'   analyze("AGE", afun = list_wrap_x(summary), format = "xx.xx")
#' lyt
#'
#' tbl <- build_table(lyt, DM2)
#' tbl
#'
#' row_paths_summary(tbl) # summary count is a content table
#'
#' ## use a cfun and extra_args to customize summarization
#' ## behavior
#' sfun <- function(x, labelstr, trim) {
#'   in_rows(
#'     c(mean(x, trim = trim), trim),
#'     .formats = "xx.x (xx.x%)",
#'     .labels = sprintf(
#'       "%s (Trimmed mean and trim %%)",
#'       labelstr
#'     )
#'   )
#' }
#'
#' lyt2 <- basic_table(show_colcounts = TRUE) %>%
#'   split_cols_by("ARM") %>%
#'   split_rows_by("COUNTRY", split_fun = drop_split_levels) %>%
#'   summarize_row_groups("AGE",
#'     cfun = sfun,
#'     extra_args = list(trim = .2)
#'   ) %>%
#'   analyze("AGE", afun = list_wrap_x(summary), format = "xx.xx") %>%
#'   append_topleft(c("Country", "  Age"))
#'
#' tbl2 <- build_table(lyt2, DM2)
#' tbl2
#'
#' @author Gabriel Becker
#' @export
summarize_row_groups <- function(lyt,
                                 var = "",
                                 label_fstr = "%s",
                                 format = "xx (xx.x%)",
                                 na_str = "-",
                                 cfun = NULL,
                                 indent_mod = 0L,
                                 extra_args = list()) {
  if (is.null(cfun)) {
    if (is.character(format) && length(gregexpr("xx(\\.x*){0,1}", format)[[1]]) == 1) {
      cfun <- .count_raw_constr(var, format, label_fstr)
    } else {
      cfun <- .count_wpcts_constr(var, format, label_fstr)
    }
  }
  cfun <- .validate_cfuns(cfun)
  .add_row_summary(lyt,
    cfun = cfun,
    cformat = format,
    cna_str = na_str,
    indent_mod = indent_mod,
    cvar = var,
    extra_args = extra_args
  )
}

#' Add the column population counts to the header
#'
#' Add the data derived column counts.
#'
#' @details It is often the case that the the column counts derived from the
#'   input data to [build_table()] is not representative of the population counts.
#'   For example, if events are counted in the table and the header should
#'   display the number of subjects and not the total number of events.
#'
#' @inheritParams lyt_args
#'
#' @inherit split_cols_by return
#'
#' @examples
#' lyt <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   add_colcounts() %>%
#'   split_rows_by("RACE", split_fun = drop_split_levels) %>%
#'   analyze("AGE", afun = function(x) list(min = min(x), max = max(x)))
#' lyt
#'
#' tbl <- build_table(lyt, DM)
#' tbl
#'
#' @author Gabriel Becker
#' @export
add_colcounts <- function(lyt, format = "(N=xx)") {
  if (is.null(lyt)) {
    lyt <- PreDataTableLayouts()
  }
  disp_ccounts(lyt) <- TRUE
  colcount_format(lyt) <- format
  lyt
}

## Currently existing tables can ONLY be added as new entries at the top level, never at any level of nesting.
#' Add an already calculated table to the layout
#'
#' @inheritParams lyt_args
#' @inheritParams gen_args
#'
#' @inherit split_cols_by return
#'
#' @examples
#' lyt1 <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   analyze("AGE", afun = mean, format = "xx.xx")
#'
#' tbl1 <- build_table(lyt1, DM)
#' tbl1
#'
#' lyt2 <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   analyze("AGE", afun = sd, format = "xx.xx") %>%
#'   add_existing_table(tbl1)
#'
#' tbl2 <- build_table(lyt2, DM)
#' tbl2
#'
#' table_structure(tbl2)
#' row_paths_summary(tbl2)
#'
#' @author Gabriel Becker
#' @export
add_existing_table <- function(lyt, tt, indent_mod = 0) {
  indent_mod(tt) <- indent_mod
  lyt <- split_rows(
    lyt,
    tt,
    next_rpos(lyt, nested = FALSE)
  )
  lyt
}

## takes_coln = function(f) {
##     stopifnot(is(f, "function"))
##     forms = names(formals(f))
##     res = ".N_col" %in% forms
##     res
## }

## takes_totn = function(f) {
##     stopifnot(is(f, "function"))
##     forms = names(formals(f))
##     res = ".N_total" %in% forms
##     res
## }

## use data to transform dynamic cuts to static cuts
#' @rdname int_methods
setGeneric("fix_dyncuts", function(spl, df) standardGeneric("fix_dyncuts"))

#' @rdname int_methods
setMethod("fix_dyncuts", "Split", function(spl, df) spl)

#' @rdname int_methods
setMethod(
  "fix_dyncuts", "VarDynCutSplit",
  function(spl, df) {
    var <- spl_payload(spl)
    varvec <- df[[var]]

    cfun <- spl_cutfun(spl)
    cuts <- cfun(varvec)
    cutlabels <- spl_cutlabelfun(spl)(cuts)
    if (length(cutlabels) != length(cuts) - 1 && !is.null(names(cuts))) {
      cutlabels <- names(cuts)[-1]
    }

    ret <- make_static_cut_split(
      var = var, split_label = obj_label(spl),
      cuts = cuts, cutlabels = cutlabels,
      cumulative = spl_is_cmlcuts(spl)
    )
    ## ret = VarStaticCutSplit(var = var, split_label = obj_label(spl),
    ##                   cuts = cuts, cutlabels = cutlabels)
    ## ## classes are tthe same structurally CumulativeCutSplit
    ## ## is just a sentinal so it can hit different make_subset_expr
    ## ## method
    ## if(spl_is_cmlcuts(spl))
    ##     ret = as(ret, "CumulativeCutSplit")
    ret
  }
)

#' @rdname int_methods
setMethod(
  "fix_dyncuts", "VTableTree",
  function(spl, df) spl
)

.fd_helper <- function(spl, df) {
  lst <- lapply(spl, fix_dyncuts, df = df)
  spl@.Data <- lst
  spl
}

#' @rdname int_methods
setMethod(
  "fix_dyncuts", "PreDataRowLayout",
  function(spl, df) {
    #   rt = root_spl(spl)
    ret <- .fd_helper(spl, df)
    #    root_spl(ret) = rt
    ret
  }
)

#' @rdname int_methods
setMethod(
  "fix_dyncuts", "PreDataColLayout",
  function(spl, df) {
    #   rt = root_spl(spl)
    ret <- .fd_helper(spl, df)
    #   root_spl(ret) = rt
    #   disp_ccounts(ret) = disp_ccounts(spl)
    #   colcount_format(ret) = colcount_format(spl)
    ret
  }
)

#' @rdname int_methods
setMethod(
  "fix_dyncuts", "SplitVector",
  function(spl, df) {
    .fd_helper(spl, df)
  }
)

#' @rdname int_methods
setMethod(
  "fix_dyncuts", "PreDataTableLayouts",
  function(spl, df) {
    rlayout(spl) <- fix_dyncuts(rlayout(spl), df)
    clayout(spl) <- fix_dyncuts(clayout(spl), df)
    spl
  }
)

## Manual column construction in a simple (seeming to the user) way.
#' Manual column declaration
#'
#' @param ... one or more vectors of levels to appear in the column space. If more than one set of levels is given,
#'   the values of the second are nested within each value of the first, and so on.
#' @param .lst (`list`)\cr a list of sets of levels, by default populated via `list(...)`.
#' @param ccount_format (`FormatSpec`)\cr the format to use when counts are displayed.
#'
#' @return An `InstantiatedColumnInfo` object, suitable for declaring the column structure for a manually constructed
#'   table.
#'
#' @examples
#' # simple one level column space
#' rows <- lapply(1:5, function(i) {
#'   DataRow(rep(i, times = 3))
#' })
#' tbl <- TableTree(kids = rows, cinfo = manual_cols(split = c("a", "b", "c")))
#' tbl
#'
#' # manually declared nesting
#' tbl2 <- TableTree(
#'   kids = list(DataRow(as.list(1:4))),
#'   cinfo = manual_cols(
#'     Arm = c("Arm A", "Arm B"),
#'     Gender = c("M", "F")
#'   )
#' )
#' tbl2
#'
#' @author Gabriel Becker
#' @export
manual_cols <- function(..., .lst = list(...), ccount_format = NULL) {
  if (is.null(names(.lst))) {
    names(.lst) <- paste("colsplit", seq_along(.lst))
  }

  splvec <- SplitVector(lst = mapply(ManualSplit,
    levels = .lst,
    label = names(.lst)
  ))
  ctree <- splitvec_to_coltree(data.frame(), splvec = splvec, pos = TreePos(), global_cc_format = ccount_format)

  ret <- InstantiatedColumnInfo(treelyt = ctree)
  rm_all_colcounts(ret)
}


#' Set all column counts at all levels of nesting to NA
#'
#' @inheritParams gen_args
#'
#' @return `obj` with all column counts reset to missing
#'
#' @export
#' @examples
#' lyt <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   split_cols_by("SEX") %>%
#'   analyze("AGE")
#' tbl <- build_table(lyt, ex_adsl)
#'
#' # before
#' col_counts(tbl)
#' tbl <- rm_all_colcounts(tbl)
#' col_counts(tbl)
setGeneric("rm_all_colcounts", function(obj) standardGeneric("rm_all_colcounts"))

#' @rdname rm_all_colcounts
#' @export
setMethod(
  "rm_all_colcounts", "VTableTree",
  function(obj) {
    cinfo <- col_info(obj)
    cinfo <- rm_all_colcounts(cinfo)
    col_info(obj) <- cinfo
    obj
  }
)

#' @rdname rm_all_colcounts
#' @export
setMethod(
  "rm_all_colcounts", "InstantiatedColumnInfo",
  function(obj) {
    ctree <- coltree(obj)
    ctree <- rm_all_colcounts(ctree)
    coltree(obj) <- ctree
    obj
  }
)

#' @rdname rm_all_colcounts
#' @export
setMethod(
  "rm_all_colcounts", "LayoutColTree",
  function(obj) {
    obj@column_count <- NA_integer_
    tree_children(obj) <- lapply(tree_children(obj), rm_all_colcounts)
    obj
  }
)

#' @rdname rm_all_colcounts
#' @export
setMethod(
  "rm_all_colcounts", "LayoutColLeaf",
  function(obj) {
    obj@column_count <- NA_integer_
    obj
  }
)

#' Returns a function that coerces the return values of a function to a list
#'
#' @param f (`function`)\cr the function to wrap.
#'
#' @details
#' `list_wrap_x` generates a wrapper which takes `x` as its first argument, while `list_wrap_df` generates an
#' otherwise identical wrapper function whose first argument is named `df`.
#'
#' We provide both because when using the functions as tabulation in [analyze()], functions which take `df` as
#' their first argument are passed the full subset data frame, while those which accept anything else notably
#' including `x` are passed only the relevant subset of the variable being analyzed.
#'
#' @return A function that returns a list of `CellValue` objects.
#'
#' @examples
#' summary(iris$Sepal.Length)
#'
#' f <- list_wrap_x(summary)
#' f(x = iris$Sepal.Length)
#'
#' f2 <- list_wrap_df(summary)
#' f2(df = iris$Sepal.Length)
#'
#' @author Gabriel Becker
#' @rdname list_wrap
#' @export
list_wrap_x <- function(f) {
  function(x, ...) {
    vs <- as.list(f(x, ...))
    ret <- mapply(
      function(v, nm) {
        rcell(v, label = nm)
      },
      v = vs,
      nm = names(vs)
    )
    ret
  }
}

#' @rdname list_wrap
#' @export
list_wrap_df <- function(f) {
  function(df, ...) {
    vs <- as.list(f(df, ...))
    ret <- mapply(
      function(v, nm) {
        rcell(v, label = nm)
      },
      v = vs,
      nm = names(vs)
    )
    ret
  }
}

#' Layout with 1 column and zero rows
#'
#' Every layout must start with a basic table.
#'
#' @inheritParams constr_args
#' @inheritParams gen_args
#' @param show_colcounts (`logical(1)`)\cr Indicates whether the lowest level of
#'   applied to data. `NA`, the default, indicates that the `show_colcounts`
#'   argument(s) passed to the relevant calls to `split_cols_by*`
#'   functions. Non-missing values will override the behavior specified in
#'   column splitting layout instructions which create the lowest level, or
#'   leaf, columns.
#' @param colcount_format (`string`)\cr format for use when displaying the column counts. Must be 1d, or 2d
#'   where one component is a percent. This will also apply to any displayed higher
#'   level column counts where an explicit format was not specified. Defaults to `"(N=xx)"`. See Details below.
#' @param top_level_section_div (`character(1)`)\cr if assigned a single character, the first (top level) split
#'   or division of the table will be highlighted by a line made of that character. See [section_div] for more
#'   information.
#'
#' @details
#' `colcount_format` is ignored if `show_colcounts` is `FALSE` (the default). When `show_colcounts` is `TRUE`,
#' and `colcount_format` is 2-dimensional with a percent component, the value component for the percent is always
#' populated with `1` (i.e. 100%). 1d formats are used to render the counts exactly as they normally would be,
#' while 2d formats which don't include a percent, and all 3d formats result in an error. Formats in the form of
#' functions are not supported for `colcount` format. See [formatters::list_valid_format_labels()] for the list
#' of valid format labels to select from.
#'
#' @inherit split_cols_by return
#'
#' @note
#' - Because percent components in `colcount_format` are *always* populated with the value 1, we can get arguably
#'   strange results, such as that individual arm columns and a combined "all patients" column all list "100%" as
#'   their percentage, even though the individual arm columns represent strict subsets of the "all patients" column.
#'
#' - Note that subtitles ([formatters::subtitles()]) and footers ([formatters::main_footer()] and
#' [formatters::prov_footer()]) that span more than one line can be supplied as a character vector to maintain
#' indentation on multiple lines.
#'
#' @examples
#' lyt <- basic_table() %>%
#'   analyze("AGE", afun = mean)
#'
#' tbl <- build_table(lyt, DM)
#' tbl
#'
#' lyt2 <- basic_table(
#'   title = "Title of table",
#'   subtitles = c("a number", "of subtitles"),
#'   main_footer = "test footer",
#'   prov_footer = paste(
#'     "test.R program, executed at",
#'     Sys.time()
#'   )
#' ) %>%
#'   split_cols_by("ARM") %>%
#'   analyze("AGE", mean)
#'
#' tbl2 <- build_table(lyt2, DM)
#' tbl2
#'
#' lyt3 <- basic_table(
#'   show_colcounts = TRUE,
#'   colcount_format = "xx. (xx.%)"
#' ) %>%
#'   split_cols_by("ARM")
#'
#' @export
basic_table <- function(title = "",
                        subtitles = character(),
                        main_footer = character(),
                        prov_footer = character(),
                        show_colcounts = NA, # FALSE,
                        colcount_format = "(N=xx)",
                        header_section_div = NA_character_,
                        top_level_section_div = NA_character_,
                        inset = 0L,
                        round_type = valid_round_type) {
  round_type <- match.arg(round_type)
  inset <- as.integer(inset)
  if (is.na(inset) || inset < 0L) {
    stop("Got invalid table_inset value, must be an integer > 0")
  }
  .check_header_section_div(header_section_div)
  checkmate::assert_character(top_level_section_div, len = 1, n.chars = 1)

  ret <- PreDataTableLayouts(
    title = title,
    subtitles = subtitles,
    main_footer = main_footer,
    prov_footer = prov_footer,
    header_section_div = header_section_div,
    top_level_section_div = top_level_section_div,
    table_inset = as.integer(inset),
    round_type = round_type
  )

  ## unconditional now, NA case is handled in cinfo construction
  disp_ccounts(ret) <- show_colcounts
  colcount_format(ret) <- colcount_format
  ## if (isTRUE(show_colcounts)) {
  ##   ret <- add_colcounts(ret, format = colcount_format)
  ## }
  ret
}

#' Append a description to the 'top-left' materials for the layout
#'
#' This function *adds* `newlines` to the current set of "top-left materials".
#'
#' @details
#' Adds `newlines` to the set of strings representing the 'top-left' materials declared in the layout (the content
#' displayed to the left of the column labels when the resulting tables are printed).
#'
#' Top-left material strings are stored and then displayed *exactly as is*, no structure or indenting is applied to
#' them either when they are added or when they are displayed.
#'
#' @inheritParams lyt_args
#' @param newlines (`character`)\cr the new line(s) to be added to the materials.
#'
#' @note
#' Currently, where in the construction of the layout this is called makes no difference, as it is independent of
#' the actual splitting keywords. This may change in the future.
#'
#' This function is experimental, its name and the details of its behavior are subject to change in future versions.
#'
#' @inherit split_cols_by return
#'
#' @seealso [top_left()]
#'
#' @examplesIf require(dplyr)
#' library(dplyr)
#'
#' DM2 <- DM %>% mutate(RACE = factor(RACE), SEX = factor(SEX))
#'
#' lyt <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   split_cols_by("SEX") %>%
#'   split_rows_by("RACE") %>%
#'   append_topleft("Ethnicity") %>%
#'   analyze("AGE") %>%
#'   append_topleft("  Age")
#'
#' tbl <- build_table(lyt, DM2)
#' tbl
#'
#' @export
append_topleft <- function(lyt, newlines) {
  stopifnot(
    is(lyt, "PreDataTableLayouts"),
    is(newlines, "character")
  )
  lyt@top_left <- c(lyt@top_left, newlines)
  lyt
}

#' Cell value constructors
#'
#' Construct a cell value and associate formatting, labeling, indenting, and column spanning information with it.
#'
#' @inheritParams compat_args
#' @inheritParams lyt_args
#' @inheritParams gen_args
#' @param x (`ANY`)\cr cell value.
#' @param format (`string` or `function`)\cr the format label (string) or `formatters` function to apply to `x`.
#'   See [formatters::list_valid_format_labels()] for currently supported format labels.
#' @param label (`string` or `NULL`)\cr label. If non-`NULL`, it will be looked at when determining row labels.
#' @param colspan (`integer(1)`)\cr column span value.
#' @param footnotes (`list` or `NULL`)\cr referential footnote messages for the cell.
#' @param stat_names (`character` or `NA`)\cr names for the statistics in the cell. It can be a vector of strings.
#'   If `NA`, statistic names are not specified.
#'
#' @inherit CellValue return
#'
#' @note Currently column spanning is only supported for defining header structure.
#'
#' @examples
#' rcell(1, format = "xx.x")
#' rcell(c(1, 2), format = c("xx - xx"))
#' rcell(c(1, 2), stat_names = c("Rand1", "Rand2"))
#'
#' @rdname rcell
#' @export
rcell <- function(x,
                  format = NULL,
                  colspan = 1L,
                  label = NULL,
                  indent_mod = NULL,
                  footnotes = NULL,
                  align = NULL,
                  format_na_str = NULL,
                  stat_names = NULL,
                  round_type = valid_round_type) {
  round_type <- match.arg(round_type)
  checkmate::assert_character(stat_names, null.ok = TRUE)
  if (!is.null(align)) {
    check_aligns(align)
  }
  if (is(x, "CellValue")) {
    if (!is.null(label)) {
      obj_label(x) <- label
    }
    if (colspan != 1L) {
      cell_cspan(x) <- colspan
    }
    if (!is.null(indent_mod)) {
      indent_mod(x) <- indent_mod
    }
    if (!is.null(format)) {
      obj_format(x) <- format
    }
    if (!is.null(footnotes)) {
      cell_footnotes(x) <- lapply(footnotes, RefFootnote)
    }
    if (!is.null(format_na_str)) {
      obj_na_str(x) <- format_na_str
    }
    if (!is.null(stat_names)) {
      obj_stat_names(x) <- stat_names
    }
    ret <- x
  } else {
    if (is.null(label)) {
      label <- obj_label(x)
    }
    if (is.null(format)) {
      format <- obj_format(x)
    }
    if (is.null(indent_mod)) {
      indent_mod <- indent_mod(x)
    }
    footnotes <- lapply(footnotes, RefFootnote)
    ret <- CellValue(
      val = x,
      format = format,
      colspan = colspan,
      label = label,
      indent_mod = indent_mod,
      footnotes = footnotes,
      format_na_str = format_na_str,
      stat_names = stat_names %||% NA_character_,
      round_type = round_type
    ) # RefFootnote(footnote))
  }
  if (!is.null(align)) {
    cell_align(ret) <- align
  }
  ret
}

#' @param is_ref (`flag`)\cr whether function is being used in the reference column (i.e. `.in_ref_col` should be
#'   passed to this argument).
#' @param refval (`ANY`)\cr value to use when in the reference column. Defaults to `NULL`.
#'
#' @details
#' `non_ref_rcell` provides the common *blank for cells in the reference column, this value otherwise*, and should
#' be passed the value of `.in_ref_col` when it is used.
#'
#' @rdname rcell
#' @export
non_ref_rcell <- function(x, is_ref, format = NULL, colspan = 1L,
                          label = NULL, indent_mod = NULL,
                          refval = NULL,
                          align = "center",
                          format_na_str = NULL) {
  val <- if (is_ref) refval else x
  rcell(val,
    format = format, colspan = colspan, label = label,
    indent_mod = indent_mod, align = align,
    format_na_str = format_na_str
  )
}

#' Create multiple rows in analysis or summary functions
#'
#' Define the cells that get placed into multiple rows in `afun`.
#'
#' @param ... single row defining expressions.
#' @param .list (`list`)\cr list cell content (usually `rcells`). The `.list` is concatenated to `...`.
#' @param .names (`character` or `NULL`)\cr names of the returned list/structure.
#' @param .labels (`character` or `NULL`)\cr labels for the defined rows.
#' @param .formats (`character` or `NULL`)\cr formats for the values.
#' @param .indent_mods (`integer` or `NULL`)\cr indent modifications for the defined rows.
#' @param .cell_footnotes (`list`)\cr referential footnote messages to be associated by name with *cells*.
#' @param .row_footnotes (`list`)\cr referential footnotes messages to be associated by name with *rows*.
#' @param .aligns (`character` or `NULL`)\cr alignments for the cells. Standard for `NULL` is `"center"`.
#'   See [formatters::list_valid_aligns()] for currently supported alignments.
#' @param .format_na_strs (`character` or `NULL`)\cr NA strings for the cells.
#' @param .stat_names (`list`)\cr names for the statistics in the cells.
#'   It can be a vector of values. If `list(NULL)`, statistic names are not specified and will
#'   appear as `NA`.
#'
#' @note In post-processing, referential footnotes can also be added using row and column
#'   paths with [`fnotes_at_path<-`].
#'
#' @return A `RowsVerticalSection` object (or `NULL`). The details of this object should be considered an
#'   internal implementation detail.
#'
#' @seealso [analyze()]
#'
#' @examples
#' in_rows(1, 2, 3, .names = c("a", "b", "c"))
#' in_rows(1, 2, 3, .labels = c("a", "b", "c"))
#' in_rows(1, 2, 3, .names = c("a", "b", "c"), .labels = c("AAA", "BBB", "CCC"))
#' in_rows(
#'   .list = list(a = c(NA, NA)),
#'   .formats = "xx - xx",
#'   .format_na_strs = list(c("asda", "lkjklj"))
#' )
#' in_rows(.list = list(a = c(NA, NA)), .format_na_strs = c("asda", "lkjklj"))
#'
#' in_rows(.list = list(a = 1, b = 2, c = 3))
#' in_rows(1, 2, .list = list(3), .names = c("a", "b", "c"))
#'
#' lyt <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   analyze("AGE", afun = function(x) {
#'     in_rows(
#'       "Mean (sd)" = rcell(c(mean(x), sd(x)), format = "xx.xx (xx.xx)"),
#'       "Range" = rcell(range(x), format = "xx.xx - xx.xx")
#'     )
#'   })
#'
#' tbl <- build_table(lyt, ex_adsl)
#' tbl
#'
#' @export
in_rows <- function(..., .list = NULL, .names = NULL,
                    .labels = NULL,
                    .formats = NULL,
                    .indent_mods = NULL,
                    .cell_footnotes = list(NULL),
                    .row_footnotes = list(NULL),
                    .aligns = NULL,
                    .format_na_strs = NULL,
                    .stat_names = list(NULL)) {
  if (is.function(.formats)) {
    .formats <- list(.formats)
  }

  l <- c(list(...), .list)

  if (missing(.names) && missing(.labels)) {
    if (length(l) > 0 && is.null(names(l))) {
      stop("need a named list")
    } else {
      .names <- names(l)
    }
    stopifnot(!anyNA(.names))
  }

  if (length(l) == 0) {
    if (
      length(.labels) > 0 ||
        length(.formats) > 0 ||
        length(.names) > 0 ||
        length(.indent_mods) > 0 ||
        length(.format_na_strs) > 0 ||
        (!all(is.na(.stat_names)) && length(.stat_names) > 0)
    ) {
      stop(
        "in_rows got 0 rows but length >0 of at least one of ",
        ".labels, .formats, .names, .indent_mods, .format_na_strs, .stat_names. ",
        "Does your analysis/summary function handle the 0 row ",
        "df/length 0 x case?"
      )
    }
    l2 <- list()
  } else {
    if (is.null(.formats)) {
      .formats <- list(NULL)
    }
    stopifnot(is.list(.cell_footnotes))
    if (length(.cell_footnotes) != length(l)) {
      .cell_footnotes <- c(
        .cell_footnotes,
        setNames(
          rep(list(character()),
            length.out = length(setdiff(
              names(l),
              names(.cell_footnotes)
            ))
          ),
          setdiff(
            names(l),
            names(.cell_footnotes)
          )
        )
      )
      .cell_footnotes <- .cell_footnotes[names(l)]
    }
    if (is.null(.aligns)) {
      .aligns <- list(NULL)
    }

    l2 <- mapply(rcell,
      x = l, format = .formats,
      footnotes = .cell_footnotes %||% list(NULL),
      align = .aligns,
      format_na_str = .format_na_strs %||% list(NULL),
      stat_names = .stat_names %||% list(NULL),
      SIMPLIFY = FALSE
    )
  }
  if (is.null(.labels)) {
    objlabs <- vapply(l2, function(x) obj_label(x) %||% "", "")
    if (any(nzchar(objlabs))) {
      .labels <- objlabs
    }
  }

  if (is.null(.names) && !is.null(names(l))) {
    .names <- names(l)
  }
  stopifnot(is.list(.row_footnotes))
  if (length(.row_footnotes) != length(l2)) {
    tmp <- .row_footnotes
    .row_footnotes <- vector("list", length(l2))
    pos <- match(names(tmp), .names)
    nonna <- which(!is.na(pos))
    .row_footnotes[pos] <- tmp[nonna]
    #        length(.row_footnotes) <- length(l2)
  }
  ret <- RowsVerticalSection(l2,
    names = .names,
    labels = .labels,
    indent_mods = .indent_mods,
    formats = .formats,
    footnotes = .row_footnotes,
    format_na_strs = .format_na_strs
  )
  ## if(!is.null(.names))
  ##     names(l2) <- .names
  ## else
  ##     names(l2) <- names(l)
  if (length(ret) == 0) NULL else ret

  ##   if (length(l) == 0) NULL else l
}

.validate_nms <- function(vals, .stats, arg) {
  if (!is.null(arg)) {
    if (is.null(names(arg))) {
      stopifnot(length(arg) == length(.stats))
      names(arg) <- names(vals)
    } else {
      lblpos <- match(names(arg), names(vals))
      stopifnot(!anyNA(lblpos))
    }
  }
  arg
}

#' Create a custom analysis function wrapping an existing function
#'
#' @param fun (`function`)\cr the function to be wrapped in a new customized analysis function.
#'   `fun` should return a named `list`.
#' @param .stats (`character`)\cr names of elements to keep from `fun`'s full output.
#' @param .formats (`ANY`)\cr vector or list of formats to override any defaults applied by `fun`.
#' @param .labels (`character`)\cr vector of labels to override defaults returned by `fun`.
#' @param .indent_mods (`integer`)\cr named vector of indent modifiers for the generated rows.
#' @param .ungroup_stats (`character`)\cr vector of names, which must match elements of `.stats`.
#' @param ... additional arguments to `fun` which effectively become new defaults. These can still be
#'   overridden by `extra_args` within a split.
#' @param .null_ref_cells (`flag`)\cr whether cells for the reference column should be `NULL`-ed by the
#'   returned analysis function. Defaults to `TRUE` if `fun` accepts `.in_ref_col` as a formal argument. Note
#'   this argument occurs after `...` so it must be *fully* specified by name when set.
#' @param .format_na_strs (`ANY`)\cr vector/list of `NA` strings to override any defaults applied by `fun`.
#'
#' @return A function suitable for use in [analyze()] with element selection, reformatting, and relabeling
#'   performed automatically.
#'
#' @note
#' Setting `.ungroup_stats` to non-`NULL` changes the *structure* of the value(s) returned by `fun`, rather than
#' just labeling (`.labels`), formatting (`.formats`), and selecting amongst (`.stats`) them. This means that
#' subsequent `make_afun` calls to customize the output further both can and must operate on the new structure,
#' *not* the original structure returned by `fun`. See the final pair of examples below.
#'
#' @seealso [analyze()]
#'
#' @examples
#' s_summary <- function(x) {
#'   stopifnot(is.numeric(x))
#'
#'   list(
#'     n = sum(!is.na(x)),
#'     mean_sd = c(mean = mean(x), sd = sd(x)),
#'     min_max = range(x)
#'   )
#' }
#'
#' s_summary(iris$Sepal.Length)
#'
#' a_summary <- make_afun(
#'   fun = s_summary,
#'   .formats = c(n = "xx", mean_sd = "xx.xx (xx.xx)", min_max = "xx.xx - xx.xx"),
#'   .labels = c(n = "n", mean_sd = "Mean (sd)", min_max = "min - max")
#' )
#'
#' a_summary(x = iris$Sepal.Length)
#'
#' a_summary2 <- make_afun(a_summary, .stats = c("n", "mean_sd"))
#'
#' a_summary2(x = iris$Sepal.Length)
#'
#' a_summary3 <- make_afun(a_summary, .formats = c(mean_sd = "(xx.xxx, xx.xxx)"))
#'
#' s_foo <- function(df, .N_col, a = 1, b = 2) {
#'   list(
#'     nrow_df = nrow(df),
#'     .N_col = .N_col,
#'     a = a,
#'     b = b
#'   )
#' }
#'
#' s_foo(iris, 40)
#'
#' a_foo <- make_afun(s_foo,
#'   b = 4,
#'   .formats = c(nrow_df = "xx.xx", ".N_col" = "xx.", a = "xx", b = "xx.x"),
#'   .labels = c(
#'     nrow_df = "Nrow df",
#'     ".N_col" = "n in cols", a = "a value", b = "b value"
#'   ),
#'   .indent_mods = c(nrow_df = 2L, a = 1L)
#' )
#'
#' a_foo(iris, .N_col = 40)
#' a_foo2 <- make_afun(a_foo, .labels = c(nrow_df = "Number of Rows"))
#' a_foo2(iris, .N_col = 40)
#'
#' # grouping and further customization
#' s_grp <- function(df, .N_col, a = 1, b = 2) {
#'   list(
#'     nrow_df = nrow(df),
#'     .N_col = .N_col,
#'     letters = list(
#'       a = a,
#'       b = b
#'     )
#'   )
#' }
#' a_grp <- make_afun(s_grp,
#'   b = 3,
#'   .labels = c(
#'     nrow_df = "row count",
#'     .N_col = "count in column"
#'   ),
#'   .formats = c(nrow_df = "xx.", .N_col = "xx."),
#'   .indent_mods = c(letters = 1L),
#'   .ungroup_stats = "letters"
#' )
#' a_grp(iris, 40)
#' a_aftergrp <- make_afun(a_grp,
#'   .stats = c("nrow_df", "b"),
#'   .formats = c(b = "xx.")
#' )
#' a_aftergrp(iris, 40)
#'
#' s_ref <- function(x, .in_ref_col, .ref_group) {
#'   list(
#'     mean_diff = mean(x) - mean(.ref_group)
#'   )
#' }
#'
#' a_ref <- make_afun(s_ref,
#'   .labels = c(mean_diff = "Mean Difference from Ref")
#' )
#' a_ref(iris$Sepal.Length, .in_ref_col = TRUE, 1:10)
#' a_ref(iris$Sepal.Length, .in_ref_col = FALSE, 1:10)
#'
#' @export
make_afun <- function(fun,
                      .stats = NULL,
                      .formats = NULL,
                      .labels = NULL,
                      .indent_mods = NULL,
                      .ungroup_stats = NULL,
                      .format_na_strs = NULL,
                      ...,
                      .null_ref_cells = ".in_ref_col" %in% names(formals(fun))) {
  ## there is a LOT more computing-on-the-language hackery in here that I
  ## would prefer, but currently this is the way I see to do everything we
  ## want to do.

  ## too clever by three-quarters (because half wasn't enough)
  ## gross scope hackery
  fun_args <- force(list(...))
  fun_fnames <- names(formals(fun))

  ## force EVERYTHING otherwise calling this within loops is the stuff of
  ## nightmares
  force(.stats)
  force(.formats)
  force(.format_na_strs)
  force(.labels)
  force(.indent_mods)
  force(.ungroup_stats)
  force(.null_ref_cells) ## this one probably isn't needed?

  ret <- function(x, ...) { ## remember formals get clobbered here

    ## this helper will grab the value and wrap it in a named list if
    ## we need the variable and return list() otherwise.
    ## We define it in here so that the scoping hackery works correctly
    .if_in_formals <- function(nm, ifnot = list(), named_lwrap = TRUE) {
      val <- if (nm %in% fun_fnames) get(nm) else ifnot
      if (named_lwrap && !identical(val, ifnot)) {
        setNames(list(val), nm)
      } else {
        val
      }
    }

    custargs <- fun_args

    ## special handling cause I need it at the bottom as well
    in_rc_argl <- .if_in_formals(".in_ref_col")
    .in_ref_col <- if (length(in_rc_argl) > 0) in_rc_argl[[1]] else FALSE

    sfunargs <- c(
      ## these are either named lists containing the arg, or list()
      ## depending on whether fun accept the argument or not
      .if_in_formals("x"),
      .if_in_formals("df"),
      .if_in_formals(".N_col"),
      .if_in_formals(".N_total"),
      .if_in_formals(".N_row"),
      .if_in_formals(".ref_group"),
      in_rc_argl,
      .if_in_formals(".df_row"),
      .if_in_formals(".var"),
      .if_in_formals(".ref_full")
    )

    allvars <- setdiff(fun_fnames, c("...", names(sfunargs)))
    ## values int he actual call to this function override customization
    ## done by the constructor. evalparse is to avoid a "... in wrong context" NOTE
    if ("..." %in% fun_fnames) {
      exargs <- eval(parser_helper(text = "list(...)"))
      custargs[names(exargs)] <- exargs
      allvars <- unique(c(allvars, names(custargs)))
    }

    for (var in allvars) {
      ## not missing, i.e. specified in the direct call, takes precedence
      if (var %in% fun_fnames && eval(parser_helper(text = paste0("!missing(", var, ")")))) {
        sfunargs[[var]] <- get(var)
      } else if (var %in% names(custargs)) { ## not specified in the call, but specified in the constructor
        sfunargs[[var]] <- custargs[[var]]
      }
      ## else left out so we hit the original default we inherited from fun
    }

    rawvals <- do.call(fun, sfunargs)

    ## note single brackets here so its a list
    ## no matter what. thats important!
    final_vals <- if (is.null(.stats)) rawvals else rawvals[.stats]

    if (!is.list(rawvals)) {
      stop("make_afun expects a function fun that always returns a list")
    }
    if (!is.null(.stats)) {
      stopifnot(all(.stats %in% names(rawvals)))
    } else {
      .stats <- names(rawvals)
    }
    if (!is.null(.ungroup_stats) && !all(.ungroup_stats %in% .stats)) {
      stop(
        "Stats specified for ungrouping not included in non-null .stats list: ",
        setdiff(.ungroup_stats, .stats)
      )
    }

    .labels <- .validate_nms(final_vals, .stats, .labels)
    .formats <- .validate_nms(final_vals, .stats, .formats)
    .indent_mods <- .validate_nms(final_vals, .stats, .indent_mods)
    .format_na_strs <- .validate_nms(final_vals, .stats, .format_na_strs)

    final_labels <- value_labels(final_vals)
    final_labels[names(.labels)] <- .labels

    final_formats <- lapply(final_vals, obj_format)
    final_formats[names(.formats)] <- .formats

    final_format_na_strs <- lapply(final_vals, obj_na_str)
    final_format_na_strs[names(.format_na_strs)] <- .format_na_strs

    if (is(final_vals, "RowsVerticalSection")) {
      final_imods <- indent_mod(final_vals)
    } else {
      final_imods <- vapply(final_vals, indent_mod, 1L)
    }
    final_imods[names(.indent_mods)] <- .indent_mods

    if (!is.null(.ungroup_stats)) {
      for (nm in .ungroup_stats) {
        tmp <- final_vals[[nm]]
        if (is(tmp, "CellValue")) {
          tmp <- tmp[[1]]
        } ## unwrap it
        final_vals <- insert_replace(final_vals, nm, tmp)
        stopifnot(all(nzchar(names(final_vals))))

        final_labels <- insert_replace(
          final_labels,
          nm,
          setNames(
            value_labels(tmp),
            names(tmp)
          )
        )
        final_formats <- insert_replace(
          final_formats,
          nm,
          setNames(
            rep(final_formats[nm],
              length.out = length(tmp)
            ),
            names(tmp)
          )
        )
        final_format_na_strs <- insert_replace(
          final_format_na_strs,
          nm,
          setNames(
            rep(final_format_na_strs[nm],
              length.out = length(tmp)
            ),
            names(tmp)
          )
        )
        final_imods <- insert_replace(
          final_imods,
          nm,
          setNames(
            rep(final_imods[nm],
              length.out = length(tmp)
            ),
            names(tmp)
          )
        )
      }
    }
    rcells <- mapply(
      function(x, f, l, na_str) {
        if (is(x, "CellValue")) {
          obj_label(x) <- l
          obj_format(x) <- f
          obj_na_str(x) <- na_str
          #                indent_mod(x) <- im
          x
        } else if (.null_ref_cells) {
          non_ref_rcell(x,
            is_ref = .in_ref_col,
            format = f, label = l,
            format_na_str = na_str
          ) # , indent_mod = im)
        } else {
          rcell(x, format = f, label = l, format_na_str = na_str) # , indent_mod = im)
        }
      },
      f = final_formats, x = final_vals,
      l = final_labels,
      na_str = final_format_na_strs,
      #        im = final_imods,
      SIMPLIFY = FALSE
    )
    in_rows(.list = rcells, .indent_mods = final_imods) ## , .labels = .labels)
  }
  formals(ret) <- formals(fun)
  ret
}

insert_replace <- function(x, nm, newvals = x[[nm]]) {
  i <- match(nm, names(x))
  if (is.na(i)) {
    stop("name not found")
  }
  bef <- if (i > 1) 1:(i - 1) else numeric()
  aft <- if (i < length(x)) (i + 1):length(x) else numeric()
  ret <- c(x[bef], newvals, x[aft])
  names(ret) <- c(names(x)[bef], names(newvals), names(x)[aft])
  ret
}

parser_helper <- function(text, envir = parent.frame(2)) {
  parse(text = text, keep.source = FALSE)
}

length_w_name <- function(x, .parent_splval) {
  in_rows(length(x),
    .names = value_labels(.parent_splval)
  )
}

#' @importFrom utils browseURL
NULL

#' Display an `rtable` object in the Viewer pane in RStudio or in a browser
#'
#' The table will be displayed using bootstrap styling.
#'
#' @param x (`rtable` or `shiny.tag`)\cr an object of class `rtable` or `shiny.tag` (defined in `htmltools` package).
#' @param y (`rtable` or `shiny.tag`)\cr optional second argument of same type as `x`.
#' @param ... arguments passed to [as_html()].
#'
#' @return Not meaningful. Called for the side effect of opening a browser or viewer pane.
#'
#' @examples
#' if (interactive()) {
#'   sl5 <- factor(iris$Sepal.Length > 5,
#'     levels = c(TRUE, FALSE),
#'     labels = c("S.L > 5", "S.L <= 5")
#'   )
#'
#'   df <- cbind(iris, sl5 = sl5)
#'
#'   lyt <- basic_table() %>%
#'     split_cols_by("sl5") %>%
#'     analyze("Sepal.Length")
#'
#'   tbl <- build_table(lyt, df)
#'
#'   Viewer(tbl)
#'   Viewer(tbl, tbl)
#'
#'
#'   tbl2 <- htmltools::tags$div(
#'     class = "table-responsive",
#'     as_html(tbl, class_table = "table")
#'   )
#'
#'   Viewer(tbl, tbl2)
#' }
#' @export
Viewer <- function(x, y = NULL, ...) {
  check_convert <- function(x, name, accept_NULL = FALSE) {
    if (accept_NULL && is.null(x)) {
      NULL
    } else if (is(x, "shiny.tag")) {
      x
    } else if (is(x, "VTableTree")) {
      as_html(x, ...)
    } else {
      stop("object of class rtable or shiny tag excepted for ", name)
    }
  }

  x_tag <- check_convert(x, "x", FALSE)
  y_tag <- check_convert(y, "y", TRUE)

  html_output <- if (is.null(y)) {
    x_tag
  } else {
    tags$div(class = "container-fluid", htmltools::tags$div(
      class = "row",
      tags$div(class = "col-xs-6", x_tag),
      tags$div(class = "col-xs-6", y_tag)
    ))
  }

  sandbox_folder <- file.path(tempdir(), "rtable")

  if (!dir.exists(sandbox_folder)) {
    dir.create(sandbox_folder, recursive = TRUE)
    pbs <- file.path(path.package(package = "rtables"), "bootstrap/")
    file.copy(list.files(pbs, full.names = TRUE, recursive = FALSE), sandbox_folder, recursive = TRUE)
    # list.files(sandbox_folder)
  }

  # get html name
  n_try <- 10000
  for (i in seq_len(n_try)) {
    htmlFile <- file.path(sandbox_folder, paste0("table", i, ".html"))

    if (!file.exists(htmlFile)) {
      break
    } else if (i == n_try) {
      stop("too many html rtables created, restart your session")
    }
  }

  html_bs <- tags$html(
    lang = "en",
    tags$head(
      tags$meta(charset = "utf-8"),
      tags$meta("http-equiv" = "X-UA-Compatible", content = "IE=edge"),
      tags$meta(
        name = "viewport",
        content = "width=device-width, initial-scale=1"
      ),
      tags$title("rtable"),
      tags$link(
        href = "css/bootstrap.min.css",
        rel = "stylesheet"
      )
    ),
    tags$body(
      html_output
    )
  )

  cat(
    paste("<!DOCTYPE html>\n", htmltools::doRenderTags(html_bs)),
    file = htmlFile, append = FALSE
  )

  viewer <- getOption("viewer")

  if (!is.null(viewer)) {
    viewer(htmlFile)
  } else {
    browseURL(htmlFile)
  }
}

## NB handling the case where there are no values is done during tabulation
## which is the only reason expression(TRUE) is ok, because otherwise
## we (sometimes) run into
## factor()[TRUE] giving <NA> (i.e. length 1)

#' Make subset expression for a split-value pair
#'
#' @param spl `(Split)`\cr A split object.
#' @param val `(SplitValue or string)`\cr The value, either as a
#'     `SplitValue` object or the raw value as a string.
#'
#' @details
#'
#' If `val` is a `SplitValue` object which already contains a
#' subsetting expression with length `>0`, that is immediately
#' returned. Otherwise, the appropriate subsetting expression is
#' constructed based on the split type of `spl` and the value `val`.
#'
#' @note this is occasionally useful when constructing custom
#'     splitting behavior which may used for column splitting but
#'     generally should not be called directly by the end user.
#'
#' @return A subseting expression to be used to restrict data to a
#'     particular column during tabulation.
#'
#' @examples
#'
#' spl <- VarLevelSplit("ARM", split_label = "ARM")
#' make_subset_expr(spl, "B: Placebo")
#' @export

setGeneric("make_subset_expr", function(spl, val) standardGeneric("make_subset_expr"))

#' @rdname make_subset_expr
setMethod(
  "make_subset_expr", "VarLevelSplit",
  function(spl, val) {
    ## this is how custom split functions will communicate the correct expression
    ## to the column modeling code
    if (length(value_expr(val)) > 0) {
      return(value_expr(val))
    }

    v <- unlist(rawvalues(val))
    ## XXX if we're including all levels should even missing be included?
    if (is(v, "AllLevelsSentinel")) {
      as.expression(bquote((!is.na(.(a))), list(a = as.name(spl_payload(spl)))))
    } else {
      as.expression(bquote((!is.na(.(a)) & .(a) %in% .(b)), list(
        a = as.name(spl_payload(spl)),
        b = v
      )))
    }
  }
)

#' @rdname make_subset_expr
setMethod(
  "make_subset_expr", "MultiVarSplit",
  function(spl, val) {
    ## this is how custom split functions will communicate the correct expression
    ## to the column modeling code
    if (length(value_expr(val)) > 0) {
      return(value_expr(val))
    }

    ## v = rawvalues(val)
    ## as.expression(bquote(!is.na(.(a)), list(a = v)))
    expression(TRUE)
  }
)

#' @rdname make_subset_expr
setMethod(
  "make_subset_expr", "AnalyzeVarSplit",
  function(spl, val) {
    if (avar_inclNAs(spl)) {
      expression(TRUE)
    } else {
      as.expression(bquote(
        !is.na(.(a)),
        list(a = as.name(spl_payload(spl)))
      ))
    }
  }
)

#' @rdname make_subset_expr
setMethod(
  "make_subset_expr", "AnalyzeColVarSplit",
  function(spl, val) {
    expression(TRUE)
  }
)

## XXX these are going to be ridiculously slow
## FIXME

#' @rdname make_subset_expr
setMethod(
  "make_subset_expr", "VarStaticCutSplit",
  function(spl, val) {
    v <- rawvalues(val)
    ##    as.expression(bquote(which(cut(.(a), breaks=.(brk), labels = .(labels),
    as.expression(bquote(
      cut(.(a),
        breaks = .(brk), labels = .(labels),
        include.lowest = TRUE
      ) == .(b),
      list(
        a = as.name(spl_payload(spl)),
        b = v,
        brk = spl_cuts(spl),
        labels = spl_cutlabels(spl)
      )
    ))
  }
)

## NB this assumes spl_cutlabels(spl) is in order!!!!!!
#' @rdname make_subset_expr
setMethod(
  "make_subset_expr", "CumulativeCutSplit",
  function(spl, val) {
    v <- rawvalues(val)
    ## as.expression(bquote(which(as.integer(cut(.(a), breaks=.(brk),
    as.expression(bquote(
      as.integer(cut(.(a),
        breaks = .(brk),
        labels = .(labels),
        include.lowest = TRUE
      )) <=
        as.integer(factor(.(b), levels = .(labels))),
      list(
        a = as.name(spl_payload(spl)),
        b = v,
        brk = spl_cuts(spl),
        labels = spl_cutlabels(spl)
      )
    ))
  }
)

## I think this one is unnecessary,
## build_table collapses DynCutSplits into
## static ones.
##
## XXX TODO fixme
## setMethod("make_subset_expr", "VarDynCutSplit",
##           function(spl, val) {
##     v = rawvalues(val)
##     ##   as.expression(bquote(which(.(fun)(.(a)) == .(b)),
##     as.expression(bquote(.(fun)(.(a)) == .(b)),
##                   list(a = as.name(spl_payload(spl)),
##                        b = v,
##                        fun = spl@cut_fun))
## })

#' @rdname make_subset_expr
setMethod(
  "make_subset_expr", "AllSplit",
  function(spl, val) expression(TRUE)
)

## probably don't need this
#' @rdname make_subset_expr
setMethod(
  "make_subset_expr", "expression",
  function(spl, val) spl
)

#' @rdname make_subset_expr
setMethod(
  "make_subset_expr", "character",
  function(spl, val) {
    newspl <- VarLevelSplit(spl, spl)
    make_subset_expr(newspl, val)
  }
)

.combine_subset_exprs <- function(ex1, ex2) {
  if (is.null(ex1) || identical(ex1, expression(TRUE))) {
    if (is.expression(ex2) && !identical(ex2, expression(TRUE))) {
      return(ex2)
    } else {
      return(expression(TRUE))
    }
  }

  ## if(is.null(ex2))
  ##     ex2 <- expression(TRUE)
  stopifnot(is.expression(ex1), is.expression(ex2))
  as.expression(bquote((.(a)) & .(b), list(a = ex1[[1]], b = ex2[[1]])))
}

make_pos_subset <- function(spls = pos_splits(pos),
                            svals = pos_splvals(pos),
                            pos) {
  expr <- NULL
  for (i in seq_along(spls)) {
    newexpr <- make_subset_expr(spls[[i]], svals[[i]])
    expr <- .combine_subset_exprs(expr, newexpr)
  }
  expr
}

get_pos_extra <- function(svals = pos_splvals(pos),
                          pos) {
  ret <- list()
  for (i in seq_along(svals)) {
    extrs <- splv_extra(svals[[i]])
    if (any(names(ret) %in% names(extrs))) {
      stop("same extra argument specified at multiple levels of nesting. Not currently supported")
    }
    ret <- c(ret, extrs)
  }
  ret
}

get_col_extras <- function(ctree) {
  leaves <- collect_leaves(ctree)
  lapply(
    leaves,
    function(x) get_pos_extra(pos = tree_pos(x))
  )
}

setGeneric(
  "make_col_subsets",
  function(lyt, df) standardGeneric("make_col_subsets")
)

setMethod(
  "make_col_subsets", "LayoutColTree",
  function(lyt, df) {
    leaves <- collect_leaves(lyt)
    lapply(leaves, make_col_subsets)
  }
)

setMethod(
  "make_col_subsets", "LayoutColLeaf",
  function(lyt, df) {
    make_pos_subset(pos = tree_pos(lyt))
  }
)

create_colinfo <- function(lyt, df, rtpos = TreePos(),
                           counts = NULL,
                           alt_counts_df = NULL,
                           total = NULL,
                           topleft = NULL) {
  ## this will work whether clayout is pre or post
  ## data
  clayout <- clayout(lyt)
  if (is.null(topleft)) {
    topleft <- top_left(lyt)
  }
  cc_format <- colcount_format(lyt) %||% "(N=xx)"

  ## do it this way for full backwards compatibility
  if (is.null(alt_counts_df)) {
    alt_counts_df <- df
  }
  ctree <- coltree(clayout, df = df, rtpos = rtpos, alt_counts_df = alt_counts_df, ccount_format = cc_format)
  if (!is.na(disp_ccounts(lyt))) {
    leaf_pths <- make_col_df(ctree, visible_only = TRUE, na_str = "", ccount_format = cc_format)$path
    for (path in leaf_pths) {
      colcount_visible(ctree, path) <- disp_ccounts(lyt)
    }
  }

  cexprs <- make_col_subsets(ctree, df)
  colextras <- col_extra_args(ctree)

  ## calculate the counts based on the df
  ## This presumes that it is called on the WHOLE dataset,
  ## NOT after any splitting has occurred. Otherwise
  ## the counts will obviously be wrong.
  if (is.null(counts)) {
    counts <- rep(NA_integer_, length(cexprs))
  } else if (length(counts) != length(cexprs)) {
    stop(
      "Length of overriding counts must equal number of columns. Got ",
      length(counts), " values for ", length(cexprs), " columns. ",
      "Use NAs to specify that the default counting machinery should be ",
      "used for that position."
    )
  }

  counts_df_name <- "alt_counts_df"
  if (identical(alt_counts_df, df)) { # is.null(alt_counts_df)) {
    alt_counts_df <- df
    counts_df_name <- "df"
  }
  calcpos <- is.na(counts)

  calccounts <- sapply(cexprs, function(ex) {
    if (identical(ex, expression(TRUE))) {
      nrow(alt_counts_df)
    } else if (identical(ex, expression(FALSE))) {
      0L
    } else {
      vec <- try(eval(ex, envir = alt_counts_df), silent = TRUE)
      if (is(vec, "numeric")) {
        length(vec)
      } else if (is(vec, "logical")) { ## sum(is.na(.)) ????
        sum(vec, na.rm = TRUE)
      }
    }
  })
  counts[calcpos] <- calccounts[calcpos]
  counts <- as.integer(counts)
  if (is.null(total)) {
    total <- sum(counts)
  }

  cpths <- col_paths(ctree)
  for (i in seq_along(cpths)) {
    facet_colcount(ctree, cpths[[i]]) <- counts[i]
  }
  InstantiatedColumnInfo(
    treelyt = ctree,
    csubs = cexprs,
    extras = colextras,
    cnts = counts,
    dispcounts = disp_ccounts(lyt),
    countformat = cc_format,
    total_cnt = total,
    topleft = topleft
  )
}

## Rules for pagination
##
## 1. user defined number of lines per page
## 2. all lines have the same height
## 3. header always reprinted on all pages
## 4. "Label-rows", i.e. content rows above break in the nesting structure, optionally reprinted (default TRUE)
## 5. Never (?) break on a "label"/content row
## 6. Never (?) break on the second (i.e. after the first) data row at a particular leaf Elementary table.
##
## Current behavior: paginate_ttree takes a TableTree object and
## returns a list of rtable (S3) objects for printing.

#' @inheritParams formatters::nlines
#'
#' @rdname formatters_methods
#' @aliases nlines,TableRow-method
#' @exportMethod nlines
setMethod(
  "nlines", "TableRow",
  function(x, colwidths, max_width, fontspec, col_gap = 3) {
    fns <- sum(unlist(lapply(row_footnotes(x), nlines, max_width = max_width, fontspec = fontspec))) +
      sum(unlist(lapply(cell_footnotes(x), nlines, max_width = max_width, fontspec = fontspec)))
    fcells <- as.vector(get_formatted_cells(x))
    spans <- row_cspans(x)
    have_cw <- !is.null(colwidths)
    ## handle spanning so that the projected word-wrapping from nlines is correct
    if (any(spans > 1)) {
      new_fcells <- character(length(spans))
      new_colwidths <- numeric(length(spans))
      cur_fcells <- fcells
      cur_colwidths <- colwidths[-1] ## not the row labels they can't span
      for (i in seq_along(spans)) {
        spi <- spans[i]
        new_fcells[i] <- cur_fcells[1] ## 1 cause we're trimming it every loop
        new_colwidths[i] <- sum(head(cur_colwidths, spi)) + col_gap * (spi - 1)
        cur_fcells <- tail(cur_fcells, -1 * spi)
        cur_colwidths <- tail(cur_colwidths, -1 * spi)
      }
      if (have_cw) {
        colwidths <- c(colwidths[1], new_colwidths)
      }
      fcells <- new_fcells
    }

    ## rowext <- max(vapply(strsplit(c(obj_label(x), fcells), "\n", fixed = TRUE),
    ##                      length,
    ##                      1L))
    rowext <- max(
      unlist(
        mapply(
          function(s, w) {
            nlines(strsplit(s, "\n", fixed = TRUE), max_width = w, fontspec = fontspec)
          },
          s = c(obj_label(x), fcells),
          w = (colwidths %||% max_width) %||% vector("list", length(c(obj_label(x), fcells))),
          SIMPLIFY = FALSE
        )
      )
    )

    rowext + fns
  }
)

#' @export
#' @rdname formatters_methods
setMethod(
  "nlines", "LabelRow",
  function(x, colwidths, max_width, fontspec = fontspec, col_gap = NULL) {
    if (labelrow_visible(x)) {
      nlines(strsplit(obj_label(x), "\n", fixed = TRUE)[[1]], max_width = colwidths[1], fontspec = fontspec) +
        sum(unlist(lapply(row_footnotes(x), nlines, max_width = max_width, fontspec = fontspec)))
    } else {
      0L
    }
  }
)

#' @export
#' @rdname formatters_methods
setMethod(
  "nlines", "RefFootnote",
  function(x, colwidths, max_width, fontspec, col_gap = NULL) {
    nlines(format_fnote_note(x), colwidths = colwidths, max_width = max_width, fontspec = fontspec)
  }
)

#' @export
#' @rdname formatters_methods
setMethod(
  "nlines", "InstantiatedColumnInfo",
  function(x, colwidths, max_width, fontspec, col_gap = 3) {
    h_rows <- .do_tbl_h_piece2(x)
    tl <- top_left(x) %||% rep("", length(h_rows))
    main_nls <- vapply(
      seq_along(h_rows),
      function(i) {
        max(
          nlines(h_rows[[i]],
            colwidths = colwidths,
            fontspec = fontspec,
            col_gap = col_gap
          ),
          nlines(tl[i],
            colwidths = colwidths[1],
            fontspec = fontspec
          )
        )
      },
      1L
    )

    ## lfs <- collect_leaves(coltree(x))
    ## depths <- sapply(lfs, function(l) length(pos_splits(l)))

    coldf <- make_col_df(x, colwidths = colwidths)
    have_fnotes <- length(unlist(coldf$col_fnotes)) > 0
    ## ret <- max(depths, length(top_left(x))) +
    ##     divider_height(x)
    ret <- sum(main_nls, divider_height(x))
    if (have_fnotes) {
      ret <- sum(
        ret,
        vapply(unlist(coldf$col_fnotes),
          nlines,
          1,
          max_width = max_width,
          fontspec = fontspec
        ),
        2 * divider_height(x)
      )
    }
    ret
  }
)

col_dfrow <- function(col,
                      nm = obj_name(col),
                      lab = obj_label(col),
                      cnum,
                      pth = NULL,
                      sibpos = NA_integer_,
                      nsibs = NA_integer_,
                      leaf_indices = cnum,
                      span = length(leaf_indices),
                      col_fnotes = list(),
                      col_count = facet_colcount(col, NULL),
                      ccount_visible = disp_ccounts(col),
                      ccount_format = colcount_format(col),
                      ccount_na_str,
                      global_cc_format) {
  if (is.null(pth)) {
    pth <- pos_to_path(tree_pos(col))
  }
  data.frame(
    stringsAsFactors = FALSE,
    name = nm,
    label = lab,
    abs_pos = cnum,
    path = I(list(pth)),
    pos_in_siblings = sibpos,
    n_siblings = nsibs,
    leaf_indices = I(list(leaf_indices)),
    total_span = span,
    col_fnotes = I(list(col_fnotes)),
    n_col_fnotes = length(col_fnotes),
    col_count = col_count,
    ccount_visible = ccount_visible,
    ccount_format = ccount_format %||% global_cc_format,
    ccount_na_str = ccount_na_str
  )
}

pos_to_path <- function(pos) {
  spls <- pos_splits(pos)
  vals <- pos_splvals(pos)

  path <- character()
  for (i in seq_along(spls)) {
    nm <- obj_name(spls[[i]])
    val_i <- value_names(vals[[i]])
    path <- c(
      path,
      obj_name(spls[[i]]),
      ## rawvalues(vals[[i]]))
      if (!is.na(val_i)) val_i
    )
  }
  path
}


add_sect_div_path <- function(df, path) {
  df[["sect_div_from_path"]] <- I(list(path))
  df
}

# make_row_df ---------------------------------------------------------------

## We now extend the rowdf beyond what is (currently as of writing) defined in
## formatters with the following columns to support section divider shenanigans:
## - self_section_div - the section divider set on that exact object (row, or table if visible_only=FALSE)
## - sect_div_from_path - the path to the element `trailing_section_div` was
## inherited from (or NA_character_ for label rows which aren't pathable and
## can only receive section divs from themselves).
## This should probably be migrated down into formatters for the next release but
## its fine here for the rtables patch release because nothing in formatters
## (ie printing or pagination) needs or uses this new info.
## TODO: migrate above down to formatters

#' @inherit formatters::make_row_df
#'
# #' @note The technically present root tree node is excluded from the summary returned by both `make_row_df` and
# #'   `make_col_df`, as it is simply the row/column structure of `tt` and thus not useful for pathing or pagination.
# #'
# #' @return a data.frame of row/column-structure information used by the pagination machinery.
# #'
# #' @export
# #' @name make_row_df
# #' @rdname make_row_df
# #' @aliases make_row_df,VTableTree-method
#' @rdname formatters_methods
#' @exportMethod make_row_df
setMethod(
  "make_row_df", "VTableTree",
  function(tt,
           colwidths = NULL,
           visible_only = TRUE,
           rownum = 0,
           indent = 0L,
           path = character(),
           incontent = FALSE,
           repr_ext = 0L,
           repr_inds = integer(),
           sibpos = NA_integer_,
           nsibs = NA_integer_,
           max_width = NULL,
           fontspec = NULL,
           col_gap = 3) {
    new_dev <- open_font_dev(fontspec)
    if (new_dev) {
      on.exit(close_font_dev())
    }

    indent <- indent + indent_mod(tt)
    ## retained for debugging info
    orig_rownum <- rownum # nolint
    if (incontent) {
      path <- c(path, "@content")
    } else if (length(path) > 0 || nzchar(obj_name(tt))) { ## don't add "" for root
      ## else if (length(path) > 0 && nzchar(obj_name(tt))) ## don't add "" for root # nolint
      path <- c(path, obj_name(tt))
    }
    ret <- list()

    ## note this is the **table** not the label row
    if (!visible_only) {
      tabrdf <- pagdfrow(
        rnum = NA,
        nm = obj_name(tt),
        lab = "",
        pth = path,
        colwidths = colwidths,
        repext = repr_ext,
        repind = list(repr_inds),
        extent = 0,
        indent = indent,
        rclass = class(tt), sibpos = sibpos,
        nsibs = nsibs,
        nrowrefs = 0L,
        ncellrefs = 0L,
        nreflines = 0L,
        fontspec = fontspec,
        trailing_sep = trailing_section_div(tt)
      )
      tabrdf <- add_sect_div_path(tabrdf, path)
      tabrdf$self_section_div <- trailing_section_div(tt)
      ret <- c(
        ret,
        list(tabrdf)
      )
    }
    if (labelrow_visible(tt)) {
      lr <- tt_labelrow(tt)
      newdf <- make_row_df(lr,
        colwidths = colwidths,
        visible_only = visible_only,
        rownum = rownum,
        indent = indent,
        path = path,
        incontent = TRUE,
        repr_ext = repr_ext,
        repr_inds = repr_inds,
        max_width = max_width,
        fontspec = fontspec
      )
      rownum <- max(newdf$abs_rownumber, na.rm = TRUE)
      # newdf <- add_sect_div_path(newdf, NA_character_) ## label rows aren't pathable...

      ret <- c(
        ret,
        list(newdf)
      )
      repr_ext <- repr_ext + 1L
      repr_inds <- c(repr_inds, rownum)
      indent <- indent + 1L
    }

    if (NROW(content_table(tt)) > 0) {
      ct_tt <- content_table(tt)
      cind <- indent + indent_mod(ct_tt)
      ## this isn't right, we can display content and label rows at the
      ## same time (though by default we don't) and they could, in theory
      ## have different trailing section divs...
      ## trailing_section_div(ct_tt) <- trailing_section_div(tt_labelrow(tt))
      contdf <- make_row_df(ct_tt,
        colwidths = colwidths,
        visible_only = visible_only,
        rownum = rownum,
        indent = cind,
        path = path,
        incontent = TRUE,
        repr_ext = repr_ext,
        repr_inds = repr_inds,
        max_width = max_width,
        fontspec = fontspec
      )
      crnums <- contdf$abs_rownumber
      crnums <- crnums[!is.na(crnums)]

      newrownum <- max(crnums, na.rm = TRUE)
      if (is.finite(newrownum)) {
        rownum <- newrownum
        repr_ext <- repr_ext + length(crnums)
        repr_inds <- c(repr_inds, crnums)
      }
      ## if someone attached a trailing separator to a content table somehow
      ## weird but not /technically/ impossible, it overrides its last row's div,
      ## as always
      if (!is.na(trailing_section_div(ct_tt))) {
        contdf$trailing_section_div[nrow(contdf)] <- trailing_section_div(ct_tt)
        contdf$sect_div_from_path[[nrow(contdf)]] <- c(path, "@content")
      }
      ret <- c(ret, list(contdf))
      indent <- cind + 1
    }

    allkids <- tree_children(tt)
    newnsibs <- length(allkids)
    for (i in seq_along(allkids)) {
      kid <- allkids[[i]]
      kiddfs <- make_row_df(kid,
        colwidths = colwidths,
        visible_only = visible_only,
        rownum = force(rownum),
        indent = indent, ## + 1,
        path = path,
        incontent = incontent,
        repr_ext = repr_ext,
        repr_inds = repr_inds,
        nsibs = newnsibs,
        sibpos = i,
        max_width = max_width,
        fontspec = fontspec
      )

      #       print(kiddfs$abs_rownumber)
      rownum <- max(rownum + 1L, kiddfs$abs_rownumber, na.rm = TRUE)
      ret <- c(ret, list(kiddfs))
    }

    ret <- do.call(rbind, ret)

    ## Case where it has Elementary table or VTableTree section_div it is overridden
    ## precedence is least specific -> most specific, so the last row of any
    ## subtable is overridden by the subtable's div, we are calling make_row_df
    ## recursively so this achieves that even when levels of structure are skipped
    ## e.g. grandparent has a section div but section div doesn't (we now have
    ## a test for this)
    if (!is.na(trailing_section_div(tt))) {
      ret$trailing_sep[nrow(ret)] <- trailing_section_div(tt)
      ret$sect_div_from_path[[nrow(ret)]] <- path
    }
    ret
  }
)

# #' @exportMethod make_row_df
#' @inherit formatters::make_row_df
#'
#' @export
#' @rdname formatters_methods
setMethod(
  "make_row_df", "TableRow",
  function(tt, colwidths = NULL, visible_only = TRUE,
           rownum = 0,
           indent = 0L,
           path = "root",
           incontent = FALSE,
           repr_ext = 0L,
           repr_inds = integer(),
           sibpos = NA_integer_,
           nsibs = NA_integer_,
           max_width = NULL,
           fontspec,
           col_gap = 3) {
    indent <- indent + indent_mod(tt)
    rownum <- rownum + 1
    rrefs <- row_footnotes(tt)
    crefs <- cell_footnotes(tt)
    reflines <- sum(
      sapply(
        c(rrefs, crefs),
        nlines,
        colwidths = colwidths,
        max_width = max_width,
        fontspec = fontspec,
        col_gap = col_gap
      )
    ) ## col_gap not strictly necessary as these aren't rows, but why not
    self_path <- c(path, unname(obj_name(tt)))
    ret <- pagdfrow(
      row = tt,
      rnum = rownum,
      colwidths = colwidths,
      sibpos = sibpos,
      nsibs = nsibs,
      pth = self_path,
      repext = repr_ext,
      repind = repr_inds,
      indent = indent,
      extent = nlines(tt, colwidths = colwidths, max_width = max_width, fontspec = fontspec, col_gap = col_gap),
      ## these two are unlist calls cause they come in lists even with no footnotes
      nrowrefs = length(rrefs),
      ncellrefs = length(unlist(crefs)),
      nreflines = reflines,
      trailing_sep = trailing_section_div(tt),
      fontspec = fontspec
    )
    ret <- add_sect_div_path(ret, self_path)
    ret$self_section_div <- trailing_section_div(tt)
    ret
  }
)

# #' @exportMethod make_row_df
#' @export
#' @rdname formatters_methods
setMethod(
  "make_row_df", "LabelRow",
  function(tt, colwidths = NULL, visible_only = TRUE,
           rownum = 0,
           indent = 0L,
           path = "root",
           incontent = FALSE,
           repr_ext = 0L,
           repr_inds = integer(),
           sibpos = NA_integer_,
           nsibs = NA_integer_,
           max_width = NULL,
           fontspec,
           col_gap = 3) {
    rownum <- rownum + 1
    indent <- indent + indent_mod(tt)
    ret <- pagdfrow(tt,
      extent = nlines(tt,
        colwidths = colwidths,
        max_width = max_width,
        fontspec = fontspec,
        col_gap = col_gap
      ),
      rnum = rownum,
      colwidths = colwidths,
      sibpos = sibpos,
      nsibs = nsibs,
      pth = path,
      repext = repr_ext,
      repind = repr_inds,
      indent = indent,
      nrowrefs = length(row_footnotes(tt)),
      ncellrefs = 0L,
      nreflines = sum(vapply(row_footnotes(tt), nlines, NA_integer_,
        colwidths = colwidths,
        max_width = max_width,
        fontspec = fontspec,
        col_gap = col_gap
      )),
      trailing_sep = trailing_section_div(tt),
      fontspec = fontspec
    )
    ret <- add_sect_div_path(ret, NA_character_)
    ret$self_section_div <- trailing_section_div(tt)
    if (!labelrow_visible(tt)) {
      ret <- ret[0, , drop = FALSE]
    }
    ret
  }
)

setGeneric("inner_col_df", function(ct,
                                    colwidths = NULL,
                                    visible_only = TRUE,
                                    colnum = 0L,
                                    sibpos = NA_integer_,
                                    nsibs = NA_integer_,
                                    ncolref = 0L,
                                    na_str,
                                    global_cc_format) {
  standardGeneric("inner_col_df")
})

#' Column layout summary
#'
#' Used for pagination. Generate a structural summary of the columns of an `rtables` table and return it as a
#' `data.frame`.
#'
#' @inheritParams formatters::make_row_df
#' @param ccount_format (`FormatSpec`)\cr The format to be used by default for
#'   column counts if one is not specified for an individual column count.
#' @param na_str (`character(1)`)\cr The string to display when a column count is NA. Users should not need to set this.
#' @export
make_col_df <- function(tt,
                        colwidths = NULL,
                        visible_only = TRUE,
                        na_str = "",
                        ccount_format = colcount_format(tt) %||% "(N=xx)") {
  ctree <- coltree(tt, ccount_format = colcount_format(tt)) ## this is a null op if its already a coltree object
  rows <- inner_col_df(ctree,
    ## colwidths is currently unused anyway...  propose_column_widths(matrix_form(tt, indent_rownames=TRUE)),
    colwidths = colwidths,
    visible_only = visible_only,
    colnum = 1L,
    sibpos = 1L,
    nsibs = 1L,
    na_str = na_str,
    global_cc_format = ccount_format
  ) ## nsiblings includes current so 1 means "only child"

  do.call(rbind, rows)
}

setMethod(
  "inner_col_df", "LayoutColLeaf",
  function(ct, colwidths, visible_only,
           colnum,
           sibpos,
           nsibs,
           na_str,
           global_cc_format) {
    list(col_dfrow(
      col = ct,
      cnum = colnum,
      sibpos = sibpos,
      nsibs = nsibs,
      leaf_indices = colnum,
      col_fnotes = col_footnotes(ct),
      ccount_na_str = na_str,
      global_cc_format = global_cc_format
    ))
  }
)

setMethod(
  "inner_col_df", "LayoutColTree",
  function(ct, colwidths, visible_only,
           colnum,
           sibpos,
           nsibs,
           na_str,
           global_cc_format) {
    kids <- tree_children(ct)
    ret <- vector("list", length(kids))
    for (i in seq_along(kids)) {
      k <- kids[[i]]
      newrows <- do.call(
        rbind,
        inner_col_df(k,
          colnum = colnum,
          sibpos = i,
          nsibs = length(kids),
          visible_only = visible_only,
          na_str = na_str,
          global_cc_format = global_cc_format
        )
      )
      colnum <- max(newrows$abs_pos, colnum, na.rm = TRUE) + 1
      ret[[i]] <- newrows
    }

    if (!visible_only) {
      allindices <- unlist(lapply(ret, function(df) df$abs_pos[!is.na(df$abs_pos)]))
      thispth <- pos_to_path(tree_pos(ct))
      if (any(nzchar(thispth))) {
        thisone <- list(col_dfrow(
          col = ct,
          cnum = NA_integer_,
          leaf_indices = allindices,
          sibpos = sibpos,
          nsibs = nsibs,
          pth = thispth,
          col_fnotes = col_footnotes(ct),
          ccount_na_str = na_str,
          global_cc_format = global_cc_format
        ))
        ret <- c(thisone, ret)
      }
    }

    ret
  }
)

## THIS INCLUDES BOTH "table stub" (i.e. column label and top_left) AND
## title/subtitle!!!!!
.header_rep_nlines <- function(tt, colwidths, max_width, fontspec, verbose = FALSE) {
  cinfo_lines <- nlines(col_info(tt), colwidths = colwidths, max_width = max_width, fontspec = fontspec)
  if (any(nzchar(all_titles(tt)))) {
    ## +1 is for blank line between subtitles and divider
    tlines <- sum(nlines(all_titles(tt),
      colwidths = colwidths,
      max_width = max_width,
      fontspec = fontspec
    )) + divider_height(tt) + 1L
  } else {
    tlines <- 0
  }
  ret <- cinfo_lines + tlines
  if (verbose) {
    message(
      "Lines required for header content: ",
      ret, " (col info: ", cinfo_lines, ", titles: ", tlines, ")"
    )
  }
  ret
}

## this is ***only*** lines that are expected to be repeated on  multiple pages:
## main footer, prov footer, and referential footnotes on **columns**

.footer_rep_nlines <- function(tt, colwidths, max_width, have_cfnotes, fontspec, verbose = FALSE) {
  flines <- nlines(main_footer(tt),
    colwidths = colwidths,
    max_width = max_width - table_inset(tt),
    fontspec = fontspec
  ) +
    nlines(prov_footer(tt), colwidths = colwidths, max_width = max_width, fontspec = fontspec)
  if (flines > 0) {
    dl_contrib <- if (have_cfnotes) 0 else divider_height(tt)
    flines <- flines + dl_contrib + 1L
  }

  if (verbose) {
    message(
      "Determining lines required for footer content",
      if (have_cfnotes) " [column fnotes present]",
      ": ", flines, " lines"
    )
  }

  flines
}

# Pagination ---------------------------------------------------------------

#' Pagination of a `TableTree`
#'
#' Paginate an `rtables` table in the vertical and/or horizontal direction, as required for the specified page size.
#'
#' @inheritParams gen_args
#' @inheritParams paginate_table
#' @param lpp (`numeric(1)`)\cr maximum lines per page including (re)printed header and context rows.
#' @param min_siblings (`numeric(1)`)\cr minimum sibling rows which must appear on either side of pagination row for a
#'   mid-subtable split to be valid. Defaults to 2.
#' @param nosplitin (`character`)\cr names of sub-tables where page-breaks are not allowed, regardless of other
#'   considerations. Defaults to none.
#'
#' @return
#' * `pag_tt_indices` returns a list of paginated-groups of row-indices of `tt`.
#' * `paginate_table` returns the subtables defined by subsetting by the indices defined by `pag_tt_indices`.
#'
#' @details
#' `rtables` pagination is context aware, meaning that label rows and row-group summaries (content rows) are repeated
#' after (vertical) pagination, as appropriate. This allows the reader to immediately understand where they are in the
#' table after turning to a new page, but does also mean that a rendered, paginated table will take up more lines of
#' text than rendering the table without pagination would.
#'
#' Pagination also takes into account word-wrapping of title, footer, column-label, and formatted cell value content.
#'
#' Vertical pagination information (pagination `data.frame`) is created using (`make_row_df`).
#'
#' Horizontal pagination is performed by creating a pagination data frame for the columns, and then applying the same
#' algorithm used for vertical pagination to it.
#'
#' If physical page size and font information are specified, these are used to derive lines-per-page (`lpp`) and
#' characters-per-page (`cpp`) values.
#'
#' The full multi-direction pagination algorithm then is as follows:
#'
#' 0. Adjust `lpp` and `cpp` to account for rendered elements that are not rows (columns):
#'   - titles/footers/column labels, and horizontal dividers in the vertical pagination case
#'   - row-labels, table_inset, and top-left materials in the horizontal case
#' 1. Perform 'forced pagination' representing page-by row splits, generating 1 or more tables.
#' 2. Perform vertical pagination separately on each table generated in (1).
#' 3. Perform horizontal pagination **on the entire table** and apply the results to each table
#'    page generated in (1)-(2).
#' 4. Return a list of subtables representing full bi-directional pagination.
#'
#' Pagination in both directions is done using the *Core Pagination Algorithm* implemented in the `formatters` package:
#'
#' @inheritSection formatters::pagination_algo Pagination Algorithm
#'
#' @examples
#' s_summary <- function(x) {
#'   if (is.numeric(x)) {
#'     in_rows(
#'       "n" = rcell(sum(!is.na(x)), format = "xx"),
#'       "Mean (sd)" = rcell(c(mean(x, na.rm = TRUE), sd(x, na.rm = TRUE)),
#'         format = "xx.xx (xx.xx)"
#'       ),
#'       "IQR" = rcell(IQR(x, na.rm = TRUE), format = "xx.xx"),
#'       "min - max" = rcell(range(x, na.rm = TRUE), format = "xx.xx - xx.xx")
#'     )
#'   } else if (is.factor(x)) {
#'     vs <- as.list(table(x))
#'     do.call(in_rows, lapply(vs, rcell, format = "xx"))
#'   } else {
#'     (
#'       stop("type not supported")
#'     )
#'   }
#' }
#'
#' lyt <- basic_table() %>%
#'   split_cols_by(var = "ARM") %>%
#'   analyze(c("AGE", "SEX", "BEP01FL", "BMRKR1", "BMRKR2", "COUNTRY"), afun = s_summary)
#'
#' tbl <- build_table(lyt, ex_adsl)
#' tbl
#'
#' nrow(tbl)
#'
#' row_paths_summary(tbl)
#'
#' tbls <- paginate_table(tbl, lpp = 15)
#' mf <- matrix_form(tbl, indent_rownames = TRUE)
#' w_tbls <- propose_column_widths(mf) # so that we have the same column widths
#'
#'
#' tmp <- lapply(tbls, function(tbli) {
#'   cat(toString(tbli, widths = w_tbls))
#'   cat("\n\n")
#'   cat("~~~~ PAGE BREAK ~~~~")
#'   cat("\n\n")
#' })
#'
#' @rdname paginate
#' @export
pag_tt_indices <- function(tt,
                           lpp = 15,
                           min_siblings = 2,
                           nosplitin = character(),
                           colwidths = NULL,
                           max_width = NULL,
                           fontspec = NULL,
                           col_gap = 3,
                           verbose = FALSE) {
  dheight <- divider_height(tt)

  #  cinfo_lines <- nlines(col_info(tt), colwidths = colwidths, max_width = max_width)
  coldf <- make_col_df(tt, colwidths)
  have_cfnotes <- length(unlist(coldf$col_fnotes)) > 0

  hlines <- .header_rep_nlines(tt,
    colwidths = colwidths, max_width = max_width,
    verbose = verbose,
    fontspec = fontspec
  )
  ## if(any(nzchar(all_titles(tt)))) {
  ##     tlines <- sum(nlines(all_titles(tt), colwidths = colwidths, max_width = max_width)) +
  ##       length(wrap_txt(all_titles(tt), max_width = max_width)) +
  ##         dheight + 1L
  ## } else {
  ##     tlines <- 0
  ## }
  ## flines <- nlines(main_footer(tt), colwidths = colwidths,
  ##                  max_width = max_width - table_inset(tt)) +
  ##     nlines(prov_footer(tt), colwidths = colwidths, max_width = max_width)
  ## if(flines > 0) {
  ##     dl_contrib <- if(have_cfnotes) 0 else dheight
  ##     flines <- flines + dl_contrib + 1L
  ## }
  flines <- .footer_rep_nlines(tt,
    colwidths = colwidths,
    max_width = max_width,
    have_cfnotes = have_cfnotes,
    fontspec = fontspec,
    verbose = verbose
  )
  ## row lines per page
  rlpp <- lpp - hlines - flines
  if (verbose) {
    message(
      "Adjusted Lines Per Page: ",
      rlpp, " (original lpp: ", lpp, ")"
    )
  }
  pagdf <- make_row_df(tt, colwidths, max_width = max_width)

  pag_indices_inner(pagdf,
    rlpp = rlpp, min_siblings = min_siblings,
    nosplitin = nosplitin,
    verbose = verbose,
    have_col_fnotes = have_cfnotes,
    div_height = dheight,
    col_gap = col_gap,
    has_rowlabels = TRUE
  )
}

copy_title_footer <- function(to, from, newptitle) {
  main_title(to) <- main_title(from)
  subtitles(to) <- subtitles(from)
  page_titles(to) <- c(page_titles(from), newptitle)
  main_footer(to) <- main_footer(from)
  prov_footer(to) <- prov_footer(from)
  to
}

pag_btw_kids <- function(tt) {
  pref <- ptitle_prefix(tt)
  lapply(
    tree_children(tt),
    function(tbl) {
      tbl <- copy_title_footer(
        tbl, tt,
        paste(pref, obj_label(tbl), sep = ": ")
      )
      labelrow_visible(tbl) <- FALSE
      tbl
    }
  )
}

force_paginate <- function(tt,
                           force_pag = vapply(tree_children(tt), has_force_pag, NA),
                           verbose = FALSE) {
  ## forced pagination is happening at this
  if (has_force_pag(tt)) {
    ret <- pag_btw_kids(tt)
    return(unlist(lapply(ret, force_paginate)))
  }
  chunks <- list()
  kinds <- seq_along(force_pag)
  while (length(kinds) > 0) {
    if (force_pag[kinds[1]]) {
      outertbl <- copy_title_footer(
        tree_children(tt)[[kinds[1]]],
        tt,
        NULL
      )

      chunks <- c(chunks, force_paginate(outertbl))
      kinds <- kinds[-1]
    } else {
      tmptbl <- tt
      runend <- min(which(force_pag[kinds]), length(kinds))
      useinds <- 1:runend
      tree_children(tmptbl) <- tree_children(tt)[useinds]
      chunks <- c(chunks, tmptbl)
      kinds <- kinds[-useinds]
    }
  }
  unlist(chunks, recursive = TRUE)
}

#' @importFrom formatters do_forced_paginate
setMethod(
  "do_forced_paginate", "VTableTree",
  function(obj) force_paginate(obj)
)

non_null_na <- function(x) !is.null(x) && is.na(x)

#' @inheritParams formatters::vert_pag_indices
#' @inheritParams formatters::page_lcpp
#' @inheritParams formatters::toString
#' @param cpp (`numeric(1)` or `NULL`)\cr width (in characters) of the pages for horizontal pagination.
#'   `NA` (the default) indicates `cpp` should be inferred from the page size; `NULL` indicates no horizontal
#'   pagination should be done regardless of page size.
#'
#' @rdname paginate
#' @aliases paginate_table
#' @export
paginate_table <- function(tt,
                           page_type = "letter",
                           font_family = "Courier",
                           font_size = 8,
                           lineheight = 1,
                           landscape = FALSE,
                           pg_width = NULL,
                           pg_height = NULL,
                           margins = c(top = .5, bottom = .5, left = .75, right = .75),
                           lpp = NA_integer_,
                           cpp = NA_integer_,
                           min_siblings = 2,
                           nosplitin = character(),
                           colwidths = NULL,
                           tf_wrap = FALSE,
                           max_width = NULL,
                           fontspec = font_spec(font_family, font_size, lineheight),
                           col_gap = 3,
                           verbose = FALSE) {
  new_dev <- open_font_dev(fontspec)
  if (new_dev) {
    on.exit(close_font_dev())
  }

  if ((non_null_na(lpp) || non_null_na(cpp)) &&
    (!is.null(page_type) || (!is.null(pg_width) && !is.null(pg_height)))) { # nolint
    pg_lcpp <- page_lcpp(
      page_type = page_type,
      font_family = font_family,
      font_size = font_size,
      lineheight = lineheight,
      pg_width = pg_width,
      pg_height = pg_height,
      margins = margins,
      landscape = landscape,
      fontspec = fontspec
    )

    if (non_null_na(lpp)) {
      lpp <- pg_lcpp$lpp
    }
    if (is.na(cpp)) {
      cpp <- pg_lcpp$cpp
    }
  } else {
    if (non_null_na(cpp)) {
      cpp <- NULL
    }
    if (non_null_na(lpp)) {
      lpp <- 70
    }
  }

  if (is.null(colwidths)) {
    colwidths <- propose_column_widths(
      matrix_form(
        tt,
        indent_rownames = TRUE,
        fontspec = fontspec,
        col_gap = col_gap
      ),
      fontspec = fontspec
    )
  }

  if (!tf_wrap) {
    if (!is.null(max_width)) {
      warning("tf_wrap is FALSE - ignoring non-null max_width value.")
    }
    max_width <- NULL
  } else if (is.null(max_width)) {
    max_width <- cpp
  } else if (identical(max_width, "auto")) {
    ## XXX this 3 is column sep width!!!!!!!
    max_width <- sum(colwidths) + col_gap * (length(colwidths) - 1)
  }
  if (!is.null(cpp) && !is.null(max_width) && max_width > cpp) {
    warning("max_width specified is wider than characters per page width (cpp).")
  }

  ## taken care of in vert_pag_indices now
  ## if(!is.null(cpp))
  ##     cpp <- cpp - table_inset(tt)

  force_pag <- vapply(tree_children(tt), has_force_pag, TRUE)
  if (has_force_pag(tt) || any(force_pag)) {
    spltabs <- do_forced_paginate(tt)
    spltabs <- unlist(spltabs, recursive = TRUE)
    ret <- lapply(spltabs, paginate_table,
      lpp = lpp,
      cpp = cpp,
      min_siblings = min_siblings,
      nosplitin = nosplitin,
      colwidths = colwidths,
      tf_wrap = tf_wrap,
      max_width = max_width,
      fontspec = fontspec,
      verbose = verbose,
      col_gap = col_gap
    )
    return(unlist(ret, recursive = TRUE))
  }

  inds <- paginate_indices(tt,
    page_type = page_type,
    fontspec = fontspec,
    ## font_family = font_family,
    ## font_size = font_size,
    ## lineheight = lineheight,
    landscape = landscape,
    pg_width = pg_width,
    pg_height = pg_height,
    margins = margins,
    lpp = lpp,
    cpp = cpp,
    min_siblings = min_siblings,
    nosplitin = nosplitin,
    colwidths = colwidths,
    tf_wrap = tf_wrap,
    max_width = max_width,
    col_gap = col_gap,
    verbose = verbose
  ) ## paginate_table apparently doesn't accept indent_size

  res <- lapply(
    inds$pag_row_indices,
    function(ii) {
      subt <- tt[ii, drop = FALSE, keep_titles = TRUE, keep_topleft = TRUE, reindex_refs = FALSE]
      lapply(
        inds$pag_col_indices,
        function(jj) {
          subt[, jj, drop = FALSE, keep_titles = TRUE, keep_topleft = TRUE, reindex_refs = FALSE]
        }
      )
    }
  )
  res <- unlist(res, recursive = FALSE)
  res
}

# as_result_df ------------------------------------------------------------
#' Generate a result data frame
#'
#' Collection of utilities to extract `data.frame` objects from `TableTree` objects.
#'
#' @inheritParams gen_args
#' @param spec (`function`)\cr function that generates the result data frame from a table (`TableTree`).
#'   It defaults to `NULL`, for standard processing.
#' @param expand_colnames (`flag`)\cr when `TRUE`, the result data frame will have expanded column
#'   names above the usual output. This is useful when the result data frame is used for further processing.
#' @param data_format (`string`)\cr the format of the data in the result data frame. It can be one value
#'   between `"full_precision"` (default), `"strings"`, and `"numeric"`. The last two values show the numeric
#'   data with the visible precision.
#' @param make_ard (`flag`)\cr when `TRUE`, the result data frame will have only one statistic per row.
#' @param keep_label_rows (`flag`)\cr when `TRUE`, the result data frame will have all labels
#'   as they appear in the final table.
#' @param simplify (`flag`)\cr when `TRUE`, the result data frame will have only visible labels and
#'   result columns. Consider showing also label rows with `keep_label_rows = TRUE`. This output can be
#'   used again to create a `TableTree` object with [df_to_tt()].
#' @param add_tbl_name_split (`flag`)\cr when `TRUE` and when the table has more than one
#'   `analyze(table_names = "<diff_names>")`, the table names will be present as a group split named
#'   `"<analysis_spl_tbl_name>"`.
#' @param verbose (`flag`)\cr when `TRUE`, the function will print additional information for
#'   `data_format != "full_precision"`.
#' @param ... additional arguments passed to spec-specific result data frame function (`spec`). When
#'   using `make_ard = TRUE`, it is possible to turn off the extraction of the exact string decimals
#'   printed by the table with `add_tbl_str_decimals = FALSE`.
#'
#' @return
#' * `as_result_df` returns a result `data.frame`.
#'
#' @seealso [df_to_tt()] when using `simplify = TRUE` and [formatters::make_row_df()] to have a
#'   comprehensive view of the hierarchical structure of the rows.
#'
#' @note When `parent_name` is used when constructing a layout to directly control
#'   the name of subtables in a table, that will be reflected in the 'group' values
#'   returned in the result dataframe/ard. When automatic de-duplication of sibling names
#'   is performed by `rtables`, that is automatically undone during the result
#'   df creation process, so the group values will be as if the relevant siblings
#'   had identical names.
#'
#' @examples
#' lyt <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   split_rows_by("STRATA1") %>%
#'   analyze(c("AGE", "BMRKR2"))
#'
#' tbl <- build_table(lyt, ex_adsl)
#' as_result_df(tbl, simplify = TRUE)
#'
#' @name data.frame_export
#' @export
as_result_df <- function(tt, spec = NULL,
                         data_format = c("full_precision", "strings", "numeric"),
                         make_ard = FALSE,
                         expand_colnames = FALSE,
                         keep_label_rows = FALSE,
                         add_tbl_name_split = FALSE,
                         simplify = FALSE,
                         verbose = FALSE,
                         round_type = obj_round_type(tt),
                         ...) {
  data_format <- data_format[[1]]
  checkmate::assert_class(tt, "VTableTree")
  checkmate::assert_function(spec, null.ok = TRUE)
  checkmate::assert_choice(data_format[[1]], choices = eval(formals(as_result_df)[["data_format"]]))
  checkmate::assert_flag(make_ard)
  checkmate::assert_flag(expand_colnames)
  checkmate::assert_flag(keep_label_rows)
  checkmate::assert_flag(simplify)
  checkmate::assert_flag(add_tbl_name_split)
  checkmate::assert_flag(verbose)

  if (nrow(tt) == 0) {
    return(sanitize_table_struct(tt))
  }

  if (make_ard) {
    simplify <- FALSE
    expand_colnames <- TRUE
    keep_label_rows <- FALSE
  }

  if (is.null(spec)) {
    # raw values
    rawvals <- cell_values(tt)
    cellvals_init <- .make_df_from_raw_data(rawvals, nr = nrow(tt), nc = ncol(tt))

    if (data_format %in% c("strings", "numeric")) {
      # we keep previous calculations to check the format of the data
      mf_tt <- matrix_form(tt, round_type = round_type)
      mf_result_chars <- mf_strings(mf_tt)[-seq_len(mf_nlheader(mf_tt)), -1, drop = FALSE]
      is_not_label_rows <- make_row_df(tt)$node_class != "LabelRow"
      mf_result_chars <- .remove_empty_elements(mf_result_chars, is_not_label_rows)
      mf_result_numeric <- .make_numeric_char_mf(mf_result_chars)
      mf_result_chars <- as.data.frame(mf_result_chars)
      mf_result_numeric <- as.data.frame(mf_result_numeric)
      cond1 <- !setequal(dim(mf_result_chars), dim(cellvals_init))
      cond2 <- !setequal(dim(mf_result_numeric), dim(cellvals_init))
      if (cond1 || cond2) {
        stop(
          "The extracted numeric data.frame does not have the same dimension of the",
          " cell values extracted with cell_values(). This is a bug. Please report it."
        ) # nocov
      }

      colnames(mf_result_chars) <- colnames(cellvals_init)
      colnames(mf_result_numeric) <- colnames(cellvals_init)
      if (data_format == "strings") {
        cellvals <- mf_result_chars
        if (isTRUE(make_ard)) {
          stop("make_ard = TRUE is not compatible with data_format = 'strings'")
        }
      } else if (data_format == "numeric") {
        if (isTRUE(make_ard)) {
          cellvals <- .convert_to_character(mf_result_numeric)
        } else {
          cellvals <- mf_result_numeric
        }
      }
      diff_in_cellvals <- length(unlist(cellvals_init)) - length(unlist(cellvals))
      if (make_ard && abs(diff_in_cellvals) > 0) {
        warning_msg <- paste0(
          "Found ", abs(diff_in_cellvals), " cell values that differ from ",
          "printed values. This is possibly related to conditional formatting. "
        )

        # number of values difference mask between cellvals and cellvals_init (TRUE if different)
        dmc <- .lengths_with_nulls(unlist(cellvals, recursive = FALSE)) !=
          .lengths_with_nulls(unlist(cellvals_init, recursive = FALSE))
        dmc <- matrix(dmc, nrow = nrow(cellvals), ncol = ncol(cellvals))

        # Mainly used for debugging
        warning_msg <- if (verbose) { # beware that \n will break this (use make_row_df(tt)$self_extent for fix)
          selected_rows_to_print <- mf_strings(mf_tt)[-seq_len(mf_nlheader(mf_tt)), , drop = FALSE]
          selected_rows_to_print <- selected_rows_to_print[!make_row_df(tt)$node_class == "LabelRow", , drop = FALSE]
          selected_rows_to_print <- cbind(
            which(apply(dmc, 1, any, simplify = TRUE)),
            as.data.frame(selected_rows_to_print[apply(dmc, 1, any), , drop = FALSE])
          )
          colnames(selected_rows_to_print) <- c("row_number", "row_name", colnames(cellvals_init))
          paste0(
            warning_msg,
            "\n",
            "The following row names were modified: ",
            paste(selected_rows_to_print$row_name, sep = ", ", collapse = ", "),
            "\n"
          )
        } else {
          paste0(warning_msg, "To see the affected row names use `verbose = TRUE`.")
        }
        warning(warning_msg)
        cellvals[dmc] <- cellvals_init[dmc]
      }
    } else {
      cellvals <- cellvals_init
    }

    rdf <- make_row_df(tt)

    df <- rdf[, c("name", "label", "abs_rownumber", "path", "reprint_inds", "node_class")]
    # Removing initial root elements from path (out of the loop -> right maxlen)
    df$path <- lapply(df$path, .fix_raw_row_path,
      which_root_name = c("root", "rbind_root"),
      all = TRUE
    )

    # Correcting maxlen for even number of paths (only multianalysis diff table names)
    maxlen <- max(lengths(df$path))
    if (maxlen %% 2 != 0) {
      maxlen <- if (add_tbl_name_split) {
        maxlen + 1
      } else {
        maxlen - 1
      }
    }

    # Loop for metadata (path and details from make_row_df)
    metadf <- do.call(
      rbind.data.frame,
      lapply(
        seq_len(NROW(df)),
        function(ii) {
          handle_rdf_row(df[ii, ], maxlen = maxlen, add_tbl_name_split = add_tbl_name_split)
        }
      )
    )

    # Should we keep label rows with NAs instead of values?
    if (keep_label_rows) {
      cellvals_mat_struct <- as.data.frame(
        matrix(NA, nrow = nrow(rdf), ncol = ncol(cellvals))
      )
      colnames(cellvals_mat_struct) <- colnames(cellvals)
      cellvals_mat_struct[metadf$node_class != "LabelRow", ] <- cellvals
      ret <- cbind(metadf, cellvals_mat_struct)
    } else {
      ret <- cbind(
        metadf[metadf$node_class != "LabelRow", ],
        cellvals
      )
    }

    # Fix for content rows analysis variable label
    if (any(ret$node_class == "ContentRow")) {
      where_to <- which(ret$node_class == "ContentRow")
      for (crow_i in where_to) {
        # For each Content row, extract the row split that is used as analysis variable
        tmp_tbl <- ret[crow_i, , drop = FALSE]
        na_labels <- lapply(tmp_tbl, is.na) |> unlist(use.names = FALSE)
        group_to_take <- colnames(tmp_tbl[, !na_labels])
        group_to_take <- group_to_take[grep("^group[0-9]+$", group_to_take)]

        # Final assignment of each Content row to its correct analysis label
        ret$avar_name[crow_i] <- ret[[group_to_take[length(group_to_take)]]][crow_i]
      }
    }

    # If we want to expand colnames
    if (expand_colnames) {
      col_name_structure <- .get_formatted_colnames(clayout(tt))
      number_of_non_data_cols <- which(colnames(ret) == "node_class")
      if (NCOL(ret) - number_of_non_data_cols != NCOL(col_name_structure)) {
        stop(
          "When expanding colnames structure, we were not able to find the same",
          " number of columns as in the result data frame. This is a bug. Please report it."
        ) # nocov
      }

      buffer_rows_for_colnames <- matrix(
        rep("<only_for_column_names>", number_of_non_data_cols * NROW(col_name_structure)),
        nrow = NROW(col_name_structure)
      )

      header_colnames_matrix <- cbind(buffer_rows_for_colnames, data.frame(col_name_structure))
      colnames(header_colnames_matrix) <- colnames(ret)

      count_row <- NULL
      if (disp_ccounts(tt)) {
        ccounts <- col_counts(tt)
        if (data_format == "strings") {
          ccounts <- mf_strings(mf_tt)[mf_nlheader(mf_tt), ]
          ccounts <- .remove_empty_elements(ccounts)
        }
        count_row <- c(rep("<only_for_column_counts>", number_of_non_data_cols), ccounts)
        header_colnames_matrix <- rbind(header_colnames_matrix, count_row)
      }
      ret <- rbind(header_colnames_matrix, ret)
    }

    # make_ard -----------------------------------------------------------------
    # ARD part for one stat per row
    if (make_ard) {
      cinfo_df <- col_info(tt)
      ci_coltree <- coltree(cinfo_df)
      column_split_names <- .get_column_split_name(ci_coltree) # used only in make_ard

      # Unnecessary columns
      ret_tmp <- ret[, !colnames(ret) %in% c("row_num", "is_group_summary", "node_class")]
      n_row_groups <- sapply(colnames(ret), function(x) {
        if (grepl("^group", x)) {
          # Extract the number after "group" using regex
          as.numeric(sub("group(\\d+).*", "\\1", x))
        } else {
          0 # Return 0 if no "group" is found
        }
      }) |>
        max()

      # Indexes of real columns (visible in the output, but no row names)
      only_col_indexes <- seq(which(colnames(ret_tmp) == "label_name") + 1, ncol(ret_tmp))

      # Core row names
      col_label_rows <- grepl("<only_for_column_*", ret_tmp$avar_name)
      number_of_col_splits <- sum(grepl("<only_for_column_names>", ret_tmp$avar_name))
      core_row_names <- ret_tmp[!col_label_rows, -only_col_indexes]
      colnames_to_rename <- colnames(core_row_names) %in% c("avar_name", "row_name", "label_name")
      # instead of avar_name  row_name  label_name ("variable_label" is not present in ARDs)
      colnames(core_row_names)[colnames_to_rename] <- c("variable", "variable_level", "variable_label")

      # Adding stats_names if present
      raw_stat_names <- .get_stat_names_from_table(tt, add_labrows = keep_label_rows)
      cell_stat_names <- .make_df_from_raw_data(raw_stat_names, nr = nrow(tt), nc = ncol(tt))

      # Moving colnames to rows (flattening)
      ret_w_cols <- NULL
      # Looping on statistical columns
      for (col_i in only_col_indexes) {
        # Making row splits into row specifications (group1 group1_level)
        current_col_split_level <- unlist(ret_tmp[seq_len(number_of_col_splits), col_i], use.names = FALSE)
        col_split_names <- column_split_names[[1]][[1]] # cross section of the column split names (not values)
        more_than_one_name_in_csn <- sapply(col_split_names, length) > 1

        # Correction for cases where there is split_cols_by_multivar
        if (any(more_than_one_name_in_csn)) {
          col_split_names[more_than_one_name_in_csn] <- lapply(
            seq(sum(more_than_one_name_in_csn)),
            function(i) {
              paste0("multivar_split", i)
            }
          )
        }

        # Alternated association of split names and values (along with group split)
        flattened_cols_names <- .c_alternated(col_split_names, current_col_split_level)
        names(flattened_cols_names) <- .c_alternated(
          paste0("group", seq_along(col_split_names) + n_row_groups),
          paste0("group", seq_along(current_col_split_level) + n_row_groups, "_level")
        )

        if (n_row_groups > 0) {
          tmp_core_ret_by_col_i <- cbind(
            core_row_names[, seq(n_row_groups * 2)],
            t(data.frame(flattened_cols_names)),
            core_row_names[, -seq(n_row_groups * 2)],
            row.names = NULL
          )
        } else {
          tmp_core_ret_by_col_i <- cbind(
            t(data.frame(flattened_cols_names)),
            core_row_names,
            row.names = NULL
          )
        }

        # retrieving stat names and stats
        stat_name <- setNames(cell_stat_names[, col_i - min(only_col_indexes) + 1, drop = TRUE], NULL)
        stat <- setNames(ret_tmp[!col_label_rows, col_i, drop = TRUE], NULL)
        necessary_stat_lengths <- lapply(stat, length)
        stat[!lengths(stat) > 0] <- NA

        # Truncating or adding NA if stat names has more or less elements than stats
        stat_name <- lapply(seq_along(stat_name), function(sn_i) {
          unlist(stat_name[[sn_i]], use.names = FALSE)[seq_len(necessary_stat_lengths[[sn_i]])]
        })
        stat_name[!nzchar(stat_name)] <- NA
        stat_name[!lengths(stat_name) > 0] <- NA

        # unnesting stat_name and stat
        tmp_ret_by_col_i <- NULL
        for (row_i in seq_along(stat)) {
          tmp_ret_by_col_i <- rbind(
            tmp_ret_by_col_i,
            cbind(
              tmp_core_ret_by_col_i[row_i, ],
              stat_name = stat_name[[row_i]],
              stat = stat[[row_i]],
              row.names = NULL
            )
          )
        }

        ret_w_cols <- rbind(ret_w_cols, tmp_ret_by_col_i)
      }

      # If add_tbl_str_decimals is not present, we need to call the function again to keep precision
      add_tbl_str_decimals <- list(...)$add_tbl_str_decimals
      if (is.null(add_tbl_str_decimals) || isTRUE(add_tbl_str_decimals)) {
        # Trying to extract strings as numeric for comparison
        tryCatch(
          {
            stat_string_ret <- as_result_df(
              tt = tt, spec = spec, data_format = "numeric",
              make_ard = TRUE, add_tbl_str_decimals = FALSE, verbose = verbose
            )
            ret_w_cols <- cbind(ret_w_cols, "stat_string" = stat_string_ret$stat)
          },
          error = function(e) {
            warning("Could not add 'stat_string' column to the result data frame. Error: ", e$message)
          }
        )
      }

      ret <- ret_w_cols
    }

    # Simplify the result data frame
    out <- if (simplify) {
      .simplify_result_df(ret)
    } else {
      ret
    }

    # take out rownames
    rownames(out) <- NULL
  } else {
    # Applying specs
    out <- spec(tt, ...)
  }

  out
}

.lengths_with_nulls <- function(lst) {
  sapply(lst, function(x) if (is.null(x)) 1 else length(x))
}


# Helper function used to structure the raw values into a dataframe
.make_df_from_raw_data <- function(rawvals, nr, nc) {
  ## if the table has one row and multiple columns, sometimes the cell values returns a list of the cell values
  ## rather than a list of length 1 representing the single row. This is bad but may not be changeable
  ## at this point.
  if (nr == 1 && length(rawvals) > 1) {
    rawvals <- list(rawvals)
  }

  # Flatten the list of lists (rows) of cell values into a data frame
  cellvals <- as.data.frame(do.call(rbind, rawvals))

  if (nr == 1 && nc == 1) {
    if (length(unlist(rawvals)) > 1) { # This happens only with nr = nc = 1 for raw values
      cellvals <- as.data.frame(I(rawvals))
    }
    colnames(cellvals) <- names(rawvals)
  }

  row.names(cellvals) <- NULL
  cellvals
}

# Is there a better alternative?
.c_alternated <- function(v1, v2) {
  unlist(mapply(c, v1, v2, SIMPLIFY = FALSE))
}

# Amazing helper function to get the statistic names from row cells!
.get_stat_names_from_table <- function(tt, add_labrows = FALSE) {
  # omit_labrows # omit label rows
  rows <- collect_leaves(tt, incl.cont = TRUE, add.labrows = add_labrows)
  lapply(rows, function(ri) {
    lapply(row_cells(ri), obj_stat_names)
  })
}

# Helper function to get column split names
.get_column_split_name <- function(ci_coltree) {
  # ci stands for column information
  if (is(ci_coltree, "LayoutAxisTree")) {
    kids <- tree_children(ci_coltree)
    return(lapply(kids, .get_column_split_name))
  }

  lapply(pos_splits(tree_pos(ci_coltree)), function(x) {
    pl <- spl_payload(x)
    if (!is.null(pl)) { # it is null when all obs (1 column)
      pl
    } else {
      x@name
    }
  })
}

# Function that selects specific outputs from the result data frame
.simplify_result_df <- function(df) {
  col_df <- colnames(df)
  if (!all(c("label_name", "node_class") %in% col_df)) {
    stop("Please simplify the result data frame only when it has 'label_name' and 'node_class' columns.")
  }
  label_names_col <- which(col_df == "label_name")
  result_cols <- seq(which(col_df == "node_class") + 1, length(col_df))

  df[, c(label_names_col, result_cols)]
}

.remove_empty_elements <- function(char_df, is_not_label_rows) {
  if (is.null(dim(char_df))) {
    return(char_df[nzchar(char_df, keepNA = TRUE)])
  }
  rows_to_remove <- apply(char_df, 1, function(row_i) all(!nzchar(row_i, keepNA = TRUE)), simplify = TRUE)
  char_df[!rows_to_remove | is_not_label_rows, , drop = FALSE]
}

# Helper function to make the character matrix numeric
.make_numeric_char_mf <- function(char_df) {
  if (is.null(dim(char_df))) {
    ret <- lapply(char_df[[1]], function(x) {
      as.numeric(stringi::stri_extract_all(x, regex = "\\d+.\\d+|\\d+")[[1]])
    }) # keeps the list (single element) for data.frame
    return(I(ret))
  }

  ret <- apply(char_df, 2, function(col_i) {
    out <- lapply(
      stringi::stri_extract_all(col_i, regex = "\\d+.\\d+|\\d+"),
      as.numeric
    )
    if (all(dim(char_df) == c(1, 1)) && is.list(out[[1]])) {
      unlist(out, use.names = FALSE)
    } else {
      out
    }
  }, simplify = FALSE)

  do.call(cbind, ret)
}

make_result_df_md_colnames <- function(maxlen) {
  spllen <- floor((maxlen - 2) / 2)
  ret <- character()
  if (spllen > 0) {
    ret <- paste("group", rep(seq_len(spllen), each = 2), c("", "_level"), sep = "")
  }
  ret <- c(ret, c("avar_name", "row_name", "label_name", "row_num", "is_group_summary", "node_class"))
}

do_label_row <- function(rdfrow, maxlen, add_tbl_name_split = FALSE) {
  pth <- rdfrow$path[[1]]
  # Adjusting for the fact that we have two columns for each split
  extra_nas_from_splits <- floor((maxlen - length(pth)) / 2) * 2

  # Special cases with hidden labels
  if (length(pth) %% 2 == 1) {
    extra_nas_from_splits <- extra_nas_from_splits + 1
  } else {
    if (isTRUE(add_tbl_name_split)) {
      pth <- c("<analysis_spl_tbl_name>", pth)
      extra_nas_from_splits <- extra_nas_from_splits - 1
    } else {
      pth <- pth[-1]
      extra_nas_from_splits <- extra_nas_from_splits + 1
    }
  }

  c(
    as.list(pth[seq_len(length(pth) - 1)]),
    as.list(replicate(extra_nas_from_splits, list(NA_character_))),
    as.list(tail(pth, 1)),
    list(
      label_name = rdfrow$label,
      row_num = rdfrow$abs_rownumber,
      content = FALSE,
      node_class = rdfrow$node_class
    )
  )
}

do_content_row <- function(rdfrow, maxlen) {
  pth <- rdfrow$path[[1]]
  contpos <- which(pth == "@content")

  seq_before <- seq_len(contpos - 1)

  c(
    as.list(pth[seq_before]),
    as.list(replicate(maxlen - contpos, list(NA_character_))),
    list(tail(pth, 1)),
    list(
      label_name = rdfrow$label,
      row_num = rdfrow$abs_rownumber,
      content = TRUE,
      node_class = rdfrow$node_class
    )
  )
}

do_data_row <- function(rdfrow, maxlen, add_tbl_name_split = FALSE) {
  pth <- rdfrow$path[[1]]
  pthlen <- length(pth)
  ## odd means we have a multi-analsysis step in the path, we do not want this in the result
  if (pthlen %% 2 == 1 && pthlen > 1) {
    # we remove the last element, as it is a fake split (tbl_name from analyse)
    # pth <- pth[-1 * (pthlen - 2)]
    if (isTRUE(add_tbl_name_split)) {
      pth <- c("<analysis_spl_tbl_name>", pth)
    } else {
      pth <- pth[-1]
    }
  }
  pthlen_new <- length(pth)
  if (pthlen_new == 1) {
    pthlen_new <- 3 # why?
  }
  c(
    as.list(pth[seq_len(pthlen_new - 2)]),
    replicate(ifelse((maxlen - pthlen_new) > 0, maxlen - pthlen_new, 0), list(NA_character_)),
    as.list(tail(pth, 2)),
    list(
      label_name = rdfrow$label,
      row_num = rdfrow$abs_rownumber,
      content = FALSE,
      node_class = rdfrow$node_class
    )
  )
}

deuniqify_path_elements <- function(path) {
  gsub("\\[[[:digit:]]+\\]$", "", path)
}

.fix_raw_row_path <- function(path, which_root_name = c("root", "rbind_root"), all = TRUE) {
  path <- deuniqify_path_elements(path)
  any_root_paths <- path[1] %in% which_root_name
  if (any_root_paths) {
    if (isTRUE(all)) {
      # Selecting the header grouping of root and rbind_root (we do not want to remove other root labels-path later)
      root_indices <- which(path %in% which_root_name)
      if (any(diff(root_indices) > 1)) { # integer(0) for diff means FALSE
        end_point_root_headers <- which(diff(root_indices) > 1)[1]
      } else {
        end_point_root_headers <- length(root_indices)
      }
      root_path_to_remove <- seq_len(end_point_root_headers)
    } else {
      root_path_to_remove <- 1
    }
    path <- path[-root_path_to_remove]
  }

  # Fix for very edge case where we have only root elements
  if (length(path) == 0) {
    path <- which_root_name[1]
  }

  path
}

handle_rdf_row <- function(rdfrow, maxlen, add_tbl_name_split = FALSE) {
  nclass <- rdfrow$node_class

  ret <- switch(nclass,
    LabelRow = do_label_row(rdfrow, maxlen, add_tbl_name_split = add_tbl_name_split),
    ContentRow = do_content_row(rdfrow, maxlen),
    DataRow = do_data_row(rdfrow, maxlen, add_tbl_name_split = add_tbl_name_split),
    stop("Unrecognized node type in row dataframe, unable to generate result data frame")
  )
  setNames(ret, make_result_df_md_colnames(maxlen))
}

# Helper recurrent function to get the column names for the result data frame from the VTableTree
.get_formatted_colnames <- function(clyt) {
  ret <- obj_label(clyt)
  if (!nzchar(ret)) {
    ret <- NULL
  }
  if (is.null(tree_children(clyt))) {
    ret
  } else {
    ret <- rbind(ret, do.call(cbind, lapply(tree_children(clyt), .get_formatted_colnames)))
    colnames(ret) <- NULL
    rownames(ret) <- NULL
    ret
  }
}

# Function to convert all elements to character while preserving structure
.convert_to_character <- function(df) {
  # Apply transformation to each column
  df_converted <- lapply(df, function(col) {
    if (is.list(col)) {
      # For columns with vector cells, convert each vector to a character vector
      I(lapply(col, as.character))
    } else {
      # For regular columns, directly convert to character
      as.character(col)
    }
  })
  # Return the transformed data frame
  data.frame(df_converted, stringsAsFactors = FALSE)
}

# path_enriched_df ------------------------------------------------------------
#
#' @describeIn data.frame_export Transform a `TableTree` object to a path-enriched `data.frame`.
#'
#' @param path_fun (`function`)\cr function to transform paths into single-string row/column names.
#' @param value_fun (`function`)\cr function to transform cell values into cells of a `data.frame`. Defaults to
#'   `collapse_values`, which creates strings where multi-valued cells are collapsed together, separated by `|`.
#'
#' @return
#' * `path_enriched_df()` returns a `data.frame` of `tt`'s cell values (processed by `value_fun`, with columns named by
#'   the full column paths (processed by `path_fun` and an additional `row_path` column with the row paths (processed
#'   by `path_fun`).
#'
#' @examples
#' lyt <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   analyze(c("AGE", "BMRKR2"))
#'
#' tbl <- build_table(lyt, ex_adsl)
#' path_enriched_df(tbl)
#'
#' @export
path_enriched_df <- function(tt, path_fun = collapse_path, value_fun = collapse_values) {
  rdf <- make_row_df(tt)
  cdf <- make_col_df(tt)
  cvs <- as.data.frame(do.call(rbind, cell_values(tt)))
  cvs <- as.data.frame(lapply(cvs, value_fun))
  row.names(cvs) <- NULL
  colnames(cvs) <- path_fun(cdf$path)
  preppaths <- path_fun(rdf[rdf$node_class != "LabelRow", ]$path)
  cbind.data.frame(row_path = preppaths, cvs)
}

.collapse_char <- "|"
.collapse_char_esc <- "\\|"

collapse_path <- function(paths) {
  if (is.list(paths)) {
    return(vapply(paths, collapse_path, ""))
  }
  paste(paths, collapse = .collapse_char)
}

collapse_values <- function(colvals) {
  if (!is.list(colvals)) { ## || all(vapply(colvals, length, 1L) == 1))
    return(colvals)
  } else if (all(vapply(colvals, length, 1L) == 1)) {
    return(unlist(colvals))
  }
  vapply(colvals, paste, "", collapse = .collapse_char)
}

# paths summary ----

#' Get a list of table row/column paths
#'
#' @param x (`VTableTree`)\cr an `rtable` object.
#'
#' @return A list of paths to each row/column within `x`.
#'
#' @seealso [cell_values()], [`fnotes_at_path<-`], [row_paths_summary()], [col_paths_summary()]
#'
#' @examples
#' lyt <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   analyze(c("SEX", "AGE"))
#'
#' tbl <- build_table(lyt, ex_adsl)
#' tbl
#'
#' row_paths(tbl)
#' col_paths(tbl)
#'
#' cell_values(tbl, c("AGE", "Mean"), c("ARM", "B: Placebo"))
#'
#' @rdname make_col_row_df
#' @export
row_paths <- function(x) {
  stopifnot(is_rtable(x))
  make_row_df(x, visible_only = TRUE)$path
}

#' @rdname make_col_row_df
#' @export
col_paths <- function(x) {
  if (!is(coltree(x), "LayoutColTree")) {
    stop("I don't know how to extract the column paths from an object of class ", class(x))
  }
  make_col_df(x, visible_only = TRUE)$path
}

#' Print row/column paths summary
#'
#' @param x (`VTableTree`)\cr an `rtable` object.
#'
#' @return A data frame summarizing the row- or column-structure of `x`.
#'
#' @examplesIf require(dplyr)
#' ex_adsl_MF <- ex_adsl %>% dplyr::filter(SEX %in% c("M", "F"))
#'
#' lyt <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   split_cols_by("SEX", split_fun = drop_split_levels) %>%
#'   analyze(c("AGE", "BMRKR2"))
#'
#' tbl <- build_table(lyt, ex_adsl_MF)
#' tbl
#'
#' df <- row_paths_summary(tbl)
#' df
#'
#' col_paths_summary(tbl)
#'
#' # manually constructed table
#' tbl2 <- rtable(
#'   rheader(
#'     rrow(
#'       "row 1", rcell("a", colspan = 2),
#'       rcell("b", colspan = 2)
#'     ),
#'     rrow("h2", "a", "b", "c", "d")
#'   ),
#'   rrow("r1", 1, 2, 1, 2), rrow("r2", 3, 4, 2, 1)
#' )
#' col_paths_summary(tbl2)
#'
#' @export
row_paths_summary <- function(x) {
  stopifnot(is_rtable(x))

  if (nrow(x) == 0) {
    return("rowname     node_class       path\n---------------------\n")
  }

  pagdf <- make_row_df(x, visible_only = TRUE)
  row.names(pagdf) <- NULL

  mat <- rbind(
    c("rowname", "node_class", "path"),
    t(apply(pagdf, 1, function(xi) {
      c(
        indent_string(xi$label, xi$indent),
        xi$node_class,
        paste(xi$path, collapse = ", ")
      )
    }))
  )

  txt <- mat_as_string(mat)
  cat(txt)
  cat("\n")

  invisible(pagdf[, c("label", "indent", "node_class", "path")])
}

#' @rdname row_paths_summary
#' @export
col_paths_summary <- function(x) {
  stopifnot(is_rtable(x))

  pagdf <- make_col_df(x, visible_only = FALSE)
  row.names(pagdf) <- NULL

  mat <- rbind(
    c("label", "path"),
    t(apply(pagdf, 1, function(xi) {
      c(
        indent_string(xi$label, floor(length(xi$path) / 2 - 1)),
        paste(xi$path, collapse = ", ")
      )
    }))
  )

  txt <- mat_as_string(mat)
  cat(txt)
  cat("\n")

  invisible(pagdf[, c("label", "path")])
}

# Rows ----
# . Summarize Rows ----

# summarize_row_df <-
#     function(name,
#              label,
#              indent,
#              depth,
#              rowtype,
#              indent_mod,
#              level) {
#         data.frame(
#             name = name,
#             label = label,
#             indent = indent,
#             depth = level,
#             rowtype = rowtype,
#             indent_mod = indent_mod,
#             level = level,
#             stringsAsFactors = FALSE
#         )
#     }

#' Summarize rows
#'
#' @inheritParams gen_args
#' @param depth (`numeric(1)`)\cr depth.
#' @param indent (`numeric(1)`)\cr indent.
#'
#' @examplesIf require(dplyr)
#' library(dplyr)
#'
#' iris2 <- iris %>%
#'   group_by(Species) %>%
#'   mutate(group = as.factor(rep_len(c("a", "b"), length.out = n()))) %>%
#'   ungroup()
#'
#' lyt <- basic_table() %>%
#'   split_cols_by("Species") %>%
#'   split_cols_by("group") %>%
#'   analyze(c("Sepal.Length", "Petal.Width"),
#'     afun = list_wrap_x(summary),
#'     format = "xx.xx"
#'   )
#'
#' tbl <- build_table(lyt, iris2)
#'
#' @rdname int_methods
setGeneric("summarize_rows_inner", function(obj, depth = 0, indent = 0) {
  standardGeneric("summarize_rows_inner")
})

#' @rdname int_methods
setMethod(
  "summarize_rows_inner", "TableTree",
  function(obj, depth = 0, indent = 0) {
    indent <- max(0L, indent + indent_mod(obj))

    lr <- summarize_rows_inner(tt_labelrow(obj), depth, indent)
    if (!is.null(lr)) {
      ret <- list(lr)
    } else {
      ret <- list()
    }

    indent <- indent + (!is.null(lr))

    ctab <- content_table(obj)
    if (NROW(ctab)) {
      ct <- summarize_rows_inner(ctab,
        depth = depth,
        indent = indent + indent_mod(ctab)
      )
      ret <- c(ret, ct)
      indent <- indent + (length(ct) > 0) * (1 + indent_mod(ctab))
    }

    kids <- tree_children(obj)
    els <- lapply(tree_children(obj), summarize_rows_inner,
      depth = depth + 1, indent = indent
    )
    if (!are(kids, "TableRow")) {
      if (!are(kids, "VTableTree")) {
        ## hatchet job of a hack, wrap em just so we can unlist em all at
        ## the same level
        rowinds <- vapply(kids, is, NA, class2 = "TableRow")
        els[rowinds] <- lapply(els[rowinds], function(x) list(x))
      }
      els <- unlist(els, recursive = FALSE)
    }
    ret <- c(ret, els)
    ret
    ## df <- do.call(rbind, c(list(lr), list(ct), els))

    ## row.names(df) <- NULL
    ## df
  }
)

# Print Table Structure ----

#' Summarize table
#'
#' @param x (`VTableTree`)\cr a table object.
#' @param detail (`string`)\cr either `row` or `subtable`.
#'
#' @return No return value. Called for the side-effect of printing a row- or subtable-structure summary of `x`.
#'
#' @examplesIf require(dplyr)
#' library(dplyr)
#'
#' iris2 <- iris %>%
#'   group_by(Species) %>%
#'   mutate(group = as.factor(rep_len(c("a", "b"), length.out = n()))) %>%
#'   ungroup()
#'
#' lyt <- basic_table() %>%
#'   split_cols_by("Species") %>%
#'   split_cols_by("group") %>%
#'   analyze(c("Sepal.Length", "Petal.Width"),
#'     afun = list_wrap_x(summary),
#'     format = "xx.xx"
#'   )
#'
#' tbl <- build_table(lyt, iris2)
#' tbl
#'
#' row_paths(tbl)
#'
#' table_structure(tbl)
#'
#' table_structure(tbl, detail = "row")
#'
#' @export
table_structure <- function(x, detail = c("subtable", "row")) {
  detail <- match.arg(detail)

  switch(detail,
    subtable = treestruct(x),
    row = table_structure_inner(x),
    stop("unsupported level of detail ", detail)
  )
}

#' @param obj (`VTableTree`)\cr a table object.
#' @param depth (`numeric(1)`)\cr depth in tree.
#' @param indent (`numeric(1)`)\cr indent.
#' @param print_indent (`numeric(1)`)\cr indent for printing.
#'
#' @rdname int_methods
setGeneric(
  "table_structure_inner",
  function(obj,
           depth = 0,
           indent = 0,
           print_indent = 0) {
    standardGeneric("table_structure_inner")
  }
)

scat <- function(..., indent = 0, newline = TRUE) {
  txt <- paste(..., collapse = "", sep = "")

  cat(indent_string(txt, indent))

  if (newline) cat("\n")
}

## helper functions
obj_visible <- function(x) {
  x@visible
}

is_empty_labelrow <- function(x) {
  obj_label(x) == "" && !labelrow_visible(x)
}

is_empty_ElementaryTable <- function(x) {
  length(tree_children(x)) == 0 && is_empty_labelrow(tt_labelrow(x))
}

#' @param object (`VTableTree`)\cr a table object.
#'
#' @rdname int_methods
#' @export
setGeneric("str", function(object, ...) {
  standardGeneric("str")
})

#' @param max.level (`numeric(1)`)\cr passed to `utils::str`. Defaults to 3 for the `VTableTree` method, unlike
#'   the underlying default of `NA`. `NA` is *not* appropriate for `VTableTree` objects.
#'
#' @rdname int_methods
#' @export
setMethod(
  "str", "VTableTree",
  function(object, max.level = 3L, ...) {
    utils::str(object, max.level = max.level, ...)
    warning("str provides a low level, implementation-detail-specific description of the TableTree object structure. ",
      "See table_structure(.) for a summary of table struture intended for end users.",
      call. = FALSE
    )
    invisible(NULL)
  }
)

#' @inheritParams table_structure_inner
#' @rdname int_methods
setMethod(
  "table_structure_inner", "TableTree",
  function(obj, depth = 0, indent = 0, print_indent = 0) {
    indent <- indent + indent_mod(obj)

    scat("TableTree: ", "[", obj_name(obj), "] (",
      obj_label(obj), ")",
      indent = print_indent
    )

    table_structure_inner(
      tt_labelrow(obj), depth, indent,
      print_indent + 1
    )

    ctab <- content_table(obj)
    visible_content <- if (is_empty_ElementaryTable(ctab)) {
      # scat("content: -", indent = print_indent + 1)
      FALSE
    } else {
      scat("content:", indent = print_indent + 1)
      table_structure_inner(ctab,
        depth = depth,
        indent = indent + indent_mod(ctab),
        print_indent = print_indent + 2
      )
    }

    if (length(tree_children(obj)) == 0) {
      scat("children: - ", indent = print_indent + 1)
    } else {
      scat("children: ", indent = print_indent + 1)
      lapply(tree_children(obj), table_structure_inner,
        depth = depth + 1,
        indent = indent + visible_content * (1 + indent_mod(ctab)),
        print_indent = print_indent + 2
      )
    }

    invisible(NULL)
  }
)

#' @rdname int_methods
setMethod(
  "table_structure_inner", "ElementaryTable",
  function(obj, depth = 0, indent = 0, print_indent = 0) {
    scat("ElementaryTable: ", "[", obj_name(obj),
      "] (", obj_label(obj), ")",
      indent = print_indent
    )

    indent <- indent + indent_mod(obj)

    table_structure_inner(
      tt_labelrow(obj), depth,
      indent, print_indent + 1
    )

    if (length(tree_children(obj)) == 0) {
      scat("children: - ", indent = print_indent + 1)
    } else {
      scat("children: ", indent = print_indent + 1)
      lapply(tree_children(obj), table_structure_inner,
        depth = depth + 1, indent = indent,
        print_indent = print_indent + 2
      )
    }

    invisible(NULL)
  }
)

#' @rdname int_methods
setMethod(
  "table_structure_inner", "TableRow",
  function(obj, depth = 0, indent = 0, print_indent = 0) {
    scat(class(obj), ": ", "[", obj_name(obj), "] (",
      obj_label(obj), ")",
      indent = print_indent
    )

    indent <- indent + indent_mod(obj)

    invisible(NULL)
  }
)

#' @rdname int_methods
setMethod(
  "table_structure_inner", "LabelRow",
  function(obj, depth = 0, indent = 0, print_indent = 0) {
    indent <- indent + indent_mod(obj)

    txtvis <- if (!obj_visible(obj)) " - <not visible>" else ""

    scat("labelrow: ", "[", obj_name(obj), "] (", obj_label(obj), ")",
      txtvis,
      indent = print_indent
    )

    obj_visible(obj)
  }
)

#' Find degenerate (sub)structures within a table
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' This function returns a list with the row-paths to all structural subtables which contain no data rows (even if
#' they have associated content rows).
#'
#' @param tt (`TableTree`)\cr a `TableTree` object.
#'
#' @return A list of character vectors representing the row paths, if any, to degenerate substructures within the table.
#'
#' @examples
#' find_degen_struct(rtable("hi"))
#'
#' @family table structure validation functions
#' @export
find_degen_struct <- function(tt) {
  degen <- list()

  recurse_check <- function(tti, path) {
    if (is(tti, "VTableTree")) {
      kids <- tree_children(tti)
      if (length(kids) == 0) {
        degen <<- c(degen, list(path))
      } else {
        for (i in seq_along(kids)) {
          recurse_check(kids[[i]], path = c(path, names(kids)[i]))
        }
      }
    }
  }
  recurse_check(tt, obj_name(tt) %||% "root")
  degen
}

#' Validate and assert valid table structure
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A `TableTree` (`rtables`-built table) is considered degenerate if:
#' \enumerate{
#'   \item{It contains no subtables or data rows (content rows do not count).}
#'   \item{It contains a subtable which is degenerate by the criterion above.}
#' }
#'
#' `validate_table_struct` assesses whether `tt` has a valid (non-degenerate) structure.
#'
#' `assert_valid_table` asserts a table must have a valid structure, and throws an informative error (the default) or
#' warning (if `warn_only` is `TRUE`) if the table is degenerate (has invalid structure or contains one or more
#' invalid substructures.
#'
#' @param tt (`TableTree`)\cr a `TableTree` object.
#'
#' @return
#' * `validate_table_struct` returns a logical value indicating valid structure.
#' * `assert_valid_table` is called for its side-effect of throwing an error or warning for degenerate tables.
#'
#' @note This function is experimental and the exact text of the warning/error is subject to change in future releases.
#'
#' @examples
#' validate_table_struct(rtable("hahaha"))
#' \dontrun{
#' assert_valid_table(rtable("oops"))
#' }
#'
#' @family table structure validation functions
#' @export
validate_table_struct <- function(tt) {
  degen_pths <- find_degen_struct(tt)
  length(degen_pths) == 0
}

## XXX this doesn't handle content paths correctly
.path_to_disp <- function(pth) {
  if (length(pth) == 1) {
    return(pth)
  }
  has_cont <- any(pth == "@content")
  if (has_cont) {
    contpos <- which(pth == "@content")
    cont_disp <- paste(tail(pth, length(pth) - contpos + 1),
      collapse = "->"
    )
    pth <- head(pth, contpos)
  } else {
    cont_disp <- character()
  }

  topaste <- character(0)
  fullpth <- pth
  while (length(pth) > 0) {
    if (length(pth) <= 1) {
      topaste <- c(topaste, pth)
      pth <- character()
    } else {
      topaste <- c(topaste, sprintf("%s[%s]", pth[1], pth[2]))
      pth <- tail(pth, -2)
    }
  }
  topaste <- c(topaste, cont_disp)
  paste(topaste, collapse = "->")
}

no_analyze_guess <- paste0(
  "Was this table created using ",
  "summarize_row_groups but no calls ",
  "to analyze?\n"
)

use_sanitize_msg <- paste("  Use sanitize_table_struct() to fix these issues")

make_degen_message <- function(degen_pths, tt) {
  msg <- sprintf(
    paste0(
      "Invalid table - found %d (sub)structures which contain no data rows.",
      "\n\tThe first occured at path:  %s"
    ),
    length(degen_pths), .path_to_disp(degen_pths[[1]])
  )
  if (length(degen_pths) == 1 && length(degen_pths[[1]]) == 1) {
    msg <- paste(msg, "  Likely Cause: Empty data or first row split on variable with only NA values",
      sep = "\n"
    )
  } else if (all(make_row_df(tt)$node_class %in% c("LabelRow", "ContentRow"))) {
    msg <- paste(msg, "  Cause: Layout did not contain any analyze() calls (only summarize_row_groups())",
      sep = "\n"
    )
  }
  msg <- paste(msg, use_sanitize_msg, sep = "\n")
  msg
}

#' @param warn_only (`flag`)\cr whether a warning should be thrown instead of an error. Defaults to `FALSE`.
#'
#' @rdname validate_table_struct
#' @export
assert_valid_table <- function(tt, warn_only = FALSE) {
  degen_pths <- find_degen_struct(tt)
  if (length(degen_pths) == 0) {
    return(TRUE)
  }

  ## we failed, now we build an informative error/warning message
  msg <- make_degen_message(degen_pths, tt)

  if (!warn_only) {
    stop(msg)
  }
  warning(msg)
  return(FALSE)
}

#' Sanitize degenerate table structures
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' Experimental function to correct structure of degenerate tables by adding messaging rows to empty sub-structures.
#'
#' @param tt (`TableTree`)\cr a `TableTree` object.
#' @param empty_msg (`string`)\cr the string which should be spanned across the inserted empty rows.
#'
#' @details
#' This function locates degenerate portions of the table (including the table overall in the case of a table with no
#' data rows) and inserts a row which spans all columns with the message `empty_msg` at each one, generating a table
#' guaranteed to be non-degenerate.
#'
#' @return If `tt` is already valid, it is returned unmodified. If `tt` is degenerate, a modified, non-degenerate
#' version of the table is returned.
#'
#' @examples
#' sanitize_table_struct(rtable("cool beans"))
#'
#' lyt <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   split_rows_by("SEX") %>%
#'   summarize_row_groups()
#'
#' ## Degenerate because it doesn't have any analyze calls -> no data rows
#' badtab <- build_table(lyt, DM)
#' sanitize_table_struct(badtab)
#'
#' @family table structure validation functions
#' @export
sanitize_table_struct <- function(tt, empty_msg = "-- This Section Contains No Data --") {
  rdf <- make_row_df(tt)

  emptyrow <- DataRow(
    vals = list(empty_msg),
    name = "empty_section",
    label = "",
    cspan = ncol(tt),
    cinfo = col_info(tt),
    format = "xx",
    table_inset = table_inset(tt)
  )
  degen_pths <- find_degen_struct(tt)

  if (identical(degen_pths, list("root"))) {
    tree_children(tt) <- list(empty_row = emptyrow)
    return(tt)
  }

  for (pth in degen_pths) {
    ## FIXME this shouldn't be necessary. why is it?
    tti <- tt_at_path(tt, path = pth)
    tree_children(tti) <- list(empty_section = emptyrow)
    tt_at_path(tt, path = pth) <- tti
  }
  tt
}

do_recursive_replace <- function(tab, path, incontent = FALSE, value) { ## rows = NULL,
  ## cols = NULL, value) {
  ## don't want this in the recursive function
  ## so thats why we have the do_ variant
  if (is.character(path) && length(path) > 1) {
    path <- as.list(path)
  }
  if (length(path) > 0 && path[[1]] == obj_name(tab)) {
    path <- path[-1]
  }
  recursive_replace(tab, path, value) ## incontent, rows, cols,value)
}

## different cases we want to support:
## 1. Replace entire children for a particular node/position in the tree
## 2. Replace entire rows at a particular (ElementaryTable) position within the
##   tree
## 3. Replace specific cell values within a set of row x column positions within
##   an ElementaryTable at a particular position within the tree
## 3. replace entire content table at a node position
## 4. replace entire rows within the content table at a particular node position
##   in the tree
## 5. replace data cell values for specific row/col positions within the content
##   table at a particular position within the tree

## XXX This is wrong, what happens if a split (or more accurately, value)
## happens more than once in the overall tree???
recursive_replace <- function(tab, path, value) { ## incontent = FALSE, rows = NULL, cols = NULL, value) {
  if (length(path) == 0) { ## done recursing
    ## if(is.null(rows) && is.null(cols)) { ## replacing whole subtree a this position
    ##     if(incontent) {
    ##         newkid = tab
    ##         content_table(newkid) = value
    ##     } else
    newkid <- value
    ## newkid has either thee content table
    ## replaced on the old kid or is the new
    ## kid
    #  } ## else { ## rows or cols (or both)  non-null
    ##     if(incontent) {
    ##         ctab = content_table(tab)
    ##         ctab[rows, cols] = value
    ##         content_table(tab) = ctab
    ##         newkid = tab

    ##     } else {
    ##         allkids = tree_children(tab)
    ##         stopifnot(are(allkids, "TableRow"))
    ##         newkid = tab
    ##         newkid[rows, cols] = value
    ##     }
    ## }
    newkid
  } else if (path[[1]] == "@content") {
    ctb <- content_table(tab)
    ctb <- recursive_replace(ctb,
      path = path[-1],
      ## rows = rows,
      ## cols = cols,
      value = value
    )
    content_table(tab) <- ctb
    tab
  } else { ## length(path) > 1, more recursing to do
    kidel <- path[[1]]
    ## broken up for debugabiliity, could be a single complex
    ## expression
    ## for now only the last step supports selecting
    ## multiple kids
    stopifnot(
      length(kidel) == 1,
      is.character(kidel) || is.factor(kidel)
    )
    knms <- names(tree_children(tab))
    if (!(kidel %in% knms)) {
      stop(sprintf("position element %s not in names of next level children", kidel))
    } else if (sum(kidel == knms) > 1) {
      stop(sprintf("position element %s appears more than once, not currently supported", kidel))
    }
    if (is.factor(kidel)) kidel <- levels(kidel)[kidel]
    newkid <- recursive_replace(
      tree_children(tab)[[kidel]],
      path[-1],
      ## incontent = incontent,
      ## rows = rows,
      ## cols = cols,
      value
    )
    tree_children(tab)[[kidel]] <- newkid
    tab
  }
}

coltree_split <- function(ctree) ctree@split

col_fnotes_at_path <- function(ctree, path, fnotes) {
  if (length(path) == 0) {
    col_footnotes(ctree) <- fnotes
    return(ctree)
  }

  if (identical(path[1], obj_name(coltree_split(ctree)))) {
    path <- path[-1]
  } else {
    stop(paste("Path appears invalid at step:", path[1]))
  }

  kids <- tree_children(ctree)
  kidel <- path[[1]]
  knms <- names(kids)
  stopifnot(kidel %in% knms)
  newkid <- col_fnotes_at_path(kids[[kidel]],
    path[-1],
    fnotes = fnotes
  )
  kids[[kidel]] <- newkid
  tree_children(ctree) <- kids
  ctree
}

#' Insert row at path
#'
#' Insert a row into an existing table directly before or directly after an existing data (i.e., non-content and
#' non-label) row, specified by its path.
#'
#' @inheritParams gen_args
#' @param after (`flag`)\cr whether `value` should be added as a row directly before (`FALSE`, the default) or after
#'   (`TRUE`) the row specified by `path`.
#'
#' @seealso [DataRow()], [rrow()]
#'
#' @examples
#' lyt <- basic_table() %>%
#'   split_rows_by("COUNTRY", split_fun = keep_split_levels(c("CHN", "USA"))) %>%
#'   analyze("AGE")
#'
#' tbl <- build_table(lyt, DM)
#'
#' tbl2 <- insert_row_at_path(
#'   tbl, c("COUNTRY", "CHN", "AGE", "Mean"),
#'   rrow("new row", 555)
#' )
#' tbl2
#'
#' tbl3 <- insert_row_at_path(tbl2, c("COUNTRY", "CHN", "AGE", "Mean"),
#'   rrow("new row redux", 888),
#'   after = TRUE
#' )
#' tbl3
#'
#' @export
setGeneric("insert_row_at_path",
  signature = c("tt", "value"),
  function(tt, path, value, after = FALSE) {
    standardGeneric("insert_row_at_path")
  }
)

#' @rdname insert_row_at_path
setMethod(
  "insert_row_at_path", c("VTableTree", "DataRow"),
  function(tt, path, value, after = FALSE) {
    if (no_colinfo(value)) {
      col_info(value) <- col_info(tt)
    } else {
      chk_compat_cinfos(tt, value)
    }
    ## retained for debugging
    origpath <- path # nolint
    idx_row <- tt_at_path(tt, path)
    if (!is(idx_row, "DataRow")) {
      stop(
        "path must resolve fully to a non-content data row. Insertion of ",
        "rows elsewhere in the tree is not currently supported."
      )
    }

    posnm <- tail(path, 1)

    path <- head(path, -1)

    subtt <- tt_at_path(tt, path)
    kids <- tree_children(subtt)
    ind <- which(names(kids) == posnm)
    if (length(ind) != 1L) {
      ## nocov start
      stop(
        "table children do not appear to be named correctly at this ",
        "path. This should not happen, please contact the maintainer of ",
        "rtables."
      )
      ## nocov end
    }
    if (after) {
      ind <- ind + 1
    }

    sq <- seq_along(kids)
    tree_children(subtt) <- c(
      kids[sq < ind],
      setNames(list(value), obj_name(value)),
      kids[sq >= ind]
    )
    tt_at_path(tt, path) <- subtt
    tt
  }
)

# nocov start
#' @rdname insert_row_at_path
setMethod(
  "insert_row_at_path", c("VTableTree", "ANY"),
  function(tt, path, value) {
    stop(
      "Currently only insertion of DataRow objects is supported. Got ",
      "object of class ", class(value), ". Please use rrow() or DataRow() ",
      "to construct your row before insertion."
    )
  }
)

# nocov end

#' Label at path
#'
#' Accesses or sets the label at a path.
#'
#' @inheritParams gen_args
#'
#' @details
#' If `path` resolves to a single row, the label for that row is retrieved or set. If, instead, `path` resolves to a
#' subtable, the text for the row-label associated with that path is retrieved or set. In the subtable case, if the
#' label text is set to a non-`NA` value, the `labelrow` will be set to visible, even if it was not before. Similarly,
#' if the label row text for a subtable is set to `NA`, the label row will bet set to non-visible, so the row will not
#' appear at all when the table is printed.
#'
#' @note When changing the row labels for content rows, it is important to path all the way to the *row*. Paths
#' ending in `"@content"` will not exhibit the behavior you want, and are thus an error. See [row_paths()] for help
#' determining the full paths to content rows.
#'
#' @examples
#' lyt <- basic_table() %>%
#'   split_rows_by("COUNTRY", split_fun = keep_split_levels(c("CHN", "USA"))) %>%
#'   analyze("AGE")
#'
#' tbl <- build_table(lyt, DM)
#'
#' label_at_path(tbl, c("COUNTRY", "CHN"))
#'
#' label_at_path(tbl, c("COUNTRY", "USA")) <- "United States"
#' tbl
#'
#' @export
label_at_path <- function(tt, path) {
  obj_label(tt_at_path(tt, path))
}

#' @export
#' @rdname label_at_path
`label_at_path<-` <- function(tt, path, value) {
  if (!is(tt, "VTableTree")) {
    stop("tt must be a TableTree or ElementaryTable object")
  }
  if (is.null(value) || is.na(value)) {
    value <- NA_character_
  }
  subt <- tt_at_path(tt, path)
  obj_label(subt) <- value
  tt_at_path(tt, path) <- subt
  tt
}

#' Access or set table elements at specified path
#'
#' @inheritParams gen_args
#' @param ... unused.
#'
#' @export
#' @rdname ttap
setGeneric("tt_at_path", function(tt, path, ...) standardGeneric("tt_at_path"))

#' @inheritParams tt_at_path
#'
#' @export
#' @rdname int_methods
setMethod(
  "tt_at_path", "VTableTree",
  function(tt, path, ...) {
    stopifnot(
      is(path, "character"),
      length(path) > 0,
      !anyNA(path)
    )

    if (path[1] == "root" && obj_name(tt) != "root") {
      path <- path[-1]
    }
    ## handle pathing that hits the root split by name
    if (obj_name(tt) == path[1]) {
      path <- path[-1]
    }

    # Extract sub-tables from the tree
    .extract_through_path(tt, path)
  }
)

# Recursive helper function to retrieve sub-tables from the tree
## need to generalize this if we ever use it in a place other than tt_at_path
## currently tt_at_path doesn't support "*"
.extract_through_path <- function(cur_tbl, cur_path, no_stop = FALSE) {
  while (length(cur_path > 0)) {
    kids <- tree_children(cur_tbl)
    curname <- cur_path[1]
    kids_names <- sapply(kids, obj_name)
    if (curname == "@content") {
      cur_tbl <- content_table(cur_tbl)
    } else if (curname %in% kids_names) {
      ## we're now guarnateed that there will only be one match
      cur_tbl <- kids[kids_names == curname][[1]]
    } else if (!no_stop && curname == "*") {
      stop("Paths including '*' wildcards are not currently supported by tt_at_path.")
    } else if (!no_stop) {
      stop(
        "Path appears invalid for this tree at step '", curname, "'. Please use only",
        " row names and NOT row labels. You can retrieve them with `row_paths_summary()$path`."
      )
    } else {
      return(NULL)
    }
    cur_path <- cur_path[-1]
  }
  cur_tbl
}

tt_type_ok <- function(obj, type) {
  switch(type,
    any = TRUE,
    row = is(obj, "TableRow"),
    table = is(obj, "VTableTree"),
    elemtable = is(obj, "ElementaryTable")
  )
}

#' Pathing
#'
#' Pathing is a method of using known structure within a table
#' to specify elements within it in a self-describing, semantically
#' meaningful way.
#'
#' @details A Path consists of a character vector of one or more elements which
#'    will be used to descend the tree structure of a table's row or column space.
#'
#' Existing paths will match the layout used to make the table in the form of
#'    split, split-value pairs corresponding to facets generated by `split_rows_by*`
#'    and, elementary subtables generated by `analyze`, and rows generated by the
#'    afun used. Groups summaries generated by `summarize_row_groups` are represented
#'    by the 'content table' attached to a subtable representing a facet generated
#'    by a `split_rows_by` instruction, and are addressed via `@content` instead
#'    of their name.
#'
#' For example, given the code
#' \preformatted{
#' lyt <- basic_table() |>
#'   split_rows_by("ARM") |>
#'   split_rows_by("RACE") |>
#'   summarize_row_groups() |>
#'   analyze("SEX") |>
#'   analyze("AGE", nested = FALSE)
#'
#' tbl <- build_table(lyt, DM)
#' }
#'
#' We know that there will be two top-level subtables, one representing
#'   (and generated via) the split on the `ARM` variable, and one
#'   generated from the non-nested analyze on `AGE`. These can be be
#'   'pathed to' at `"ARM"` and `"AGE"`, respectively. Furthermore
#'   each value for `ARM` can be pathed to via, e.g.,  `c("ARM", "A: Drug X")`
#'   or more generally using the pathing wildcard `"*"` at `c("ARM", "*")`.
#'
#' A particular `SEX` analysis subtable, then, would be pathed to via the
#'   (row) path `c("ARM", "*", "RACE", "*", "SEX")`, e.g.
#'   `c("ARM", "B: Placebo", "RACE", "ASIAN", "SEX")`. The group-summary for
#'   Asians within the placebo group would be pathed to via
#'   `c("ARM", "B: Placebo", "RACE", "ASIAN", "@content")` for the table, and
#'   `c("ARM", "B: Placebo", "RACE", "ASIAN", "@content", "ASIAN")` for the
#'   row.
#'
#' @note some pathing-based functionality supports the "*" wildcard (typically
#'   'setters'/functionality which alters a table and returns it) while some
#'   does not (typically 'getters' which retrieve a subtable/row from a table
#'   or some attribute of that subtable/row).
#'
#' @note The `"*"` wildcard will never act as `"@content"` to step into
#'   a subtable's content table; that must be specified in the path, via
#'   e.g., `c("*", "*", "@content")` instead of `c("*", "*", "*")`.
#'
#' @description for `tt_row_path_exists`, tests whether a single path (potentially
#'    including `"*"` wildcards) resolves to at least one element satisfying
#'    `tt_type` (if specified).
#' @inheritParams gen_args
#' @return For `tt_row_path_exists`: `TRUE` if the path resolves to at least one
#'     substructure (subtable or row) that satisfies `tt_type`, or if the
#'     path is length 0; `FALSE` otherwise
#' @export
#' @examples
#' lyt <- basic_table() |>
#'   split_rows_by("ARM") |>
#'   split_rows_by("STRATA1") |>
#'   analyze("SEX") |>
#'   analyze("SEX", nested = FALSE)
#' tbl <- build_table(lyt, DM)
#' tt_row_path_exists(tbl, c("root", "ARM", "*", "*", "*", "SEX")) # TRUE
#' tt_row_path_exists(tbl, c("ARM", "*", "*", "*", "SEX")) # TRUE
#' tt_row_path_exists(tbl, c("ARM", "*", "*", "SEX")) # FALSE
#' tt_row_path_exists(tbl, "FAKE") # FALSE
#' tt_row_path_exists(tbl, c("ARM", "*", "STRATA1", "*", "SEX")) # TRUE
#' tt_row_path_exists(tbl, c("ARM", "*", "STRATA", "*", "SEX")) # FALSE
#' tt_row_path_exists(tbl, "SEX") # TRUE
#' tt_row_path_exists(tbl, "SEX", tt_type = "table") # TRUE
#' tt_row_path_exists(tbl, "SEX", tt_type = "elemtable") # TRUE
#' tt_row_path_exists(tbl, "SEX", tt_type = "row") # FALSE
#' tt_row_path_exists(tbl, c("SEX", "*")) # TRUE
tt_row_path_exists <- function(obj, path, tt_type = c("any", "row", "table", "elemtable")) {
  tt_type <- match.arg(tt_type)
  if (length(path) == 0) {
    ## we matched everything and called it again, evaluate type condition and return answer
    return(tt_type_ok(obj, tt_type))
  } else if (length(path) > 1 && (is.null(obj) || is(obj, "TableRow"))) {
    ## we got to a leaf node but still have >1 step remaining, path doesn't exist
    return(FALSE)
  }

  if (path[1] == "root") {
    path <- path[-1]
  }
  if (length(path) > 0 && path[1] == obj_name(obj)) {
    path <- path[-1] ## character()[-1] is just character() again so this is ok
  }

  ## annoying we have to do this again :-/
  if (length(path) == 0) {
    ## we matched everything and called it again, evaluate type condition and return answer
    return(tt_type_ok(obj, tt_type))
  }
  kids <- tree_children(obj)
  kidnms <- vapply(kids, obj_name, "")
  curpth <- path[1]
  nextpth <- path[-1]
  if (curpth == "*") {
    ret <- any(vapply(kids, tt_row_path_exists, path = nextpth, tt_type = tt_type, TRUE))
  } else if (curpth == "@content") {
    ctab <- content_table(obj)
    if (NROW(ctab) == 0) {
      return(FALSE)
    }
    ret <- tt_row_path_exists(ctab, nextpth, tt_type = tt_type)
  } else if (curpth %in% kidnms) {
    ret <- tt_row_path_exists(kids[[curpth]], nextpth, tt_type = tt_type)
  } else {
    ret <- FALSE
  }
  ret
}

#' @rdname tt_row_path_exists
#' @param .prev_path (`character`)\cr Internal implementation detail.
#'     Do not set manually.
#' @description Given a path with at least one wildcard (`"*"`) in it,
#'     `tt_normalize_path` walks the tree and generates the complete
#'     set of fully specified (ie no wildcards) paths which exist in
#'     the row structure of `obj`
#' @return for `tt_normalize_row_path`: a list of 0 or more fully
#'     specified paths which exist in the row structure of `obj` that
#'     match the original wildcard path, and which lead to an element
#'     of type `tt_type` (if specified other than `"any")`.
#' @export
#' @aliases pathing
#' @examples
#' tt_normalize_row_path(tbl, c("root", "ARM", "*", "*", "*", "SEX"))
#' tt_normalize_row_path(tbl, "SEX", tt_type = "row") # empty list
tt_normalize_row_path <- function(obj,
                                  path,
                                  .prev_path = character(),
                                  tt_type = c("any", "row", "table", "elemtable")) {
  if (length(path) == 0) {
    return(list(.prev_path))
  }
  tt_type <- match.arg(tt_type)
  if (!tt_row_path_exists(obj, path, tt_type = tt_type)) {
    return(list())
  }
  wcpos <- grep("^[*]$", path)
  if (length(wcpos) == 0) {
    return(list(c(.prev_path, path)))
  }

  befwc <- path[seq_len(wcpos[1] - 1)]
  if (length(befwc) > 0) {
    subtbl <- tt_at_path(obj, befwc)
  } else {
    subtbl <- obj
  }
  kids <- tree_children(subtbl)

  nextstps <- names(kids)
  aftrwc <- tail(path, -1 * wcpos[1])
  if (tt_type != "any") {
    if (length(aftrwc) > 0) {
      keep <- vapply(nextstps, function(nm) tt_row_path_exists(kids[[nm]], aftrwc, tt_type = tt_type), TRUE)
    } else {
      keep <- vapply(kids, tt_type_ok, tt_type = tt_type, TRUE)
    }
    nextstps <- nextstps[keep]
    if (length(nextstps) == 0) {
      return(list())
    }
    kids <- kids[keep]
  }
  unlist(
    recursive = FALSE,
    lapply(
      kids,
      function(kdi) {
        tt_normalize_row_path(kdi, path = aftrwc, .prev_path = c(.prev_path, befwc, obj_name(kdi)))
      }
    )
  )
}

## XXX TODO some other day tt_normalize_col_path

#' @note Setting `NULL` at a defined path removes the corresponding sub-table.
#'
#' @examples
#' # Accessing sub table.
#' lyt <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   split_rows_by("SEX") %>%
#'   split_rows_by("BMRKR2") %>%
#'   analyze("AGE")
#'
#' tbl <- build_table(lyt, ex_adsl) %>% prune_table()
#' sub_tbl <- tt_at_path(tbl, path = c("SEX", "F", "BMRKR2"))
#'
#' # Removing sub table.
#' tbl2 <- tbl
#' tt_at_path(tbl2, path = c("SEX", "F")) <- NULL
#' tbl2
#'
#' # Setting sub table.
#' lyt3 <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   split_rows_by("SEX") %>%
#'   analyze("BMRKR2")
#'
#' tbl3 <- build_table(lyt3, ex_adsl) %>% prune_table()
#'
#' tt_at_path(tbl3, path = c("SEX", "F", "BMRKR2")) <- sub_tbl
#' tbl3
#'
#' @export
#' @rdname ttap
setGeneric(
  "tt_at_path<-",
  function(tt, path, ..., value) standardGeneric("tt_at_path<-")
)

#' @export
#' @keywords internal
#' @rdname int_methods
setMethod(
  "tt_at_path<-", c(tt = "VTableTree", value = "VTableTree"),
  function(tt, path, ..., value) {
    do_recursive_replace(tt, path = path, value = value)
  }
)

## this one removes the child at path from the parents list of children,
## because that is how lists behave.
#' @export
#' @keywords internal
#' @rdname int_methods
setMethod(
  "tt_at_path<-", c(tt = "VTableTree", value = "NULL"),
  function(tt, path, ..., value) {
    do_recursive_replace(tt, path = path, value = value)
  }
)

#' @export
#' @keywords internal
#' @rdname int_methods
setMethod(
  "tt_at_path<-", c(tt = "VTableTree", value = "TableRow"),
  function(tt, path, ..., value) {
    stopifnot(is(tt_at_path(tt = tt, path = path), "TableRow"))
    do_recursive_replace(tt, path = path, value = value)

    ## ##i <- .path_to_pos(path = path, seq_len(nrow(tt)), tt, NROW)
    ## i <- .path_to_pos(path = path, tt = tt)

    ## replace_rows(tt, i = i, value = list(value))
  }
)

#' Retrieve and assign elements of a `TableTree`
#'
#' @param x (`TableTree`)\cr a `TableTree` object.
#' @param i (`numeric(1)`)\cr index.
#' @param j (`numeric(1)`)\cr index.
#' @param drop (`flag`)\cr whether the value in the cell should be returned if one cell is selected by the
#'   combination of `i` and `j`. It is not possible to return a vector of values. To do so please consider using
#'   [cell_values()]. Defaults to `FALSE`.
#' @param ... additional arguments. Includes:
#'   \describe{
#'     \item{`keep_topleft`}{(`flag`) (`[` only) whether the top-left material for the table should be retained after
#'       subsetting. Defaults to `TRUE` if all rows are included (i.e. subsetting was by column), and drops it
#'       otherwise.}
#'     \item{`keep_titles`}{(`flag`) whether title information should be retained. Defaults to `FALSE`.}
#'     \item{`keep_footers`}{(`flag`) whether non-referential footer information should be retained. Defaults to
#'       `keep_titles`.}
#'     \item{`reindex_refs`}{(`flag`) whether referential footnotes should be re-indexed as if the resulting subset is
#'       the entire table. Defaults to `TRUE`.}
#'   }
#' @param value (`list`, `TableRow`, or `TableTree`)\cr replacement value.
#'
#' @details
#' By default, subsetting drops the information about title, subtitle, main footer, provenance footer, and `topleft`.
#' If only a column is selected and all rows are kept, the `topleft` information remains as default. Any referential
#' footnote is kept whenever the subset table contains the referenced element.
#'
#' @return A `TableTree` (or `ElementaryTable`) object, unless a single cell was selected with `drop = TRUE`, in which
#'   case the (possibly multi-valued) fully stripped raw value of the selected cell.
#'
#' @note
#' Subsetting always preserve the original order, even if provided indexes do not preserve it. If sorting is needed,
#' please consider using `sort_at_path()`. Also note that `character` indices are treated as paths, not vectors of
#' names in both `[` and `[<-`.
#'
#' @seealso
#' * [sort_at_path()] to understand sorting.
#' * [summarize_row_groups()] to understand path structure.
#'
#' @examples
#' lyt <- basic_table(
#'   title = "Title",
#'   subtitles = c("Sub", "titles"),
#'   prov_footer = "prov footer",
#'   main_footer = "main footer"
#' ) %>%
#'   split_cols_by("ARM") %>%
#'   split_rows_by("SEX") %>%
#'   analyze(c("AGE"))
#'
#' tbl <- build_table(lyt, DM)
#' top_left(tbl) <- "Info"
#' tbl
#'
#' # As default header, footer, and topleft information is lost
#' tbl[1, ]
#' tbl[1:2, 2]
#'
#' # Also boolean filters can work
#' tbl[, c(FALSE, TRUE, FALSE)]
#'
#' # If drop = TRUE, the content values are directly retrieved
#' tbl[2, 1]
#' tbl[2, 1, drop = TRUE]
#'
#' # Drop works also if vectors are selected, but not matrices
#' tbl[, 1, drop = TRUE]
#' tbl[2, , drop = TRUE]
#' tbl[1, 1, drop = TRUE] # NULL because it is a label row
#' tbl[2, 1:2, drop = TRUE] # vectors can be returned only with cell_values()
#' tbl[1:2, 1:2, drop = TRUE] # no dropping because it is a matrix
#'
#' # If all rows are selected, topleft is kept by default
#' tbl[, 2]
#' tbl[, 1]
#'
#' # It is possible to deselect values
#' tbl[-2, ]
#' tbl[, -1]
#'
#' # Values can be reassigned
#' tbl[4, 2] <- rcell(999, format = "xx.x")
#' tbl[2, ] <- list(rrow("FFF", 888, 666, 777))
#' tbl[6, ] <- list(-111, -222, -333)
#' tbl
#'
#' # We can keep some information from the original table if we need
#' tbl[1, 2, keep_titles = TRUE]
#' tbl[1, 2, keep_footers = TRUE, keep_titles = FALSE]
#' tbl[1, 2, keep_footers = FALSE, keep_titles = TRUE]
#' tbl[1, 2, keep_footers = TRUE]
#' tbl[1, 2, keep_topleft = TRUE]
#'
#' # Keeps the referential footnotes when subset contains them
#' fnotes_at_path(tbl, rowpath = c("SEX", "M", "AGE", "Mean")) <- "important"
#' tbl[4, 1]
#' tbl[2, 1] # None present
#'
#' # We can reindex referential footnotes, so that the new table does not depend
#' #  on the original one
#' fnotes_at_path(tbl, rowpath = c("SEX", "U", "AGE", "Mean")) <- "important"
#' tbl[, 1] # both present
#' tbl[5:6, 1] # {1} because it has been indexed again
#' tbl[5:6, 1, reindex_refs = FALSE] # {2} -> not reindexed
#'
#' # Note that order can not be changed with subsetting
#' tbl[c(4, 3, 1), c(3, 1)] # It preserves order and wanted selection
#'
#' @name brackets
NULL

#' @exportMethod [<-
#' @rdname brackets
setMethod(
  "[<-", c("VTableTree", value = "list"),
  function(x, i, j, ..., value) {
    nr <- nrow(x)
    if (missing(i)) {
      i <- seq_len(NROW(x))
    } else if (is(i, "character")) {
      i <- .path_to_pos(i, x)
    } else {
      i <- .j_to_posj(i, nr)
    }

    if (missing(j)) {
      j <- seq_along(col_exprs(col_info(x)))
    } else if (is(j, "character")) {
      j <- .path_to_pos(j, x, cols = TRUE)
    } else {
      j <- .j_to_posj(j, ncol(x))
    }

    if (length(i) > 1 && length(j) < ncol(x)) {
      stop("cannot modify multiple rows in not all columns.")
    }

    if (are(value, "TableRow")) {
      value <- rep(value, length.out = length(i))
    } else {
      value <- rep(value, length.out = length(i) * length(j))
    }

    counter <- 0
    ## this has access to value, i, and j by scoping
    replace_rowsbynum <- function(x, i, valifnone = NULL) {
      maxi <- max(i)
      if (counter >= maxi) {
        return(valifnone)
      }

      if (labelrow_visible(x)) {
        counter <<- counter + 1
        if (counter %in% i) {
          nxtval <- value[[1]]
          if (is(nxtval, "LabelRow")) {
            tt_labelrow(x) <- nxtval
          } else {
            stop(
              "can't replace label with value of class",
              class(nxtval)
            )
          }
          ## we're done with this one move to
          ## the next
          value <<- value[-1]
        }
      }
      if (is(x, "TableTree") && nrow(content_table(x)) > 0) {
        ctab <- content_table(x)

        content_table(x) <- replace_rowsbynum(ctab, i)
      }
      if (counter >= maxi) { # already done
        return(x)
      }
      kids <- tree_children(x)

      if (length(kids) > 0) {
        for (pos in seq_along(kids)) {
          curkid <- kids[[pos]]
          if (is(curkid, "TableRow")) {
            counter <<- counter + 1
            if (counter %in% i) {
              nxtval <- value[[1]]
              if (is(nxtval, class(curkid))) {
                if (no_colinfo(nxtval) && length(row_values(nxtval)) == ncol(x)) {
                  col_info(nxtval) <- col_info(x)
                }
                stopifnot(identical(col_info(x), col_info(nxtval)))
                curkid <- nxtval
                value <- value[-1]
              } else {
                if (is(nxtval, "CellValue")) {
                  rcs <- row_cells(curkid)
                  rcs[j] <- value[seq_along(j)]
                  row_cells(curkid) <- rcs
                } else {
                  rvs <- row_values(curkid)
                  rvs[j] <- value[seq_along(j)]
                  row_values(curkid) <- rvs
                }
                value <- value[-(seq_along(j))]
              }
              kids[[pos]] <- curkid
            }
          } else {
            kids[[pos]] <- replace_rowsbynum(curkid, i)
          }
          if (counter >= maxi) {
            break
          }
        }
      }
      tree_children(x) <- kids
      x
    }
    replace_rowsbynum(x, i, ...)
  }
)

#' @inheritParams brackets
#'
#' @exportMethod [<-
#' @rdname int_methods
#' @keywords internal
setMethod(
  "[<-", c("VTableTree", value = "CellValue"),
  function(x, i, j, ..., value) {
    x[i = i, j = j, ...] <- list(value)
    x
  }
)

## this is going to be hard :( :( :(

### selecting/removing columns

## we have two options here: path like we do with rows and positional
## in leaf space.
#' Subset a table or row to particular columns
#' @inheritParams gen_args
#' @inheritParams brackets
#' @inheritParams head
#' @param j (`integer`, `logical` or `character`)\cr The column(s) to subset `tt`
#'   down to. Character vectors are interpreted as a *column path*, not as names.
#'   Path can include `"*"` wildcards.
#' @param newcinfo (`NULL` or `InstantiatedColumnInfo`)\cr The new column info,
#'   if precomputed. Generally should not be manually set by users.
#' @param ... Ignored.
#'
#' @examples
#' lyt <- basic_table(
#'   title = "Title",
#'   subtitles = c("Sub", "titles"),
#'   prov_footer = "prov footer",
#'   main_footer = "main footer"
#' ) %>%
#'   split_cols_by("ARM") %>%
#'   split_cols_by("SEX") %>%
#'   analyze(c("AGE"))
#'
#' tbl <- build_table(lyt, DM)
#'
#' subset_cols(tbl, c(1, 3))
#' subset_cols(tbl, c("ARM", "*", "SEX", "F"))
#' @export
setGeneric(
  "subset_cols",
  function(tt,
           j,
           newcinfo = NULL,
           keep_topleft = TRUE,
           keep_titles = TRUE,
           keep_footers = keep_titles,
           ...) {
    standardGeneric("subset_cols")
  }
)

#' @exportMethod subset_cols
#' @rdname subset_cols
setMethod(
  "subset_cols", c("TableTree", "numeric"),
  function(tt, j, newcinfo = NULL,
           keep_topleft, keep_titles, keep_footers, ...) {
    j <- .j_to_posj(j, ncol(tt))
    if (is.null(newcinfo)) {
      cinfo <- col_info(tt)
      newcinfo <- subset_cols(cinfo, j,
        keep_topleft = keep_topleft, ...
      )
    }
    ## topleft taken care of in creation of newcinfo
    kids <- tree_children(tt)
    newkids <- lapply(kids, subset_cols, j = j, newcinfo = newcinfo, ...)
    cont <- content_table(tt)
    newcont <- subset_cols(cont, j, newcinfo = newcinfo, ...)
    tt2 <- tt
    col_info(tt2) <- newcinfo
    content_table(tt2) <- newcont
    tree_children(tt2) <- newkids
    tt_labelrow(tt2) <- subset_cols(tt_labelrow(tt2), j, newcinfo, ...)

    tt2 <- .h_copy_titles_footers_topleft(
      tt2, tt,
      keep_titles,
      keep_footers,
      keep_topleft
    )
    tt2
  }
)

#' @exportMethod subset_cols
#' @rdname subset_cols
setMethod(
  "subset_cols", c("ElementaryTable", "numeric"),
  function(tt, j, newcinfo = NULL,
           keep_topleft, keep_titles, keep_footers, ...) {
    j <- .j_to_posj(j, ncol(tt))
    if (is.null(newcinfo)) {
      cinfo <- col_info(tt)
      newcinfo <- subset_cols(cinfo, j,
        keep_topleft = keep_topleft,
        keep_titles = keep_titles,
        keep_footers = keep_footers, ...
      )
    }
    ## topleft handled in creation of newcinfo
    kids <- tree_children(tt)
    newkids <- lapply(kids, subset_cols, j = j, newcinfo = newcinfo, ...)
    tt2 <- tt
    col_info(tt2) <- newcinfo
    tree_children(tt2) <- newkids
    tt_labelrow(tt2) <- subset_cols(tt_labelrow(tt2), j, newcinfo, ...)
    tt2 <- .h_copy_titles_footers_topleft(
      tt2, tt,
      keep_titles,
      keep_footers,
      keep_topleft
    )
    tt2
  }
)

## small utility to transform any negative
## indices into positive ones, given j
## and total length

.j_to_posj <- function(j, n) {
  ## This will work for logicals, numerics, integers
  j <- seq_len(n)[j]
  j
}

path_collapse_sep <- "`"
escape_name_padding <- function(x) {
  ## ret <- gsub("[", "\\[", x, fixed = TRUE)
  ## ret <- gsub("]", "\\]", ret, fixed = TRUE)
  ## ret <- gsub(".", "\\.", ret, fixed = TRUE)
  chars <- strsplit(x, "")[[1]]
  ret <- paste0("[", chars, "]", collapse = "")
  ret
}

path_to_regex <- function(path) {
  paste(vapply(path, function(x) {
    if (identical(x, "*")) {
      paste0("[^", path_collapse_sep, "]+")
    } else {
      escape_name_padding(x)
    }
  }, ""), collapse = path_collapse_sep)
}

.path_to_pos <- function(path, tt, distinct_ok = TRUE, cols = FALSE) {
  path <- path[!grepl("^(|root)$", path)]
  if (cols) {
    rowdf <- make_col_df(tt)
  } else {
    rowdf <- make_row_df(tt)
  }
  if (length(path) == 0 || identical(path, "*") || identical(path, "root")) {
    return(seq(1, nrow(rowdf)))
  }

  paths <- rowdf$path
  pathregex <- path_to_regex(path)
  pathstrs <- vapply(paths, paste, "", collapse = path_collapse_sep)
  allmatchs <- grep(pathregex, pathstrs)
  if (length(allmatchs) == 0) {
    stop(
      if (cols) "column path [" else "row path [",
      paste(path, collapse = "->"),
      "] does not appear valid for this table"
    )
  }

  idxdiffs <- diff(allmatchs)
  if (!distinct_ok && length(idxdiffs) > 0 && any(idxdiffs > 1)) {
    firstnon <- min(which(idxdiffs > 1))
    ## its firstnon here because we would want firstnon-1 but
    ## the diffs are actually shifted 1 so they cancel out
    allmatchs <- allmatchs[seq(1, firstnon)]
  }
  allmatchs
}

## fix column spans that would be invalid
## after some columns are no longer there
.fix_rowcspans <- function(rw, j) {
  cspans <- row_cspans(rw)
  nc <- sum(cspans)
  j <- .j_to_posj(j, nc)
  ## this is overly complicated
  ## we need the starting indices
  ## but the first span might not be 1, so
  ## we pad with 1 and then take off the last
  start <- cumsum(c(1, head(cspans, -1)))
  ends <- c(tail(start, -1) - 1, nc)
  res <- mapply(function(st, en) {
    sum(j >= st & j <= en)
  }, st = start, en = ends)
  res <- res[res > 0]
  stopifnot(sum(res) == length(j))
  res
}

select_cells_j <- function(cells, j) {
  if (length(j) != length(unique(j))) {
    stop("duplicate column selections is not currently supported")
  }
  spans <- vapply(
    cells, function(x) cell_cspan(x),
    integer(1)
  )
  inds <- rep(seq_along(cells), times = spans)
  selinds <- inds[j]
  retcells <- cells[selinds[!duplicated(selinds)]]
  newspans <- vapply(
    split(selinds, selinds),
    length,
    integer(1)
  )

  mapply(function(cl, sp) {
    cell_cspan(cl) <- sp
    cl
  }, cl = retcells, sp = newspans, SIMPLIFY = FALSE)
}

#' @exportMethod subset_cols
#' @rdname subset_cols
setMethod(
  "subset_cols", c("ANY", "character"),
  function(tt, j, newcinfo = NULL, keep_topleft = TRUE, ...) {
    j <- .path_to_pos(path = j, tt = tt, cols = TRUE)
    subset_cols(tt, j, newcinfo = newcinfo, keep_topleft = keep_topleft, ...)
  }
)

#' @exportMethod subset_cols
#' @rdname subset_cols
setMethod(
  "subset_cols", c("TableRow", "numeric"),
  function(tt, j, newcinfo = NULL, keep_topleft = TRUE, ...) {
    j <- .j_to_posj(j, ncol(tt))
    if (is.null(newcinfo)) {
      cinfo <- col_info(tt)
      newcinfo <- subset_cols(cinfo, j, keep_topleft = keep_topleft, ...)
    }
    tt2 <- tt
    row_cells(tt2) <- select_cells_j(row_cells(tt2), j)

    if (length(row_cspans(tt2)) > 0) {
      row_cspans(tt2) <- .fix_rowcspans(tt2, j)
    }
    col_info(tt2) <- newcinfo
    tt2
  }
)

#' @exportMethod subset_cols
#' @rdname subset_cols
setMethod(
  "subset_cols", c("LabelRow", "numeric"),
  function(tt, j, newcinfo = NULL, keep_topleft = TRUE, ...) {
    j <- .j_to_posj(j, ncol(tt))
    if (is.null(newcinfo)) {
      cinfo <- col_info(tt)
      newcinfo <- subset_cols(cinfo, j, keep_topleft = keep_topleft, ...)
    }
    col_info(tt) <- newcinfo
    tt
  }
)

#' @exportMethod subset_cols
#' @rdname subset_cols
setMethod(
  "subset_cols", c("InstantiatedColumnInfo", "numeric"),
  function(tt, j, newcinfo = NULL, keep_topleft = TRUE, ...) {
    if (!is.null(newcinfo)) {
      return(newcinfo)
    }
    j <- .j_to_posj(j, length(col_exprs(tt)))
    newctree <- subset_cols(coltree(tt), j, NULL)
    newcextra <- col_extra_args(tt)[j]
    newcsubs <- col_exprs(tt)[j]
    newcounts <- col_counts(tt)[j]
    tl <- if (keep_topleft) top_left(tt) else character()
    InstantiatedColumnInfo(
      treelyt = newctree,
      csubs = newcsubs,
      extras = newcextra,
      cnts = newcounts,
      dispcounts = disp_ccounts(tt),
      countformat = colcount_format(tt),
      topleft = tl
    )
  }
)

#' @exportMethod subset_cols
#' @rdname subset_cols
setMethod(
  "subset_cols", c("LayoutColTree", "numeric"),
  function(tt, j, newcinfo = NULL, ...) {
    lst <- collect_leaves(tt)
    j <- .j_to_posj(j, length(lst))

    ## j has only non-negative values from
    ## this point on
    counter <- 0
    prune_children <- function(x, j) {
      kids <- tree_children(x)
      newkids <- kids
      for (i in seq_along(newkids)) {
        if (is(newkids[[i]], "LayoutColLeaf")) {
          counter <<- counter + 1
          if (!(counter %in% j)) {
            newkids[[i]] <- list()
          } ## NULL removes the position entirely
        } else {
          newkids[[i]] <- prune_children(newkids[[i]], j)
        }
      }

      newkids <- newkids[sapply(newkids, function(thing) length(thing) > 0)]
      if (length(newkids) > 0) {
        tree_children(x) <- newkids
        x
      } else {
        list()
      }
    }
    prune_children(tt, j)
  }
)

## label rows ARE included in the count
subset_by_rownum <- function(tt,
                             i,
                             keep_topleft = FALSE,
                             keep_titles = TRUE,
                             keep_footers = keep_titles,
                             ...) {
  stopifnot(is(tt, "VTableNodeInfo"))
  counter <- 0
  nr <- nrow(tt)
  i <- .j_to_posj(i, nr)
  if (length(i) == 0) {
    ret <- TableTree(cinfo = col_info(tt))
    if (isTRUE(keep_topleft)) {
      top_left(ret) <- top_left(tt)
    }
    if (isTRUE(keep_titles)) {
      main_title(ret) <- main_title(tt)
      subtitles(ret) <- subtitles(tt)
    }
    if (isTRUE(keep_footers)) {
      main_footer(ret) <- main_footer(tt)
      prov_footer(ret) <- prov_footer(tt)
    }
    return(ret)
  }

  prune_rowsbynum <- function(x, i, valifnone = NULL) {
    maxi <- max(i)
    if (counter > maxi) {
      return(valifnone)
    }

    if (labelrow_visible(x)) {
      counter <<- counter + 1
      if (!(counter %in% i)) {
        ## XXX this should do whatever
        ## is required to 'remove' the Label Row
        ## (currently implicit based on
        ## the value of the label but
        ## that shold really probably change)
        labelrow_visible(x) <- FALSE
      }
    }
    if (is(x, "TableTree") && nrow(content_table(x)) > 0) {
      ctab <- content_table(x)

      content_table(x) <- prune_rowsbynum(ctab, i,
        valifnone = ElementaryTable(
          cinfo = col_info(ctab),
          iscontent = TRUE
        )
      )
    }
    kids <- tree_children(x)
    if (counter > maxi) { # already done
      kids <- list()
    } else if (length(kids) > 0) {
      for (pos in seq_along(kids)) {
        if (is(kids[[pos]], "TableRow")) {
          counter <<- counter + 1
          if (!(counter %in% i)) {
            kids[[pos]] <- list()
          }
        } else {
          kids[[pos]] <- prune_rowsbynum(kids[[pos]], i, list())
        }
      }
      kids <- kids[sapply(kids, function(x) NROW(x) > 0)]
    }
    ## avoid lintr styler disagreement
    nokids <- length(kids) == 0 &&
      NROW(content_table(x)) == 0 &&
      !labelrow_visible(x)
    if (nokids) {
      valifnone
    } else {
      tree_children(x) <- kids
      x
    }
  }
  ret <- prune_rowsbynum(tt, i)

  ret <- .h_copy_titles_footers_topleft(
    ret, tt,
    keep_titles,
    keep_footers,
    keep_topleft
  )

  ret
}

#' @exportMethod [
#' @rdname brackets
setMethod(
  "[", c("VTableTree", "logical", "logical"),
  function(x, i, j, ..., drop = FALSE) {
    i <- .j_to_posj(i, nrow(x))
    j <- .j_to_posj(j, ncol(x))
    x[i, j, ..., drop = drop]
  }
)

#' @exportMethod [
#' @rdname int_methods
#' @keywords internal
setMethod(
  "[", c("VTableTree", "logical", "ANY"),
  function(x, i, j, ..., drop = FALSE) {
    i <- .j_to_posj(i, nrow(x))
    x[i, j, ..., drop = drop]
  }
)

#' @exportMethod [
#' @rdname int_methods
#' @keywords internal
setMethod(
  "[", c("VTableTree", "logical", "missing"),
  function(x, i, j, ..., drop = FALSE) {
    j <- seq_len(ncol(x))
    i <- .j_to_posj(i, nrow(x))
    x[i, j, ..., drop = drop]
  }
)

#' @exportMethod [
#' @rdname int_methods
#' @keywords internal
setMethod(
  "[", c("VTableTree", "ANY", "logical"),
  function(x, i, j, ..., drop = FALSE) {
    j <- .j_to_posj(j, ncol(x))
    x[i, j, ..., drop = drop]
  }
)

#' @exportMethod [
#' @rdname int_methods
#' @keywords internal
setMethod(
  "[", c("VTableTree", "ANY", "missing"),
  function(x, i, j, ..., drop = FALSE) {
    j <- seq_len(ncol(x))
    x[i = i, j = j, ..., drop = drop]
  }
)

#' @exportMethod [
#' @rdname int_methods
#' @keywords internal
setMethod(
  "[", c("VTableTree", "missing", "ANY"),
  function(x, i, j, ..., drop = FALSE) {
    i <- seq_len(nrow(x))
    x[i = i, j = j, ..., drop = drop]
  }
)

#' @exportMethod [
#' @rdname int_methods
#' @keywords internal
setMethod(
  "[", c("VTableTree", "ANY", "character"),
  function(x, i, j, ..., drop = FALSE) {
    ## j <- .colpath_to_j(j, coltree(x))
    j <- .path_to_pos(path = j, tt = x, cols = TRUE)
    x[i = i, j = j, ..., drop = drop]
  }
)

#' @exportMethod [
#' @rdname int_methods
#' @keywords internal
setMethod(
  "[", c("VTableTree", "character", "ANY"),
  function(x, i, j, ..., drop = FALSE) {
    ## i <- .path_to_pos(i, seq_len(nrow(x)), x, NROW)
    i <- .path_to_pos(i, x)
    x[i = i, j = j, ..., drop = drop]
  }
)

#' @exportMethod [
#' @rdname int_methods
#' @keywords internal
setMethod(
  "[", c("VTableTree", "character", "missing"),
  function(x, i, j, ..., drop = FALSE) {
    ## i <- .path_to_pos(i, seq_len(nrow(x)), x, NROW)
    j <- seq_len(ncol(x))
    i <- .path_to_pos(i, x)
    x[i = i, j = j, ..., drop = drop]
  }
)


## to avoid dispatch ambiguity. Not necessary, possibly not a good idea at all
#' @exportMethod [
#' @rdname int_methods
#' @keywords internal
setMethod(
  "[", c("VTableTree", "character", "character"),
  function(x, i, j, ..., drop = FALSE) {
    ## i <- .path_to_pos(i, seq_len(nrow(x)), x, NROW)
    i <- .path_to_pos(i, x)
    ## j <- .colpath_to_j(j, coltree(x))
    j <- .path_to_pos(path = j, tt = x, cols = TRUE)
    x[i = i, j = j, ..., drop = drop]
  }
)

#' @exportMethod [
#' @rdname int_methods
#' @keywords internal
setMethod(
  "[", c("VTableTree", "missing", "numeric"),
  function(x, i, j, ..., drop = FALSE) {
    i <- seq_len(nrow(x))
    x[i, j, ..., drop = drop]
  }
)

#' @exportMethod [
#' @rdname int_methods
#' @keywords internal
setMethod(
  "[", c("VTableTree", "numeric", "numeric"),
  function(x, i, j, ..., drop = FALSE) {
    ## have to do it this way because we can't add an argument since we don't
    ## own the generic declaration
    keep_topleft <- list(...)[["keep_topleft"]] %||% NA
    keep_titles <- list(...)[["keep_titles"]] %||% FALSE
    keep_footers <- list(...)[["keep_footers"]] %||% keep_titles
    reindex_refs <- list(...)[["reindex_refs"]] %||% TRUE

    if (length(j) == 0 || (length(j) == 1 && !is.na(j) && j == 0)) {
      stop("No column selected. Please consider using rtables::row.names(<tbl>) to get the row names.")
    }

    nr <- nrow(x)
    nc <- ncol(x)
    i <- .j_to_posj(i, nr)
    j <- .j_to_posj(j, nc)

    ##  if(!missing(i) && length(i) < nr) {
    if (length(i) < nr) { ## already populated by .j_to_posj
      keep_topleft <- isTRUE(keep_topleft)
      x <- subset_by_rownum(x, i,
        keep_topleft = keep_topleft,
        keep_titles = keep_titles,
        keep_footers = keep_footers
      )
    } else if (is.na(keep_topleft)) {
      keep_topleft <- TRUE
    }

    ##  if(!missing(j) && length(j) < nc)
    if (length(j) < nc) {
      x <- subset_cols(x, j,
        keep_topleft = keep_topleft,
        keep_titles = keep_titles,
        keep_footers = keep_footers
      )
    }

    # Dropping everything
    if (drop) {
      if (length(j) == 1L && length(i) == 1L) {
        rw <- collect_leaves(x, TRUE, TRUE)[[1]]
        if (is(rw, "LabelRow")) {
          warning(
            "The value selected with drop = TRUE belongs ",
            "to a label row. NULL will be returned"
          )
          x <- NULL
        } else {
          x <- row_values(rw)[[1]]
        }
      } else {
        warning(
          "Trying to drop more than one subsetted value. ",
          "We support this only with accessor function `cell_values()`. ",
          "No drop will be done at this time."
        )
        drop <- FALSE
      }
    }
    if (!drop) {
      if (!keep_topleft) {
        top_left(x) <- character()
      }
      if (reindex_refs) {
        x <- update_ref_indexing(x)
      }
    }
    x
  }
)

#' @importFrom utils compareVersion

setGeneric("tail", tail)

setMethod(
  "tail", "VTableTree",
  function(x, n = 6L, ...) {
    if (compareVersion("4.0.0", as.character(getRversion())) <= 0) {
      tail.matrix(x, n, keepnums = FALSE)
    } else {
      tail.matrix(x, n, addrownums = FALSE)
    }
  }
)

setGeneric("head", head)

setMethod(
  "head", "VTableTree",
  function(x, n = 6L, ...) {
    head.matrix(x, n)
  }
)

#' Retrieve cell values by row and column path
#'
#' @inheritParams gen_args
#' @param rowpath (`character`)\cr path in row-split space to the desired row(s). Can include `"@content"`.
#' @param colpath (`character`)\cr path in column-split space to the desired column(s). Can include `"*"`.
#' @param omit_labrows (`flag`)\cr whether label rows underneath `rowpath` should be omitted (`TRUE`, the default),
#'   or return empty lists of cell "values" (`FALSE`).
#'
#' @return
#' * `cell_values` returns a `list` (regardless of the type of value the cells hold). If `rowpath` defines a path to
#'   a single row, `cell_values` returns the list of cell values for that row, otherwise a list of such lists, one for
#'   each row captured underneath `rowpath`. This occurs after subsetting to `colpath` has occurred.
#' * `value_at` returns the "unwrapped" value of a single cell, or an error, if the combination of `rowpath` and
#'   `colpath` do not define the location of a single cell in `tt`.
#'
#' @note `cell_values` will return a single cell's value wrapped in a list. Use `value_at` to receive the "bare" cell
#'   value.
#'
#' @examples
#' lyt <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   split_cols_by("SEX") %>%
#'   split_rows_by("RACE") %>%
#'   summarize_row_groups() %>%
#'   split_rows_by("STRATA1") %>%
#'   analyze("AGE")
#'
#' @examplesIf require(dplyr)
#' library(dplyr) ## for mutate
#' tbl <- build_table(lyt, DM %>%
#'   mutate(SEX = droplevels(SEX), RACE = droplevels(RACE)))
#'
#' row_paths_summary(tbl)
#' col_paths_summary(tbl)
#'
#' cell_values(
#'   tbl, c("RACE", "ASIAN", "STRATA1", "B"),
#'   c("ARM", "A: Drug X", "SEX", "F")
#' )
#'
#' # it's also possible to access multiple values by being less specific
#' cell_values(
#'   tbl, c("RACE", "ASIAN", "STRATA1"),
#'   c("ARM", "A: Drug X", "SEX", "F")
#' )
#' cell_values(tbl, c("RACE", "ASIAN"), c("ARM", "A: Drug X", "SEX", "M"))
#'
#' ## any arm, male columns from the ASIAN content (i.e. summary) row
#' cell_values(
#'   tbl, c("RACE", "ASIAN", "@content"),
#'   c("ARM", "B: Placebo", "SEX", "M")
#' )
#' cell_values(
#'   tbl, c("RACE", "ASIAN", "@content"),
#'   c("ARM", "*", "SEX", "M")
#' )
#'
#' ## all columns
#' cell_values(tbl, c("RACE", "ASIAN", "STRATA1", "B"))
#'
#' ## all columns for the Combination arm
#' cell_values(
#'   tbl, c("RACE", "ASIAN", "STRATA1", "B"),
#'   c("ARM", "C: Combination")
#' )
#'
#' cvlist <- cell_values(
#'   tbl, c("RACE", "ASIAN", "STRATA1", "B", "AGE", "Mean"),
#'   c("ARM", "B: Placebo", "SEX", "M")
#' )
#' cvnolist <- value_at(
#'   tbl, c("RACE", "ASIAN", "STRATA1", "B", "AGE", "Mean"),
#'   c("ARM", "B: Placebo", "SEX", "M")
#' )
#' stopifnot(identical(cvlist[[1]], cvnolist))
#'
#' @rdname cell_values
#' @export
setGeneric("cell_values", function(tt, rowpath = NULL, colpath = NULL, omit_labrows = TRUE) {
  standardGeneric("cell_values")
})

#' @rdname int_methods
#' @keywords internal
#' @exportMethod cell_values
setMethod(
  "cell_values", "VTableTree",
  function(tt, rowpath, colpath = NULL, omit_labrows = TRUE) {
    .inner_cell_value(tt,
      rowpath = rowpath, colpath = colpath,
      omit_labrows = omit_labrows, value_at = FALSE
    )
  }
)

#' @rdname int_methods
#' @keywords internal
#' @exportMethod cell_values
setMethod(
  "cell_values", "TableRow",
  function(tt, rowpath, colpath = NULL, omit_labrows = TRUE) {
    if (!is.null(rowpath)) {
      stop("cell_values on TableRow objects must have NULL rowpath")
    }
    .inner_cell_value(tt,
      rowpath = rowpath, colpath = colpath,
      omit_labrows = omit_labrows, value_at = FALSE
    )
  }
)

#' @rdname int_methods
#' @keywords internal
#' @exportMethod cell_values
setMethod(
  "cell_values", "LabelRow",
  function(tt, rowpath, colpath = NULL, omit_labrows = TRUE) {
    stop("calling cell_values on LabelRow is not meaningful")
  }
)

#' @rdname cell_values
#' @export
setGeneric("value_at", function(tt, rowpath = NULL, colpath = NULL) {
  standardGeneric("value_at")
})

#' @rdname cell_values
#' @exportMethod value_at
setMethod(
  "value_at", "VTableTree",
  function(tt, rowpath, colpath = NULL) {
    .inner_cell_value(tt,
      rowpath = rowpath, colpath = colpath,
      omit_labrows = FALSE, value_at = TRUE
    )
  }
)

#' @rdname int_methods
#' @keywords internal
#' @exportMethod value_at
setMethod(
  "value_at", "TableRow",
  function(tt, rowpath, colpath = NULL) {
    .inner_cell_value(tt,
      rowpath = rowpath, colpath = colpath,
      omit_labrows = FALSE, value_at = TRUE
    )
  }
)

#' @rdname int_methods
#' @keywords internal
#' @exportMethod value_at
setMethod(
  "value_at", "LabelRow",
  function(tt, rowpath, colpath = NULL) {
    stop("calling value_at for LabelRow objects is not meaningful")
  }
)

.inner_cell_value <- function(tt,
                              rowpath,
                              colpath = NULL,
                              omit_labrows = TRUE,
                              value_at = FALSE) {
  if (is.null(rowpath)) {
    subtree <- tt
  } else {
    subtree <- tt_at_path(tt, rowpath)
  }
  if (!is.null(colpath)) {
    subtree <- subset_cols(subtree, colpath)
  }

  rows <- collect_leaves(subtree, TRUE, !omit_labrows)
  if (value_at && (ncol(subtree) != 1 || length(rows) != 1)) {
    stop("Combination of rowpath and colpath does not select individual cell.\n",
      "  To retrieve more than one cell value at a time use cell_values().",
      call. = FALSE
    )
  }
  if (length(rows) == 1) {
    ret <- row_values(rows[[1]])
    if (value_at && ncol(subtree) == 1) {
      ret <- ret[[1]]
    }
    ret
  } else {
    lapply(rows, row_values)
  }
}

## empty_table is created in onLoad because it depends on other things there.

# Helper function to copy or not header, footer, and topleft information
.h_copy_titles_footers_topleft <- function(new,
                                           old,
                                           keep_titles,
                                           keep_footers,
                                           keep_topleft,
                                           reindex_refs = FALSE,
                                           empt_tbl = empty_table) {
  ## Please note that the standard adopted come from an empty table

  # titles
  if (isTRUE(keep_titles)) {
    main_title(new) <- main_title(old)
    subtitles(new) <- subtitles(old)
  } else {
    main_title(new) <- main_title(empt_tbl)
    subtitles(new) <- subtitles(empt_tbl)
  }

  # fnotes
  if (isTRUE(keep_footers)) {
    main_footer(new) <- main_footer(old)
    prov_footer(new) <- prov_footer(old)
  } else {
    main_footer(new) <- main_footer(empt_tbl)
    prov_footer(new) <- prov_footer(empt_tbl)
  }

  # topleft
  if (isTRUE(keep_topleft)) {
    top_left(new) <- top_left(old)
  } else {
    top_left(new) <- top_left(empt_tbl)
  }

  # reindex references
  if (reindex_refs) {
    new <- update_ref_indexing(new)
  }

  new
}

#' Head and tail methods
#'
#' @inheritParams utils::head
#' @param keep_topleft (`flag`)\cr if `TRUE` (the default), top_left material for the table will be carried over to the
#'   subset.
#' @param keep_titles (`flag`)\cr if `TRUE` (the default), all title material for the table will be carried over to the
#'   subset.
#' @param keep_footers (`flag`)\cr if `TRUE`, all footer material for the table will be carried over to the subset. It
#'   defaults to `keep_titles`.
#' @param reindex_refs (`flag`)\cr defaults to `FALSE`. If `TRUE`, referential footnotes will be reindexed for the
#'   subset.
#'
#' @docType methods
#' @export
#' @rdname head_tail
setGeneric("head")

#' @docType methods
#' @export
#' @rdname head_tail
setMethod(
  "head", "VTableTree",
  function(x, n = 6, ..., keep_topleft = TRUE,
           keep_titles = TRUE,
           keep_footers = keep_titles,
           ## FALSE because this is a glance
           ## more often than a subset op
           reindex_refs = FALSE) {
    ## default
    res <- callNextMethod()
    res <- .h_copy_titles_footers_topleft(
      old = x, new = res,
      keep_topleft = keep_topleft,
      keep_titles = keep_titles,
      keep_footers = keep_footers,
      reindex_refs = reindex_refs
    )
    res
  }
)

#' @docType methods
#' @export
#' @rdname head_tail
setGeneric("tail")

#' @docType methods
#' @export
#' @rdname head_tail
setMethod(
  "tail", "VTableTree",
  function(x, n = 6, ..., keep_topleft = TRUE,
           keep_titles = TRUE,
           keep_footers = keep_titles,
           ## FALSE because this is a glance
           ## more often than a subset op
           reindex_refs = FALSE) {
    res <- callNextMethod()
    res <- .h_copy_titles_footers_topleft(
      old = x, new = res,
      keep_topleft = keep_topleft,
      keep_titles = keep_titles,
      keep_footers = keep_footers,
      reindex_refs = reindex_refs
    )
    res
  }
)

#' @import formatters
#' @importMethodsFrom formatters toString matrix_form nlines
NULL

# toString ----

## #' @export
## setGeneric("toString", function(x,...) standardGeneric("toString"))

## ## preserve S3 behavior
## setMethod("toString", "ANY", base::toString)

## #' @export
## setMethod("print", "ANY", base::print)

#' Convert an `rtable` object to a string
#'
#' @inheritParams formatters::toString
#' @inheritParams gen_args
#' @inherit formatters::toString
#'
#' @return A string representation of `x` as it appears when printed.
#'
#' @examplesIf require(dplyr)
#' library(dplyr)
#'
#' iris2 <- iris %>%
#'   group_by(Species) %>%
#'   mutate(group = as.factor(rep_len(c("a", "b"), length.out = n()))) %>%
#'   ungroup()
#'
#' lyt <- basic_table() %>%
#'   split_cols_by("Species") %>%
#'   split_cols_by("group") %>%
#'   analyze(c("Sepal.Length", "Petal.Width"), afun = list_wrap_x(summary), format = "xx.xx")
#'
#' tbl <- build_table(lyt, iris2)
#'
#' cat(toString(tbl, col_gap = 3))
#'
#' @rdname tostring
#' @aliases tostring toString,VTableTree-method
#' @exportMethod toString
setMethod("toString", "VTableTree", function(x,
                                             widths = NULL,
                                             col_gap = 3,
                                             hsep = horizontal_sep(x),
                                             indent_size = 2,
                                             tf_wrap = FALSE,
                                             max_width = NULL,
                                             fontspec = font_spec(),
                                             ttype_ok = FALSE,
                                             round_type = obj_round_type(x)) {
  toString(
    matrix_form(x,
      indent_rownames = TRUE,
      indent_size = indent_size,
      fontspec = fontspec,
      col_gap = col_gap,
      round_type = round_type
    ),
    widths = widths, col_gap = col_gap,
    hsep = hsep,
    tf_wrap = tf_wrap,
    max_width = max_width,
    fontspec = fontspec,
    ttype_ok = ttype_ok
  )
})

#' Table shells
#'
#' A table shell is a rendering of the table which maintains the structure, but does not display the values, rather
#' displaying the formatting instructions for each cell.
#'
#' @inheritParams formatters::toString
#' @inheritParams gen_args
#'
#' @return
#' * `table_shell` returns `NULL`, as the function is called for the side effect of printing the shell to the console.
#' * `table_shell_str` returns the string representing the table shell.
#'
#' @seealso [value_formats()] for a matrix of formats for each cell in a table.
#'
#' @examplesIf require(dplyr)
#' library(dplyr)
#'
#' iris2 <- iris %>%
#'   group_by(Species) %>%
#'   mutate(group = as.factor(rep_len(c("a", "b"), length.out = n()))) %>%
#'   ungroup()
#'
#' lyt <- basic_table() %>%
#'   split_cols_by("Species") %>%
#'   split_cols_by("group") %>%
#'   analyze(c("Sepal.Length", "Petal.Width"), afun = list_wrap_x(summary), format = "xx.xx")
#'
#' tbl <- build_table(lyt, iris2)
#' table_shell(tbl)
#'
#' @export
table_shell <- function(tt, widths = NULL, col_gap = 3, hsep = default_hsep(),
                        tf_wrap = FALSE, max_width = NULL) {
  cat(table_shell_str(
    tt = tt, widths = widths, col_gap = col_gap, hsep = hsep,
    tf_wrap = tf_wrap, max_width = max_width
  ))
}

## XXX consider moving to formatters, its really just a function
## of the MatrixPrintForm
#' @rdname table_shell
#' @export
table_shell_str <- function(tt, widths = NULL, col_gap = 3, hsep = default_hsep(),
                            tf_wrap = FALSE, max_width = NULL) {
  matform <- matrix_form(tt, indent_rownames = TRUE)
  format_strs <- vapply(
    as.vector(matform$formats),
    function(x) {
      if (inherits(x, "function")) {
        "<fnc>"
      } else if (inherits(x, "character")) {
        x
      } else {
        stop("Don't know how to make a shell with formats of class: ", class(x))
      }
    }, ""
  )

  format_strs_mat <- matrix(format_strs, ncol = ncol(matform$strings))
  format_strs_mat[, 1] <- matform$strings[, 1]
  nlh <- mf_nlheader(matform)
  format_strs_mat[seq_len(nlh), ] <- matform$strings[seq_len(nlh), ]

  matform$strings <- format_strs_mat
  if (is.null(widths)) {
    widths <- propose_column_widths(matform)
  }
  toString(matform,
    widths = widths, col_gap = col_gap, hsep = hsep,
    tf_wrap = tf_wrap, max_width = max_width
  )
}

#' Transform an `rtable` to a list of matrices which can be used for outputting
#'
#' Although `rtables` are represented as a tree data structure when outputting the table to ASCII or HTML
#' it is useful to map the `rtable` to an in-between state with the formatted cells in a matrix form.
#'
#' @inheritParams gen_args
#' @inheritParams formatters::format_value
#' @param indent_rownames (`flag`)\cr if `TRUE`, the column with the row names in the `strings` matrix of the output
#'   has indented row names (strings pre-fixed).
#' @param expand_newlines (`flag`)\cr whether the matrix form generated should expand rows whose values contain
#'   newlines into multiple 'physical' rows (as they will appear when rendered into ASCII). Defaults to `TRUE`.
#' @param fontspec (`font_spec`)\cr The font that should be used by default when
#'   rendering this `MatrixPrintForm` object, or NULL (the default).
#' @param col_gap (`numeric(1)`)]\cr The number of spaces (in the font specified
#'  by `fontspec`) that should be placed between columns when the table
#'  is rendered directly to text (e.g., by `toString` or `export_as_txt`). Defaults
#'  to `3`.
#'
#' @details
#' The strings in the return object are defined as follows: row labels are those determined by `make_row_df` and cell
#' values are determined using `get_formatted_cells`. (Column labels are calculated using a non-exported internal
#' function.
#'
#' @return A list with the following elements:
#'   \describe{
#'     \item{`strings`}{The content, as it should be printed, of the top-left material, column headers, row labels,
#'       and cell values of `tt`.}
#'     \item{`spans`}{The column-span information for each print-string in the `strings` matrix.}
#'     \item{`aligns`}{The text alignment for each print-string in the `strings` matrix.}
#'     \item{`display`}{Whether each print-string in the strings matrix should be printed.}
#'     \item{`row_info`}{The `data.frame` generated by `make_row_df`.}
#'   }
#'
#' With an additional `nrow_header` attribute indicating the number of pseudo "rows" that the column structure defines.
#'
#' @examplesIf require(dplyr)
#' library(dplyr)
#'
#' iris2 <- iris %>%
#'   group_by(Species) %>%
#'   mutate(group = as.factor(rep_len(c("a", "b"), length.out = n()))) %>%
#'   ungroup()
#'
#' lyt <- basic_table() %>%
#'   split_cols_by("Species") %>%
#'   split_cols_by("group") %>%
#'   analyze(c("Sepal.Length", "Petal.Width"),
#'     afun = list_wrap_x(summary), format = "xx.xx"
#'   )
#'
#' lyt
#'
#' tbl <- build_table(lyt, iris2)
#'
#' matrix_form(tbl)
#'
#' @export
setMethod(
  "matrix_form", "VTableTree",
  function(obj,
           indent_rownames = FALSE,
           expand_newlines = TRUE,
           indent_size = 2,
           fontspec = NULL,
           col_gap = 3L,
           round_type = obj_round_type(obj)) {
    new_dev <- open_font_dev(fontspec)
    if (new_dev) {
      on.exit(close_font_dev())
    }

    stopifnot(is(obj, "VTableTree"))
    check_ccount_vis_ok(obj)
    header_content <- .tbl_header_mat(obj) # first col are for row.names

    sr <- make_row_df(obj, fontspec = fontspec)

    body_content_strings <- if (NROW(sr) == 0) {
      character()
    } else {
      cbind(as.character(sr$label), get_formatted_cells(obj, round_type = round_type))
    }

    formats_strings <- if (NROW(sr) == 0) {
      character()
    } else {
      cbind("", get_formatted_cells(obj, shell = TRUE))
    }

    tsptmp <- lapply(collect_leaves(obj, TRUE, TRUE), function(rr) {
      sp <- row_cspans(rr)
      rep(sp, times = sp)
    })

    ## the 1 is for row labels
    body_spans <- if (nrow(obj) > 0) {
      cbind(1L, do.call(rbind, tsptmp))
    } else {
      matrix(1, nrow = 0, ncol = ncol(obj) + 1)
    }

    body_aligns <- if (NROW(sr) == 0) {
      character()
    } else {
      cbind("left", get_cell_aligns(obj))
    }

    body <- rbind(header_content$body, body_content_strings)

    hdr_fmt_blank <- matrix("",
      nrow = nrow(header_content$body),
      ncol = ncol(header_content$body)
    )
    if (disp_ccounts(obj)) {
      hdr_fmt_blank[nrow(hdr_fmt_blank), ] <- c("", rep(colcount_format(obj), ncol(obj)))
    }

    formats <- rbind(hdr_fmt_blank, formats_strings)

    spans <- rbind(header_content$span, body_spans)
    row.names(spans) <- NULL

    aligns <- rbind(
      matrix(rep("center", length(header_content$body)),
        nrow = nrow(header_content$body)
      ),
      body_aligns
    )

    aligns[, 1] <- "left" # row names and topleft (still needed for topleft)

    nr_header <- nrow(header_content$body)
    if (indent_rownames) {
      body[, 1] <- indent_string(body[, 1], c(rep(0, nr_header), sr$indent),
        incr = indent_size
      )
      # why also formats?
      formats[, 1] <- indent_string(formats[, 1], c(rep(0, nr_header), sr$indent),
        incr = indent_size
      )
    } else if (NROW(sr) > 0) {
      sr$indent <- rep(0, NROW(sr))
    }

    col_ref_strs <- matrix(vapply(header_content$footnotes, function(x) {
      if (length(x) == 0) {
        ""
      } else {
        paste(vapply(x, format_fnote_ref, ""), collapse = " ")
      }
    }, ""), ncol = ncol(body))
    body_ref_strs <- get_ref_matrix(obj)

    body <- matrix(
      paste0(
        body,
        rbind(
          col_ref_strs,
          body_ref_strs
        )
      ),
      nrow = nrow(body),
      ncol = ncol(body)
    )

    ref_fnotes <- get_formatted_fnotes(obj) # pagination will not count extra lines coming from here
    pag_titles <- page_titles(obj)

    MatrixPrintForm(
      strings = body,
      spans = spans,
      aligns = aligns,
      formats = formats,
      ## display = display, purely a function of spans, handled in constructor now
      row_info = sr,
      colpaths = make_col_df(obj)[["path"]],
      ## line_grouping handled internally now line_grouping = 1:nrow(body),
      ref_fnotes = ref_fnotes,
      nlines_header = nr_header, ## this is fixed internally
      nrow_header = nr_header,
      expand_newlines = expand_newlines,
      has_rowlabs = TRUE,
      has_topleft = TRUE,
      main_title = main_title(obj),
      subtitles = subtitles(obj),
      page_titles = pag_titles,
      main_footer = main_footer(obj),
      prov_footer = prov_footer(obj),
      table_inset = table_inset(obj),
      header_section_div = header_section_div(obj),
      horizontal_sep = horizontal_sep(obj),
      indent_size = indent_size,
      fontspec = fontspec,
      col_gap = col_gap,
      round_type = round_type
    )
  }
)


check_ccount_vis_ok <- function(tt) {
  ctree <- coltree(tt)
  tlkids <- tree_children(ctree)
  lapply(tlkids, ccvis_check_subtree)
  invisible(NULL)
}

ccvis_check_subtree <- function(ctree) {
  kids <- tree_children(ctree)
  if (is.null(kids)) {
    return(invisible(NULL))
  }
  vals <- vapply(kids, disp_ccounts, TRUE)
  if (length(unique(vals)) > 1) {
    unmatch <- which(!duplicated(vals))[1:2]
    stop(
      "Detected different colcount visibility among sibling facets (those ",
      "arising from the same split_cols_by* layout instruction). This is ",
      "not supported.\n",
      "Set count values to NA if you want a blank space to appear as the ",
      "displayed count for particular facets.\n",
      "First disagreement occured at paths:\n",
      .path_to_disp(pos_to_path(tree_pos(kids[[unmatch[1]]]))), "\n",
      .path_to_disp(pos_to_path(tree_pos(kids[[unmatch[2]]])))
    )
  }
  lapply(kids, ccvis_check_subtree)
  invisible(NULL)
}

.resolve_fn_symbol <- function(fn) {
  if (!is(fn, "RefFootnote")) {
    return(NULL)
  }
  ret <- ref_symbol(fn)
  if (is.na(ret)) {
    ret <- as.character(ref_index(fn))
  }
  ret
}

format_fnote_ref <- function(fn) {
  if (length(fn) == 0 || (is.list(fn) && all(vapply(fn, function(x) length(x) == 0, TRUE)))) {
    return("")
  } else if (is.list(fn) && all(vapply(fn, is.list, TRUE))) {
    return(vapply(fn, format_fnote_ref, ""))
  }
  if (is.list(fn)) {
    inds <- unlist(lapply(unlist(fn), .resolve_fn_symbol))
  } else {
    inds <- .resolve_fn_symbol(fn)
  }
  if (length(inds) > 0) {
    paste0(" {", paste(unique(inds), collapse = ", "), "}")
  } else {
    ""
  }
}

format_fnote_note <- function(fn) {
  if (length(fn) == 0 || (is.list(fn) && all(vapply(fn, function(x) length(x) == 0, TRUE)))) {
    return(character())
  }
  if (is.list(fn)) {
    return(unlist(lapply(unlist(fn), format_fnote_note)))
  }

  if (is(fn, "RefFootnote")) {
    paste0("{", .resolve_fn_symbol(fn), "} - ", ref_msg(fn))
  } else {
    NULL
  }
}

.fn_ind_extractor <- function(strs) {
  res <- suppressWarnings(as.numeric(gsub("\\{([[:digit:]]+)\\}.*", "\\1", strs)))
  res[res == "NA"] <- NA_character_
  ## these mixing is allowed now with symbols
  ## if(!(sum(is.na(res)) %in% c(0L, length(res))))
  ##     stop("Got NAs mixed with non-NAS for extracted footnote indices. This should not happen")
  res
}

get_ref_matrix <- function(tt) {
  if (ncol(tt) == 0 || nrow(tt) == 0) {
    return(matrix("", nrow = nrow(tt), ncol = ncol(tt) + 1L))
  }
  rows <- collect_leaves(tt, incl.cont = TRUE, add.labrows = TRUE)
  lst <- unlist(lapply(rows, cell_footnotes), recursive = FALSE)
  cstrs <- unlist(lapply(lst, format_fnote_ref))
  bodymat <- matrix(cstrs,
    byrow = TRUE,
    nrow = nrow(tt),
    ncol = ncol(tt)
  )
  cbind(vapply(rows, function(rw) format_fnote_ref(row_footnotes(rw)), ""), bodymat)
}

get_formatted_fnotes <- function(tt) {
  colresfs <- unlist(make_col_df(tt, visible_only = FALSE)$col_fnotes)
  rows <- collect_leaves(tt, incl.cont = TRUE, add.labrows = TRUE)
  lst <- c(
    colresfs,
    unlist(
      lapply(rows, function(r) unlist(c(row_footnotes(r), cell_footnotes(r)), recursive = FALSE)),
      recursive = FALSE
    )
  )

  inds <- vapply(lst, ref_index, 1L)
  ord <- order(inds)
  lst <- lst[ord]
  syms <- vapply(lst, ref_symbol, "")
  keep <- is.na(syms) | !duplicated(syms)
  lst <- lst[keep]
  unique(vapply(lst, format_fnote_note, ""))

  ##                    , recursive = FALSE)
  ## rlst <- unlist(lapply(rows, row_footnotes))
  ## lst <-
  ## syms <- vapply(lst, ref_symbol, "")
  ## keep <- is.na(syms) | !duplicated(syms)
  ## lst <- lst[keep]
  ## inds <- vapply(lst, ref_index, 1L)
  ## cellstrs <- unlist(lapply(lst, format_fnote_note))
  ## rstrs <- unlist(lapply(rows, function(rw) format_fnote_note(row_footnotes(rw))))
  ## allstrs <- c(colstrs, rstrs, cellstrs)
  ## inds <- .fn_ind_extractor(allstrs)
  ## allstrs[order(inds)]
}

.do_tbl_h_piece2 <- function(tt) {
  coldf <- make_col_df(tt, visible_only = FALSE)
  remain <- seq_len(nrow(coldf))
  chunks <- list()
  cur <- 1
  na_str <- colcount_na_str(tt)

  ## XXX this would be better as the facet-associated
  ## format but I don't know that we need to
  ## support that level of differentiation anyway...
  cc_format <- colcount_format(tt)
  ## each iteration of this loop identifies
  ## all rows corresponding to one top-level column
  ## label and its children, then processes those
  ## with .do_header_chunk
  while (length(remain) > 0) {
    rw <- remain[1]
    inds <- coldf$leaf_indices[[rw]]
    endblock <- which(coldf$abs_pos == max(inds))

    stopifnot(endblock >= rw)
    chunk_res <- .do_header_chunk(coldf[rw:endblock, ], cc_format, na_str = na_str)
    chunk_res <- unlist(chunk_res, recursive = FALSE)
    chunks[[cur]] <- chunk_res
    remain <- remain[remain > endblock]
    cur <- cur + 1
  }
  chunks <- .pad_tops(chunks)
  lapply(
    seq_along(chunks[[1]]),
    function(i) {
      DataRow(unlist(lapply(chunks, `[[`, i), recursive = FALSE))
    }
  )
}

.pad_end <- function(lst, padto, ncols) {
  curcov <- sum(vapply(lst, cell_cspan, 0L))
  if (curcov == padto) {
    return(lst)
  }

  c(lst, list(rcell("", colspan = padto - curcov)))
}

.pad_tops <- function(chunks) {
  lens <- vapply(chunks, length, 1L)
  padto <- max(lens)
  needpad <- lens != padto
  if (all(!needpad)) {
    return(chunks)
  }

  for (i in seq_along(lens)) {
    if (lens[i] < padto) {
      chk <- chunks[[i]]
      span <- sum(vapply(chk[[length(chk)]], cell_cspan, 1L))
      chunks[[i]] <- c(
        replicate(list(list(rcell("", colspan = span))),
          n = padto - lens[i]
        ),
        chk
      )
    }
  }
  chunks
}

.do_header_chunk <- function(coldf, cc_format, na_str) {
  ## hard assumption that coldf is a section
  ## of a column dataframe summary that was
  ## created with visible_only=FALSE
  nleafcols <- length(coldf$leaf_indices[[1]])

  spldfs <- split(coldf, lengths(coldf$path))
  toret <- lapply(
    seq_along(spldfs),
    function(i) {
      rws <- spldfs[[i]]
      thisbit_vals <- lapply(
        seq_len(nrow(rws)),
        function(ri) {
          cellii <- rcell(rws[ri, "label", drop = TRUE],
            colspan = rws$total_span[ri],
            footnotes = rws[ri, "col_fnotes", drop = TRUE][[1]]
          )
          cellii
        }
      )
      ret <- list(.pad_end(thisbit_vals, padto = nleafcols))
      anycounts <- any(rws$ccount_visible)
      if (anycounts) {
        thisbit_ns <- lapply(
          seq_len(nrow(rws)),
          function(ri) {
            vis_ri <- rws$ccount_visible[ri]
            val <- if (vis_ri) rws$col_count[ri] else NULL
            fmt <- rws$ccount_format[ri]
            if (is.character(fmt)) {
              cfmt_dim <- names(which(sapply(formatters::list_valid_format_labels(), function(x) any(x == fmt))))
              if (cfmt_dim == "2d") {
                if (grepl("%", fmt)) {
                  val <- c(val, 1) ## XXX This is the old behavior but it doesn't take into account parent counts...
                } else {
                  stop(
                    "This 2d format is not supported for column counts. ",
                    "Please choose a 1d format or a 2d format that includes a % value."
                  )
                }
              } else if (cfmt_dim == "3d") {
                stop("3d formats are not supported for column counts.")
              }
            }
            cellii <- rcell(
              val,
              colspan = rws$total_span[ri],
              format = fmt, # cc_format,
              format_na_str = na_str
            )
            cellii
          }
        )
        ret <- c(ret, list(.pad_end(thisbit_ns, padto = nleafcols)))
      }
      ret
    }
  )
  toret
}

.tbl_header_mat <- function(tt) {
  rows <- .do_tbl_h_piece2(tt) ## (clyt)
  cinfo <- col_info(tt)

  nc <- ncol(tt)
  body <- matrix(rapply(rows, function(x) {
    cs <- row_cspans(x)
    strs <- get_formatted_cells(x)
    strs
  }), ncol = nc, byrow = TRUE)

  span <- matrix(rapply(rows, function(x) {
    cs <- row_cspans(x)
    if (is.null(cs)) cs <- rep(1, ncol(x))
    rep(cs, cs)
  }), ncol = nc, byrow = TRUE)

  fnote <- do.call(
    rbind,
    lapply(rows, function(x) {
      cell_footnotes(x)
    })
  )

  tl <- top_left(cinfo)
  lentl <- length(tl)
  nli <- nrow(body)
  if (lentl == 0) {
    tl <- rep("", nli)
  } else if (lentl > nli) {
    tl_tmp <- paste0(tl, collapse = "\n")
    tl <- rep("", nli)
    tl[length(tl)] <- tl_tmp
  } else if (lentl < nli) {
    # We want topleft alignment that goes to the bottom!
    tl <- c(rep("", nli - lentl), tl)
  }
  list(
    body = cbind(tl, body, deparse.level = 0), span = cbind(1, span),
    footnotes = cbind(list(list()), fnote)
  )
}

# get formatted cells ----

#' Get formatted cells
#'
#' @inheritParams gen_args
#' @inheritParams formatters::format_value
#' @param shell (`flag`)\cr whether the formats themselves should be returned instead of the values with formats
#'   applied. Defaults to `FALSE`.
#'
#' @return The formatted print-strings for all (body) cells in `obj`.
#'
#' @examplesIf require(dplyr)
#' library(dplyr)
#'
#' iris2 <- iris %>%
#'   group_by(Species) %>%
#'   mutate(group = as.factor(rep_len(c("a", "b"), length.out = n()))) %>%
#'   ungroup()
#'
#' tbl <- basic_table() %>%
#'   split_cols_by("Species") %>%
#'   split_cols_by("group") %>%
#'   analyze(c("Sepal.Length", "Petal.Width"), afun = list_wrap_x(summary), format = "xx.xx") %>%
#'   build_table(iris2)
#'
#' get_formatted_cells(tbl)
#'
#' @export
#' @rdname gfc
setGeneric(
  "get_formatted_cells",
  function(obj, shell = FALSE, round_type = obj_round_type(obj)) standardGeneric("get_formatted_cells")
)

#' @rdname gfc
setMethod(
  "get_formatted_cells", "TableTree",
  function(obj, shell = FALSE, round_type = obj_round_type(obj)) {
    lr <- get_formatted_cells(tt_labelrow(obj), shell = shell, round_type = round_type)

    ct <- get_formatted_cells(content_table(obj), shell = shell, round_type = round_type)

    els <- lapply(tree_children(obj), get_formatted_cells, shell = shell, round_type = round_type)

    ## TODO fix ncol problem for rrow()
    if (ncol(ct) == 0 && ncol(lr) != ncol(ct)) {
      ct <- lr[NULL, ]
    }

    do.call(rbind, c(list(lr), list(ct), els))
  }
)

#' @rdname gfc
setMethod(
  "get_formatted_cells", "ElementaryTable",
  function(obj, shell = FALSE, round_type = obj_round_type(obj)) {
    lr <- get_formatted_cells(tt_labelrow(obj), shell = shell, round_type = round_type)
    els <- lapply(tree_children(obj), get_formatted_cells, shell = shell, round_type = round_type)
    do.call(rbind, c(list(lr), els))
  }
)

#' @rdname gfc
setMethod(
  "get_formatted_cells", "TableRow",
  function(obj, shell = FALSE, round_type = obj_round_type(obj)) {
    # Parent row format and na_str
    pr_row_format <- if (is.null(obj_format(obj))) "xx" else obj_format(obj)
    pr_row_na_str <- obj_na_str(obj) %||% "NA"

    matrix(
      unlist(Map(function(val, spn, shelli) {
        stopifnot(is(spn, "integer"))

        out <- format_rcell(val,
          pr_row_format = pr_row_format,
          pr_row_na_str = pr_row_na_str,
          shell = shelli,
          round_type = round_type
        )
        if (!is.function(out) && is.character(out)) {
          out <- paste(out, collapse = ", ")
        }

        rep(list(out), spn)
      }, val = row_cells(obj), spn = row_cspans(obj), shelli = shell)),
      ncol = ncol(obj)
    )
  }
)

#' @rdname gfc
setMethod(
  "get_formatted_cells", "LabelRow",
  function(obj, shell = FALSE, round_type = obj_round_type(obj)) {
    nc <- ncol(obj) # TODO note rrow() or rrow("label") has the wrong ncol
    vstr <- if (shell) "-" else ""
    if (labelrow_visible(obj)) {
      matrix(rep(vstr, nc), ncol = nc)
    } else {
      matrix(character(0), ncol = nc)
    }
  }
)

#' @rdname gfc
setGeneric("get_cell_aligns", function(obj) standardGeneric("get_cell_aligns"))

#' @rdname gfc
setMethod(
  "get_cell_aligns", "TableTree",
  function(obj) {
    lr <- get_cell_aligns(tt_labelrow(obj))

    ct <- get_cell_aligns(content_table(obj))

    els <- lapply(tree_children(obj), get_cell_aligns)

    ## TODO fix ncol problem for rrow()
    if (ncol(ct) == 0 && ncol(lr) != ncol(ct)) {
      ct <- lr[NULL, ]
    }

    do.call(rbind, c(list(lr), list(ct), els))
  }
)

#' @rdname gfc
setMethod(
  "get_cell_aligns", "ElementaryTable",
  function(obj) {
    lr <- get_cell_aligns(tt_labelrow(obj))
    els <- lapply(tree_children(obj), get_cell_aligns)
    do.call(rbind, c(list(lr), els))
  }
)

#' @rdname gfc
setMethod(
  "get_cell_aligns", "TableRow",
  function(obj) {
    als <- vapply(row_cells(obj), cell_align, "")
    spns <- row_cspans(obj)

    matrix(rep(als, times = spns),
      ncol = ncol(obj)
    )
  }
)

#' @rdname gfc
setMethod(
  "get_cell_aligns", "LabelRow",
  function(obj) {
    nc <- ncol(obj) # TODO note rrow() or rrow("label") has the wrong ncol
    if (labelrow_visible(obj)) {
      matrix(rep("center", nc), ncol = nc)
    } else {
      matrix(character(0), ncol = nc)
    }
  }
)

# utility functions ----

#' From a sorted sequence of numbers, remove numbers where diff == 1
#'
#' @examples
#' remove_consecutive_numbers(x = c(2, 4, 9))
#' remove_consecutive_numbers(x = c(2, 4, 5, 9))
#' remove_consecutive_numbers(x = c(2, 4, 5, 6, 9))
#' remove_consecutive_numbers(x = 4:9)
#'
#' @noRd
remove_consecutive_numbers <- function(x) {
  # actually should be integer
  stopifnot(is.wholenumber(x), is.numeric(x), !is.unsorted(x))

  if (length(x) == 0) {
    return(integer(0))
  }
  if (!is.integer(x)) x <- as.integer(x)

  x[c(TRUE, diff(x) != 1)]
}

#' Insert an empty string
#'
#' @examples
#' empty_string_after(letters[1:5], 2)
#' empty_string_after(letters[1:5], c(2, 4))
#'
#' @noRd
empty_string_after <- function(x, indices) {
  if (length(indices) > 0) {
    offset <- 0
    for (i in sort(indices)) {
      x <- append(x, "", i + offset)
      offset <- offset + 1
    }
  }
  x
}

#' Indent strings
#'
#' Used in rtables to indent row names for the ASCII output.
#'
#' @param x (`character`)\cr a character vector.
#' @param indent (`numeric`)\cr a vector of non-negative integers of length `length(x)`.
#' @param incr (`integer(1)`)\cr a non-negative number of spaces per indent level.
#' @param including_newline (`flag`)\cr whether newlines should also be indented.
#'
#' @return `x`, indented with left-padding with `indent * incr` white-spaces.
#'
#' @examples
#' indent_string("a", 0)
#' indent_string("a", 1)
#' indent_string(letters[1:3], 0:2)
#' indent_string(paste0(letters[1:3], "\n", LETTERS[1:3]), 0:2)
#'
#' @export
indent_string <- function(x, indent = 0, incr = 2, including_newline = TRUE) {
  if (length(x) > 0) {
    indent <- rep_len(indent, length.out = length(x))
    incr <- rep_len(incr, length.out = length(x))
  }

  indent_str <- strrep(" ", (indent > 0) * indent * incr)

  if (including_newline) {
    x <- unlist(mapply(function(xi, stri) {
      gsub("\n", stri, xi, fixed = TRUE)
    }, x, paste0("\n", indent_str)))
  }

  paste0(indent_str, x)
}

## .paste_no_na <- function(x, ...) {
##   paste(na.omit(x), ...)
## }

## #' Pad a string and align within string
## #'
## #' @param x string
## #' @param n number of character of the output string, if `n < nchar(x)` an error is thrown
## #'
## #' @noRd
## #'
## #' @examples
## #'
## #' padstr("abc", 3)
## #' padstr("abc", 4)
## #' padstr("abc", 5)
## #' padstr("abc", 5, "left")
## #' padstr("abc", 5, "right")
## #'
## #' if(interactive()){
## #' padstr("abc", 1)
## #' }
## #'
## padstr <- function(x, n, just = c("center", "left", "right")) {

##   just <- match.arg(just)

##   if (length(x) != 1) stop("length of x needs to be 1 and not", length(x))
##   if (is.na(n) || !is.numeric(n) || n < 0) stop("n needs to be numeric and > 0")

##   if (is.na(x)) x <- "<NA>"

##   nc <- nchar(x)

##   if (n < nc) stop("\"", x, "\" has more than ", n, " characters")

##   switch(
##     just,
##     center = {
##       pad <- (n - nc)/2
##       paste0(spaces(floor(pad)), x, spaces(ceiling(pad)))
##     },
##     left = paste0(x, spaces(n - nc)),
##     right = paste0(spaces(n - nc), x)
##   )
## }

## spaces <- function(n) {
##   strrep(" ", n)
## }

#' Convert matrix of strings into a string with aligned columns
#'
#' Note that this function is intended to print simple rectangular matrices and not `rtable`s.
#'
#' @param mat (`matrix`)\cr a matrix of strings.
#' @param nheader (`integer(1)`)\cr number of header rows.
#' @param colsep (`string`)\cr a string that separates the columns.
#' @param hsep (`character(1)`)\cr character to build line separator.
#'
#' @return A string.
#'
#' @examples
#' mat <- matrix(c("A", "B", "C", "a", "b", "c"), nrow = 2, byrow = TRUE)
#' cat(mat_as_string(mat))
#' cat("\n")
#'
#' @noRd
mat_as_string <- function(mat, nheader = 1, colsep = "    ", hsep = default_hsep()) {
  colwidths <- apply(apply(mat, c(1, 2), nchar), 2, max)

  rows_formatted <- apply(mat, 1, function(row) {
    paste(unlist(mapply(padstr, row, colwidths, "left")), collapse = colsep)
  })

  header_rows <- seq_len(nheader)
  nchwidth <- nchar(rows_formatted[1])
  paste(c(
    rows_formatted[header_rows],
    substr(strrep(hsep, nchwidth), 1, nchwidth),
    rows_formatted[-header_rows]
  ), collapse = "\n")
}

#' Default tabulation
#'
#' This function is used when [analyze()] is invoked.
#'
#' @param x (`vector`)\cr the *already split* data being tabulated for a particular cell/set of cells.
#' @param ... additional parameters to pass on.
#'
#' @details This function has the following behavior given particular types of inputs:
#'   \describe{
#'     \item{numeric}{calls [mean()] on `x`.}
#'     \item{logical}{calls [sum()] on `x`.}
#'     \item{factor}{calls [length()] on `x`.}
#'   }
#'
#' The [in_rows()] function is called on the resulting value(s). All other classes of input currently lead to an error.
#'
#' @inherit in_rows return
#'
#' @author Gabriel Becker and Adrian Waddell
#'
#' @examples
#' simple_analysis(1:3)
#' simple_analysis(iris$Species)
#' simple_analysis(iris$Species == "setosa")
#'
#' @rdname rtinner
#' @export
setGeneric("simple_analysis", function(x, ...) standardGeneric("simple_analysis"))

#' @rdname rtinner
#' @exportMethod simple_analysis
setMethod(
  "simple_analysis", "numeric",
  function(x, ...) in_rows("Mean" = rcell(mean(x, ...), stat_names = "mean", format = "xx.xx"))
)

#' @rdname rtinner
#' @exportMethod simple_analysis
setMethod(
  "simple_analysis", "logical",
  function(x, ...) in_rows("Count" = rcell(sum(x, ...), stat_names = "n", format = "xx"))
)

#' @rdname rtinner
#' @exportMethod simple_analysis
setMethod(
  "simple_analysis", "factor",
  function(x, ...) in_rows(.list = as.list(table(x)), .stat_names = "n")
)

#' @rdname rtinner
#' @exportMethod simple_analysis
setMethod(
  "simple_analysis", "ANY",
  function(x, ...) {
    stop("No default simple_analysis behavior for class ", class(x), " please specify FUN  explicitly.")
  }
)

#' Check if an object is a valid `rtable`
#'
#' @param x (`ANY`)\cr an object.
#'
#' @return `TRUE` if `x` is a formal `TableTree` object, `FALSE` otherwise.
#'
#' @examples
#' is_rtable(build_table(basic_table(), iris))
#'
#' @export
is_rtable <- function(x) {
  is(x, "VTableTree")
}

# nocov start
## is each object in a collection from a class
are <- function(object_collection, class2) {
  all(vapply(object_collection, is, logical(1), class2))
}

num_all_equal <- function(x, tol = .Machine$double.eps^0.5) {
  stopifnot(is.numeric(x))

  if (length(x) == 1) {
    return(TRUE)
  }

  y <- range(x) / mean(x)
  isTRUE(all.equal(y[1], y[2], tolerance = tol))
}

# copied over from utils.nest which is not open-source
all_true <- function(lst, fcn, ...) {
  all(vapply(lst, fcn, logical(1), ...))
}

is_logical_single <- function(x) {
  !is.null(x) &&
    is.logical(x) &&
    length(x) == 1 &&
    !is.na(x)
}

is_logical_vector_modif <- function(x, min_length = 1) {
  !is.null(x) &&
    is.logical(x) &&
    is.atomic(x) &&
    !anyNA(x) &&
    ifelse(min_length > 0, length(x) >= min_length, TRUE)
}
# nocov end

# Shorthand for functions that take df as first parameter
.takes_df <- function(f) {
  func_takes(f, "df", is_first = TRUE)
}

# Checking if function takes parameters
func_takes <- function(func, params, is_first = FALSE) {
  if (is.list(func)) {
    return(lapply(func, func_takes, params = params, is_first = is_first))
  }
  if (is.null(func) || !is(func, "function")) {
    # safe-net: should this fail instead?
    return(setNames(rep(FALSE, length(params)), params))
  }
  f_params <- formals(func)
  if (!is_first) {
    return(setNames(params %in% names(f_params), params))
  } else {
    if (length(params) > 1L) {
      stop("is_first works only with one parameters.")
    }
    return(!is.null(f_params) && names(f_params)[1] == params)
  }
}

#' Translate spl_context to a path to display in error messages
#'
#' @param ctx (`data.frame`)\cr the `spl_context` data frame where the error occurred.
#'
#' @return A character string containing a description of the row path corresponding to `ctx`.
#'
#' @export
spl_context_to_disp_path <- function(ctx) {
  ## this can happen in the first split in column space, but
  ## should never happen in row space
  if (length(ctx$split) == 0) {
    return("root")
  }
  if (ctx$split[1] == "root" && ctx$value[1] == "root") {
    ctx <- ctx[-1, ]
  }
  ret <- paste(sprintf("%s[%s]", ctx[["split"]], ctx[["value"]]),
    collapse = "->"
  )
  if (length(ret) == 0 || nchar(ret) == 0) {
    ret <- "root"
  }
  ret
}

# Utility function to paste vector of values in a nice way
paste_vec <- function(vec) {
  paste0('c("', paste(vec, collapse = '", "'), '")')
}

# Utility for checking if a package is installed
check_required_packages <- function(pkgs) {
  for (pkgi in pkgs) {
    if (!requireNamespace(pkgi, quietly = TRUE)) {
      stop(
        "This function requires the ", pkgi, " package. ",
        "Please install it if you wish to use it"
      )
    }
  }
}

# Generics and how they are used directly -------------------------------------

## check_validsplit - Check if the split is valid for the data, error if not

## .apply_spl_extras - Generate Extras

## .apply_spl_datapart - generate data partition

## .apply_spl_rawvals - Generate raw (i.e. non SplitValue object) partition values

setGeneric(
  ".applysplit_rawvals",
  function(spl, df) standardGeneric(".applysplit_rawvals")
)

setGeneric(
  ".applysplit_datapart",
  function(spl, df, vals) standardGeneric(".applysplit_datapart")
)

setGeneric(
  ".applysplit_extras",
  function(spl, df, vals) standardGeneric(".applysplit_extras")
)

setGeneric(
  ".applysplit_partlabels",
  function(spl, df, vals, labels) standardGeneric(".applysplit_partlabels")
)

setGeneric(
  "check_validsplit",
  function(spl, df) standardGeneric("check_validsplit")
)

setGeneric(
  ".applysplit_ref_vals",
  function(spl, df, vals) standardGeneric(".applysplit_ref_vals")
)
# Custom split fncs ------------------------------------------------------------
#' Custom split functions
#'
#' Split functions provide the work-horse for `rtables`'s generalized partitioning. These functions accept a (sub)set
#' of incoming data and a split object, and return "splits" of that data.
#'
#' @section Custom Splitting Function Details:
#'
#' User-defined custom split functions can perform any type of computation on the incoming data provided that they
#' meet the requirements for generating "splits" of the incoming data based on the split object.
#'
#' Split functions are functions that accept:
#'   \describe{
#'     \item{df}{a `data.frame` of incoming data to be split.}
#'     \item{spl}{a Split object. This is largely an internal detail custom functions will not need to worry about,
#'       but `obj_name(spl)`, for example, will give the name of the split as it will appear in paths in the resulting
#'       table.}
#'     \item{vals}{any pre-calculated values. If given non-`NULL` values, the values returned should match these.
#'       Should be `NULL` in most cases and can usually be ignored.}
#'     \item{labels}{any pre-calculated value labels. Same as above for `values`.}
#'     \item{trim}{if `TRUE`, resulting splits that are empty are removed.}
#'     \item{(optional) .spl_context}{a `data.frame` describing previously performed splits which collectively
#'       arrived at `df`.}
#'   }
#'
#' The function must then output a named `list` with the following elements:
#'
#'   \describe{
#'     \item{values}{the vector of all values corresponding to the splits of `df`.}
#'     \item{datasplit}{a list of `data.frame`s representing the groupings of the actual observations from `df`.}
#'     \item{labels}{a character vector giving a string label for each value listed in the `values` element above.}
#'     \item{(optional) extras}{if present, extra arguments are to be passed to summary and analysis functions
#'       whenever they are executed on the corresponding element of `datasplit` or a subset thereof.}
#'   }
#'
#' One way to generate custom splitting functions is to wrap existing split functions and modify either the incoming
#' data before they are called or their outputs.
#'
#' @seealso [make_split_fun()] for the API for creating custom split functions, and [split_funcs] for a variety of
#'   pre-defined split functions.
#'
#' @examples
#' # Example of a picky split function. The number of values in the column variable
#' # var decrees if we are going to print also the column with all observation
#' # or not.
#'
#' picky_splitter <- function(var) {
#'   # Main layout function
#'   function(df, spl, vals, labels, trim) {
#'     orig_vals <- vals
#'
#'     # Check for number of levels if all are selected
#'     if (is.null(vals)) {
#'       vec <- df[[var]]
#'       vals <- unique(vec)
#'     }
#'
#'     # Do a split with or without All obs
#'     if (length(vals) == 1) {
#'       do_base_split(spl = spl, df = df, vals = vals, labels = labels, trim = trim)
#'     } else {
#'       fnc_tmp <- add_overall_level("Overall", label = "All Obs", first = FALSE)
#'       fnc_tmp(df = df, spl = spl, vals = orig_vals, trim = trim)
#'     }
#'   }
#' }
#'
#' # Data sub-set
#' d1 <- subset(ex_adsl, ARM == "A: Drug X" | (ARM == "B: Placebo" & SEX == "F"))
#' d1 <- subset(d1, SEX %in% c("M", "F"))
#' d1$SEX <- factor(d1$SEX)
#'
#' # This table uses the number of values in the SEX column to add the overall col or not
#' lyt <- basic_table() %>%
#'   split_cols_by("ARM", split_fun = drop_split_levels) %>%
#'   split_cols_by("SEX", split_fun = picky_splitter("SEX")) %>%
#'   analyze("AGE", show_labels = "visible")
#' tbl <- build_table(lyt, d1)
#' tbl
#'
#' @name custom_split_funs
NULL

## do various cleaning, and naming, plus
## ensure partinfo$values contains SplitValue objects only
.fixupvals <- function(partinfo) {
  if (is.factor(partinfo$labels)) {
    partinfo$labels <- as.character(partinfo$labels)
  }

  vals <- partinfo$values
  if (is.factor(vals)) {
    vals <- levels(vals)[vals]
  }
  extr <- partinfo$extras
  dpart <- partinfo$datasplit
  labels <- partinfo$labels
  if (is.null(labels)) {
    if (!is.null(names(vals))) {
      labels <- names(vals)
    } else if (!is.null(names(dpart))) {
      labels <- names(dpart)
    } else if (!is.null(names(extr))) {
      labels <- names(extr)
    }
  }

  subsets <- partinfo$subset_exprs
  if (is.null(subsets)) {
    subsets <- vector(mode = "list", length = length(vals))
    ## use labels here cause we already did all that work
    ## to get the names on the labels vector right
    names(subsets) <- names(labels)
  }

  if (is.null(vals) && !is.null(extr)) {
    vals <- seq_along(extr)
  }

  if (length(vals) == 0) {
    stopifnot(length(extr) == 0)
    return(partinfo)
  }
  ## length(vals) > 0 from here down

  if (are(vals, "SplitValue") && !are(vals, "LevelComboSplitValue")) {
    if (!is.null(extr)) {
      ## in_ref_cols is in here for some reason even though its already in the SplitValue object.
      ## https://github.com/insightsengineering/rtables/issues/707#issuecomment-1678810598
      ## the if is a bandaid.
      ## XXX FIXME RIGHT
      sq <- seq_along(vals)
      if (any(vapply(sq, function(i) !all(names(extr[[i]]) %in% names(splv_extra(vals[[i]]))), TRUE))) {
        warning(
          "Got a partinfo list with values that are ",
          "already SplitValue objects and non-null extras ",
          "element. This shouldn't happen"
        )
      }
    }
  } else {
    if (is.null(extr)) {
      extr <- rep(list(list()), length(vals))
    }
    vals <- make_splvalue_vec(vals, extr, labels = labels, subset_exprs = subsets)
  }
  ## we're done with this so take it off
  partinfo$extras <- NULL

  vnames <- value_names(vals)
  names(vals) <- vnames
  partinfo$values <- vals

  if (!identical(names(dpart), vnames)) {
    names(dpart) <- vnames
    partinfo$datasplit <- dpart
  }

  partinfo$labels <- labels

  stopifnot(length(unique(sapply(partinfo, NROW))) == 1)
  partinfo
}

.add_ref_extras <- function(spl, df, partinfo) {
  ## this is only the .in_ref_col booleans
  refvals <- .applysplit_ref_vals(spl, df, partinfo$values)
  ref_ind <- which(unlist(refvals))
  stopifnot(length(ref_ind) == 1)

  vnames <- value_names(partinfo$values)
  if (is.null(partinfo$extras)) {
    names(refvals) <- vnames
    partinfo$extras <- refvals
  } else {
    newextras <- mapply(
      function(old, incol, ref_full) {
        c(old, list(
          .in_ref_col = incol,
          .ref_full = ref_full
        ))
      },
      old = partinfo$extras,
      incol = unlist(refvals),
      MoreArgs = list(ref_full = partinfo$datasplit[[ref_ind]]),
      SIMPLIFY = FALSE
    )
    names(newextras) <- vnames
    partinfo$extras <- newextras
  }
  partinfo
}

#' Apply basic split (for use in custom split functions)
#'
#' This function is intended for use inside custom split functions. It applies the current split *as if it had no
#' custom splitting function* so that those default splits can be further manipulated.
#'
#' @inheritParams gen_args
#' @param vals (`ANY`)\cr already calculated/known values of the split. Generally should be left as `NULL`.
#' @param labels (`character`)\cr labels associated with `vals`. Should be `NULL` whenever `vals` is, which should
#'   almost always be the case.
#' @param trim (`flag`)\cr whether groups corresponding to empty data subsets should be removed. Defaults to
#'   `FALSE`.
#'
#' @return The result of the split being applied as if it had no custom split function. See [custom_split_funs].
#'
#' @examples
#' uneven_splfun <- function(df, spl, vals = NULL, labels = NULL, trim = FALSE) {
#'   ret <- do_base_split(spl, df, vals, labels, trim)
#'   if (NROW(df) == 0) {
#'     ret <- lapply(ret, function(x) x[1])
#'   }
#'   ret
#' }
#'
#' lyt <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   split_cols_by_multivar(c("USUBJID", "AESEQ", "BMRKR1"),
#'     varlabels = c("N", "E", "BMR1"),
#'     split_fun = uneven_splfun
#'   ) %>%
#'   analyze_colvars(list(
#'     USUBJID = function(x, ...) length(unique(x)),
#'     AESEQ = max,
#'     BMRKR1 = mean
#'   ))
#'
#' tbl <- build_table(lyt, subset(ex_adae, as.numeric(ARM) <= 2))
#' tbl
#'
#' @export
do_base_split <- function(spl, df, vals = NULL, labels = NULL, trim = FALSE) {
  spl2 <- spl
  split_fun(spl2) <- NULL
  do_split(spl2,
    df = df, vals = vals, labels = labels, trim = trim,
    spl_context = NULL
  )
}

### NB This is called at EACH level of recursive splitting
do_split <- function(spl,
                     df,
                     vals = NULL,
                     labels = NULL,
                     trim = FALSE,
                     spl_context) {
  ## this will error if, e.g., df doesn't have columns
  ## required by spl, or generally any time the spl
  ## can't be applied to df
  check_validsplit(spl, df)
  ## note the <- here!!!
  if (!is.null(splfun <- split_fun(spl))) {
    ## Currently the contract is that split_functions take df, vals, labels and
    ## return list(values=., datasplit=., labels = .), optionally with
    ## an additional extras element
    if (func_takes(splfun, ".spl_context")) {
      ret <- tryCatch(
        splfun(df, spl, vals, labels,
          trim = trim,
          .spl_context = spl_context
        ),
        error = function(e) e
      ) ## rawvalues(spl_context ))
    } else {
      ret <- tryCatch(splfun(df, spl, vals, labels, trim = trim),
        error = function(e) e
      )
    }
    if (is(ret, "error")) {
      stop(
        "Error applying custom split function: ", ret$message, "\n\tsplit: ",
        class(spl), " (", payloadmsg(spl), ")\n",
        "\toccured at path: ",
        spl_context_to_disp_path(spl_context), "\n"
      )
    }
  } else {
    ret <- .apply_split_inner(df = df, spl = spl, vals = vals, labels = labels, trim = trim)
  }

  ## this adds .ref_full and .in_ref_col
  if (is(spl, "VarLevWBaselineSplit")) {
    ret <- .add_ref_extras(spl, df, ret)
  }

  ## this:
  ## - guarantees that ret$values contains SplitValue objects
  ## - removes the extras element since its redundant after the above
  ## - Ensures datasplit and values lists are named according to labels
  ## - ensures labels are character not factor
  ret <- .fixupvals(ret)
  ## we didn't put this in .fixupvals because that get called withint he split functions
  ## created by make_split_fun and its not clear this check should be happening then.
  if (has_force_pag(spl) && length(ret$datasplit) == 0) { ## this means it's page_by=TRUE
    stop(
      "Page-by split resulted in zero pages (no observed values of split variable?). \n\tsplit: ",
      class(spl), " (", payloadmsg(spl), ")\n",
      "\toccured at path: ",
      spl_context_to_disp_path(spl_context), "\n"
    )
  }
  ret
}

.apply_split_inner <- function(spl, df, vals = NULL, labels = NULL, trim = FALSE) {
  if (is.null(vals)) {
    vals <- .applysplit_rawvals(spl, df)
  }
  extr <- .applysplit_extras(spl, df, vals)

  if (is.null(vals)) {
    return(list(
      values = list(),
      datasplit = list(),
      labels = list(),
      extras = list()
    ))
  }

  dpart <- .applysplit_datapart(spl, df, vals)

  if (is.null(labels)) {
    labels <- .applysplit_partlabels(spl, df, vals, labels)
  } else {
    stopifnot(names(labels) == names(vals))
  }
  ## get rid of columns that would not have any
  ## observations.
  ##
  ## But only if there were any rows to start with
  ## if not we're in a manually constructed table
  ## column tree
  if (trim) {
    hasdata <- sapply(dpart, function(x) nrow(x) > 0)
    if (nrow(df) > 0 && length(dpart) > sum(hasdata)) { # some empties
      dpart <- dpart[hasdata]
      vals <- vals[hasdata]
      extr <- extr[hasdata]
      labels <- labels[hasdata]
    }
  }

  if (is.null(spl_child_order(spl)) || is(spl, "AllSplit")) {
    vord <- seq_along(vals)
  } else {
    vord <- match(
      spl_child_order(spl),
      vals
    )
    vord <- vord[!is.na(vord)]
  }

  ## FIXME: should be an S4 object, not a list
  ret <- list(
    values = vals[vord],
    datasplit = dpart[vord],
    labels = labels[vord],
    extras = extr[vord]
  )
  ret
}

.checkvarsok <- function(spl, df) {
  vars <- spl_payload(spl)
  ## could be multiple vars in the future?
  ## no reason not to make that work here now.
  if (!all(vars %in% names(df))) {
    stop(
      " variable(s) [",
      paste(setdiff(vars, names(df)),
        collapse = ", "
      ),
      "] not present in data. (",
      class(spl), ")"
    )
  }
  invisible(NULL)
}

### Methods to verify a split appears to be valid, applicable
### to the ***current subset*** of the df.
###
### This is called at each level of recursive splitting so
### do NOT make it check, e.g., if the ref_group level of
### a factor is present in the data, because it may not be.

setMethod(
  "check_validsplit", "VarLevelSplit",
  function(spl, df) {
    .checkvarsok(spl, df)
  }
)

setMethod(
  "check_validsplit", "MultiVarSplit",
  function(spl, df) {
    .checkvarsok(spl, df)
  }
)

setMethod(
  "check_validsplit", "VAnalyzeSplit",
  function(spl, df) {
    if (!is.na(spl_payload(spl))) {
      .checkvarsok(spl, df)
    } else {
      TRUE
    }
  }
)

setMethod(
  "check_validsplit", "CompoundSplit",
  function(spl, df) {
    all(sapply(spl_payload(spl), df))
  }
)

## default does nothing, add methods as they become
## required
setMethod(
  "check_validsplit", "Split",
  function(spl, df) invisible(NULL)
)

setMethod(
  ".applysplit_rawvals", "VarLevelSplit",
  function(spl, df) {
    varvec <- df[[spl_payload(spl)]]
    if (is.factor(varvec)) {
      levels(varvec)
    } else {
      unique(varvec)
    }
  }
)

setMethod(
  ".applysplit_rawvals", "MultiVarSplit",
  function(spl, df) {
    ##    spl_payload(spl)
    spl_varnames(spl)
  }
)

setMethod(
  ".applysplit_rawvals", "AllSplit",
  function(spl, df) obj_name(spl)
) # "all obs")

setMethod(
  ".applysplit_rawvals", "ManualSplit",
  function(spl, df) spl@levels
)

## setMethod(".applysplit_rawvals", "NULLSplit",
##           function(spl, df) "")

setMethod(
  ".applysplit_rawvals", "VAnalyzeSplit",
  function(spl, df) spl_payload(spl)
)

## formfactor here is gross we're gonna have ot do this
## all again in tthe data split part :-/
setMethod(
  ".applysplit_rawvals", "VarStaticCutSplit",
  function(spl, df) {
    spl_cutlabels(spl)
  }
)

setMethod(
  ".applysplit_datapart", "VarLevelSplit",
  function(spl, df, vals) {
    if (!(spl_payload(spl) %in% names(df))) {
      stop(
        "Attempted to split on values of column (", spl_payload(spl),
        ") not present in the data"
      )
    }
    ret <- lapply(seq_along(vals), function(i) {
      spl_col <- df[[spl_payload(spl)]]
      df[!is.na(spl_col) & spl_col == vals[[i]], ]
    })
    names(ret) <- as.character(vals)
    ret
  }
)

setMethod(
  ".applysplit_datapart", "MultiVarSplit",
  function(spl, df, vals) {
    allvnms <- spl_varnames(spl)
    if (!is.null(vals) && !identical(allvnms, vals)) {
      incl <- match(vals, allvnms)
    } else {
      incl <- seq_along(allvnms)
    }
    vars <- spl_payload(spl)[incl]
    ## don't remove  nas
    ## ret = lapply(vars, function(cl) {
    ##     df[!is.na(df[[cl]]),]
    ## })
    ret <- rep(list(df), length(vars))
    names(ret) <- vals
    ret
  }
)

setMethod(
  ".applysplit_datapart", "AllSplit",
  function(spl, df, vals) list(df)
)

## ## not sure I need this
setMethod(
  ".applysplit_datapart", "ManualSplit",
  function(spl, df, vals) rep(list(df), times = length(vals))
)

## setMethod(".applysplit_datapart", "NULLSplit",
##           function(spl, df, vals) list(df[FALSE,]))

setMethod(
  ".applysplit_datapart", "VarStaticCutSplit",
  function(spl, df, vals) {
    #  lbs = spl_cutlabels(spl)
    var <- spl_payload(spl)
    varvec <- df[[var]]
    cts <- spl_cuts(spl)
    cfct <- cut(varvec, cts, include.lowest = TRUE) # , labels = lbs)
    split(df, cfct, drop = FALSE)
  }
)

setMethod(
  ".applysplit_datapart", "CumulativeCutSplit",
  function(spl, df, vals) {
    #  lbs = spl_cutlabels(spl)
    var <- spl_payload(spl)
    varvec <- df[[var]]
    cts <- spl_cuts(spl)
    cfct <- cut(varvec, cts, include.lowest = TRUE) # , labels = lbs)
    ret <- lapply(
      seq_along(levels(cfct)),
      function(i) df[as.integer(cfct) <= i, ]
    )
    names(ret) <- levels(cfct)
    ret
  }
)

## XXX TODO *CutSplit Methods

setClass("NullSentinel", contains = "NULL")
nullsentinel <- new("NullSentinel")
noarg <- function() nullsentinel

## Extras generation methods
setMethod(
  ".applysplit_extras", "Split",
  function(spl, df, vals) {
    splex <- split_exargs(spl)
    nvals <- length(vals)
    lapply(seq_len(nvals), function(vpos) {
      one_ex <- lapply(splex, function(arg) {
        if (length(arg) >= vpos) {
          arg[[vpos]]
        } else {
          noarg()
        }
      })
      names(one_ex) <- names(splex)
      one_ex <- one_ex[!sapply(one_ex, is, "NullSentinel")]
      one_ex
    })
  }
)

setMethod(
  ".applysplit_ref_vals", "Split",
  function(spl, df, vals) rep(list(NULL), length(vals))
)

setMethod(
  ".applysplit_ref_vals", "VarLevWBaselineSplit",
  function(spl, df, vals) {
    bl_level <- spl@ref_group_value # XXX XXX
    vnames <- value_names(vals)
    ret <- lapply(vnames, function(vl) {
      list(.in_ref_col = vl == bl_level)
    })
    names(ret) <- vnames
    ret
  }
)

## XXX TODO FIXME
setMethod(
  ".applysplit_partlabels", "Split",
  function(spl, df, vals, labels) as.character(vals)
)

setMethod(
  ".applysplit_partlabels", "VarLevelSplit",
  function(spl, df, vals, labels) {
    varname <- spl_payload(spl)
    vlabelname <- spl_labelvar(spl)
    varvec <- df[[varname]]
    ## we used to check if vals was NULL but
    ## this is called after a short-circuit return in .apply_split_inner in that
    ## case
    ## so vals is guaranteed to be non-null here
    if (is.null(labels)) {
      if (varname == vlabelname) {
        labels <- vals
      } else {
        labfact <- is.factor(df[[vlabelname]])
        lablevs <- if (labfact) levels(df[[vlabelname]]) else NULL
        labels <- sapply(vals, function(v) {
          vlabel <- unique(df[varvec == v, vlabelname, drop = TRUE])
          ## TODO remove this once 1-to-1 value-label map is enforced
          ## elsewhere.
          stopifnot(length(vlabel) < 2)
          if (length(vlabel) == 0) {
            vlabel <- ""
          } else if (labfact) {
            vlabel <- lablevs[vlabel]
          }
          vlabel
        })
      }
    }
    names(labels) <- as.character(vals)
    labels
  }
)

setMethod(
  ".applysplit_partlabels", "MultiVarSplit",
  function(spl, df, vals, labels) value_labels(spl)
)

make_splvalue_vec <- function(vals, extrs = list(list()), labels = vals,
                              subset_exprs) {
  if (length(vals) == 0) {
    return(vals)
  }

  if (is(extrs, "AsIs")) {
    extrs <- unclass(extrs)
  }
  ## if(are(vals, "SplitValue")) {

  ##     return(vals)
  ## }

  mapply(SplitValue,
    val = vals, extr = extrs,
    label = labels,
    sub_expr = subset_exprs,
    SIMPLIFY = FALSE
  )
}

#' Score functions for sorting `TableTrees`
#'
#' @inheritParams gen_args
#'
#' @return A single numeric value indicating score according to the relevant metric for `tt`, to be used when sorting.
#'
#' @export
#' @rdname score_funs
cont_n_allcols <- function(tt) {
  ctab <- content_table(tt)
  if (NROW(ctab) == 0) {
    stop(
      "cont_n_allcols score function used at subtable [",
      obj_name(tt), "] that has no content table."
    )
  }
  sum(sapply(
    row_values(tree_children(ctab)[[1]]),
    function(cv) cv[1]
  ))
}

#' @param j (`numeric(1)`)\cr index of column used for scoring.
#'
#' @seealso For examples and details, please read the documentation for [sort_at_path()] and the
#' [Sorting and Pruning](https://insightsengineering.github.io/rtables/latest-tag/articles/sorting_pruning.html)
#' vignette.
#'
#' @export
#' @rdname score_funs
cont_n_onecol <- function(j) {
  function(tt) {
    ctab <- content_table(tt)
    if (NROW(ctab) == 0) {
      stop(
        "cont_n_allcols score function used at subtable [",
        obj_name(tt), "] that has no content table."
      )
    }
    row_values(tree_children(ctab)[[1]])[[j]][1]
  }
}

## used for pruning functions and scoring functions(sorting)
match_fun_args <- function(fun, ...) {
  dotargs <- list(...)
  retargs <- list()
  formnms <- names(formals(fun))
  if ("..." %in% formnms) {
    retargs <- dotargs
  } else if (any(names(dotargs) %in% formnms)) {
    retargs <- dotargs[names(dotargs) %in% formnms]
  }
  retargs
}

#' Sorting a table at a specific path
#'
#' Main sorting function to order the sub-structure of a `TableTree` at a particular path in the table tree.
#'
#' @inheritParams gen_args
#' @param scorefun (`function`)\cr scoring function. Should accept the type of children directly under the position
#'   at `path` (either `VTableTree`, `VTableRow`, or `VTableNodeInfo`, which covers both) and return a numeric value
#'   to be sorted.
#' @param decreasing (`flag`)\cr whether the scores generated by `scorefun` should be sorted in decreasing order. If
#'   unset (the default of `NA`), it is set to `TRUE` if the generated scores are numeric and `FALSE` if they are
#'   characters.
#' @param na.pos (`string`)\cr what should be done with children (sub-trees/rows) with `NA` scores. Defaults to
#'   `"omit"`, which removes them. Other allowed values are `"last"`  and `"first"`, which indicate where `NA` scores
#'   should be placed in the order.
#' @param .prev_path (`character`)\cr internal detail, do not set manually.
#' @param ... Additional (named) arguments that will be passed directly down to
#'   `score_fun` *if* it accepts them (or accepts `...` itself).
#'
#' @return A `TableTree` with the same structure as `tt` with the exception that the requested sorting has been done
#'   at `path`.
#'
#' @details
#' `sort_at_path`, given a path, locates the (sub)table(s) described by the path (see below for handling of the `"*"`
#' wildcard). For each such subtable, it then calls `scorefun` on each direct child of the table, using the resulting
#' scores to determine their sorted order. `tt` is then modified to reflect each of these one or more sorting
#' operations.
#'
#' `score_fun` can optionally accept `decreasing`, which will be passed the value passed
#' to `sort_at_path` automatically, and other arguments which can be set via `...`. The
#' first argument passed to `scorefun` will always be the table structure (subtable or row)
#' it is scoring.
#'
#' In `path`, a leading `"root"` element will be ignored, regardless of whether this matches the object name (and thus
#' actual root path name) of `tt`. Including `"root"` in paths where it does not match the name of `tt` may mask deeper
#' misunderstandings of how valid paths within a `TableTree` object correspond to the layout used to originally declare
#' it, which we encourage users to avoid.
#'
#' `path` can include the "wildcard" `"*"` as a step, which translates roughly to *any* node/branching element and means
#' that each child at that step will be *separately* sorted based on `scorefun` and the remaining `path` entries. This
#' can occur multiple times in a path.
#'
#' A list of valid (non-wildcard) paths can be seen in the `path` column of the `data.frame` created by
#' [formatters::make_row_df()] with the `visible_only` argument set to `FALSE`. It can also be inferred from the
#' summary given by [table_structure()].
#'
#' Note that sorting needs a deeper understanding of table structure in `rtables`. Please consider reading the related
#' vignette
#' ([Sorting and Pruning](https://insightsengineering.github.io/rtables/latest-tag/articles/sorting_pruning.html))
#' and explore table structure with useful functions like [table_structure()] and [row_paths_summary()]. It is also
#' very important to understand the difference between "content" rows and "data" rows. The first one analyzes and
#' describes the split variable generally and is generated with [summarize_row_groups()], while the second one is
#' commonly produced by calling one of the various [analyze()] instances.
#'
#' Built-in score functions are [cont_n_allcols()] and [cont_n_onecol()]. They are both working with content rows
#' (coming from [summarize_row_groups()]) while a custom score function needs to be used on `DataRow`s. Here, some
#' useful descriptor and accessor functions (coming from related vignette):
#'  - [cell_values()] - Retrieves a named list of a `TableRow` or `TableTree` object's values.
#'  - [formatters::obj_name()] - Retrieves the name of an object. Note this can differ from the label that is
#'  displayed (if any is)  when printing.
#'  - [formatters::obj_label()] - Retrieves the display label of an object. Note this can differ from the name that
#'  appears in the path.
#'  - [content_table()] - Retrieves a `TableTree` object's content table (which contains its summary rows).
#'  - [tree_children()] - Retrieves a `TableTree` object's direct children (either subtables, rows or possibly a mix
#'    thereof, though that should not happen in practice).
#'
#' @seealso
#' * Score functions [cont_n_allcols()] and [cont_n_onecol()].
#' * [formatters::make_row_df()] and [table_structure()] for pathing information.
#' * [tt_at_path()] to select a table's (sub)structure at a given path.
#'
#' @examples
#' # Creating a table to sort
#'
#' # Function that gives two statistics per table-tree "leaf"
#' more_analysis_fnc <- function(x) {
#'   in_rows(
#'     "median" = median(x),
#'     "mean" = mean(x),
#'     .formats = "xx.x"
#'   )
#' }
#'
#' # Main layout of the table
#' raw_lyt <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   split_rows_by(
#'     "RACE",
#'     split_fun = drop_and_remove_levels("WHITE") # dropping WHITE levels
#'   ) %>%
#'   summarize_row_groups() %>%
#'   split_rows_by("STRATA1") %>%
#'   summarize_row_groups() %>%
#'   analyze("AGE", afun = more_analysis_fnc)
#'
#' # Creating the table and pruning empty and NAs
#' tbl <- build_table(raw_lyt, DM) %>%
#'   prune_table()
#'
#' # Peek at the table structure to understand how it is built
#' table_structure(tbl)
#'
#' #  Sorting only ASIAN sub-table, or, in other words, sorting STRATA elements for
#' # the ASIAN group/row-split. This uses content_table() accessor function as it
#' # is a "ContentRow". In this case, we also base our sorting only on the second column.
#' sort_at_path(tbl, c("ASIAN", "STRATA1"), cont_n_onecol(2))
#'
#' # Custom scoring function that is working on "DataRow"s
#' scorefun <- function(tt) {
#'   # Here we could use browser()
#'   sum(unlist(row_values(tt))) # Different accessor function
#' }
#' # Sorting mean and median for all the AGE leaves!
#' sort_at_path(tbl, c("RACE", "*", "STRATA1", "*", "AGE"), scorefun)
#'
#' last_cat_scorefun <- function(x, decreasing, lastcat) {
#'   mycat <- obj_name(x)
#'   if (mycat == lastcat) {
#'     ifelse(isTRUE(decreasing), -Inf, Inf)
#'   } else {
#'     match(tolower(substr(mycat, 1, 1)), letters)
#'   }
#' }
#'
#' lyt2 <- basic_table() %>%
#'   split_rows_by("SEX") %>%
#'   analyze("AGE")
#'
#' tbl2 <- build_table(lyt2, DM)
#' sort_at_path(tbl2, "SEX", last_cat_scorefun, lastcat = "M")
#' sort_at_path(tbl2, "SEX", last_cat_scorefun, lastcat = "M", decreasing = FALSE)
#'
#' @export
sort_at_path <- function(tt,
                         path,
                         scorefun,
                         decreasing = NA,
                         na.pos = c("omit", "last", "first"),
                         .prev_path = character(),
                         ...) {
  if (NROW(tt) == 0) {
    return(tt)
  }

  ## XXX hacky fix this!!!
  ## tt_at_path removes root even if actual root table isn't named root, we need to match that behavior
  if (path[1] == "root") {
    ## always remove first root element but only add it to
    ## .prev_path (used for error reporting) if it actually matched the name
    if (obj_name(tt) == "root") {
      .prev_path <- c(.prev_path, path[1])
    }
    path <- path[-1]
  }
  if (identical(obj_name(tt), path[1])) {
    .prev_path <- c(.prev_path, path[1])
    path <- path[-1]
  }

  curpath <- path
  subtree <- tt
  backpath <- c()
  count <- 0
  while (length(curpath) > 0) {
    curname <- curpath[1]
    oldkids <- tree_children(subtree)
    ## we sort each child separately based on the score function
    ## and the remaining path
    if (curname == "*") {
      oldnames <- vapply(oldkids, obj_name, "")
      newkids <- lapply(
        seq_along(oldkids),
        function(i) {
          sort_at_path(oldkids[[i]],
            path = curpath[-1],
            scorefun = scorefun,
            decreasing = decreasing,
            na.pos = na.pos,
            ## its ok to modify the "path" here because its only ever used for
            ## informative error reporting.
            .prev_path = c(.prev_path, backpath, paste0("* (", oldnames[i], ")")),
            ...
          )
        }
      )
      names(newkids) <- oldnames
      newtab <- subtree
      tree_children(newtab) <- newkids
      if (length(backpath) > 0) {
        ret <- recursive_replace(tt, backpath, value = newtab)
      } else {
        ret <- newtab
      }
      return(ret)
    } else if (!(curname %in% names(oldkids))) {
      stop(
        "Unable to find child(ren) '",
        curname, "'\n\t occurred at path: ",
        paste(c(.prev_path, path[seq_len(count)]), collapse = " -> "),
        "\n  Use 'make_row_df(obj, visible_only = TRUE)[, c(\"label\", \"path\", \"node_class\")]' or \n",
        "'table_structure(obj)' to explore valid paths."
      )
    }
    subtree <- tree_children(subtree)[[curname]]
    backpath <- c(backpath, curpath[1])
    curpath <- curpath[-1]
    count <- count + 1
  }
  real_backpath <- path[seq_len(count)]

  na.pos <- match.arg(na.pos)
  ##    subtree <- tt_at_path(tt, path)
  kids <- tree_children(subtree)
  ## relax this to allow character "scores"
  ## scores <- vapply(kids, scorefun, NA_real_)
  more_args <- match_fun_args(scorefun, decreasing = decreasing, ...)
  scores <- lapply(kids, function(x) {
    tryCatch(do.call(scorefun, c(list(x), more_args)),
      error = function(e) e
    )
  })
  errs <- which(vapply(scores, is, class2 = "error", TRUE))
  if (length(errs) > 0) {
    stop("Encountered at least ", length(errs), " error(s) when applying score function.\n",
      "First error: ", scores[[errs[1]]]$message,
      "\n\toccurred at path: ",
      paste(c(.prev_path, real_backpath, names(kids)[errs[1]]), collapse = " -> "),
      call. = FALSE
    )
  } else {
    scores <- unlist(scores)
  }
  if (!is.null(dim(scores)) || length(scores) != length(kids)) {
    stop(
      "Score function does not appear to have return exactly one ",
      "scalar value per child"
    )
  }
  if (is.na(decreasing)) {
    decreasing <- if (is.character(scores)) FALSE else TRUE
  }
  ord <- order(scores, na.last = (na.pos != "first"), decreasing = decreasing)
  newkids <- kids[ord]
  if (anyNA(scores) && na.pos == "omit") { # we did na last here
    newkids <- head(newkids, -1 * sum(is.na(scores)))
  }

  newtree <- subtree
  tree_children(newtree) <- newkids
  tt_at_path(tt, path) <- newtree
  tt
}

insert_brs <- function(vec) {
  if (length(vec) == 1) {
    ret <- list(vec)
  } else {
    nout <- length(vec) * 2 - 1
    ret <- vector("list", nout)
    for (i in seq_along(vec)) {
      ret[[2 * i - 1]] <- vec[i]
      if (2 * i < nout) {
        ret[[2 * i]] <- tags$br()
      }
    }
  }
  ret
}

div_helper <- function(lst, class) {
  do.call(tags$div, c(list(class = paste(class, "rtables-container"), lst)))
}

#' Convert an `rtable` object to a `shiny.tag` HTML object
#'
#' The returned HTML object can be immediately used in `shiny` and `rmarkdown`.
#'
#' @param x (`VTableTree`)\cr a `TableTree` object.
#' @param class_table (`character`)\cr class for `table` tag.
#' @param class_tr (`character`)\cr class for `tr` tag.
#' @param class_th (`character`)\cr class for `th` tag.
#' @param width (`character`)\cr a string to indicate the desired width of the table. Common input formats include a
#'   percentage of the viewer window width (e.g. `"100%"`) or a distance value (e.g. `"300px"`). Defaults to `NULL`.
#' @param link_label (`character`)\cr link anchor label (not including `tab:` prefix) for the table.
#' @param bold (`character`)\cr elements in table output that should be bold. Options are `"main_title"`,
#'   `"subtitles"`, `"header"`, `"row_names"`, `"label_rows"`, and `"content_rows"` (which includes any non-label
#'   rows). Defaults to `"header"`.
#' @param header_sep_line (`flag`)\cr whether a black line should be printed to under the table header. Defaults
#'   to `TRUE`.
#' @param no_spaces_between_cells (`flag`)\cr whether spaces between table cells should be collapsed. Defaults
#'   to `FALSE`.
#' @param expand_newlines (`flag`)\cr Defaults to `FALSE`, relying on `html` output to solve newline characters (`\n`).
#'   Doing this keeps the structure of the cells but may depend on the output device.
#' @param round_type (`"iec"`, `"iec_mod"` or `"sas"`)\cr the type of rounding to perform.
#' See [round_fmt()] for details.
#'
#' @importFrom htmltools tags
#'
#' @return A `shiny.tag` object representing `x` in HTML.
#'
#' @examples
#' tbl <- rtable(
#'   header = LETTERS[1:3],
#'   format = "xx",
#'   rrow("r1", 1, 2, 3),
#'   rrow("r2", 4, 3, 2, indent = 1),
#'   rrow("r3", indent = 2)
#' )
#'
#' as_html(tbl)
#'
#' as_html(tbl, class_table = "table", class_tr = "row")
#'
#' as_html(tbl, bold = c("header", "row_names"))
#'
#' \dontrun{
#' Viewer(tbl)
#' }
#'
#' @export
as_html <- function(x,
                    width = NULL,
                    class_table = "table table-condensed table-hover",
                    class_tr = NULL,
                    class_th = NULL,
                    link_label = NULL,
                    bold = c("header"),
                    header_sep_line = TRUE,
                    no_spaces_between_cells = FALSE,
                    expand_newlines = FALSE,
                    round_type = if (is(x, "VTableTree")) obj_round_type(x) else valid_round_type) {
  if (is.null(x)) {
    return(tags$p("Empty Table"))
  }

  stopifnot(is(x, "VTableTree"))

  mat <- matrix_form(x, indent_rownames = TRUE, expand_newlines = expand_newlines, round_type = round_type)

  nlh <- mf_nlheader(mat)
  nc <- ncol(x) + 1
  nr <- length(mf_lgrouping(mat))

  # Structure is a list of lists with rows (one for each line grouping) and cols as dimensions
  cells <- matrix(rep(list(list()), (nr * nc)), ncol = nc)

  for (i in seq_len(nr)) {
    for (j in seq_len(nc)) {
      curstrs <- mf_strings(mat)[i, j]
      curspn <- mf_spans(mat)[i, j]
      algn <- mf_aligns(mat)[i, j]

      inhdr <- i <= nlh
      tagfun <- if (inhdr) tags$th else tags$td
      cells[i, j][[1]] <- tagfun(
        class = if (inhdr) class_th else class_tr,
        style = paste0("text-align: ", algn, ";"),
        style = if (inhdr && !"header" %in% bold) "font-weight: normal;",
        style = if (i == nlh && header_sep_line) "border-bottom: 1px solid black;",
        colspan = if (curspn != 1) curspn,
        insert_brs(curstrs)
      )
    }
  }

  if (header_sep_line) {
    cells[nlh][[1]] <- htmltools::tagAppendAttributes(
      cells[nlh, 1][[1]],
      style = "border-bottom: 1px solid black;"
    )
  }

  # Create a map between line numbers and line groupings, adjusting abs_rownumber with nlh
  map <- data.frame(lines = seq_len(nr), abs_rownumber = mat$line_grouping)
  row_info_df <- data.frame(indent = mat$row_info$indent, abs_rownumber = mat$row_info$abs_rownumber + nlh)
  map <- merge(map, row_info_df, by = "abs_rownumber")

  # add indent values for headerlines
  map <- rbind(data.frame(abs_rownumber = 1:nlh, indent = 0, lines = 0), map)


  # Row labels style
  for (i in seq_len(nr)) {
    indent <- ifelse(any(map$lines == i), map$indent[map$lines == i][1], -1)

    # Apply indentation
    if (indent > 0) {
      cells[i, 1][[1]] <- htmltools::tagAppendAttributes(
        cells[i, 1][[1]],
        style = paste0("padding-left: ", indent * 3, "ch;")
      )
    }

    # Apply bold font weight if "row_names" is in 'bold'
    if ("row_names" %in% bold) {
      cells[i, 1][[1]] <- htmltools::tagAppendAttributes(
        cells[i, 1][[1]],
        style = "font-weight: bold;"
      )
    }
  }

  # label rows style
  if ("label_rows" %in% bold) {
    which_lbl_rows <- which(mat$row_info$node_class == "LabelRow")
    cells[which_lbl_rows + nlh, ] <- lapply(
      cells[which_lbl_rows + nlh, ],
      htmltools::tagAppendAttributes,
      style = "font-weight: bold;"
    )
  }

  # content rows style
  if ("content_rows" %in% bold) {
    which_cntnt_rows <- which(mat$row_info$node_class %in% c("ContentRow", "DataRow"))
    cells[which_cntnt_rows + nlh, ] <- lapply(
      cells[which_cntnt_rows + nlh, ],
      htmltools::tagAppendAttributes,
      style = "font-weight: bold;"
    )
  }

  if (any(!mat$display)) {
    # Check that expansion kept the same display info
    check_expansion <- c()
    for (ii in unique(mat$line_grouping)) {
      rows <- which(mat$line_grouping == ii)
      check_expansion <- c(
        check_expansion,
        apply(mat$display[rows, , drop = FALSE], 2, function(x) all(x) || all(!x))
      )
    }

    if (!all(check_expansion)) {
      stop(
        "Found that a group of rows have different display options even if ",
        "they belong to the same line group. This should not happen. Please ",
        "file an issue or report to the maintainers."
      ) # nocov
    }

    for (ii in unique(mat$line_grouping)) {
      rows <- which(mat$line_grouping == ii)
      should_display_col <- apply(mat$display[rows, , drop = FALSE], 2, any)
      cells[ii, !should_display_col] <- NA_integer_
    }
  }

  rows <- apply(cells, 1, function(row) {
    tags$tr(
      class = class_tr,
      style = "white-space: pre;",
      Filter(function(x) !identical(x, NA_integer_), row)
    )
  })

  hsep_line <- tags$hr(class = "solid")

  hdrtag <- div_helper(
    class = "rtables-titles-block",
    list(
      div_helper(
        class = "rtables-main-titles-block",
        lapply(main_title(x), if ("main_title" %in% bold) tags$b else tags$p,
          class = "rtables-main-title"
        )
      ),
      div_helper(
        class = "rtables-subtitles-block",
        lapply(subtitles(x), if ("subtitles" %in% bold) tags$b else tags$p,
          class = "rtables-subtitle"
        )
      )
    )
  )

  tabletag <- do.call(
    tags$table,
    c(
      rows,
      list(
        class = class_table,
        style = paste(
          if (no_spaces_between_cells) "border-collapse: collapse;",
          if (!is.null(width)) paste("width:", width)
        ),
        tags$caption(sprintf("(\\#tag:%s)", link_label),
          style = "caption-side: top;",
          .noWS = "after-begin"
        )
      )
    )
  )

  rfnotes <- div_helper(
    class = "rtables-ref-footnotes-block",
    lapply(mat$ref_footnotes, tags$p,
      class = "rtables-referential-footnote"
    )
  )

  mftr <- div_helper(
    class = "rtables-main-footers-block",
    lapply(main_footer(x), tags$p,
      class = "rtables-main-footer"
    )
  )

  pftr <- div_helper(
    class = "rtables-prov-footers-block",
    lapply(prov_footer(x), tags$p,
      class = "rtables-prov-footer"
    )
  )

  ## XXX this omits the divs entirely if they are empty. Do we want that or do
  ## we want them to be there but empty??
  ftrlst <- list(
    if (length(mat$ref_footnotes) > 0) rfnotes,
    if (length(mat$ref_footnotes) > 0) hsep_line,
    if (length(main_footer(x)) > 0) mftr,
    if (length(main_footer(x)) > 0 && length(prov_footer(x)) > 0) tags$br(), # line break
    if (length(prov_footer(x)) > 0) pftr
  )

  if (!is.null(unlist(ftrlst))) ftrlst <- c(list(hsep_line), ftrlst)
  ftrlst <- ftrlst[!vapply(ftrlst, is.null, TRUE)]

  ftrtag <- div_helper(
    class = "rtables-footers-block",
    ftrlst
  )

  div_helper(
    class = "rtables-all-parts-block",
    list(
      tags$head(
        tags$style(
          ".rtables-all-parts-block table tr {    border-top: 1px solid #ddd;}"
        )
      ),
      hdrtag,
      tabletag,
      ftrtag
    )
  )
}

treestruct <- function(obj, ind = 0L) {
  nc <- ncol(obj)
  cat(rep(" ", times = ind),
    sprintf("[%s] %s", class(obj), obj_name(obj)),
    sep = ""
  )
  if (!is(obj, "ElementaryTable") && nrow(obj@content) > 0) {
    crows <- nrow(content_table(obj))
    ccols <- if (crows == 0) 0 else nc
    cat(sprintf(
      " [cont: %d x %d]",
      crows, ccols
    ))
  }
  if (is(obj, "VTableTree") && length(tree_children(obj))) {
    kids <- tree_children(obj)
    if (are(kids, "TableRow")) {
      cat(sprintf(
        " (%d x %d)\n",
        length(kids), nc
      ))
    } else {
      cat("\n")
      lapply(kids, treestruct, ind = ind + 1)
    }
  }
  invisible(NULL)
}

setGeneric(
  "ploads_to_str",
  function(x, collapse = ":") standardGeneric("ploads_to_str")
)

setMethod(
  "ploads_to_str", "Split",
  function(x, collapse = ":") {
    paste(sapply(spl_payload(x), ploads_to_str),
      collapse = collapse
    )
  }
)

setMethod(
  "ploads_to_str", "CompoundSplit",
  function(x, collapse = ":") {
    paste(sapply(spl_payload(x), ploads_to_str),
      collapse = collapse
    )
  }
)

setMethod(
  "ploads_to_str", "list",
  function(x, collapse = ":") {
    stop("Please contact the maintainer")
  }
)

setMethod(
  "ploads_to_str", "SplitVector",
  function(x, collapse = ":") {
    sapply(x, ploads_to_str)
  }
)

setMethod(
  "ploads_to_str", "ANY",
  function(x, collapse = ":") {
    paste(x)
  }
)

setGeneric("payloadmsg", function(spl) standardGeneric("payloadmsg"))

setMethod(
  "payloadmsg", "VarLevelSplit",
  function(spl) {
    spl_payload(spl)
  }
)

setMethod(
  "payloadmsg", "MultiVarSplit",
  function(spl) "var"
)

setMethod(
  "payloadmsg", "VarLevWBaselineSplit",
  function(spl) {
    paste0(
      spl_payload(spl), "[bsl ",
      spl@ref_group_value, # XXX XXX
      "]"
    )
  }
)

setMethod(
  "payloadmsg", "ManualSplit",
  function(spl) "mnl"
)

setMethod(
  "payloadmsg", "AllSplit",
  function(spl) "all"
)

setMethod(
  "payloadmsg", "ANY",
  function(spl) {
    warning("don't know how to make payload print message for Split of class", class(spl))
    "XXX"
  }
)

spldesc <- function(spl, value = "") {
  value <- rawvalues(value)
  payloadmsg <- payloadmsg(spl)
  format <- "%s (%s)"
  sprintf(
    format,
    value,
    payloadmsg
  )
}

layoutmsg <- function(obj) {
  ## if(!is(obj, "VLayoutNode"))
  ##     stop("how did a non layoutnode object get in docatlayout??")

  pos <- tree_pos(obj)
  spllst <- pos_splits(pos)
  spvallst <- pos_splvals(pos)
  if (is(obj, "LayoutAxisTree")) {
    kids <- tree_children(obj)
    return(unlist(lapply(kids, layoutmsg)))
  }

  msg <- paste(
    collapse = " -> ",
    mapply(spldesc,
      spl = spllst,
      value = spvallst
    )
  )
  msg
}

setMethod(
  "show", "LayoutAxisTree",
  function(object) {
    msg <- layoutmsg(object)
    cat(msg, "\n")
    invisible(object)
  }
)


#' Display column tree structure
#'
#' Displays the tree structure of the columns of a
#' table or column structure object.
#'
#' @inheritParams gen_args
#'
#' @return Nothing, called for its side effect of displaying
#' a summary to the terminal.
#'
#' @examples
#' lyt <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   split_cols_by("STRATA1") %>%
#'   split_cols_by("SEX", nested = FALSE) %>%
#'   analyze("AGE")
#'
#' tbl <- build_table(lyt, ex_adsl)
#' coltree_structure(tbl)
#' @export
coltree_structure <- function(obj) {
  ctree <- coltree(obj)
  cat(layoutmsg2(ctree))
}

lastposmsg <- function(pos) {
  spls <- pos_splits(pos)
  splvals <- value_names(pos_splvals(pos))
  indiv_msgs <- unlist(mapply(function(spl, valnm) paste(obj_name(spl), valnm, sep = ": "),
    spl = spls,
    valnm = splvals,
    SIMPLIFY = FALSE
  ))
  paste(indiv_msgs, collapse = " -> ")
}

layoutmsg2 <- function(obj, level = 1) {
  nm <- obj_name(obj)
  pos <- tree_pos(obj)
  nopos <- identical(pos, EmptyTreePos)

  msg <- paste0(strrep(" ", times = 2 * (level - 1)), "[", nm, "] (", if (nopos) "no pos" else lastposmsg(pos), ")\n")
  if (is(obj, "LayoutAxisTree")) {
    kids <- tree_children(obj)
    msg <- c(msg, unlist(lapply(kids, layoutmsg2, level = level + 1)))
  }
  msg
}

setGeneric("spltype_abbrev", function(obj) standardGeneric("spltype_abbrev"))

setMethod(
  "spltype_abbrev", "VarLevelSplit",
  function(obj) "lvls"
)

setMethod(
  "spltype_abbrev", "VarLevWBaselineSplit",
  function(obj) paste("ref_group", obj@ref_group_value)
)

setMethod(
  "spltype_abbrev", "MultiVarSplit",
  function(obj) "vars"
)

setMethod(
  "spltype_abbrev", "VarStaticCutSplit",
  function(obj) "scut"
)

setMethod(
  "spltype_abbrev", "VarDynCutSplit",
  function(obj) "dcut"
)
setMethod(
  "spltype_abbrev", "AllSplit",
  function(obj) "all obs"
)
## setMethod("spltype_abbrev", "NULLSplit",
##           function(obj) "no obs")

setMethod(
  "spltype_abbrev", "AnalyzeVarSplit",
  function(obj) "** analysis **"
)

setMethod(
  "spltype_abbrev", "CompoundSplit",
  function(obj) paste("compound", paste(sapply(spl_payload(obj), spltype_abbrev), collapse = " "))
)

setMethod(
  "spltype_abbrev", "AnalyzeMultiVars",
  function(obj) "** multivar analysis **"
)
setMethod(
  "spltype_abbrev", "AnalyzeColVarSplit",
  function(obj) "** col-var analysis **"
)

docat_splitvec <- function(object, indent = 0) {
  if (indent > 0) {
    cat(rep(" ", times = indent), sep = "")
  }
  if (length(object) == 1L && is(object[[1]], "VTableNodeInfo")) {
    tab <- object[[1]]
    msg <- sprintf(
      "A Pre-Existing Table [%d x %d]",
      nrow(tab), ncol(tab)
    )
  } else {
    plds <- ploads_to_str(object) ## lapply(object, spl_payload))

    tabbrev <- sapply(object, spltype_abbrev)
    msg <- paste(
      collapse = " -> ",
      paste0(plds, " (", tabbrev, ")")
    )
  }
  cat(msg, "\n")
}

setMethod(
  "show", "SplitVector",
  function(object) {
    cat("A SplitVector Pre-defining a Tree Structure\n\n")
    docat_splitvec(object)
    cat("\n")
    invisible(object)
  }
)

docat_predataxis <- function(object, indent = 0) {
  lapply(object, docat_splitvec)
}

setMethod(
  "show", "PreDataColLayout",
  function(object) {
    cat("A Pre-data Column Layout Object\n\n")
    docat_predataxis(object)
    invisible(object)
  }
)

setMethod(
  "show", "PreDataRowLayout",
  function(object) {
    cat("A Pre-data Row Layout Object\n\n")
    docat_predataxis(object)
    invisible(object)
  }
)

setMethod(
  "show", "PreDataTableLayouts",
  function(object) {
    cat("A Pre-data Table Layout\n")
    cat("\nColumn-Split Structure:\n")
    docat_predataxis(object@col_layout)
    cat("\nRow-Split Structure:\n")
    docat_predataxis(object@row_layout)
    cat("\n")
    invisible(object)
  }
)

setMethod(
  "show", "InstantiatedColumnInfo",
  function(object) {
    layoutmsg <- layoutmsg(coltree(object))
    cat("An InstantiatedColumnInfo object",
      "Columns:",
      layoutmsg,
      if (disp_ccounts(object)) {
        paste(
          "ColumnCounts:\n",
          paste(col_counts(object),
            collapse = ", "
          )
        )
      },
      "",
      sep = "\n"
    )
    invisible(object)
  }
)

#' @rdname int_methods
setMethod("print", "VTableTree", function(x, ...) {
  msg <- toString(x, ...)
  cat(msg)
  invisible(x)
})

#' @rdname int_methods
setMethod("show", "VTableTree", function(object) {
  cat(toString(object))
  invisible(object)
})

setMethod("show", "TableRow", function(object) {
  cat(sprintf(
    "[%s indent_mod %d]: %s   %s\n",
    class(object),
    indent_mod(object),
    obj_label(object),
    paste(as.vector(get_formatted_cells(object)),
      collapse = "   "
    )
  ))
  invisible(object)
})

#' Variable associated with a split
#'
#' This function is intended for use when writing custom splitting logic. In cases where the split is associated with
#' a single variable, the name of that variable will be returned. At time of writing this includes splits generated
#' via the [split_rows_by()], [split_cols_by()], [split_rows_by_cuts()], [split_cols_by_cuts()],
#' [split_rows_by_cutfun()], and [split_cols_by_cutfun()] layout directives.
#'
#' @param spl (`VarLevelSplit`)\cr the split object.
#'
#' @return For splits with a single variable associated with them, returns the split. Otherwise, an error is raised.
#'
#' @export
#' @seealso \code{\link{make_split_fun}}
setGeneric("spl_variable", function(spl) standardGeneric("spl_variable"))

#' @rdname spl_variable
#' @export
setMethod("spl_variable", "VarLevelSplit", function(spl) spl_payload(spl))

#' @rdname spl_variable
#' @export
setMethod("spl_variable", "VarDynCutSplit", function(spl) spl_payload(spl))

#' @rdname spl_variable
#' @export
setMethod("spl_variable", "VarStaticCutSplit", function(spl) spl_payload(spl))

#' @rdname spl_variable
#' @export
setMethod(
  "spl_variable", "Split",
  function(spl) stop("Split class ", class(spl), " not associated with a single variable.")
)

in_col_split <- function(spl_ctx) {
  identical(
    names(spl_ctx),
    names(context_df_row(cinfo = NULL))
  )
}

assert_splres_element <- function(pinfo, nm, len = NULL, component = NULL) {
  msg_2_append <- ""
  if (!is.null(component)) {
    msg_2_append <- paste0(
      "Invalid split function constructed by upstream call to ",
      "make_split_fun. Problem source: ",
      component, " argument."
    )
  }
  if (!(nm %in% names(pinfo))) {
    stop(
      "Split result does not have required element: ", nm, ".",
      msg_2_append
    )
  }
  if (!is.null(len) && length(pinfo[[nm]]) != len) {
    stop(
      "Split result element ", nm, " does not have required length ", len, ".",
      msg_2_append
    )
  }
  TRUE
}

validate_split_result <- function(pinfo, component = NULL) {
  assert_splres_element(pinfo, "datasplit", component = component)
  len <- length(pinfo$datasplit)
  assert_splres_element(pinfo, "values", len, component = component)
  assert_splres_element(pinfo, "labels", len, component = component)
  TRUE
}

#' Construct split result object
#'
#' These functions can be used to create or add to a split result in functions which implement core splitting or
#' post-processing within a custom split function.
#'
#' @param values (`character` or `list(SplitValue)`)\cr the values associated with each facet.
#' @param datasplit (`list(data.frame)`)\cr the facet data for each facet generated in the split.
#' @param labels (`character`)\cr the labels associated with each facet.
#' @param extras (`list` or `NULL`)\cr extra values associated with each of the facets which will be passed to
#'   analysis functions applied within the facet.
#' @param subset_exprs (`list`)\cr A list of subsetting expressions (e.g.,
#'     created with `quote()`) to be used during column subsetting.
#'
#' @return A named list representing the facets generated by the split with elements `values`, `datasplit`, and
#'   `labels`, which are the same length and correspond to each other element-wise.
#'
#' @details
#' These functions performs various housekeeping tasks to ensure that the split result list is as the rtables
#' internals expect it, most of which are not relevant to end users.
#'
#' @examples
#' splres <- make_split_result(
#'   values = c("hi", "lo"),
#'   datasplit = list(hi = mtcars, lo = mtcars[1:10, ]),
#'   labels = c("more data", "less data"),
#'   subset_exprs = list(expression(TRUE), expression(seq_along(wt) <= 10))
#' )
#'
#' splres2 <- add_to_split_result(splres,
#'   values = "med",
#'   datasplit = list(med = mtcars[1:20, ]),
#'   labels = "kinda some data",
#'   subset_exprs = quote(seq_along(wt) <= 20)
#' )
#'
#' @family make_custom_split
#' @rdname make_split_result
#' @export
#' @family make_custom_split
make_split_result <- function(values, datasplit, labels, extras = NULL, subset_exprs = vector("list", length(values))) {
  if (length(values) == 1 && is(datasplit, "data.frame")) {
    datasplit <- list(datasplit)
  }
  ret <- list(values = values, datasplit = datasplit, labels = labels, subset_exprs = subset_exprs)
  if (!is.null(extras)) {
    ret$extras <- extras
  }
  .fixupvals(ret)
}

#' @param splres (`list`)\cr a list representing the result of splitting.
#'
#' @rdname make_split_result
#' @export
add_to_split_result <- function(splres, values, datasplit, labels, extras = NULL, subset_exprs = NULL) {
  validate_split_result(splres)
  newstuff <- make_split_result(values, datasplit, labels, extras, subset_exprs = list(subset_exprs))
  ret <- lapply(
    names(splres),
    function(nm) c(splres[[nm]], newstuff[[nm]])
  )
  names(ret) <- names(splres)
  .fixupvals(ret)
}


.can_take_spl_context <- function(f) any(c(".spl_context", "...") %in% names(formals(f)))

#' Create a custom splitting function
#'
#' @param pre (`list`)\cr zero or more functions which operate on the incoming data and return a new data frame that
#'   should split via `core_split`. They will be called on the data in the order they appear in the list.
#' @param core_split (`function` or `NULL`)\cr if non-`NULL`, a function which accepts the same arguments that
#'   `do_base_split` does, and returns the same type of named list. Custom functions which override this behavior
#'   cannot be used in column splits.
#' @param post (`list`)\cr zero or more functions which should be called on the list output by splitting.
#'
#' @details
#' Custom split functions can be thought of as (up to) 3 different types of manipulations of the splitting process:
#'
#' 1. Pre-processing of the incoming data to be split.
#' 2. (Row-splitting only) Customization of the core mapping of incoming data to facets.
#' 3. Post-processing operations on the set of facets (groups) generated by the split.
#'
#' This function provides an interface to create custom split functions by implementing and specifying sets of
#' operations in each of those classes of customization independently.
#'
#' Pre-processing functions (1), must accept: `df`, `spl`, `vals`, and `labels`, and can optionally accept
#' `.spl_context`. They then manipulate `df` (the incoming data for the split) and return a modified data frame.
#' This modified data frame *must* contain all columns present in the incoming data frame, but can add columns if
#' necessary (though we note that these  new columns cannot be used in the layout as split or analysis variables,
#' because they will not be present when validity checking is done).
#'
#' The preprocessing component is useful for things such as manipulating factor levels, e.g., to trim unobserved ones
#' or to reorder levels based on observed counts, etc.
#'
#' Core  splitting functions  override  the  fundamental
#' splitting procedure,  and are only  necessary in rare  cases. These
#' must  accept  `spl`, `df`,  `vals`,  `labels`,  and can  optionally
#' accept `.spl_context`. They should return a split result object
#' constructed via `make_split_result()`.
#'
#' In particular, if the custom split function will be used in
#' column space, subsetting expressions (e.g., as returned by
#' `quote()` or `bquote` must be provided, while they are
#' optional (and largely ignored, currently) in row space.
#'
#'
#' Post-processing functions (3) must accept the result of the core split as their first argument (which can be
#' anything), in addition to `spl`, and `fulldf`, and can optionally accept `.spl_context`. They must each return a
#' modified version of the same structure specified above for core splitting.
#'
#' In both the pre- and post-processing cases, multiple functions can be specified. When this happens, they are applied
#' sequentially, in the order they appear in the list passed to the relevant argument (`pre` and `post`, respectively).
#'
#' @return A custom function that can be used as a split function.
#'
#' @seealso [custom_split_funs] for a more detailed discussion on what custom split functions do.
#'
#' @examples
#' mysplitfun <- make_split_fun(
#'   pre = list(drop_facet_levels),
#'   post = list(add_overall_facet("ALL", "All Arms"))
#' )
#'
#' basic_table(show_colcounts = TRUE) %>%
#'   split_cols_by("ARM", split_fun = mysplitfun) %>%
#'   analyze("AGE") %>%
#'   build_table(subset(DM, ARM %in% c("B: Placebo", "C: Combination")))
#'
#' ## post (and pre) arguments can take multiple functions, here
#' ## we add an overall facet and the reorder the facets
#' reorder_facets <- function(splret, spl, fulldf, ...) {
#'   ord <- order(names(splret$values))
#'   make_split_result(
#'     splret$values[ord],
#'     splret$datasplit[ord],
#'     splret$labels[ord]
#'   )
#' }
#'
#' mysplitfun2 <- make_split_fun(
#'   pre = list(drop_facet_levels),
#'   post = list(
#'     add_overall_facet("ALL", "All Arms"),
#'     reorder_facets
#'   )
#' )
#' basic_table(show_colcounts = TRUE) %>%
#'   split_cols_by("ARM", split_fun = mysplitfun2) %>%
#'   analyze("AGE") %>%
#'   build_table(subset(DM, ARM %in% c("B: Placebo", "C: Combination")))
#'
#' very_stupid_core <- function(spl, df, vals, labels, .spl_context) {
#'   make_split_result(c("stupid", "silly"),
#'     datasplit = list(df[1:10, ], df[11:30, ]),
#'     labels = c("first 10", "second 20")
#'   )
#' }
#'
#' dumb_30_facet <- add_combo_facet("dumb",
#'   label = "thirty patients",
#'   levels = c("stupid", "silly")
#' )
#' nonsense_splfun <- make_split_fun(
#'   core_split = very_stupid_core,
#'   post = list(dumb_30_facet)
#' )
#'
#' ## recall core split overriding is not supported in column space
#' ## currently, but we can see it in action in row space
#'
#' lyt_silly <- basic_table() %>%
#'   split_rows_by("ARM", split_fun = nonsense_splfun) %>%
#'   summarize_row_groups() %>%
#'   analyze("AGE")
#' silly_table <- build_table(lyt_silly, DM)
#' silly_table
#'
#' @family make_custom_split
#' @export
make_split_fun <- function(pre = list(), core_split = NULL, post = list()) {
  function(df,
           spl,
           vals = NULL,
           labels = NULL,
           trim = FALSE,
           .spl_context) {
    orig_columns <- names(df)
    for (pre_fn in pre) {
      if (.can_take_spl_context(pre_fn)) {
        df <- pre_fn(df = df, spl = spl, vals = vals, labels = labels, .spl_context = .spl_context)
      } else {
        df <- pre_fn(df = df, spl = spl, vals = vals, labels = labels)
      }
      if (!is(df, "data.frame")) {
        stop(
          "Error in custom split function, pre-split step did not return a data.frame. ",
          "See upstream call to make_split_fun for original source of error."
        )
      }
    }

    if (!all(orig_columns %in% names(df))) {
      stop(
        "Preprocessing functions(s) in custom split function removed a column from the incoming data.",
        " This is not supported. See upstread make_split_fun call (pre argument) for original source of error."
      )
    }

    if (is.null(core_split)) {
      ret <- do_base_split(spl = spl, df = df, vals = vals, labels = labels)
    } else {
      ret <- core_split(spl = spl, df = df, vals = vals, labels = labels, .spl_context)
      validate_split_result(ret, component = "core_split")
    }

    for (post_fn in post) {
      if (.can_take_spl_context(post_fn)) {
        ret <- post_fn(ret, spl = spl, .spl_context = .spl_context, fulldf = df)
      } else {
        ret <- post_fn(ret, spl = spl, fulldf = df)
      }
    }
    validate_split_result(ret, "post")
    ret
  }
}

#' Add a combination facet in post-processing
#'
#' Add a combination facet during the post-processing stage in a custom split fun.
#'
#' @param name (`string`)\cr name for the resulting facet (for use in pathing, etc.).
#' @param label (`string`)\cr label for the resulting facet.
#' @param levels (`character`)\cr vector of levels to combine within the resulting facet.
#' @param extra (`list`)\cr extra arguments to be passed to analysis functions applied within the resulting facet.
#'
#' @details
#' For `add_combo_facet`, the data associated with the resulting facet will be the data associated with the facets for
#' each level in `levels`, row-bound together. In particular, this means that if those levels are overlapping, data
#' that appears in both will be duplicated.
#'
#' @return A function which can be used within the `post` argument in [make_split_fun()].
#'
#' @seealso [make_split_fun()]
#'
#' @examples
#' mysplfun <- make_split_fun(post = list(
#'   add_combo_facet("A_B",
#'     label = "Arms A+B",
#'     levels = c("A: Drug X", "B: Placebo")
#'   ),
#'   add_overall_facet("ALL", label = "All Arms")
#' ))
#'
#' lyt <- basic_table(show_colcounts = TRUE) %>%
#'   split_cols_by("ARM", split_fun = mysplfun) %>%
#'   analyze("AGE")
#'
#' tbl <- build_table(lyt, DM)
#'
#' @family make_custom_split
#' @export
add_combo_facet <- function(name, label = name, levels, extra = list()) {
  function(ret, spl, .spl_context, fulldf) {
    if (is(levels, "AllLevelsSentinel")) {
      subexpr <- expression(TRUE)
      datpart <- list(fulldf)
    } else {
      subexpr <- .combine_value_exprs(ret$values[levels])
      datpart <- list(do.call(rbind, ret$datasplit[levels]))
    }


    val <- LevelComboSplitValue(
      val = name, extr = extra, combolevels = levels, label = label,
      sub_expr = subexpr
    )
    add_to_split_result(ret,
      values = list(val), labels = label,
      datasplit = datpart
    )
  }
}

.combine_value_exprs <- function(val_lst, spl) {
  exprs <- lapply(val_lst, value_expr)
  nulls <- vapply(exprs, is.null, TRUE)
  if (all(nulls)) {
    return(NULL) # default behavior all the way down the line, no need to do anything.
  } else if (any(nulls)) {
    exprs[nulls] <- lapply(val_lst[nulls], function(vali) make_subset_expr(spl, vali))
  }
  Reduce(.or_combine_exprs, exprs)
}

## no NULLS coming in here, everything has been populated
## by either custom subsetting expressions or the result of make_subset_expr(spl, val)
.or_combine_exprs <- function(ex1, ex2) {
  if (identical(ex1, expression(FALSE))) {
    return(ex2)
  } else if (identical(ex2, expression(FALSE))) {
    return(ex1)
  } else if (identical(ex1, expression(TRUE)) || identical(ex2, expression(TRUE))) {
    return(TRUE)
  }
  as.expression(bquote((.(a)) | .(b), list(a = ex1[[1]], b = ex2[[1]])))
}

#' @rdname add_combo_facet
#' @export
add_overall_facet <- function(name, label, extra = list()) {
  add_combo_facet(
    name = name, label = label, levels = select_all_levels,
    extra = extra
  )
}

#' Trim levels of another variable from each facet (post-processing split step)
#'
#' @param innervar (`character`)\cr the variable(s) to trim (remove unobserved levels) independently within each facet.
#'
#' @return A function suitable for use in the `pre` (list) argument of `make_split_fun`.
#'
#' @seealso [make_split_fun()]
#'
#' @family make_custom_split
#' @export
trim_levels_in_facets <- function(innervar) {
  function(ret, ...) {
    for (var in innervar) {
      ret$datasplit <- lapply(ret$datasplit, function(df) {
        df[[var]] <- factor(df[[var]])
        df
      })
    }
    ret
  }
}

#' Pre-processing function for use in `make_split_fun`
#'
#' This function is intended for use as a pre-processing component in `make_split_fun`, and should not be called
#' directly by end users.
#'
#' @param df (`data.frame`)\cr the incoming data corresponding with the parent facet.
#' @param spl (`VarLevelSplit`)\cr the split.
#' @param ... additional parameters passed internally.
#'
#' @seealso [make_split_fun()]
#'
#' @family make_custom_split
#' @export
drop_facet_levels <- function(df, spl, ...) {
  if (!is(spl, "VarLevelSplit") || is.na(spl_payload(spl))) {
    stop("Unable to determine faceting variable in drop_facet_levels application.")
  }
  var <- spl_payload(spl)
  df[[var]] <- factor(df[[var]])
  df
}

#' Postprocessing split function behavior to generally restrict facets
#'
#' @param facets `(character)`\cr Vector of facet names
#' @param op `("keep", or "exclude")`\cr Whether `facets` names facets
#'     to be (exclusively) kept (the default) or removed.
#' @param reorder `(flag)`\cr For `op == "keep"`, should the resulting
#'     facets be reordered to the order they appear in
#'     `facets`. Defaults to `TRUE`. Ignored if `op == "exclude"`.
#' @param quiet `(logical(1))`\cr Whether warnings should be given or
#'     not (the default) when facets named in `facets` are not found
#'     in the split result.
#'
#' @return a function suitable for use within the `post` argument of
#'     [make_split_fun()].
#'
#' @details This is a function factory which creates a post-process
#'     behavioral building block for use in [make_split_fun()].
#'
#' This factory provides the equivalent of both `keep_split_levels`
#' and `remove_split_levels` in a form suitable for use in
#' [make_split_fun()].
#'
#' When `op` is `"keep"` (the default), resulting facets are
#' restricted to only those named in `facets` when the generated
#' function is applied to a split result; in the case of `"exclude"`,
#' facets named in `facets` are removed so that only those not named
#' remain.
#'
#' The generated function will throw a warning if any of `facets` are
#' not found in the split result it receives during splitting, unless
#' it was created with `quiet = FALSE`.
#'
#' @seealso [make_split_fun()]
#'
#' @examples
#'
#' keep_spl <- make_split_fun(post = list(restrict_facets(c("M", "F"), op = "keep")))
#'
#' lyt <- basic_table() |>
#'   split_cols_by("SEX", split_fun = keep_spl) |>
#'   analyze("AGE")
#'
#' build_table(lyt, ex_adsl)
#'
#'
#' excl_undiff <- restrict_facets("UNDIFFERENTIATED", op = "exclude")
#' excl_spl <- make_split_fun(post = list(excl_undiff))
#'
#' lyt <- basic_table() |>
#'   split_cols_by("SEX", split_fun = excl_spl) |>
#'   analyze("AGE")
#'
#' build_table(lyt, ex_adsl)
#'
#' @family make_custom_split
#' @export
restrict_facets <- function(facets,
                            op = c("keep", "exclude"),
                            reorder = TRUE,
                            quiet = FALSE) {
  op <- match.arg(op)
  function(splret, spl, fulldf) {
    nms <- names(splret[[1]])
    mtch <- match(facets, nms)
    if (anyNA(mtch)) {
      if (!quiet) {
        warning(
          "restrict facets (op: ",
          op, ") could not find facets [",
          paste(facets[is.na(mtch)], collapse = ", "),
          "]. Ignoring these."
        )
      }
      mtch <- mtch[!is.na(mtch)]
    }

    sel_vec <- mtch
    if (op == "exclude") {
      sel_vec <- -1 * sel_vec
    } else if (!reorder) { # op is keep
      sel_vec <- sort(sel_vec)
    }
    ret <- lapply(
      splret,
      function(lst) lst[sel_vec]
    )
    names(ret) <- names(splret)
    ret
  }
}

.reindex_one_pos <- function(refs, cur_idx_fun) {
  if (length(refs) == 0) {
    return(refs)
  }

  lapply(refs, function(refi) {
    ## these can be symbols, e.g. ^, † now, those are
    ## special and don't get reindexed cause they're not numbered
    ## to begin with
    idx <- ref_index(refi)
    if (is.na(idx) || !is.na(as.integer(idx))) {
      ref_index(refi) <- cur_idx_fun(refi)
    }
    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
    )

    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") # nocov
    }
    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_footnotes(ctree) <- .reindex_one_pos(
    col_footnotes(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_footnotes(ctree)
  ## if(length(unlist(cfs)) > 0) {
  ##     col_footnotes(ctree) <- .reindex_one_pos(lapply(cfs,
  ##                                      function(refs) lapply(refs, function(refi) {
}

#' Update footnote indices on a built table
#'
#' Re-indexes footnotes within a built table.
#'
#' @inheritParams gen_args
#'
#' @details
#' After adding or removing referential footnotes manually, or after subsetting a table, the reference indexes
#' (i.e. the number associated with specific footnotes) may be incorrect. This function recalculates these based
#' on the full table.
#'
#' @note In the future this should not generally need to be called manually.
#'
#' @export
update_ref_indexing <- function(tt) {
  col_fnotes <- c(list(row_fnotes = list()), col_footnotes(tt))
  row_fnotes <- row_footnotes(tt)
  cell_fnotes <- cell_footnotes(tt)
  all_fns <- rbind(col_fnotes, cbind(row_fnotes, cell_fnotes))
  all_fns <- unlist(t(all_fns))
  unique_fnotes <- unique(sapply(all_fns, ref_msg))

  cur_index <- function(ref_fn) {
    match(ref_msg(ref_fn), unique_fnotes)
  }

  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, ]
  if (nrow(rdf) == 0) {
    return(tt)
  }

  for (i in seq_len(nrow(rdf))) {
    path <- unname(rdf$path[[i]])
    tt_at_path(tt, path) <-
      .idx_helper(
        tt_at_path(tt, path),
        cur_index
      )
  }
  tt
}

#' Format `rcell` objects
#'
#' This is a wrapper for [formatters::format_value()] for use with `CellValue` objects
#'
#' @inheritParams lyt_args
#' @inheritParams gen_args
#' @param x (`CellValue` or `ANY`)\cr an object of class `CellValue`, or a raw value.
#' @param format (`string` or `function`)\cr the format label or formatter function to
#'   apply to `x`.
#' @param output (`string`)\cr output type.
#' @param pr_row_format (`list`)\cr list of default formats coming from the general row.
#' @param pr_row_na_str (`list`)\cr list of default `"NA"` strings coming from the general row.
#' @param shell (`flag`)\cr whether the formats themselves should be returned instead of the
#'   values with formats applied. Defaults to `FALSE`.
#'
#' @return Formatted text.
#'
#' @examples
#' cll <- CellValue(pi, format = "xx.xxx")
#' format_rcell(cll)
#'
#' # Cell values precedes the row values
#' cll <- CellValue(pi, format = "xx.xxx")
#' format_rcell(cll, pr_row_format = "xx.x")
#'
#' # Similarly for NA values
#' cll <- CellValue(NA, format = "xx.xxx", format_na_str = "This is THE NA")
#' format_rcell(cll, pr_row_na_str = "This is NA")
#'
#' @export
format_rcell <- function(x, format,
                         output = c("ascii", "html"),
                         na_str = obj_na_str(x) %||% "NA",
                         pr_row_format = NULL,
                         pr_row_na_str = NULL,
                         round_type,
                         shell = FALSE) {
  # Check for format and parent row format
  format <- if (missing(format)) obj_format(x) else format
  if (is.null(format) && !is.null(pr_row_format)) {
    format <- pr_row_format
  }
  if (missing(round_type) && !is.null(obj_round_type(x))) {
    round_type <- obj_round_type(x)
  }
  if (missing(round_type) && is.null(obj_round_type(x))) {
    round_type <- valid_round_type[1]
  }
  # Check for na_str from parent
  if (is.null(obj_na_str(x)) && !is.null(pr_row_na_str)) {
    na_str <- pr_row_na_str
  }

  # Main call to external function or shell
  if (shell) {
    return(format)
  }
  format_value(rawvalues(x),
    format = format,
    output = output,
    na_str = na_str,
    round_type = round_type
  )
}

#' Create an `ElementaryTable` from a `data.frame`
#'
#' @param df (`data.frame`)\cr a data frame.
#'
#' @details
#' If row names are not defined in `df` (or they are simple numbers), then the row names are taken from the column
#' `label_name`, if it exists. If `label_name` exists, then it is also removed from the original data. This behavior
#' is compatible with [as_result_df()], when `as_is = TRUE` and the row names are not unique.
#'
#' @seealso [as_result_df()] for the inverse operation.
#'
#' @examples
#' df_to_tt(mtcars)
#'
#' @export
df_to_tt <- function(df) {
  colnms <- colnames(df)
  cinfo <- manual_cols(colnms)
  rnames <- rownames(df)
  havern <- !is.null(rnames)

  if ((!havern || all(grepl("[0-9]+", rnames))) && "label_name" %in% colnms) {
    rnames <- df$label_name
    df <- df[, -match("label_name", colnms)]
    colnms <- colnames(df)
    cinfo <- manual_cols(colnms)
    havern <- TRUE
  }

  kids <- lapply(seq_len(nrow(df)), function(i) {
    rni <- if (havern) rnames[i] else ""
    do.call(rrow, c(list(row.name = rni), unclass(df[i, ])))
  })

  ElementaryTable(kids = kids, cinfo = cinfo)
}

#' @importFrom tools file_ext
NULL

#' Create enriched flat value table with paths
#'
#' This function creates a flat tabular file of cell values and corresponding paths via [path_enriched_df()]. It then
#' writes that data frame out as a `tsv` file.
#'
#' By default (i.e. when `value_func` is not specified, list columns where at least one value has length > 1 are
#' collapsed to character vectors by collapsing the list element with `"|"`.
#'
#' @note
#' There is currently no round-trip capability for this type of export. You can read values exported this way back in
#' via `import_from_tsv` but you will receive only the `data.frame` version back, NOT a `TableTree`.
#'
#' @inheritParams gen_args
#' @inheritParams data.frame_export
#' @param file (`string`)\cr the path of the file to written to or read from.
#' @param sep (`string`)\cr defaults to `\t`. See [utils::write.table()] for more details.
#' @param ... (`any`)\cr additional arguments to be passed to [utils::write.table()].
#'
#' @return
#' * `export_as_tsv` returns `NULL` silently.
#' * `import_from_tsv` returns a `data.frame` with re-constituted list values.
#'
#' @seealso [path_enriched_df()] for the underlying function that does the work.
#'
#' @importFrom utils write.table read.table
#' @rdname tsv_io
#' @export
export_as_tsv <- function(tt, file = NULL, path_fun = collapse_path,
                          value_fun = collapse_values, sep = "\t", ...) {
  df <- path_enriched_df(tt, path_fun = path_fun, value_fun = value_fun)
  write.table(df, file, sep = sep, ...)
}

#' @rdname tsv_io
#' @export
import_from_tsv <- function(file) {
  rawdf <- read.table(file, header = TRUE, sep = "\t")
  as.data.frame(lapply(
    rawdf,
    function(col) {
      if (!any(grepl(.collapse_char, col, fixed = TRUE))) {
        col
      } else {
        I(strsplit(col, split = .collapse_char_esc))
      }
    }
  ))
}
# txt (formatters) --------------------------------------------------------------------
#' @importFrom formatters export_as_txt
#'
#' @examples
#' lyt <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   analyze(c("AGE", "BMRKR2", "COUNTRY"))
#'
#' tbl <- build_table(lyt, ex_adsl)
#'
#' cat(export_as_txt(tbl, file = NULL, paginate = TRUE, lpp = 8))
#'
#' \dontrun{
#' tf <- tempfile(fileext = ".txt")
#' export_as_txt(tbl, file = tf)
#' system2("cat", tf)
#' }
#'
#' @export
formatters::export_as_txt

# pdf (formatters) ----------------------------------------------------------
#' @importFrom formatters export_as_pdf
#'
#' @examples
#' lyt <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   analyze(c("AGE", "BMRKR2", "COUNTRY"))
#'
#' tbl <- build_table(lyt, ex_adsl)
#'
#' \dontrun{
#' tf <- tempfile(fileext = ".pdf")
#' export_as_pdf(tbl, file = tf, pg_height = 4)
#' tf <- tempfile(fileext = ".pdf")
#' export_as_pdf(tbl, file = tf, lpp = 8)
#' }
#'
#' @export
formatters::export_as_pdf

#' Change indentation of all `rrows` in an `rtable`
#'
#' Change indentation of all `rrows` in an `rtable`
#'
#' @param x (`VTableTree`)\cr an `rtable` object.
#' @param by (`integer`)\cr number to increase indentation of rows by. Can be negative. If final indentation is
#'   less than 0, the indentation is set to 0.
#'
#' @return `x` with its indent modifier incremented by `by`.
#'
#' @examples
#' is_setosa <- iris$Species == "setosa"
#' m_tbl <- rtable(
#'   header = rheader(
#'     rrow(row.name = NULL, rcell("Sepal.Length", colspan = 2), rcell("Petal.Length", colspan = 2)),
#'     rrow(NULL, "mean", "median", "mean", "median")
#'   ),
#'   rrow(
#'     row.name = "All Species",
#'     mean(iris$Sepal.Length), median(iris$Sepal.Length),
#'     mean(iris$Petal.Length), median(iris$Petal.Length),
#'     format = "xx.xx"
#'   ),
#'   rrow(
#'     row.name = "Setosa",
#'     mean(iris$Sepal.Length[is_setosa]), median(iris$Sepal.Length[is_setosa]),
#'     mean(iris$Petal.Length[is_setosa]), median(iris$Petal.Length[is_setosa]),
#'     format = "xx.xx"
#'   )
#' )
#' indent(m_tbl)
#' indent(m_tbl, 2)
#'
#' @export
indent <- function(x, by = 1) {
  if (nrow(x) == 0 || by == 0) {
    return(x)
  }

  indent_mod(x) <- indent_mod(x) + by
  x
}

#' Clear all indent modifiers from a table
#'
#' @inheritParams gen_args
#'
#' @return The same class as `tt`, with all indent modifiers set to zero.
#'
#' @examples
#' lyt1 <- basic_table() %>%
#'   summarize_row_groups("STUDYID", label_fstr = "overall summary") %>%
#'   split_rows_by("AEBODSYS", child_labels = "visible") %>%
#'   summarize_row_groups("STUDYID", label_fstr = "subgroup summary") %>%
#'   analyze("AGE", indent_mod = -1L)
#'
#' tbl1 <- build_table(lyt1, ex_adae)
#' tbl1
#' clear_indent_mods(tbl1)
#'
#' @export
#' @rdname clear_imods
setGeneric("clear_indent_mods", function(tt) standardGeneric("clear_indent_mods"))

#' @export
#' @rdname clear_imods
setMethod(
  "clear_indent_mods", "VTableTree",
  function(tt) {
    ct <- content_table(tt)
    if (!is.null(ct)) {
      content_table(tt) <- clear_indent_mods(ct)
    }
    tree_children(tt) <- lapply(tree_children(tt), clear_indent_mods)
    indent_mod(tt) <- 0L
    tt
  }
)

#' @export
#' @rdname clear_imods
setMethod(
  "clear_indent_mods", "TableRow",
  function(tt) {
    indent_mod(tt) <- 0L
    tt
  }
)

1		.reindex_one_pos <- function(refs, cur_idx_fun) {
2	2623x	if (length(refs) == 0) {
3	2557x	return(refs)
4		}
5
6	66x	lapply(refs, function(refi) {
7		## these can be symbols, e.g. ^, † now, those are
8		## special and don't get reindexed cause they're not numbered
9		## to begin with
10	71x	idx <- ref_index(refi)
11	71x	if (is.na(idx) \|\| !is.na(as.integer(idx))) {
12	71x	ref_index(refi) <- cur_idx_fun(refi)
13		}
14	71x	refi
15		})
16		}
17
18	56x	setGeneric(".idx_helper", function(tr, cur_idx_fun) standardGeneric(".idx_helper"))
19
20		setMethod(
21		".idx_helper", "TableRow",
22		function(tr, cur_idx_fun) {
23	54x	row_footnotes(tr) <- .reindex_one_pos(
24	54x	row_footnotes(tr),
25	54x	cur_idx_fun
26		)
27
28	54x	cell_footnotes(tr) <- lapply(cell_footnotes(tr), ## crfs,
29	54x	.reindex_one_pos,
30	54x	cur_idx_fun = cur_idx_fun
31		)
32	54x	tr
33		}
34		)
35
36		setMethod(
37		".idx_helper", "VTableTree",
38		function(tr, cur_idx_fun) {
39	2x	if (!labelrow_visible(tr)) {
40		stop("got a row footnote on a non-visible label row. this should never happen") # nocov
41		}
42	2x	lr <- tt_labelrow(tr)
43
44	2x	row_footnotes(lr) <- .reindex_one_pos(
45	2x	row_footnotes(lr),
46	2x	cur_idx_fun
47		)
48
49	2x	tt_labelrow(tr) <- lr
50
51	2x	tr
52		}
53		)
54
55		index_col_refs <- function(tt, cur_idx_fun) {
56	522x	ctree <- coltree(tt)
57	522x	ctree <- .index_col_refs_inner(ctree, cur_idx_fun)
58	522x	coltree(tt) <- ctree
59	522x	tt
60		}
61
62		.index_col_refs_inner <- function(ctree, cur_idx_fun) {
63	2398x	col_footnotes(ctree) <- .reindex_one_pos(
64	2398x	col_footnotes(ctree),
65	2398x	cur_idx_fun
66		)
67
68	2398x	if (is(ctree, "LayoutColTree")) {
69	890x	tree_children(ctree) <- lapply(tree_children(ctree),
70	890x	.index_col_refs_inner,
71	890x	cur_idx_fun = cur_idx_fun
72		)
73		}
74	2398x	ctree
75		## cfs <- col_footnotes(ctree)
76		## if(length(unlist(cfs)) > 0) {
77		## col_footnotes(ctree) <- .reindex_one_pos(lapply(cfs,
78		## function(refs) lapply(refs, function(refi) {
79		}
80
81		#' Update footnote indices on a built table
82		#'
83		#' Re-indexes footnotes within a built table.
84		#'
85		#' @inheritParams gen_args
86		#'
87		#' @details
88		#' After adding or removing referential footnotes manually, or after subsetting a table, the reference indexes
89		#' (i.e. the number associated with specific footnotes) may be incorrect. This function recalculates these based
90		#' on the full table.
91		#'
92		#' @note In the future this should not generally need to be called manually.
93		#'
94		#' @export
95		update_ref_indexing <- function(tt) {
96	522x	col_fnotes <- c(list(row_fnotes = list()), col_footnotes(tt))
97	522x	row_fnotes <- row_footnotes(tt)
98	522x	cell_fnotes <- cell_footnotes(tt)
99	522x	all_fns <- rbind(col_fnotes, cbind(row_fnotes, cell_fnotes))
100	522x	all_fns <- unlist(t(all_fns))
101	522x	unique_fnotes <- unique(sapply(all_fns, ref_msg))
102
103	522x	cur_index <- function(ref_fn) {
104	71x	match(ref_msg(ref_fn), unique_fnotes)
105		}
106
107	522x	if (ncol(tt) > 0) {
108	522x	tt <- index_col_refs(tt, cur_index)
109		} ## col_info(tt) <- index_col_refs(col_info(tt), cur_index)
110		## TODO when column refs are a thing we will
111		## still need to do those here before returning!!!
112	522x	if (nrow(tt) == 0) {
113	19x	return(tt)
114		}
115
116	503x	rdf <- make_row_df(tt)
117
118	503x	rdf <- rdf[rdf$nreflines > 0, ]
119	503x	if (nrow(rdf) == 0) {
120	471x	return(tt)
121		}
122
123	32x	for (i in seq_len(nrow(rdf))) {
124	56x	path <- unname(rdf$path[[i]])
125	56x	tt_at_path(tt, path) <-
126	56x	.idx_helper(
127	56x	tt_at_path(tt, path),
128	56x	cur_index
129		)
130		}
131	32x	tt
132		}

1		#' Trimming and pruning criteria
2		#'
3		#' Criteria functions (and constructors thereof) for trimming and pruning tables.
4		#'
5		#' @inheritParams gen_args
6		#'
7		#' @return A logical value indicating whether `tr` should be included (`TRUE`) or pruned (`FALSE`) during pruning.
8		#'
9		#' @seealso [prune_table()], [trim_rows()]
10		#'
11		#' @details `all_zero_or_na` returns `TRUE` (and thus indicates trimming/pruning) for any non-`LabelRow`
12		#' `TableRow` which contain only any mix of `NA` (including `NaN`), `0`, `Inf` and `-Inf` values.
13		#'
14		#' @examples
15		#' adsl <- ex_adsl
16		#' levels(adsl$SEX) <- c(levels(ex_adsl$SEX), "OTHER")
17		#' adsl$AGE[adsl$SEX == "UNDIFFERENTIATED"] <- 0
18		#' adsl$BMRKR1 <- 0
19		#'
20		#' tbl_to_prune <- basic_table() %>%
21		#' analyze("BMRKR1") %>%
22		#' split_cols_by("ARM") %>%
23		#' split_rows_by("SEX") %>%
24		#' summarize_row_groups() %>%
25		#' split_rows_by("STRATA1") %>%
26		#' summarize_row_groups() %>%
27		#' analyze("AGE") %>%
28		#' build_table(adsl)
29		#'
30		#' tbl_to_prune %>% prune_table(all_zero_or_na)
31		#'
32		#' @rdname trim_prune_funs
33		#' @export
34		all_zero_or_na <- function(tr) {
35	347x	if (!is(tr, "TableRow") \|\| is(tr, "LabelRow")) {
36	93x	return(FALSE)
37		}
38	254x	rvs <- unlist(unname(row_values(tr)))
39	254x	all(is.na(rvs) \| rvs == 0 \| !is.finite(rvs))
40		}
41
42		#' @details `all_zero` returns `TRUE` for any non-`LabelRow` which contains only (non-missing) zero values.
43		#'
44		#' @examples
45		#' tbl_to_prune %>% prune_table(all_zero)
46		#'
47		#' @rdname trim_prune_funs
48		#' @export
49		all_zero <- function(tr) {
50	8x	if (!is(tr, "TableRow") \|\| is(tr, "LabelRow")) {
51	!	return(FALSE)
52		}
53	8x	rvs <- unlist(unname(row_values(tr)))
54	8x	isTRUE(all(rvs == 0))
55		}
56
57		#' Trim rows from a populated table without regard for table structure
58		#'
59		#' @inheritParams gen_args
60		#' @param criteria (`function`)\cr function which takes a `TableRow` object and returns `TRUE` if that row
61		#' should be removed. Defaults to [all_zero_or_na()].
62		#'
63		#' @return The table with rows that have only `NA` or 0 cell values removed.
64		#'
65		#' @note
66		#' Visible `LabelRow`s are including in this trimming, which can lead to either all label rows being trimmed or
67		#' label rows remaining when all data rows have been trimmed, depending on what `criteria` returns when called on
68		#' a `LabelRow` object. To avoid this, use the structurally-aware [prune_table()] machinery instead.
69		#'
70		#' @details
71		#' This function will be deprecated in the future in favor of the more elegant and versatile [prune_table()]
72		#' function which can perform the same function as `trim_rows()` but is more powerful as it takes table structure
73		#' into account.
74		#'
75		#' @seealso [prune_table()]
76		#'
77		#' @examples
78		#' adsl <- ex_adsl
79		#' levels(adsl$SEX) <- c(levels(ex_adsl$SEX), "OTHER")
80		#'
81		#' tbl_to_trim <- basic_table() %>%
82		#' analyze("BMRKR1") %>%
83		#' split_cols_by("ARM") %>%
84		#' split_rows_by("SEX") %>%
85		#' summarize_row_groups() %>%
86		#' split_rows_by("STRATA1") %>%
87		#' summarize_row_groups() %>%
88		#' analyze("AGE") %>%
89		#' build_table(adsl)
90		#'
91		#' tbl_to_trim %>% trim_rows()
92		#'
93		#' tbl_to_trim %>% trim_rows(all_zero)
94		#'
95		#' @export
96		trim_rows <- function(tt, criteria = all_zero_or_na) {
97	3x	rows <- collect_leaves(tt, TRUE, TRUE)
98	3x	torm <- vapply(rows, criteria,
99	3x	NA,
100	3x	USE.NAMES = FALSE
101		)
102	3x	tt[!torm, ,
103	3x	keep_topleft = TRUE,
104	3x	keep_titles = TRUE,
105	3x	keep_footers = TRUE,
106	3x	reindex_refs = TRUE
107		]
108		}
109
110		#' @inheritParams trim_rows
111		#'
112		#' @details
113		#' `content_all_zeros_nas` prunes a subtable if both of the following are true:
114		#'
115		#' * It has a content table with exactly one row in it.
116		#' * `all_zero_or_na` returns `TRUE` for that single content row. In practice, when the default summary/content
117		#' function is used, this represents pruning any subtable which corresponds to an empty set of the input data
118		#' (e.g. because a factor variable was used in [split_rows_by()] but not all levels were present in the data).
119		#'
120		#' @examples
121		#' tbl_to_prune %>% prune_table(content_all_zeros_nas)
122		#'
123		#' @rdname trim_prune_funs
124		#' @export
125		content_all_zeros_nas <- function(tt, criteria = all_zero_or_na) {
126		## this will be NULL if
127		## tt is something that doesn't have a content table
128	254x	ct <- content_table(tt)
129		## NROW returns 0 for NULL.
130	254x	if (NROW(ct) == 0 \|\| nrow(ct) > 1) {
131	242x	return(FALSE)
132		}
133
134	12x	cr <- tree_children(ct)[[1]]
135	12x	criteria(cr)
136		}
137
138		#' @details
139		#' `prune_empty_level` combines `all_zero_or_na` behavior for `TableRow` objects, `content_all_zeros_nas` on
140		#' `content_table(tt)` for `TableTree` objects, and an additional check that returns `TRUE` if the `tt` has no
141		#' children.
142		#'
143		#' @examples
144		#' tbl_to_prune %>% prune_table(prune_empty_level)
145		#'
146		#' @rdname trim_prune_funs
147		#' @export
148		prune_empty_level <- function(tt) {
149	389x	if (is(tt, "TableRow")) {
150	151x	return(all_zero_or_na(tt))
151		}
152
153	238x	if (content_all_zeros_nas(tt)) {
154	2x	return(TRUE)
155		}
156	236x	kids <- tree_children(tt)
157	236x	length(kids) == 0
158		}
159
160		#' @details `prune_zeros_only` behaves as `prune_empty_level` does, except that like `all_zero` it prunes
161		#' only in the case of all non-missing zero values.
162		#'
163		#' @examples
164		#' tbl_to_prune %>% prune_table(prune_zeros_only)
165		#'
166		#' @rdname trim_prune_funs
167		#' @export
168		prune_zeros_only <- function(tt) {
169	16x	if (is(tt, "TableRow")) {
170	8x	return(all_zero(tt))
171		}
172
173	8x	if (content_all_zeros_nas(tt, criteria = all_zero)) {
174	!	return(TRUE)
175		}
176	8x	kids <- tree_children(tt)
177	8x	length(kids) == 0
178		}
179
180		#' @param min (`numeric(1)`)\cr (used by `low_obs_pruner` only). Minimum aggregate count value.
181		#' Subtables whose combined/average count are below this threshold will be pruned.
182		#' @param type (`string`)\cr how count values should be aggregated. Must be `"sum"` (the default) or `"mean"`.
183		#'
184		#' @details
185		#' `low_obs_pruner` is a constructor function which, when called, returns a pruning criteria function which
186		#' will prune on content rows by comparing sum or mean (dictated by `type`) of the count portions of the cell
187		#' values (defined as the first value per cell regardless of how many values per cell there are) against `min`.
188		#'
189		#' @examples
190		#' min_prune <- low_obs_pruner(70, "sum")
191		#' tbl_to_prune %>% prune_table(min_prune)
192		#'
193		#' @rdname trim_prune_funs
194		#' @export
195		low_obs_pruner <- function(min, type = c("sum", "mean")) {
196	3x	type <- match.arg(type)
197	3x	function(tt) {
198	21x	if (is(tt, "TableRow") \|\| NROW(ctab <- content_table(tt)) != 1) { ## note the <- in there!!!
199	9x	return(FALSE) ## only trimming on count content rows
200		}
201	12x	ctr <- tree_children(ctab)[[1]]
202	12x	vals <- sapply(row_values(ctr), function(v) v[[1]])
203	12x	sumvals <- sum(vals)
204	12x	if (type == "mean") {
205	8x	sumvals <- sumvals / length(vals)
206		}
207	12x	sumvals < min
208		}
209		}
210
211		#' Recursively prune a `TableTree`
212		#'
213		#' @inheritParams gen_args
214		#' @param prune_func (`function`)\cr a function to be called on each subtree which returns `TRUE` if the
215		#' entire subtree should be removed.
216		#' @param stop_depth (`numeric(1)`)\cr the depth after which subtrees should not be checked for pruning.
217		#' Defaults to `NA` which indicates pruning should happen at all levels.
218		#' @param depth (`numeric(1)`)\cr used internally, not intended to be set by the end user.
219		#' @param ... named arguments to optionally be passed down to `prune_func` if it
220		#' accepts them (or `...`)
221		#'
222		#' @return A `TableTree` pruned via recursive application of `prune_func`.
223		#'
224		#' @seealso [prune_empty_level()] for details on this and several other basic pruning functions included
225		#' in the `rtables` package.
226		#'
227		#' @examples
228		#' adsl <- ex_adsl
229		#' levels(adsl$SEX) <- c(levels(ex_adsl$SEX), "OTHER")
230		#'
231		#' tbl_to_prune <- basic_table() %>%
232		#' split_cols_by("ARM") %>%
233		#' split_rows_by("SEX") %>%
234		#' summarize_row_groups() %>%
235		#' split_rows_by("STRATA1") %>%
236		#' summarize_row_groups() %>%
237		#' analyze("AGE") %>%
238		#' build_table(adsl)
239		#'
240		#' tbl_to_prune %>% prune_table()
241		#'
242		#' @export
243		prune_table <- function(tt,
244		prune_func = prune_empty_level,
245		stop_depth = NA_real_,
246		depth = 0,
247		...) {
248	325x	if (!is.na(stop_depth) && depth > stop_depth) {
249	!	return(tt)
250		}
251	325x	if (is(tt, "TableRow")) {
252	54x	if (prune_func(tt)) {
253	!	tt <- NULL
254		}
255	54x	return(tt)
256		}
257
258	271x	kids <- tree_children(tt)
259
260	271x	more_args <- match_fun_args(prune_func, depth = depth, ...)
261	271x	torm <- vapply(kids, function(tb) {
262	390x	!is.null(tb) && do.call(prune_func, c(list(tb), more_args))
263	271x	}, NA)
264
265	270x	keepkids <- kids[!torm]
266	270x	keepkids <- lapply(keepkids, prune_table,
267	270x	prune_func = prune_func,
268	270x	stop_depth = stop_depth,
269	270x	depth = depth + 1,
270		...
271		)
272
273	270x	keepkids <- keepkids[!vapply(keepkids, is.null, NA)]
274	270x	if (length(keepkids) > 0) {
275	135x	tree_children(tt) <- keepkids
276		} else {
277	135x	tt <- NULL
278		}
279	270x	tt
280		}

1		#' Compare two rtables
2		#'
3		#' Prints a matrix where `.` means cell matches, `X` means cell does
4		#' not match, `+` cell (row) is missing, and `-` cell (row)
5		#' should not be there. If `structure` is set to `TRUE`, `C` indicates
6		#' column-structure mismatch, `R` indicates row-structure mismatch, and
7		#' `S` indicates mismatch in both row and column structure.
8		#'
9		#' @param object (`VTableTree`)\cr `rtable` to test.
10		#' @param expected (`VTableTree`)\cr expected `rtable`.
11		#' @param tol (`numeric(1)`)\cr tolerance.
12		#' @param comp.attr (`flag`)\cr whether to compare cell formats. Other attributes are
13		#' silently ignored.
14		#' @param structure (`flag`)\cr whether structures (in the form of column and row
15		#' paths to cells) should be compared. Currently defaults to `FALSE`, but this is
16		#' subject to change in future versions.
17		#'
18		#' @note In its current form, `compare_rtables` does not take structure into
19		#' account, only row and cell position.
20		#'
21		#' @return A matrix of class `rtables_diff` representing the differences
22		#' between `object` and `expected` as described above.
23		#'
24		#' @examples
25		#' t1 <- rtable(header = c("A", "B"), format = "xx", rrow("row 1", 1, 2))
26		#' t2 <- rtable(header = c("A", "B", "C"), format = "xx", rrow("row 1", 1, 2, 3))
27		#'
28		#' compare_rtables(object = t1, expected = t2)
29		#'
30		#' if (interactive()) {
31		#' Viewer(t1, t2)
32		#' }
33		#'
34		#' expected <- rtable(
35		#' header = c("ARM A\nN=100", "ARM B\nN=200"),
36		#' format = "xx",
37		#' rrow("row 1", 10, 15),
38		#' rrow(),
39		#' rrow("section title"),
40		#' rrow("row colspan", rcell(c(.345543, .4432423), colspan = 2, format = "(xx.xx, xx.xx)"))
41		#' )
42		#'
43		#' expected
44		#'
45		#' object <- rtable(
46		#' header = c("ARM A\nN=100", "ARM B\nN=200"),
47		#' format = "xx",
48		#' rrow("row 1", 10, 15),
49		#' rrow("section title"),
50		#' rrow("row colspan", rcell(c(.345543, .4432423), colspan = 2, format = "(xx.xx, xx.xx)"))
51		#' )
52		#'
53		#' compare_rtables(object, expected, comp.attr = FALSE)
54		#'
55		#' object <- rtable(
56		#' header = c("ARM A\nN=100", "ARM B\nN=200"),
57		#' format = "xx",
58		#' rrow("row 1", 10, 15),
59		#' rrow(),
60		#' rrow("section title")
61		#' )
62		#'
63		#' compare_rtables(object, expected)
64		#'
65		#' object <- rtable(
66		#' header = c("ARM A\nN=100", "ARM B\nN=200"),
67		#' format = "xx",
68		#' rrow("row 1", 14, 15.03),
69		#' rrow(),
70		#' rrow("section title"),
71		#' rrow("row colspan", rcell(c(.345543, .4432423), colspan = 2, format = "(xx.xx, xx.xx)"))
72		#' )
73		#'
74		#' compare_rtables(object, expected)
75		#'
76		#' object <- rtable(
77		#' header = c("ARM A\nN=100", "ARM B\nN=200"),
78		#' format = "xx",
79		#' rrow("row 1", 10, 15),
80		#' rrow(),
81		#' rrow("section title"),
82		#' rrow("row colspan", rcell(c(.345543, .4432423), colspan = 2, format = "(xx.x, xx.x)"))
83		#' )
84		#'
85		#' compare_rtables(object, expected)
86		#'
87		#' @export
88		compare_rtables <- function(object, expected, tol = 0.1, comp.attr = TRUE,
89		structure = FALSE) {
90		# if (identical(object, expected)) return(invisible(TRUE))
91
92	12x	if (!is(object, "VTableTree")) {
93	!	stop(
94	!	"argument object is expected to be of class TableTree or ",
95	!	"ElementaryTable"
96		)
97		}
98	12x	if (!is(expected, "VTableTree")) {
99	!	stop(
100	!	"argument expected is expected to be of class TableTree or ",
101	!	"ElementaryTable"
102		)
103		}
104	12x	dim_out <- apply(rbind(dim(object), dim(expected)), 2, max)
105
106	12x	X <- matrix(rep(".", dim_out[1] * dim_out[2]), ncol = dim_out[2])
107	12x	row.names(X) <- as.character(1:dim_out[1])
108	12x	colnames(X) <- as.character(1:dim_out[2])
109
110	12x	if (!identical(names(object), names(expected))) {
111	7x	attr(X, "info") <- "column names are not the same"
112		}
113
114	12x	if (!comp.attr) {
115	!	attr(X, "info") <- c(
116	!	attr(X, "info"),
117	!	"cell attributes have not been compared"
118		)
119		}
120	12x	if (!identical(row.names(object), row.names(expected))) {
121	2x	attr(X, "info") <- c(attr(X, "info"), "row labels are not the same")
122		}
123
124	12x	nro <- nrow(object)
125	12x	nre <- nrow(expected)
126	12x	nco <- ncol(object)
127	12x	nce <- ncol(expected)
128
129	12x	if (nco < nce) {
130	2x	X[, seq(nco + 1, nce)] <- "-"
131	10x	} else if (nce < nco) {
132	3x	X[, seq(nce + 1, nco)] <- "+"
133		}
134	12x	if (nro < nre) {
135	1x	X[seq(nro + 1, nre), ] <- "-"
136	11x	} else if (nre < nro) {
137	!	X[seq(nre + 1, nro), ] <- "+"
138		}
139
140	12x	orig_object <- object # nolint
141	12x	orig_expected <- expected # nolint
142	12x	if (nro != nre \|\| nco != nce) {
143	5x	object <- object[1:min(nro, nre), 1:min(nco, nce), drop = FALSE]
144	5x	expected <- expected[1:min(nro, nre), 1:min(nco, nce), drop = FALSE]
145	5x	inner <- compare_rtables(object, expected, tol = tol, comp.attr = comp.attr, structure = structure)
146	5x	X[seq_len(nrow(object)), seq_len(ncol(object))] <- inner
147	5x	class(X) <- c("rtables_diff", class(X))
148	5x	return(X)
149		}
150
151		## from here dimensions match!
152
153	7x	orows <- cell_values(object, omit_labrows = FALSE)
154	7x	erows <- cell_values(expected, omit_labrows = FALSE)
155	7x	if (nrow(object) == 1) {
156	!	orows <- list(orows)
157	!	erows <- list(erows)
158		}
159	7x	res <- mapply(compare_rrows,
160	7x	row1 = orows, row2 = erows, tol = tol, ncol = ncol(object),
161	7x	USE.NAMES = FALSE, SIMPLIFY = FALSE
162		)
163	7x	X <- do.call(rbind, res)
164	7x	rpo <- row_paths(object)
165	7x	rpe <- row_paths(expected)
166
167	7x	if (comp.attr) {
168	7x	ofmts <- value_formats(object)
169	7x	efmts <- value_formats(expected)
170		## dim(ofmts) <- NULL
171		## dim(efmts) <- NULL
172
173	7x	fmt_mismatch <- which(!mapply(identical, x = ofmts, y = efmts)) ## inherently ignores dim
174
175
176		## note the single index here!!!, no comma!!!!
177	7x	X[fmt_mismatch] <- "X"
178		}
179
180
181	7x	if (structure) {
182	1x	rp_mismatches <- !mapply(identical, x = rpo, y = rpe)
183	1x	cpo <- col_paths(object)
184	1x	cpe <- col_paths(expected)
185	1x	cp_mismatches <- !mapply(identical, x = cpo, y = cpe)
186
187	1x	if (any(rp_mismatches)) { # P for (row or column) path do not match
188	!	X[rp_mismatches, ] <- "R"
189		}
190	1x	if (any(cp_mismatches)) {
191	1x	crep <- rep("C", nrow(X))
192	1x	if (any(rp_mismatches)) {
193	!	crep[rp_mismatches] <- "P"
194		}
195	1x	X[, cp_mismatches] <- rep(crep, sum(cp_mismatches))
196		}
197		}
198	7x	class(X) <- c("rtables_diff", class(X))
199	7x	X
200		}
201
202		## for (i in 1:dim(X)[1]) {
203		## for (j in 1:dim(X)[2]) {
204
205		## is_equivalent <- TRUE
206		## if (i <= nro && i <= nre && j <= nco && j <= nce) {
207		## x <- object[i,j, drop = TRUE]
208		## y <- expected[i,j, drop = TRUE]
209
210		## attr_x <- attributes(x)
211		## attr_y <- attributes(y)
212
213		## attr_x_sorted <- if (is.null(attr_x)) NULL else attr_x[order(names(attr_x))]
214		## attr_y_sorted <- if (is.null(attr_y)) NULL else attr_y[order(names(attr_y))]
215
216		## if (comp.attr && !identical(attr_x_sorted, attr_y_sorted)) {
217		## is_equivalent <- FALSE
218		## } else if (is.numeric(x) && is.numeric(y)) {
219		## if (any(abs(na.omit(x - y)) > tol)) {
220		## is_equivalent <- FALSE
221		## }
222		## } else {
223		## if (!identical(x, y)) {
224		## is_equivalent <- FALSE
225		## }
226		## }
227
228		## if (!is_equivalent) {
229		## X[i,j] <- "X"
230		## }
231		## } else if (i > nro \|\| j > nco) {
232		## ## missing in object
233		## X[i, j] <- "+"
234		## } else {
235		## ## too many elements
236		## X[i, j] <- "-"
237		## }
238		## }
239		## }
240		## class(X) <- c("rtable_diff", class(X))
241		## X
242		## }
243
244		compare_value <- function(x, y, tol) {
245	359x	if (identical(x, y) \|\| (is.numeric(x) && is.numeric(y) && max(abs(x - y)) <= tol)) {
246		"."
247		} else {
248	72x	"X"
249		}
250		}
251
252		compare_rrows <- function(row1, row2, tol, ncol) {
253	173x	if (length(row1) == ncol && length(row2) == ncol) {
254	115x	mapply(compare_value, x = row1, y = row2, tol = tol, USE.NAMES = FALSE)
255	58x	} else if (length(row1) == 0 && length(row2) == 0) {
256	44x	rep(".", ncol)
257		} else {
258	14x	rep("X", ncol)
259		}
260		}
261
262		## #' @export
263		## print.rtable_diff <- function(x, ...) {
264		## print.default(unclass(x), quote = FALSE, ...)
265		## }

1		#' Cell value constructors
2		#'
3		#' Construct a cell value and associate formatting, labeling, indenting, and column spanning information with it.
4		#'
5		#' @inheritParams compat_args
6		#' @inheritParams lyt_args
7		#' @inheritParams gen_args
8		#' @param x (`ANY`)\cr cell value.
9		#' @param format (`string` or `function`)\cr the format label (string) or `formatters` function to apply to `x`.
10		#' See [formatters::list_valid_format_labels()] for currently supported format labels.
11		#' @param label (`string` or `NULL`)\cr label. If non-`NULL`, it will be looked at when determining row labels.
12		#' @param colspan (`integer(1)`)\cr column span value.
13		#' @param footnotes (`list` or `NULL`)\cr referential footnote messages for the cell.
14		#' @param stat_names (`character` or `NA`)\cr names for the statistics in the cell. It can be a vector of strings.
15		#' If `NA`, statistic names are not specified.
16		#'
17		#' @inherit CellValue return
18		#'
19		#' @note Currently column spanning is only supported for defining header structure.
20		#'
21		#' @examples
22		#' rcell(1, format = "xx.x")
23		#' rcell(c(1, 2), format = c("xx - xx"))
24		#' rcell(c(1, 2), stat_names = c("Rand1", "Rand2"))
25		#'
26		#' @rdname rcell
27		#' @export
28		rcell <- function(x,
29		format = NULL,
30		colspan = 1L,
31		label = NULL,
32		indent_mod = NULL,
33		footnotes = NULL,
34		align = NULL,
35		format_na_str = NULL,
36		stat_names = NULL,
37		round_type = valid_round_type) {
38	37479x	round_type <- match.arg(round_type)
39	37479x	checkmate::assert_character(stat_names, null.ok = TRUE)
40	37479x	if (!is.null(align)) {
41	59x	check_aligns(align)
42		}
43	37479x	if (is(x, "CellValue")) {
44	22682x	if (!is.null(label)) {
45	1x	obj_label(x) <- label
46		}
47	22682x	if (colspan != 1L) {
48	1x	cell_cspan(x) <- colspan
49		}
50	22682x	if (!is.null(indent_mod)) {
51	1x	indent_mod(x) <- indent_mod
52		}
53	22682x	if (!is.null(format)) {
54	1x	obj_format(x) <- format
55		}
56	22682x	if (!is.null(footnotes)) {
57	384x	cell_footnotes(x) <- lapply(footnotes, RefFootnote)
58		}
59	22682x	if (!is.null(format_na_str)) {
60	!	obj_na_str(x) <- format_na_str
61		}
62	22682x	if (!is.null(stat_names)) {
63	8x	obj_stat_names(x) <- stat_names
64		}
65	22682x	ret <- x
66		} else {
67	14797x	if (is.null(label)) {
68	11711x	label <- obj_label(x)
69		}
70	14797x	if (is.null(format)) {
71	8297x	format <- obj_format(x)
72		}
73	14797x	if (is.null(indent_mod)) {
74	14797x	indent_mod <- indent_mod(x)
75		}
76	14797x	footnotes <- lapply(footnotes, RefFootnote)
77	14797x	ret <- CellValue(
78	14797x	val = x,
79	14797x	format = format,
80	14797x	colspan = colspan,
81	14797x	label = label,
82	14797x	indent_mod = indent_mod,
83	14797x	footnotes = footnotes,
84	14797x	format_na_str = format_na_str,
85	14797x	stat_names = stat_names %\|\|% NA_character_,
86	14797x	round_type = round_type
87	14797x	) # RefFootnote(footnote))
88		}
89	37479x	if (!is.null(align)) {
90	59x	cell_align(ret) <- align
91		}
92	37479x	ret
93		}
94
95		#' @param is_ref (`flag`)\cr whether function is being used in the reference column (i.e. `.in_ref_col` should be
96		#' passed to this argument).
97		#' @param refval (`ANY`)\cr value to use when in the reference column. Defaults to `NULL`.
98		#'
99		#' @details
100		#' `non_ref_rcell` provides the common blank for cells in the reference column, this value otherwise, and should
101		#' be passed the value of `.in_ref_col` when it is used.
102		#'
103		#' @rdname rcell
104		#' @export
105		non_ref_rcell <- function(x, is_ref, format = NULL, colspan = 1L,
106		label = NULL, indent_mod = NULL,
107		refval = NULL,
108		align = "center",
109		format_na_str = NULL) {
110	2x	val <- if (is_ref) refval else x
111	2x	rcell(val,
112	2x	format = format, colspan = colspan, label = label,
113	2x	indent_mod = indent_mod, align = align,
114	2x	format_na_str = format_na_str
115		)
116		}
117
118		#' Create multiple rows in analysis or summary functions
119		#'
120		#' Define the cells that get placed into multiple rows in `afun`.
121		#'
122		#' @param ... single row defining expressions.
123		#' @param .list (`list`)\cr list cell content (usually `rcells`). The `.list` is concatenated to `...`.
124		#' @param .names (`character` or `NULL`)\cr names of the returned list/structure.
125		#' @param .labels (`character` or `NULL`)\cr labels for the defined rows.
126		#' @param .formats (`character` or `NULL`)\cr formats for the values.
127		#' @param .indent_mods (`integer` or `NULL`)\cr indent modifications for the defined rows.
128		#' @param .cell_footnotes (`list`)\cr referential footnote messages to be associated by name with cells.
129		#' @param .row_footnotes (`list`)\cr referential footnotes messages to be associated by name with rows.
130		#' @param .aligns (`character` or `NULL`)\cr alignments for the cells. Standard for `NULL` is `"center"`.
131		#' See [formatters::list_valid_aligns()] for currently supported alignments.
132		#' @param .format_na_strs (`character` or `NULL`)\cr NA strings for the cells.
133		#' @param .stat_names (`list`)\cr names for the statistics in the cells.
134		#' It can be a vector of values. If `list(NULL)`, statistic names are not specified and will
135		#' appear as `NA`.
136		#'
137		#' @note In post-processing, referential footnotes can also be added using row and column
138		#' paths with [`fnotes_at_path<-`].
139		#'
140		#' @return A `RowsVerticalSection` object (or `NULL`). The details of this object should be considered an
141		#' internal implementation detail.
142		#'
143		#' @seealso [analyze()]
144		#'
145		#' @examples
146		#' in_rows(1, 2, 3, .names = c("a", "b", "c"))
147		#' in_rows(1, 2, 3, .labels = c("a", "b", "c"))
148		#' in_rows(1, 2, 3, .names = c("a", "b", "c"), .labels = c("AAA", "BBB", "CCC"))
149		#' in_rows(
150		#' .list = list(a = c(NA, NA)),
151		#' .formats = "xx - xx",
152		#' .format_na_strs = list(c("asda", "lkjklj"))
153		#' )
154		#' in_rows(.list = list(a = c(NA, NA)), .format_na_strs = c("asda", "lkjklj"))
155		#'
156		#' in_rows(.list = list(a = 1, b = 2, c = 3))
157		#' in_rows(1, 2, .list = list(3), .names = c("a", "b", "c"))
158		#'
159		#' lyt <- basic_table() %>%
160		#' split_cols_by("ARM") %>%
161		#' analyze("AGE", afun = function(x) {
162		#' in_rows(
163		#' "Mean (sd)" = rcell(c(mean(x), sd(x)), format = "xx.xx (xx.xx)"),
164		#' "Range" = rcell(range(x), format = "xx.xx - xx.xx")
165		#' )
166		#' })
167		#'
168		#' tbl <- build_table(lyt, ex_adsl)
169		#' tbl
170		#'
171		#' @export
172		in_rows <- function(..., .list = NULL, .names = NULL,
173		.labels = NULL,
174		.formats = NULL,
175		.indent_mods = NULL,
176		.cell_footnotes = list(NULL),
177		.row_footnotes = list(NULL),
178		.aligns = NULL,
179		.format_na_strs = NULL,
180		.stat_names = list(NULL)) {
181	6814x	if (is.function(.formats)) {
182	!	.formats <- list(.formats)
183		}
184
185	6814x	l <- c(list(...), .list)
186
187	6814x	if (missing(.names) && missing(.labels)) {
188	2400x	if (length(l) > 0 && is.null(names(l))) {
189	!	stop("need a named list")
190		} else {
191	2400x	.names <- names(l)
192		}
193	2400x	stopifnot(!anyNA(.names))
194		}
195
196	6814x	if (length(l) == 0) {
197		if (
198	!	length(.labels) > 0 \|\|
199	!	length(.formats) > 0 \|\|
200	!	length(.names) > 0 \|\|
201	!	length(.indent_mods) > 0 \|\|
202	!	length(.format_na_strs) > 0 \|\|
203	!	(!all(is.na(.stat_names)) && length(.stat_names) > 0)
204		) {
205	!	stop(
206	!	"in_rows got 0 rows but length >0 of at least one of ",
207	!	".labels, .formats, .names, .indent_mods, .format_na_strs, .stat_names. ",
208	!	"Does your analysis/summary function handle the 0 row ",
209	!	"df/length 0 x case?"
210		)
211		}
212	!	l2 <- list()
213		} else {
214	6814x	if (is.null(.formats)) {
215	6287x	.formats <- list(NULL)
216		}
217	6814x	stopifnot(is.list(.cell_footnotes))
218	6814x	if (length(.cell_footnotes) != length(l)) {
219	1592x	.cell_footnotes <- c(
220	1592x	.cell_footnotes,
221	1592x	setNames(
222	1592x	rep(list(character()),
223	1592x	length.out = length(setdiff(
224	1592x	names(l),
225	1592x	names(.cell_footnotes)
226		))
227		),
228	1592x	setdiff(
229	1592x	names(l),
230	1592x	names(.cell_footnotes)
231		)
232		)
233		)
234	1592x	.cell_footnotes <- .cell_footnotes[names(l)]
235		}
236	6814x	if (is.null(.aligns)) {
237	6811x	.aligns <- list(NULL)
238		}
239
240	6814x	l2 <- mapply(rcell,
241	6814x	x = l, format = .formats,
242	6814x	footnotes = .cell_footnotes %\|\|% list(NULL),
243	6814x	align = .aligns,
244	6814x	format_na_str = .format_na_strs %\|\|% list(NULL),
245	6814x	stat_names = .stat_names %\|\|% list(NULL),
246	6814x	SIMPLIFY = FALSE
247		)
248		}
249	6814x	if (is.null(.labels)) {
250	3358x	objlabs <- vapply(l2, function(x) obj_label(x) %\|\|% "", "")
251	3358x	if (any(nzchar(objlabs))) {
252	69x	.labels <- objlabs
253		}
254		}
255
256	6814x	if (is.null(.names) && !is.null(names(l))) {
257	129x	.names <- names(l)
258		}
259	6814x	stopifnot(is.list(.row_footnotes))
260	6814x	if (length(.row_footnotes) != length(l2)) {
261	1592x	tmp <- .row_footnotes
262	1592x	.row_footnotes <- vector("list", length(l2))
263	1592x	pos <- match(names(tmp), .names)
264	1592x	nonna <- which(!is.na(pos))
265	1592x	.row_footnotes[pos] <- tmp[nonna]
266		# length(.row_footnotes) <- length(l2)
267		}
268	6814x	ret <- RowsVerticalSection(l2,
269	6814x	names = .names,
270	6814x	labels = .labels,
271	6814x	indent_mods = .indent_mods,
272	6814x	formats = .formats,
273	6814x	footnotes = .row_footnotes,
274	6814x	format_na_strs = .format_na_strs
275		)
276		## if(!is.null(.names))
277		## names(l2) <- .names
278		## else
279		## names(l2) <- names(l)
280	!	if (length(ret) == 0) NULL else ret
281
282		## if (length(l) == 0) NULL else l
283		}
284
285		.validate_nms <- function(vals, .stats, arg) {
286	268x	if (!is.null(arg)) {
287	112x	if (is.null(names(arg))) {
288	!	stopifnot(length(arg) == length(.stats))
289	!	names(arg) <- names(vals)
290		} else {
291	112x	lblpos <- match(names(arg), names(vals))
292	112x	stopifnot(!anyNA(lblpos))
293		}
294		}
295	268x	arg
296		}
297
298		#' Create a custom analysis function wrapping an existing function
299		#'
300		#' @param fun (`function`)\cr the function to be wrapped in a new customized analysis function.
301		#' `fun` should return a named `list`.
302		#' @param .stats (`character`)\cr names of elements to keep from `fun`'s full output.
303		#' @param .formats (`ANY`)\cr vector or list of formats to override any defaults applied by `fun`.
304		#' @param .labels (`character`)\cr vector of labels to override defaults returned by `fun`.
305		#' @param .indent_mods (`integer`)\cr named vector of indent modifiers for the generated rows.
306		#' @param .ungroup_stats (`character`)\cr vector of names, which must match elements of `.stats`.
307		#' @param ... additional arguments to `fun` which effectively become new defaults. These can still be
308		#' overridden by `extra_args` within a split.
309		#' @param .null_ref_cells (`flag`)\cr whether cells for the reference column should be `NULL`-ed by the
310		#' returned analysis function. Defaults to `TRUE` if `fun` accepts `.in_ref_col` as a formal argument. Note
311		#' this argument occurs after `...` so it must be fully specified by name when set.
312		#' @param .format_na_strs (`ANY`)\cr vector/list of `NA` strings to override any defaults applied by `fun`.
313		#'
314		#' @return A function suitable for use in [analyze()] with element selection, reformatting, and relabeling
315		#' performed automatically.
316		#'
317		#' @note
318		#' Setting `.ungroup_stats` to non-`NULL` changes the structure of the value(s) returned by `fun`, rather than
319		#' just labeling (`.labels`), formatting (`.formats`), and selecting amongst (`.stats`) them. This means that
320		#' subsequent `make_afun` calls to customize the output further both can and must operate on the new structure,
321		#' not the original structure returned by `fun`. See the final pair of examples below.
322		#'
323		#' @seealso [analyze()]
324		#'
325		#' @examples
326		#' s_summary <- function(x) {
327		#' stopifnot(is.numeric(x))
328		#'
329		#' list(
330		#' n = sum(!is.na(x)),
331		#' mean_sd = c(mean = mean(x), sd = sd(x)),
332		#' min_max = range(x)
333		#' )
334		#' }
335		#'
336		#' s_summary(iris$Sepal.Length)
337		#'
338		#' a_summary <- make_afun(
339		#' fun = s_summary,
340		#' .formats = c(n = "xx", mean_sd = "xx.xx (xx.xx)", min_max = "xx.xx - xx.xx"),
341		#' .labels = c(n = "n", mean_sd = "Mean (sd)", min_max = "min - max")
342		#' )
343		#'
344		#' a_summary(x = iris$Sepal.Length)
345		#'
346		#' a_summary2 <- make_afun(a_summary, .stats = c("n", "mean_sd"))
347		#'
348		#' a_summary2(x = iris$Sepal.Length)
349		#'
350		#' a_summary3 <- make_afun(a_summary, .formats = c(mean_sd = "(xx.xxx, xx.xxx)"))
351		#'
352		#' s_foo <- function(df, .N_col, a = 1, b = 2) {
353		#' list(
354		#' nrow_df = nrow(df),
355		#' .N_col = .N_col,
356		#' a = a,
357		#' b = b
358		#' )
359		#' }
360		#'
361		#' s_foo(iris, 40)
362		#'
363		#' a_foo <- make_afun(s_foo,
364		#' b = 4,
365		#' .formats = c(nrow_df = "xx.xx", ".N_col" = "xx.", a = "xx", b = "xx.x"),
366		#' .labels = c(
367		#' nrow_df = "Nrow df",
368		#' ".N_col" = "n in cols", a = "a value", b = "b value"
369		#' ),
370		#' .indent_mods = c(nrow_df = 2L, a = 1L)
371		#' )
372		#'
373		#' a_foo(iris, .N_col = 40)
374		#' a_foo2 <- make_afun(a_foo, .labels = c(nrow_df = "Number of Rows"))
375		#' a_foo2(iris, .N_col = 40)
376		#'
377		#' # grouping and further customization
378		#' s_grp <- function(df, .N_col, a = 1, b = 2) {
379		#' list(
380		#' nrow_df = nrow(df),
381		#' .N_col = .N_col,
382		#' letters = list(
383		#' a = a,
384		#' b = b
385		#' )
386		#' )
387		#' }
388		#' a_grp <- make_afun(s_grp,
389		#' b = 3,
390		#' .labels = c(
391		#' nrow_df = "row count",
392		#' .N_col = "count in column"
393		#' ),
394		#' .formats = c(nrow_df = "xx.", .N_col = "xx."),
395		#' .indent_mods = c(letters = 1L),
396		#' .ungroup_stats = "letters"
397		#' )
398		#' a_grp(iris, 40)
399		#' a_aftergrp <- make_afun(a_grp,
400		#' .stats = c("nrow_df", "b"),
401		#' .formats = c(b = "xx.")
402		#' )
403		#' a_aftergrp(iris, 40)
404		#'
405		#' s_ref <- function(x, .in_ref_col, .ref_group) {
406		#' list(
407		#' mean_diff = mean(x) - mean(.ref_group)
408		#' )
409		#' }
410		#'
411		#' a_ref <- make_afun(s_ref,
412		#' .labels = c(mean_diff = "Mean Difference from Ref")
413		#' )
414		#' a_ref(iris$Sepal.Length, .in_ref_col = TRUE, 1:10)
415		#' a_ref(iris$Sepal.Length, .in_ref_col = FALSE, 1:10)
416		#'
417		#' @export
418		make_afun <- function(fun,
419		.stats = NULL,
420		.formats = NULL,
421		.labels = NULL,
422		.indent_mods = NULL,
423		.ungroup_stats = NULL,
424		.format_na_strs = NULL,
425		...,
426		.null_ref_cells = ".in_ref_col" %in% names(formals(fun))) {
427		## there is a LOT more computing-on-the-language hackery in here that I
428		## would prefer, but currently this is the way I see to do everything we
429		## want to do.
430
431		## too clever by three-quarters (because half wasn't enough)
432		## gross scope hackery
433	23x	fun_args <- force(list(...))
434	23x	fun_fnames <- names(formals(fun))
435
436		## force EVERYTHING otherwise calling this within loops is the stuff of
437		## nightmares
438	23x	force(.stats)
439	23x	force(.formats)
440	23x	force(.format_na_strs)
441	23x	force(.labels)
442	23x	force(.indent_mods)
443	23x	force(.ungroup_stats)
444	23x	force(.null_ref_cells) ## this one probably isn't needed?
445
446	23x	ret <- function(x, ...) { ## remember formals get clobbered here
447
448		## this helper will grab the value and wrap it in a named list if
449		## we need the variable and return list() otherwise.
450		## We define it in here so that the scoping hackery works correctly
451	66x	.if_in_formals <- function(nm, ifnot = list(), named_lwrap = TRUE) {
452	660x	val <- if (nm %in% fun_fnames) get(nm) else ifnot
453	660x	if (named_lwrap && !identical(val, ifnot)) {
454	78x	setNames(list(val), nm)
455		} else {
456	582x	val
457		}
458		}
459
460	66x	custargs <- fun_args
461
462		## special handling cause I need it at the bottom as well
463	66x	in_rc_argl <- .if_in_formals(".in_ref_col")
464	66x	.in_ref_col <- if (length(in_rc_argl) > 0) in_rc_argl[[1]] else FALSE
465
466	66x	sfunargs <- c(
467		## these are either named lists containing the arg, or list()
468		## depending on whether fun accept the argument or not
469	66x	.if_in_formals("x"),
470	66x	.if_in_formals("df"),
471	66x	.if_in_formals(".N_col"),
472	66x	.if_in_formals(".N_total"),
473	66x	.if_in_formals(".N_row"),
474	66x	.if_in_formals(".ref_group"),
475	66x	in_rc_argl,
476	66x	.if_in_formals(".df_row"),
477	66x	.if_in_formals(".var"),
478	66x	.if_in_formals(".ref_full")
479		)
480
481	66x	allvars <- setdiff(fun_fnames, c("...", names(sfunargs)))
482		## values int he actual call to this function override customization
483		## done by the constructor. evalparse is to avoid a "... in wrong context" NOTE
484	66x	if ("..." %in% fun_fnames) {
485	5x	exargs <- eval(parser_helper(text = "list(...)"))
486	5x	custargs[names(exargs)] <- exargs
487	5x	allvars <- unique(c(allvars, names(custargs)))
488		}
489
490	66x	for (var in allvars) {
491		## not missing, i.e. specified in the direct call, takes precedence
492	22x	if (var %in% fun_fnames && eval(parser_helper(text = paste0("!missing(", var, ")")))) {
493	5x	sfunargs[[var]] <- get(var)
494	17x	} else if (var %in% names(custargs)) { ## not specified in the call, but specified in the constructor
495	4x	sfunargs[[var]] <- custargs[[var]]
496		}
497		## else left out so we hit the original default we inherited from fun
498		}
499
500	66x	rawvals <- do.call(fun, sfunargs)
501
502		## note single brackets here so its a list
503		## no matter what. thats important!
504	66x	final_vals <- if (is.null(.stats)) rawvals else rawvals[.stats]
505
506	66x	if (!is.list(rawvals)) {
507	!	stop("make_afun expects a function fun that always returns a list")
508		}
509	66x	if (!is.null(.stats)) {
510	10x	stopifnot(all(.stats %in% names(rawvals)))
511		} else {
512	56x	.stats <- names(rawvals)
513		}
514	66x	if (!is.null(.ungroup_stats) && !all(.ungroup_stats %in% .stats)) {
515	!	stop(
516	!	"Stats specified for ungrouping not included in non-null .stats list: ",
517	!	setdiff(.ungroup_stats, .stats)
518		)
519		}
520
521	66x	.labels <- .validate_nms(final_vals, .stats, .labels)
522	66x	.formats <- .validate_nms(final_vals, .stats, .formats)
523	66x	.indent_mods <- .validate_nms(final_vals, .stats, .indent_mods)
524	66x	.format_na_strs <- .validate_nms(final_vals, .stats, .format_na_strs)
525
526	66x	final_labels <- value_labels(final_vals)
527	66x	final_labels[names(.labels)] <- .labels
528
529	66x	final_formats <- lapply(final_vals, obj_format)
530	66x	final_formats[names(.formats)] <- .formats
531
532	66x	final_format_na_strs <- lapply(final_vals, obj_na_str)
533	66x	final_format_na_strs[names(.format_na_strs)] <- .format_na_strs
534
535	66x	if (is(final_vals, "RowsVerticalSection")) {
536	20x	final_imods <- indent_mod(final_vals)
537		} else {
538	46x	final_imods <- vapply(final_vals, indent_mod, 1L)
539		}
540	66x	final_imods[names(.indent_mods)] <- .indent_mods
541
542	66x	if (!is.null(.ungroup_stats)) {
543	2x	for (nm in .ungroup_stats) {
544	3x	tmp <- final_vals[[nm]]
545	3x	if (is(tmp, "CellValue")) {
546	1x	tmp <- tmp[[1]]
547	23x	} ## unwrap it
548	3x	final_vals <- insert_replace(final_vals, nm, tmp)
549	3x	stopifnot(all(nzchar(names(final_vals))))
550
551	3x	final_labels <- insert_replace(
552	3x	final_labels,
553	3x	nm,
554	3x	setNames(
555	3x	value_labels(tmp),
556	3x	names(tmp)
557		)
558		)
559	3x	final_formats <- insert_replace(
560	3x	final_formats,
561	3x	nm,
562	3x	setNames(
563	3x	rep(final_formats[nm],
564	3x	length.out = length(tmp)
565		),
566	3x	names(tmp)
567		)
568		)
569	3x	final_format_na_strs <- insert_replace(
570	3x	final_format_na_strs,
571	3x	nm,
572	3x	setNames(
573	3x	rep(final_format_na_strs[nm],
574	3x	length.out = length(tmp)
575		),
576	3x	names(tmp)
577		)
578		)
579	3x	final_imods <- insert_replace(
580	3x	final_imods,
581	3x	nm,
582	3x	setNames(
583	3x	rep(final_imods[nm],
584	3x	length.out = length(tmp)
585		),
586	3x	names(tmp)
587		)
588		)
589		}
590		}
591	66x	rcells <- mapply(
592	66x	function(x, f, l, na_str) {
593	197x	if (is(x, "CellValue")) {
594	65x	obj_label(x) <- l
595	65x	obj_format(x) <- f
596	65x	obj_na_str(x) <- na_str
597		# indent_mod(x) <- im
598	65x	x
599	132x	} else if (.null_ref_cells) {
600	!	non_ref_rcell(x,
601	!	is_ref = .in_ref_col,
602	!	format = f, label = l,
603	!	format_na_str = na_str
604	!	) # , indent_mod = im)
605		} else {
606	132x	rcell(x, format = f, label = l, format_na_str = na_str) # , indent_mod = im)
607		}
608		},
609	66x	f = final_formats, x = final_vals,
610	66x	l = final_labels,
611	66x	na_str = final_format_na_strs,
612		# im = final_imods,
613	66x	SIMPLIFY = FALSE
614		)
615	66x	in_rows(.list = rcells, .indent_mods = final_imods) ## , .labels = .labels)
616		}
617	23x	formals(ret) <- formals(fun)
618	23x	ret
619		}
620
621		insert_replace <- function(x, nm, newvals = x[[nm]]) {
622	15x	i <- match(nm, names(x))
623	15x	if (is.na(i)) {
624	!	stop("name not found")
625		}
626	15x	bef <- if (i > 1) 1:(i - 1) else numeric()
627	15x	aft <- if (i < length(x)) (i + 1):length(x) else numeric()
628	15x	ret <- c(x[bef], newvals, x[aft])
629	15x	names(ret) <- c(names(x)[bef], names(newvals), names(x)[aft])
630	15x	ret
631		}
632
633		parser_helper <- function(text, envir = parent.frame(2)) {
634	545x	parse(text = text, keep.source = FALSE)
635		}
636
637		length_w_name <- function(x, .parent_splval) {
638	!	in_rows(length(x),
639	!	.names = value_labels(.parent_splval)
640		)
641		}

1		#' @importFrom utils browseURL
2		NULL
3
4		#' Display an `rtable` object in the Viewer pane in RStudio or in a browser
5		#'
6		#' The table will be displayed using bootstrap styling.
7		#'
8		#' @param x (`rtable` or `shiny.tag`)\cr an object of class `rtable` or `shiny.tag` (defined in `htmltools` package).
9		#' @param y (`rtable` or `shiny.tag`)\cr optional second argument of same type as `x`.
10		#' @param ... arguments passed to [as_html()].
11		#'
12		#' @return Not meaningful. Called for the side effect of opening a browser or viewer pane.
13		#'
14		#' @examples
15		#' if (interactive()) {
16		#' sl5 <- factor(iris$Sepal.Length > 5,
17		#' levels = c(TRUE, FALSE),
18		#' labels = c("S.L > 5", "S.L <= 5")
19		#' )
20		#'
21		#' df <- cbind(iris, sl5 = sl5)
22		#'
23		#' lyt <- basic_table() %>%
24		#' split_cols_by("sl5") %>%
25		#' analyze("Sepal.Length")
26		#'
27		#' tbl <- build_table(lyt, df)
28		#'
29		#' Viewer(tbl)
30		#' Viewer(tbl, tbl)
31		#'
32		#'
33		#' tbl2 <- htmltools::tags$div(
34		#' class = "table-responsive",
35		#' as_html(tbl, class_table = "table")
36		#' )
37		#'
38		#' Viewer(tbl, tbl2)
39		#' }
40		#' @export
41		Viewer <- function(x, y = NULL, ...) {
42	3x	check_convert <- function(x, name, accept_NULL = FALSE) {
43	6x	if (accept_NULL && is.null(x)) {
44	3x	NULL
45	3x	} else if (is(x, "shiny.tag")) {
46	!	x
47	3x	} else if (is(x, "VTableTree")) {
48	3x	as_html(x, ...)
49		} else {
50	!	stop("object of class rtable or shiny tag excepted for ", name)
51		}
52		}
53
54	3x	x_tag <- check_convert(x, "x", FALSE)
55	3x	y_tag <- check_convert(y, "y", TRUE)
56
57	3x	html_output <- if (is.null(y)) {
58	3x	x_tag
59		} else {
60	!	tags$div(class = "container-fluid", htmltools::tags$div(
61	!	class = "row",
62	!	tags$div(class = "col-xs-6", x_tag),
63	!	tags$div(class = "col-xs-6", y_tag)
64		))
65		}
66
67	3x	sandbox_folder <- file.path(tempdir(), "rtable")
68
69	3x	if (!dir.exists(sandbox_folder)) {
70	1x	dir.create(sandbox_folder, recursive = TRUE)
71	1x	pbs <- file.path(path.package(package = "rtables"), "bootstrap/")
72	1x	file.copy(list.files(pbs, full.names = TRUE, recursive = FALSE), sandbox_folder, recursive = TRUE)
73		# list.files(sandbox_folder)
74		}
75
76		# get html name
77	3x	n_try <- 10000
78	3x	for (i in seq_len(n_try)) {
79	6x	htmlFile <- file.path(sandbox_folder, paste0("table", i, ".html"))
80
81	6x	if (!file.exists(htmlFile)) {
82	3x	break
83	3x	} else if (i == n_try) {
84	!	stop("too many html rtables created, restart your session")
85		}
86		}
87
88	3x	html_bs <- tags$html(
89	3x	lang = "en",
90	3x	tags$head(
91	3x	tags$meta(charset = "utf-8"),
92	3x	tags$meta("http-equiv" = "X-UA-Compatible", content = "IE=edge"),
93	3x	tags$meta(
94	3x	name = "viewport",
95	3x	content = "width=device-width, initial-scale=1"
96		),
97	3x	tags$title("rtable"),
98	3x	tags$link(
99	3x	href = "css/bootstrap.min.css",
100	3x	rel = "stylesheet"
101		)
102		),
103	3x	tags$body(
104	3x	html_output
105		)
106		)
107
108	3x	cat(
109	3x	paste("<!DOCTYPE html>\n", htmltools::doRenderTags(html_bs)),
110	3x	file = htmlFile, append = FALSE
111		)
112
113	3x	viewer <- getOption("viewer")
114
115	3x	if (!is.null(viewer)) {
116	3x	viewer(htmlFile)
117		} else {
118	!	browseURL(htmlFile)
119		}
120		}

1		## NB handling the case where there are no values is done during tabulation
2		## which is the only reason expression(TRUE) is ok, because otherwise
3		## we (sometimes) run into
4		## factor()[TRUE] giving <NA> (i.e. length 1)
5
6		#' Make subset expression for a split-value pair
7		#'
8		#' @param spl `(Split)`\cr A split object.
9		#' @param val `(SplitValue or string)`\cr The value, either as a
10		#' `SplitValue` object or the raw value as a string.
11		#'
12		#' @details
13		#'
14		#' If `val` is a `SplitValue` object which already contains a
15		#' subsetting expression with length `>0`, that is immediately
16		#' returned. Otherwise, the appropriate subsetting expression is
17		#' constructed based on the split type of `spl` and the value `val`.
18		#'
19		#' @note this is occasionally useful when constructing custom
20		#' splitting behavior which may used for column splitting but
21		#' generally should not be called directly by the end user.
22		#'
23		#' @return A subseting expression to be used to restrict data to a
24		#' particular column during tabulation.
25		#'
26		#' @examples
27		#'
28		#' spl <- VarLevelSplit("ARM", split_label = "ARM")
29		#' make_subset_expr(spl, "B: Placebo")
30		#' @export
31
32	5074x	setGeneric("make_subset_expr", function(spl, val) standardGeneric("make_subset_expr"))
33
34		#' @rdname make_subset_expr
35		setMethod(
36		"make_subset_expr", "VarLevelSplit",
37		function(spl, val) {
38		## this is how custom split functions will communicate the correct expression
39		## to the column modeling code
40	3820x	if (length(value_expr(val)) > 0) {
41	14x	return(value_expr(val))
42		}
43
44	3806x	v <- unlist(rawvalues(val))
45		## XXX if we're including all levels should even missing be included?
46	3806x	if (is(v, "AllLevelsSentinel")) {
47	9x	as.expression(bquote((!is.na(.(a))), list(a = as.name(spl_payload(spl)))))
48		} else {
49	3797x	as.expression(bquote((!is.na(.(a)) & .(a) %in% .(b)), list(
50	3797x	a = as.name(spl_payload(spl)),
51	3797x	b = v
52		)))
53		}
54		}
55		)
56
57		#' @rdname make_subset_expr
58		setMethod(
59		"make_subset_expr", "MultiVarSplit",
60		function(spl, val) {
61		## this is how custom split functions will communicate the correct expression
62		## to the column modeling code
63	314x	if (length(value_expr(val)) > 0) {
64	1x	return(value_expr(val))
65		}
66
67		## v = rawvalues(val)
68		## as.expression(bquote(!is.na(.(a)), list(a = v)))
69	313x	expression(TRUE)
70		}
71		)
72
73		#' @rdname make_subset_expr
74		setMethod(
75		"make_subset_expr", "AnalyzeVarSplit",
76		function(spl, val) {
77	!	if (avar_inclNAs(spl)) {
78	!	expression(TRUE)
79		} else {
80	!	as.expression(bquote(
81	!	!is.na(.(a)),
82	!	list(a = as.name(spl_payload(spl)))
83		))
84		}
85		}
86		)
87
88		#' @rdname make_subset_expr
89		setMethod(
90		"make_subset_expr", "AnalyzeColVarSplit",
91		function(spl, val) {
92	!	expression(TRUE)
93		}
94		)
95
96		## XXX these are going to be ridiculously slow
97		## FIXME
98
99		#' @rdname make_subset_expr
100		setMethod(
101		"make_subset_expr", "VarStaticCutSplit",
102		function(spl, val) {
103	135x	v <- rawvalues(val)
104		## as.expression(bquote(which(cut(.(a), breaks=.(brk), labels = .(labels),
105	135x	as.expression(bquote(
106	135x	cut(.(a),
107	135x	breaks = .(brk), labels = .(labels),
108	135x	include.lowest = TRUE
109	135x	) == .(b),
110	135x	list(
111	135x	a = as.name(spl_payload(spl)),
112	135x	b = v,
113	135x	brk = spl_cuts(spl),
114	135x	labels = spl_cutlabels(spl)
115		)
116		))
117		}
118		)
119
120		## NB this assumes spl_cutlabels(spl) is in order!!!!!!
121		#' @rdname make_subset_expr
122		setMethod(
123		"make_subset_expr", "CumulativeCutSplit",
124		function(spl, val) {
125	63x	v <- rawvalues(val)
126		## as.expression(bquote(which(as.integer(cut(.(a), breaks=.(brk),
127	63x	as.expression(bquote(
128	63x	as.integer(cut(.(a),
129	63x	breaks = .(brk),
130	63x	labels = .(labels),
131	63x	include.lowest = TRUE
132		)) <=
133	63x	as.integer(factor(.(b), levels = .(labels))),
134	63x	list(
135	63x	a = as.name(spl_payload(spl)),
136	63x	b = v,
137	63x	brk = spl_cuts(spl),
138	63x	labels = spl_cutlabels(spl)
139		)
140		))
141		}
142		)
143
144		## I think this one is unnecessary,
145		## build_table collapses DynCutSplits into
146		## static ones.
147		##
148		## XXX TODO fixme
149		## setMethod("make_subset_expr", "VarDynCutSplit",
150		## function(spl, val) {
151		## v = rawvalues(val)
152		## ## as.expression(bquote(which(.(fun)(.(a)) == .(b)),
153		## as.expression(bquote(.(fun)(.(a)) == .(b)),
154		## list(a = as.name(spl_payload(spl)),
155		## b = v,
156		## fun = spl@cut_fun))
157		## })
158
159		#' @rdname make_subset_expr
160		setMethod(
161		"make_subset_expr", "AllSplit",
162	440x	function(spl, val) expression(TRUE)
163		)
164
165		## probably don't need this
166		#' @rdname make_subset_expr
167		setMethod(
168		"make_subset_expr", "expression",
169	!	function(spl, val) spl
170		)
171
172		#' @rdname make_subset_expr
173		setMethod(
174		"make_subset_expr", "character",
175		function(spl, val) {
176	!	newspl <- VarLevelSplit(spl, spl)
177	!	make_subset_expr(newspl, val)
178		}
179		)
180
181		.combine_subset_exprs <- function(ex1, ex2) {
182	3452x	if (is.null(ex1) \|\| identical(ex1, expression(TRUE))) {
183	2224x	if (is.expression(ex2) && !identical(ex2, expression(TRUE))) {
184	1701x	return(ex2)
185		} else {
186	523x	return(expression(TRUE))
187		}
188		}
189
190		## if(is.null(ex2))
191		## ex2 <- expression(TRUE)
192	1228x	stopifnot(is.expression(ex1), is.expression(ex2))
193	1228x	as.expression(bquote((.(a)) & .(b), list(a = ex1[[1]], b = ex2[[1]])))
194		}
195
196		make_pos_subset <- function(spls = pos_splits(pos),
197		svals = pos_splvals(pos),
198		pos) {
199	1205x	expr <- NULL
200	1205x	for (i in seq_along(spls)) {
201	1838x	newexpr <- make_subset_expr(spls[[i]], svals[[i]])
202	1838x	expr <- .combine_subset_exprs(expr, newexpr)
203		}
204	1205x	expr
205		}
206
207		get_pos_extra <- function(svals = pos_splvals(pos),
208		pos) {
209	1211x	ret <- list()
210	1211x	for (i in seq_along(svals)) {
211	1850x	extrs <- splv_extra(svals[[i]])
212	1850x	if (any(names(ret) %in% names(extrs))) {
213	!	stop("same extra argument specified at multiple levels of nesting. Not currently supported")
214		}
215	1850x	ret <- c(ret, extrs)
216		}
217	1211x	ret
218		}
219
220		get_col_extras <- function(ctree) {
221	399x	leaves <- collect_leaves(ctree)
222	399x	lapply(
223	399x	leaves,
224	399x	function(x) get_pos_extra(pos = tree_pos(x))
225		)
226		}
227
228		setGeneric(
229		"make_col_subsets",
230	1603x	function(lyt, df) standardGeneric("make_col_subsets")
231		)
232
233		setMethod(
234		"make_col_subsets", "LayoutColTree",
235		function(lyt, df) {
236	398x	leaves <- collect_leaves(lyt)
237	398x	lapply(leaves, make_col_subsets)
238		}
239		)
240
241		setMethod(
242		"make_col_subsets", "LayoutColLeaf",
243		function(lyt, df) {
244	1205x	make_pos_subset(pos = tree_pos(lyt))
245		}
246		)
247
248		create_colinfo <- function(lyt, df, rtpos = TreePos(),
249		counts = NULL,
250		alt_counts_df = NULL,
251		total = NULL,
252		topleft = NULL) {
253		## this will work whether clayout is pre or post
254		## data
255	404x	clayout <- clayout(lyt)
256	404x	if (is.null(topleft)) {
257	404x	topleft <- top_left(lyt)
258		}
259	404x	cc_format <- colcount_format(lyt) %\|\|% "(N=xx)"
260
261		## do it this way for full backwards compatibility
262	404x	if (is.null(alt_counts_df)) {
263	384x	alt_counts_df <- df
264		}
265	404x	ctree <- coltree(clayout, df = df, rtpos = rtpos, alt_counts_df = alt_counts_df, ccount_format = cc_format)
266	397x	if (!is.na(disp_ccounts(lyt))) {
267	93x	leaf_pths <- make_col_df(ctree, visible_only = TRUE, na_str = "", ccount_format = cc_format)$path
268	93x	for (path in leaf_pths) {
269	357x	colcount_visible(ctree, path) <- disp_ccounts(lyt)
270		}
271		}
272
273	397x	cexprs <- make_col_subsets(ctree, df)
274	397x	colextras <- col_extra_args(ctree)
275
276		## calculate the counts based on the df
277		## This presumes that it is called on the WHOLE dataset,
278		## NOT after any splitting has occurred. Otherwise
279		## the counts will obviously be wrong.
280	397x	if (is.null(counts)) {
281	393x	counts <- rep(NA_integer_, length(cexprs))
282	4x	} else if (length(counts) != length(cexprs)) {
283	1x	stop(
284	1x	"Length of overriding counts must equal number of columns. Got ",
285	1x	length(counts), " values for ", length(cexprs), " columns. ",
286	1x	"Use NAs to specify that the default counting machinery should be ",
287	1x	"used for that position."
288		)
289		}
290
291	396x	counts_df_name <- "alt_counts_df"
292	396x	if (identical(alt_counts_df, df)) { # is.null(alt_counts_df)) {
293	380x	alt_counts_df <- df
294	380x	counts_df_name <- "df"
295		}
296	396x	calcpos <- is.na(counts)
297
298	396x	calccounts <- sapply(cexprs, function(ex) {
299	1196x	if (identical(ex, expression(TRUE))) {
300	186x	nrow(alt_counts_df)
301	1010x	} else if (identical(ex, expression(FALSE))) {
302	!	0L
303		} else {
304	1010x	vec <- try(eval(ex, envir = alt_counts_df), silent = TRUE)
305	1010x	if (is(vec, "numeric")) {
306	!	length(vec)
307	1010x	} else if (is(vec, "logical")) { ## sum(is.na(.)) ????
308	1010x	sum(vec, na.rm = TRUE)
309		}
310		}
311		})
312	396x	counts[calcpos] <- calccounts[calcpos]
313	396x	counts <- as.integer(counts)
314	396x	if (is.null(total)) {
315	!	total <- sum(counts)
316		}
317
318	396x	cpths <- col_paths(ctree)
319	396x	for (i in seq_along(cpths)) {
320	1196x	facet_colcount(ctree, cpths[[i]]) <- counts[i]
321		}
322	396x	InstantiatedColumnInfo(
323	396x	treelyt = ctree,
324	396x	csubs = cexprs,
325	396x	extras = colextras,
326	396x	cnts = counts,
327	396x	dispcounts = disp_ccounts(lyt),
328	396x	countformat = cc_format,
329	396x	total_cnt = total,
330	396x	topleft = topleft
331		)
332		}

1		# paths summary ----
2
3		#' Get a list of table row/column paths
4		#'
5		#' @param x (`VTableTree`)\cr an `rtable` object.
6		#'
7		#' @return A list of paths to each row/column within `x`.
8		#'
9		#' @seealso [cell_values()], [`fnotes_at_path<-`], [row_paths_summary()], [col_paths_summary()]
10		#'
11		#' @examples
12		#' lyt <- basic_table() %>%
13		#' split_cols_by("ARM") %>%
14		#' analyze(c("SEX", "AGE"))
15		#'
16		#' tbl <- build_table(lyt, ex_adsl)
17		#' tbl
18		#'
19		#' row_paths(tbl)
20		#' col_paths(tbl)
21		#'
22		#' cell_values(tbl, c("AGE", "Mean"), c("ARM", "B: Placebo"))
23		#'
24		#' @rdname make_col_row_df
25		#' @export
26		row_paths <- function(x) {
27	46x	stopifnot(is_rtable(x))
28	46x	make_row_df(x, visible_only = TRUE)$path
29		}
30
31		#' @rdname make_col_row_df
32		#' @export
33		col_paths <- function(x) {
34	2849x	if (!is(coltree(x), "LayoutColTree")) {
35	!	stop("I don't know how to extract the column paths from an object of class ", class(x))
36		}
37	2849x	make_col_df(x, visible_only = TRUE)$path
38		}
39
40		#' Print row/column paths summary
41		#'
42		#' @param x (`VTableTree`)\cr an `rtable` object.
43		#'
44		#' @return A data frame summarizing the row- or column-structure of `x`.
45		#'
46		#' @examplesIf require(dplyr)
47		#' ex_adsl_MF <- ex_adsl %>% dplyr::filter(SEX %in% c("M", "F"))
48		#'
49		#' lyt <- basic_table() %>%
50		#' split_cols_by("ARM") %>%
51		#' split_cols_by("SEX", split_fun = drop_split_levels) %>%
52		#' analyze(c("AGE", "BMRKR2"))
53		#'
54		#' tbl <- build_table(lyt, ex_adsl_MF)
55		#' tbl
56		#'
57		#' df <- row_paths_summary(tbl)
58		#' df
59		#'
60		#' col_paths_summary(tbl)
61		#'
62		#' # manually constructed table
63		#' tbl2 <- rtable(
64		#' rheader(
65		#' rrow(
66		#' "row 1", rcell("a", colspan = 2),
67		#' rcell("b", colspan = 2)
68		#' ),
69		#' rrow("h2", "a", "b", "c", "d")
70		#' ),
71		#' rrow("r1", 1, 2, 1, 2), rrow("r2", 3, 4, 2, 1)
72		#' )
73		#' col_paths_summary(tbl2)
74		#'
75		#' @export
76		row_paths_summary <- function(x) {
77	1x	stopifnot(is_rtable(x))
78
79	1x	if (nrow(x) == 0) {
80	!	return("rowname node_class path\n---------------------\n")
81		}
82
83	1x	pagdf <- make_row_df(x, visible_only = TRUE)
84	1x	row.names(pagdf) <- NULL
85
86	1x	mat <- rbind(
87	1x	c("rowname", "node_class", "path"),
88	1x	t(apply(pagdf, 1, function(xi) {
89	28x	c(
90	28x	indent_string(xi$label, xi$indent),
91	28x	xi$node_class,
92	28x	paste(xi$path, collapse = ", ")
93		)
94		}))
95		)
96
97	1x	txt <- mat_as_string(mat)
98	1x	cat(txt)
99	1x	cat("\n")
100
101	1x	invisible(pagdf[, c("label", "indent", "node_class", "path")])
102		}
103
104		#' @rdname row_paths_summary
105		#' @export
106		col_paths_summary <- function(x) {
107	1x	stopifnot(is_rtable(x))
108
109	1x	pagdf <- make_col_df(x, visible_only = FALSE)
110	1x	row.names(pagdf) <- NULL
111
112	1x	mat <- rbind(
113	1x	c("label", "path"),
114	1x	t(apply(pagdf, 1, function(xi) {
115	6x	c(
116	6x	indent_string(xi$label, floor(length(xi$path) / 2 - 1)),
117	6x	paste(xi$path, collapse = ", ")
118		)
119		}))
120		)
121
122	1x	txt <- mat_as_string(mat)
123	1x	cat(txt)
124	1x	cat("\n")
125
126	1x	invisible(pagdf[, c("label", "path")])
127		}
128
129		# Rows ----
130		# . Summarize Rows ----
131
132		# summarize_row_df <-
133		# function(name,
134		# label,
135		# indent,
136		# depth,
137		# rowtype,
138		# indent_mod,
139		# level) {
140		# data.frame(
141		# name = name,
142		# label = label,
143		# indent = indent,
144		# depth = level,
145		# rowtype = rowtype,
146		# indent_mod = indent_mod,
147		# level = level,
148		# stringsAsFactors = FALSE
149		# )
150		# }
151
152		#' Summarize rows
153		#'
154		#' @inheritParams gen_args
155		#' @param depth (`numeric(1)`)\cr depth.
156		#' @param indent (`numeric(1)`)\cr indent.
157		#'
158		#' @examplesIf require(dplyr)
159		#' library(dplyr)
160		#'
161		#' iris2 <- iris %>%
162		#' group_by(Species) %>%
163		#' mutate(group = as.factor(rep_len(c("a", "b"), length.out = n()))) %>%
164		#' ungroup()
165		#'
166		#' lyt <- basic_table() %>%
167		#' split_cols_by("Species") %>%
168		#' split_cols_by("group") %>%
169		#' analyze(c("Sepal.Length", "Petal.Width"),
170		#' afun = list_wrap_x(summary),
171		#' format = "xx.xx"
172		#' )
173		#'
174		#' tbl <- build_table(lyt, iris2)
175		#'
176		#' @rdname int_methods
177		setGeneric("summarize_rows_inner", function(obj, depth = 0, indent = 0) {
178	!	standardGeneric("summarize_rows_inner")
179		})
180
181		#' @rdname int_methods
182		setMethod(
183		"summarize_rows_inner", "TableTree",
184		function(obj, depth = 0, indent = 0) {
185	!	indent <- max(0L, indent + indent_mod(obj))
186
187	!	lr <- summarize_rows_inner(tt_labelrow(obj), depth, indent)
188	!	if (!is.null(lr)) {
189	!	ret <- list(lr)
190		} else {
191	!	ret <- list()
192		}
193
194	!	indent <- indent + (!is.null(lr))
195
196	!	ctab <- content_table(obj)
197	!	if (NROW(ctab)) {
198	!	ct <- summarize_rows_inner(ctab,
199	!	depth = depth,
200	!	indent = indent + indent_mod(ctab)
201		)
202	!	ret <- c(ret, ct)
203	!	indent <- indent + (length(ct) > 0) * (1 + indent_mod(ctab))
204		}
205
206	!	kids <- tree_children(obj)
207	!	els <- lapply(tree_children(obj), summarize_rows_inner,
208	!	depth = depth + 1, indent = indent
209		)
210	!	if (!are(kids, "TableRow")) {
211	!	if (!are(kids, "VTableTree")) {
212		## hatchet job of a hack, wrap em just so we can unlist em all at
213		## the same level
214	!	rowinds <- vapply(kids, is, NA, class2 = "TableRow")
215	!	els[rowinds] <- lapply(els[rowinds], function(x) list(x))
216		}
217	!	els <- unlist(els, recursive = FALSE)
218		}
219	!	ret <- c(ret, els)
220	!	ret
221		## df <- do.call(rbind, c(list(lr), list(ct), els))
222
223		## row.names(df) <- NULL
224		## df
225		}
226		)
227
228		# Print Table Structure ----
229
230		#' Summarize table
231		#'
232		#' @param x (`VTableTree`)\cr a table object.
233		#' @param detail (`string`)\cr either `row` or `subtable`.
234		#'
235		#' @return No return value. Called for the side-effect of printing a row- or subtable-structure summary of `x`.
236		#'
237		#' @examplesIf require(dplyr)
238		#' library(dplyr)
239		#'
240		#' iris2 <- iris %>%
241		#' group_by(Species) %>%
242		#' mutate(group = as.factor(rep_len(c("a", "b"), length.out = n()))) %>%
243		#' ungroup()
244		#'
245		#' lyt <- basic_table() %>%
246		#' split_cols_by("Species") %>%
247		#' split_cols_by("group") %>%
248		#' analyze(c("Sepal.Length", "Petal.Width"),
249		#' afun = list_wrap_x(summary),
250		#' format = "xx.xx"
251		#' )
252		#'
253		#' tbl <- build_table(lyt, iris2)
254		#' tbl
255		#'
256		#' row_paths(tbl)
257		#'
258		#' table_structure(tbl)
259		#'
260		#' table_structure(tbl, detail = "row")
261		#'
262		#' @export
263		table_structure <- function(x, detail = c("subtable", "row")) {
264	2x	detail <- match.arg(detail)
265
266	2x	switch(detail,
267	1x	subtable = treestruct(x),
268	1x	row = table_structure_inner(x),
269	!	stop("unsupported level of detail ", detail)
270		)
271		}
272
273		#' @param obj (`VTableTree`)\cr a table object.
274		#' @param depth (`numeric(1)`)\cr depth in tree.
275		#' @param indent (`numeric(1)`)\cr indent.
276		#' @param print_indent (`numeric(1)`)\cr indent for printing.
277		#'
278		#' @rdname int_methods
279		setGeneric(
280		"table_structure_inner",
281		function(obj,
282		depth = 0,
283		indent = 0,
284		print_indent = 0) {
285	70x	standardGeneric("table_structure_inner")
286		}
287		)
288
289		scat <- function(..., indent = 0, newline = TRUE) {
290	101x	txt <- paste(..., collapse = "", sep = "")
291
292	101x	cat(indent_string(txt, indent))
293
294	101x	if (newline) cat("\n")
295		}
296
297		## helper functions
298		obj_visible <- function(x) {
299	50x	x@visible
300		}
301
302		is_empty_labelrow <- function(x) {
303	4x	obj_label(x) == "" && !labelrow_visible(x)
304		}
305
306		is_empty_ElementaryTable <- function(x) {
307	10x	length(tree_children(x)) == 0 && is_empty_labelrow(tt_labelrow(x))
308		}
309
310		#' @param object (`VTableTree`)\cr a table object.
311		#'
312		#' @rdname int_methods
313		#' @export
314		setGeneric("str", function(object, ...) {
315	!	standardGeneric("str")
316		})
317
318		#' @param max.level (`numeric(1)`)\cr passed to `utils::str`. Defaults to 3 for the `VTableTree` method, unlike
319		#' the underlying default of `NA`. `NA` is not appropriate for `VTableTree` objects.
320		#'
321		#' @rdname int_methods
322		#' @export
323		setMethod(
324		"str", "VTableTree",
325		function(object, max.level = 3L, ...) {
326	!	utils::str(object, max.level = max.level, ...)
327	!	warning("str provides a low level, implementation-detail-specific description of the TableTree object structure. ",
328	!	"See table_structure(.) for a summary of table struture intended for end users.",
329	!	call. = FALSE
330		)
331	!	invisible(NULL)
332		}
333		)
334
335		#' @inheritParams table_structure_inner
336		#' @rdname int_methods
337		setMethod(
338		"table_structure_inner", "TableTree",
339		function(obj, depth = 0, indent = 0, print_indent = 0) {
340	10x	indent <- indent + indent_mod(obj)
341
342	10x	scat("TableTree: ", "[", obj_name(obj), "] (",
343	10x	obj_label(obj), ")",
344	10x	indent = print_indent
345		)
346
347	10x	table_structure_inner(
348	10x	tt_labelrow(obj), depth, indent,
349	10x	print_indent + 1
350		)
351
352	10x	ctab <- content_table(obj)
353	10x	visible_content <- if (is_empty_ElementaryTable(ctab)) {
354		# scat("content: -", indent = print_indent + 1)
355	4x	FALSE
356		} else {
357	6x	scat("content:", indent = print_indent + 1)
358	6x	table_structure_inner(ctab,
359	6x	depth = depth,
360	6x	indent = indent + indent_mod(ctab),
361	6x	print_indent = print_indent + 2
362		)
363		}
364
365	10x	if (length(tree_children(obj)) == 0) {
366	!	scat("children: - ", indent = print_indent + 1)
367		} else {
368	10x	scat("children: ", indent = print_indent + 1)
369	10x	lapply(tree_children(obj), table_structure_inner,
370	10x	depth = depth + 1,
371	10x	indent = indent + visible_content * (1 + indent_mod(ctab)),
372	10x	print_indent = print_indent + 2
373		)
374		}
375
376	10x	invisible(NULL)
377		}
378		)
379
380		#' @rdname int_methods
381		setMethod(
382		"table_structure_inner", "ElementaryTable",
383		function(obj, depth = 0, indent = 0, print_indent = 0) {
384	15x	scat("ElementaryTable: ", "[", obj_name(obj),
385	15x	"] (", obj_label(obj), ")",
386	15x	indent = print_indent
387		)
388
389	15x	indent <- indent + indent_mod(obj)
390
391	15x	table_structure_inner(
392	15x	tt_labelrow(obj), depth,
393	15x	indent, print_indent + 1
394		)
395
396	15x	if (length(tree_children(obj)) == 0) {
397	!	scat("children: - ", indent = print_indent + 1)
398		} else {
399	15x	scat("children: ", indent = print_indent + 1)
400	15x	lapply(tree_children(obj), table_structure_inner,
401	15x	depth = depth + 1, indent = indent,
402	15x	print_indent = print_indent + 2
403		)
404		}
405
406	15x	invisible(NULL)
407		}
408		)
409
410		#' @rdname int_methods
411		setMethod(
412		"table_structure_inner", "TableRow",
413		function(obj, depth = 0, indent = 0, print_indent = 0) {
414	20x	scat(class(obj), ": ", "[", obj_name(obj), "] (",
415	20x	obj_label(obj), ")",
416	20x	indent = print_indent
417		)
418
419	20x	indent <- indent + indent_mod(obj)
420
421	20x	invisible(NULL)
422		}
423		)
424
425		#' @rdname int_methods
426		setMethod(
427		"table_structure_inner", "LabelRow",
428		function(obj, depth = 0, indent = 0, print_indent = 0) {
429	25x	indent <- indent + indent_mod(obj)
430
431	25x	txtvis <- if (!obj_visible(obj)) " - <not visible>" else ""
432
433	25x	scat("labelrow: ", "[", obj_name(obj), "] (", obj_label(obj), ")",
434	25x	txtvis,
435	25x	indent = print_indent
436		)
437
438	25x	obj_visible(obj)
439		}
440		)

1		#' Find degenerate (sub)structures within a table
2		#'
3		#' @description `r lifecycle::badge("experimental")`
4		#'
5		#' This function returns a list with the row-paths to all structural subtables which contain no data rows (even if
6		#' they have associated content rows).
7		#'
8		#' @param tt (`TableTree`)\cr a `TableTree` object.
9		#'
10		#' @return A list of character vectors representing the row paths, if any, to degenerate substructures within the table.
11		#'
12		#' @examples
13		#' find_degen_struct(rtable("hi"))
14		#'
15		#' @family table structure validation functions
16		#' @export
17		find_degen_struct <- function(tt) {
18	7x	degen <- list()
19
20	7x	recurse_check <- function(tti, path) {
21	103x	if (is(tti, "VTableTree")) {
22	103x	kids <- tree_children(tti)
23	103x	if (length(kids) == 0) {
24	69x	degen <<- c(degen, list(path))
25		} else {
26	34x	for (i in seq_along(kids)) {
27	96x	recurse_check(kids[[i]], path = c(path, names(kids)[i]))
28		}
29		}
30		}
31		}
32	7x	recurse_check(tt, obj_name(tt) %\|\|% "root")
33	7x	degen
34		}
35
36		#' Validate and assert valid table structure
37		#'
38		#' @description `r lifecycle::badge("experimental")`
39		#'
40		#' A `TableTree` (`rtables`-built table) is considered degenerate if:
41		#' \enumerate{
42		#' \item{It contains no subtables or data rows (content rows do not count).}
43		#' \item{It contains a subtable which is degenerate by the criterion above.}
44		#' }
45		#'
46		#' `validate_table_struct` assesses whether `tt` has a valid (non-degenerate) structure.
47		#'
48		#' `assert_valid_table` asserts a table must have a valid structure, and throws an informative error (the default) or
49		#' warning (if `warn_only` is `TRUE`) if the table is degenerate (has invalid structure or contains one or more
50		#' invalid substructures.
51		#'
52		#' @param tt (`TableTree`)\cr a `TableTree` object.
53		#'
54		#' @return
55		#' * `validate_table_struct` returns a logical value indicating valid structure.
56		#' * `assert_valid_table` is called for its side-effect of throwing an error or warning for degenerate tables.
57		#'
58		#' @note This function is experimental and the exact text of the warning/error is subject to change in future releases.
59		#'
60		#' @examples
61		#' validate_table_struct(rtable("hahaha"))
62		#' \dontrun{
63		#' assert_valid_table(rtable("oops"))
64		#' }
65		#'
66		#' @family table structure validation functions
67		#' @export
68		validate_table_struct <- function(tt) {
69	1x	degen_pths <- find_degen_struct(tt)
70	1x	length(degen_pths) == 0
71		}
72
73		## XXX this doesn't handle content paths correctly
74		.path_to_disp <- function(pth) {
75	4x	if (length(pth) == 1) {
76	1x	return(pth)
77		}
78	3x	has_cont <- any(pth == "@content")
79	3x	if (has_cont) {
80	!	contpos <- which(pth == "@content")
81	!	cont_disp <- paste(tail(pth, length(pth) - contpos + 1),
82	!	collapse = "->"
83		)
84	!	pth <- head(pth, contpos)
85		} else {
86	3x	cont_disp <- character()
87		}
88
89	3x	topaste <- character(0)
90	3x	fullpth <- pth
91	3x	while (length(pth) > 0) {
92	6x	if (length(pth) <= 1) {
93	!	topaste <- c(topaste, pth)
94	!	pth <- character()
95		} else {
96	6x	topaste <- c(topaste, sprintf("%s[%s]", pth[1], pth[2]))
97	6x	pth <- tail(pth, -2)
98		}
99		}
100	3x	topaste <- c(topaste, cont_disp)
101	3x	paste(topaste, collapse = "->")
102		}
103
104		no_analyze_guess <- paste0(
105		"Was this table created using ",
106		"summarize_row_groups but no calls ",
107		"to analyze?\n"
108		)
109
110		use_sanitize_msg <- paste(" Use sanitize_table_struct() to fix these issues")
111
112		make_degen_message <- function(degen_pths, tt) {
113	2x	msg <- sprintf(
114	2x	paste0(
115	2x	"Invalid table - found %d (sub)structures which contain no data rows.",
116	2x	"\n\tThe first occured at path: %s"
117		),
118	2x	length(degen_pths), .path_to_disp(degen_pths[[1]])
119		)
120	2x	if (length(degen_pths) == 1 && length(degen_pths[[1]]) == 1) {
121	1x	msg <- paste(msg, " Likely Cause: Empty data or first row split on variable with only NA values",
122	1x	sep = "\n"
123		)
124	1x	} else if (all(make_row_df(tt)$node_class %in% c("LabelRow", "ContentRow"))) {
125	1x	msg <- paste(msg, " Cause: Layout did not contain any analyze() calls (only summarize_row_groups())",
126	1x	sep = "\n"
127		)
128		}
129	2x	msg <- paste(msg, use_sanitize_msg, sep = "\n")
130	2x	msg
131		}
132
133		#' @param warn_only (`flag`)\cr whether a warning should be thrown instead of an error. Defaults to `FALSE`.
134		#'
135		#' @rdname validate_table_struct
136		#' @export
137		assert_valid_table <- function(tt, warn_only = FALSE) {
138	2x	degen_pths <- find_degen_struct(tt)
139	2x	if (length(degen_pths) == 0) {
140	!	return(TRUE)
141		}
142
143		## we failed, now we build an informative error/warning message
144	2x	msg <- make_degen_message(degen_pths, tt)
145
146	2x	if (!warn_only) {
147	2x	stop(msg)
148		}
149	!	warning(msg)
150	!	return(FALSE)
151		}
152
153		#' Sanitize degenerate table structures
154		#'
155		#' @description `r lifecycle::badge("experimental")`
156		#'
157		#' Experimental function to correct structure of degenerate tables by adding messaging rows to empty sub-structures.
158		#'
159		#' @param tt (`TableTree`)\cr a `TableTree` object.
160		#' @param empty_msg (`string`)\cr the string which should be spanned across the inserted empty rows.
161		#'
162		#' @details
163		#' This function locates degenerate portions of the table (including the table overall in the case of a table with no
164		#' data rows) and inserts a row which spans all columns with the message `empty_msg` at each one, generating a table
165		#' guaranteed to be non-degenerate.
166		#'
167		#' @return If `tt` is already valid, it is returned unmodified. If `tt` is degenerate, a modified, non-degenerate
168		#' version of the table is returned.
169		#'
170		#' @examples
171		#' sanitize_table_struct(rtable("cool beans"))
172		#'
173		#' lyt <- basic_table() %>%
174		#' split_cols_by("ARM") %>%
175		#' split_rows_by("SEX") %>%
176		#' summarize_row_groups()
177		#'
178		#' ## Degenerate because it doesn't have any analyze calls -> no data rows
179		#' badtab <- build_table(lyt, DM)
180		#' sanitize_table_struct(badtab)
181		#'
182		#' @family table structure validation functions
183		#' @export
184		sanitize_table_struct <- function(tt, empty_msg = "-- This Section Contains No Data --") {
185	4x	rdf <- make_row_df(tt)
186
187	4x	emptyrow <- DataRow(
188	4x	vals = list(empty_msg),
189	4x	name = "empty_section",
190	4x	label = "",
191	4x	cspan = ncol(tt),
192	4x	cinfo = col_info(tt),
193	4x	format = "xx",
194	4x	table_inset = table_inset(tt)
195		)
196	4x	degen_pths <- find_degen_struct(tt)
197
198	4x	if (identical(degen_pths, list("root"))) {
199	2x	tree_children(tt) <- list(empty_row = emptyrow)
200	2x	return(tt)
201		}
202
203	2x	for (pth in degen_pths) {
204		## FIXME this shouldn't be necessary. why is it?
205	33x	tti <- tt_at_path(tt, path = pth)
206	33x	tree_children(tti) <- list(empty_section = emptyrow)
207	33x	tt_at_path(tt, path = pth) <- tti
208		}
209	2x	tt
210		}

1		#' Default tabulation
2		#'
3		#' This function is used when [analyze()] is invoked.
4		#'
5		#' @param x (`vector`)\cr the already split data being tabulated for a particular cell/set of cells.
6		#' @param ... additional parameters to pass on.
7		#'
8		#' @details This function has the following behavior given particular types of inputs:
9		#' \describe{
10		#' \item{numeric}{calls [mean()] on `x`.}
11		#' \item{logical}{calls [sum()] on `x`.}
12		#' \item{factor}{calls [length()] on `x`.}
13		#' }
14		#'
15		#' The [in_rows()] function is called on the resulting value(s). All other classes of input currently lead to an error.
16		#'
17		#' @inherit in_rows return
18		#'
19		#' @author Gabriel Becker and Adrian Waddell
20		#'
21		#' @examples
22		#' simple_analysis(1:3)
23		#' simple_analysis(iris$Species)
24		#' simple_analysis(iris$Species == "setosa")
25		#'
26		#' @rdname rtinner
27		#' @export
28	1836x	setGeneric("simple_analysis", function(x, ...) standardGeneric("simple_analysis"))
29
30		#' @rdname rtinner
31		#' @exportMethod simple_analysis
32		setMethod(
33		"simple_analysis", "numeric",
34	1263x	function(x, ...) in_rows("Mean" = rcell(mean(x, ...), stat_names = "mean", format = "xx.xx"))
35		)
36
37		#' @rdname rtinner
38		#' @exportMethod simple_analysis
39		setMethod(
40		"simple_analysis", "logical",
41	4x	function(x, ...) in_rows("Count" = rcell(sum(x, ...), stat_names = "n", format = "xx"))
42		)
43
44		#' @rdname rtinner
45		#' @exportMethod simple_analysis
46		setMethod(
47		"simple_analysis", "factor",
48	569x	function(x, ...) in_rows(.list = as.list(table(x)), .stat_names = "n")
49		)
50
51		#' @rdname rtinner
52		#' @exportMethod simple_analysis
53		setMethod(
54		"simple_analysis", "ANY",
55		function(x, ...) {
56	!	stop("No default simple_analysis behavior for class ", class(x), " please specify FUN explicitly.")
57		}
58		)
59
60		#' Check if an object is a valid `rtable`
61		#'
62		#' @param x (`ANY`)\cr an object.
63		#'
64		#' @return `TRUE` if `x` is a formal `TableTree` object, `FALSE` otherwise.
65		#'
66		#' @examples
67		#' is_rtable(build_table(basic_table(), iris))
68		#'
69		#' @export
70		is_rtable <- function(x) {
71	48x	is(x, "VTableTree")
72		}
73
74		# nocov start
75		## is each object in a collection from a class
76		are <- function(object_collection, class2) {
77		all(vapply(object_collection, is, logical(1), class2))
78		}
79
80		num_all_equal <- function(x, tol = .Machine$double.eps^0.5) {
81		stopifnot(is.numeric(x))
82
83		if (length(x) == 1) {
84		return(TRUE)
85		}
86
87		y <- range(x) / mean(x)
88		isTRUE(all.equal(y[1], y[2], tolerance = tol))
89		}
90
91		# copied over from utils.nest which is not open-source
92		all_true <- function(lst, fcn, ...) {
93		all(vapply(lst, fcn, logical(1), ...))
94		}
95
96		is_logical_single <- function(x) {
97		!is.null(x) &&
98		is.logical(x) &&
99		length(x) == 1 &&
100		!is.na(x)
101		}
102
103		is_logical_vector_modif <- function(x, min_length = 1) {
104		!is.null(x) &&
105		is.logical(x) &&
106		is.atomic(x) &&
107		!anyNA(x) &&
108		ifelse(min_length > 0, length(x) >= min_length, TRUE)
109		}
110		# nocov end
111
112		# Shorthand for functions that take df as first parameter
113		.takes_df <- function(f) {
114	1915x	func_takes(f, "df", is_first = TRUE)
115		}
116
117		# Checking if function takes parameters
118		func_takes <- function(func, params, is_first = FALSE) {
119	12957x	if (is.list(func)) {
120	2648x	return(lapply(func, func_takes, params = params, is_first = is_first))
121		}
122	10309x	if (is.null(func) \|\| !is(func, "function")) {
123		# safe-net: should this fail instead?
124	2254x	return(setNames(rep(FALSE, length(params)), params))
125		}
126	8055x	f_params <- formals(func)
127	8055x	if (!is_first) {
128	2619x	return(setNames(params %in% names(f_params), params))
129		} else {
130	5436x	if (length(params) > 1L) {
131	1x	stop("is_first works only with one parameters.")
132		}
133	5435x	return(!is.null(f_params) && names(f_params)[1] == params)
134		}
135		}
136
137		#' Translate spl_context to a path to display in error messages
138		#'
139		#' @param ctx (`data.frame`)\cr the `spl_context` data frame where the error occurred.
140		#'
141		#' @return A character string containing a description of the row path corresponding to `ctx`.
142		#'
143		#' @export
144		spl_context_to_disp_path <- function(ctx) {
145		## this can happen in the first split in column space, but
146		## should never happen in row space
147	23x	if (length(ctx$split) == 0) {
148	2x	return("root")
149		}
150	21x	if (ctx$split[1] == "root" && ctx$value[1] == "root") {
151	20x	ctx <- ctx[-1, ]
152		}
153	21x	ret <- paste(sprintf("%s[%s]", ctx[["split"]], ctx[["value"]]),
154	21x	collapse = "->"
155		)
156	21x	if (length(ret) == 0 \|\| nchar(ret) == 0) {
157	14x	ret <- "root"
158		}
159	21x	ret
160		}
161
162		# Utility function to paste vector of values in a nice way
163		paste_vec <- function(vec) {
164	7x	paste0('c("', paste(vec, collapse = '", "'), '")')
165		}
166
167		# Utility for checking if a package is installed
168		check_required_packages <- function(pkgs) {
169	!	for (pkgi in pkgs) {
170	!	if (!requireNamespace(pkgi, quietly = TRUE)) {
171	!	stop(
172	!	"This function requires the ", pkgi, " package. ",
173	!	"Please install it if you wish to use it"
174		)
175		}
176		}
177		}

1		#' Score functions for sorting `TableTrees`
2		#'
3		#' @inheritParams gen_args
4		#'
5		#' @return A single numeric value indicating score according to the relevant metric for `tt`, to be used when sorting.
6		#'
7		#' @export
8		#' @rdname score_funs
9		cont_n_allcols <- function(tt) {
10	6x	ctab <- content_table(tt)
11	6x	if (NROW(ctab) == 0) {
12	2x	stop(
13	2x	"cont_n_allcols score function used at subtable [",
14	2x	obj_name(tt), "] that has no content table."
15		)
16		}
17	4x	sum(sapply(
18	4x	row_values(tree_children(ctab)[[1]]),
19	4x	function(cv) cv[1]
20		))
21		}
22
23		#' @param j (`numeric(1)`)\cr index of column used for scoring.
24		#'
25		#' @seealso For examples and details, please read the documentation for [sort_at_path()] and the
26		#' [Sorting and Pruning](https://insightsengineering.github.io/rtables/latest-tag/articles/sorting_pruning.html)
27		#' vignette.
28		#'
29		#' @export
30		#' @rdname score_funs
31		cont_n_onecol <- function(j) {
32	2x	function(tt) {
33	6x	ctab <- content_table(tt)
34	6x	if (NROW(ctab) == 0) {
35	2x	stop(
36	2x	"cont_n_allcols score function used at subtable [",
37	2x	obj_name(tt), "] that has no content table."
38		)
39		}
40	4x	row_values(tree_children(ctab)[[1]])[[j]][1]
41		}
42		}
43
44		## used for pruning functions and scoring functions(sorting)
45		match_fun_args <- function(fun, ...) {
46	309x	dotargs <- list(...)
47	309x	retargs <- list()
48	309x	formnms <- names(formals(fun))
49	309x	if ("..." %in% formnms) {
50	!	retargs <- dotargs
51	309x	} else if (any(names(dotargs) %in% formnms)) {
52	11x	retargs <- dotargs[names(dotargs) %in% formnms]
53		}
54	309x	retargs
55		}
56
57		#' Sorting a table at a specific path
58		#'
59		#' Main sorting function to order the sub-structure of a `TableTree` at a particular path in the table tree.
60		#'
61		#' @inheritParams gen_args
62		#' @param scorefun (`function`)\cr scoring function. Should accept the type of children directly under the position
63		#' at `path` (either `VTableTree`, `VTableRow`, or `VTableNodeInfo`, which covers both) and return a numeric value
64		#' to be sorted.
65		#' @param decreasing (`flag`)\cr whether the scores generated by `scorefun` should be sorted in decreasing order. If
66		#' unset (the default of `NA`), it is set to `TRUE` if the generated scores are numeric and `FALSE` if they are
67		#' characters.
68		#' @param na.pos (`string`)\cr what should be done with children (sub-trees/rows) with `NA` scores. Defaults to
69		#' `"omit"`, which removes them. Other allowed values are `"last"` and `"first"`, which indicate where `NA` scores
70		#' should be placed in the order.
71		#' @param .prev_path (`character`)\cr internal detail, do not set manually.
72		#' @param ... Additional (named) arguments that will be passed directly down to
73		#' `score_fun` if it accepts them (or accepts `...` itself).
74		#'
75		#' @return A `TableTree` with the same structure as `tt` with the exception that the requested sorting has been done
76		#' at `path`.
77		#'
78		#' @details
79		#' `sort_at_path`, given a path, locates the (sub)table(s) described by the path (see below for handling of the `"*"`
80		#' wildcard). For each such subtable, it then calls `scorefun` on each direct child of the table, using the resulting
81		#' scores to determine their sorted order. `tt` is then modified to reflect each of these one or more sorting
82		#' operations.
83		#'
84		#' `score_fun` can optionally accept `decreasing`, which will be passed the value passed
85		#' to `sort_at_path` automatically, and other arguments which can be set via `...`. The
86		#' first argument passed to `scorefun` will always be the table structure (subtable or row)
87		#' it is scoring.
88		#'
89		#' In `path`, a leading `"root"` element will be ignored, regardless of whether this matches the object name (and thus
90		#' actual root path name) of `tt`. Including `"root"` in paths where it does not match the name of `tt` may mask deeper
91		#' misunderstandings of how valid paths within a `TableTree` object correspond to the layout used to originally declare
92		#' it, which we encourage users to avoid.
93		#'
94		#' `path` can include the "wildcard" `""` as a step, which translates roughly to any* node/branching element and means
95		#' that each child at that step will be separately sorted based on `scorefun` and the remaining `path` entries. This
96		#' can occur multiple times in a path.
97		#'
98		#' A list of valid (non-wildcard) paths can be seen in the `path` column of the `data.frame` created by
99		#' [formatters::make_row_df()] with the `visible_only` argument set to `FALSE`. It can also be inferred from the
100		#' summary given by [table_structure()].
101		#'
102		#' Note that sorting needs a deeper understanding of table structure in `rtables`. Please consider reading the related
103		#' vignette
104		#' ([Sorting and Pruning](https://insightsengineering.github.io/rtables/latest-tag/articles/sorting_pruning.html))
105		#' and explore table structure with useful functions like [table_structure()] and [row_paths_summary()]. It is also
106		#' very important to understand the difference between "content" rows and "data" rows. The first one analyzes and
107		#' describes the split variable generally and is generated with [summarize_row_groups()], while the second one is
108		#' commonly produced by calling one of the various [analyze()] instances.
109		#'
110		#' Built-in score functions are [cont_n_allcols()] and [cont_n_onecol()]. They are both working with content rows
111		#' (coming from [summarize_row_groups()]) while a custom score function needs to be used on `DataRow`s. Here, some
112		#' useful descriptor and accessor functions (coming from related vignette):
113		#' - [cell_values()] - Retrieves a named list of a `TableRow` or `TableTree` object's values.
114		#' - [formatters::obj_name()] - Retrieves the name of an object. Note this can differ from the label that is
115		#' displayed (if any is) when printing.
116		#' - [formatters::obj_label()] - Retrieves the display label of an object. Note this can differ from the name that
117		#' appears in the path.
118		#' - [content_table()] - Retrieves a `TableTree` object's content table (which contains its summary rows).
119		#' - [tree_children()] - Retrieves a `TableTree` object's direct children (either subtables, rows or possibly a mix
120		#' thereof, though that should not happen in practice).
121		#'
122		#' @seealso
123		#' * Score functions [cont_n_allcols()] and [cont_n_onecol()].
124		#' * [formatters::make_row_df()] and [table_structure()] for pathing information.
125		#' * [tt_at_path()] to select a table's (sub)structure at a given path.
126		#'
127		#' @examples
128		#' # Creating a table to sort
129		#'
130		#' # Function that gives two statistics per table-tree "leaf"
131		#' more_analysis_fnc <- function(x) {
132		#' in_rows(
133		#' "median" = median(x),
134		#' "mean" = mean(x),
135		#' .formats = "xx.x"
136		#' )
137		#' }
138		#'
139		#' # Main layout of the table
140		#' raw_lyt <- basic_table() %>%
141		#' split_cols_by("ARM") %>%
142		#' split_rows_by(
143		#' "RACE",
144		#' split_fun = drop_and_remove_levels("WHITE") # dropping WHITE levels
145		#' ) %>%
146		#' summarize_row_groups() %>%
147		#' split_rows_by("STRATA1") %>%
148		#' summarize_row_groups() %>%
149		#' analyze("AGE", afun = more_analysis_fnc)
150		#'
151		#' # Creating the table and pruning empty and NAs
152		#' tbl <- build_table(raw_lyt, DM) %>%
153		#' prune_table()
154		#'
155		#' # Peek at the table structure to understand how it is built
156		#' table_structure(tbl)
157		#'
158		#' # Sorting only ASIAN sub-table, or, in other words, sorting STRATA elements for
159		#' # the ASIAN group/row-split. This uses content_table() accessor function as it
160		#' # is a "ContentRow". In this case, we also base our sorting only on the second column.
161		#' sort_at_path(tbl, c("ASIAN", "STRATA1"), cont_n_onecol(2))
162		#'
163		#' # Custom scoring function that is working on "DataRow"s
164		#' scorefun <- function(tt) {
165		#' # Here we could use browser()
166		#' sum(unlist(row_values(tt))) # Different accessor function
167		#' }
168		#' # Sorting mean and median for all the AGE leaves!
169		#' sort_at_path(tbl, c("RACE", "", "STRATA1", "", "AGE"), scorefun)
170		#'
171		#' last_cat_scorefun <- function(x, decreasing, lastcat) {
172		#' mycat <- obj_name(x)
173		#' if (mycat == lastcat) {
174		#' ifelse(isTRUE(decreasing), -Inf, Inf)
175		#' } else {
176		#' match(tolower(substr(mycat, 1, 1)), letters)
177		#' }
178		#' }
179		#'
180		#' lyt2 <- basic_table() %>%
181		#' split_rows_by("SEX") %>%
182		#' analyze("AGE")
183		#'
184		#' tbl2 <- build_table(lyt2, DM)
185		#' sort_at_path(tbl2, "SEX", last_cat_scorefun, lastcat = "M")
186		#' sort_at_path(tbl2, "SEX", last_cat_scorefun, lastcat = "M", decreasing = FALSE)
187		#'
188		#' @export
189		sort_at_path <- function(tt,
190		path,
191		scorefun,
192		decreasing = NA,
193		na.pos = c("omit", "last", "first"),
194		.prev_path = character(),
195		...) {
196	52x	if (NROW(tt) == 0) {
197	1x	return(tt)
198		}
199
200		## XXX hacky fix this!!!
201		## tt_at_path removes root even if actual root table isn't named root, we need to match that behavior
202	51x	if (path[1] == "root") {
203		## always remove first root element but only add it to
204		## .prev_path (used for error reporting) if it actually matched the name
205	2x	if (obj_name(tt) == "root") {
206	2x	.prev_path <- c(.prev_path, path[1])
207		}
208	2x	path <- path[-1]
209		}
210	51x	if (identical(obj_name(tt), path[1])) {
211	6x	.prev_path <- c(.prev_path, path[1])
212	6x	path <- path[-1]
213		}
214
215	51x	curpath <- path
216	51x	subtree <- tt
217	51x	backpath <- c()
218	51x	count <- 0
219	51x	while (length(curpath) > 0) {
220	59x	curname <- curpath[1]
221	59x	oldkids <- tree_children(subtree)
222		## we sort each child separately based on the score function
223		## and the remaining path
224	59x	if (curname == "*") {
225	12x	oldnames <- vapply(oldkids, obj_name, "")
226	12x	newkids <- lapply(
227	12x	seq_along(oldkids),
228	12x	function(i) {
229	38x	sort_at_path(oldkids[[i]],
230	38x	path = curpath[-1],
231	38x	scorefun = scorefun,
232	38x	decreasing = decreasing,
233	38x	na.pos = na.pos,
234		## its ok to modify the "path" here because its only ever used for
235		## informative error reporting.
236	38x	.prev_path = c(.prev_path, backpath, paste0("* (", oldnames[i], ")")),
237		...
238		)
239		}
240		)
241	7x	names(newkids) <- oldnames
242	7x	newtab <- subtree
243	7x	tree_children(newtab) <- newkids
244	7x	if (length(backpath) > 0) {
245	3x	ret <- recursive_replace(tt, backpath, value = newtab)
246		} else {
247	4x	ret <- newtab
248		}
249	7x	return(ret)
250	47x	} else if (!(curname %in% names(oldkids))) {
251	1x	stop(
252	1x	"Unable to find child(ren) '",
253	1x	curname, "'\n\t occurred at path: ",
254	1x	paste(c(.prev_path, path[seq_len(count)]), collapse = " -> "),
255	1x	"\n Use 'make_row_df(obj, visible_only = TRUE)[, c(\"label\", \"path\", \"node_class\")]' or \n",
256	1x	"'table_structure(obj)' to explore valid paths."
257		)
258		}
259	46x	subtree <- tree_children(subtree)[[curname]]
260	46x	backpath <- c(backpath, curpath[1])
261	46x	curpath <- curpath[-1]
262	46x	count <- count + 1
263		}
264	38x	real_backpath <- path[seq_len(count)]
265
266	38x	na.pos <- match.arg(na.pos)
267		## subtree <- tt_at_path(tt, path)
268	38x	kids <- tree_children(subtree)
269		## relax this to allow character "scores"
270		## scores <- vapply(kids, scorefun, NA_real_)
271	38x	more_args <- match_fun_args(scorefun, decreasing = decreasing, ...)
272	38x	scores <- lapply(kids, function(x) {
273	100x	tryCatch(do.call(scorefun, c(list(x), more_args)),
274	100x	error = function(e) e
275		)
276		})
277	38x	errs <- which(vapply(scores, is, class2 = "error", TRUE))
278	38x	if (length(errs) > 0) {
279	4x	stop("Encountered at least ", length(errs), " error(s) when applying score function.\n",
280	4x	"First error: ", scores[[errs[1]]]$message,
281	4x	"\n\toccurred at path: ",
282	4x	paste(c(.prev_path, real_backpath, names(kids)[errs[1]]), collapse = " -> "),
283	4x	call. = FALSE
284		)
285		} else {
286	34x	scores <- unlist(scores)
287		}
288	34x	if (!is.null(dim(scores)) \|\| length(scores) != length(kids)) {
289	!	stop(
290	!	"Score function does not appear to have return exactly one ",
291	!	"scalar value per child"
292		)
293		}
294	34x	if (is.na(decreasing)) {
295	18x	decreasing <- if (is.character(scores)) FALSE else TRUE
296		}
297	34x	ord <- order(scores, na.last = (na.pos != "first"), decreasing = decreasing)
298	34x	newkids <- kids[ord]
299	34x	if (anyNA(scores) && na.pos == "omit") { # we did na last here
300	!	newkids <- head(newkids, -1 * sum(is.na(scores)))
301		}
302
303	34x	newtree <- subtree
304	34x	tree_children(newtree) <- newkids
305	34x	tt_at_path(tt, path) <- newtree
306	34x	tt
307		}

1		insert_brs <- function(vec) {
2	1045x	if (length(vec) == 1) {
3	1045x	ret <- list(vec)
4		} else {
5	!	nout <- length(vec) * 2 - 1
6	!	ret <- vector("list", nout)
7	!	for (i in seq_along(vec)) {
8	!	ret[[2 * i - 1]] <- vec[i]
9	!	if (2 * i < nout) {
10	!	ret[[2 * i]] <- tags$br()
11		}
12		}
13		}
14	1045x	ret
15		}
16
17		div_helper <- function(lst, class) {
18	96x	do.call(tags$div, c(list(class = paste(class, "rtables-container"), lst)))
19		}
20
21		#' Convert an `rtable` object to a `shiny.tag` HTML object
22		#'
23		#' The returned HTML object can be immediately used in `shiny` and `rmarkdown`.
24		#'
25		#' @param x (`VTableTree`)\cr a `TableTree` object.
26		#' @param class_table (`character`)\cr class for `table` tag.
27		#' @param class_tr (`character`)\cr class for `tr` tag.
28		#' @param class_th (`character`)\cr class for `th` tag.
29		#' @param width (`character`)\cr a string to indicate the desired width of the table. Common input formats include a
30		#' percentage of the viewer window width (e.g. `"100%"`) or a distance value (e.g. `"300px"`). Defaults to `NULL`.
31		#' @param link_label (`character`)\cr link anchor label (not including `tab:` prefix) for the table.
32		#' @param bold (`character`)\cr elements in table output that should be bold. Options are `"main_title"`,
33		#' `"subtitles"`, `"header"`, `"row_names"`, `"label_rows"`, and `"content_rows"` (which includes any non-label
34		#' rows). Defaults to `"header"`.
35		#' @param header_sep_line (`flag`)\cr whether a black line should be printed to under the table header. Defaults
36		#' to `TRUE`.
37		#' @param no_spaces_between_cells (`flag`)\cr whether spaces between table cells should be collapsed. Defaults
38		#' to `FALSE`.
39		#' @param expand_newlines (`flag`)\cr Defaults to `FALSE`, relying on `html` output to solve newline characters (`\n`).
40		#' Doing this keeps the structure of the cells but may depend on the output device.
41		#' @param round_type (`"iec"`, `"iec_mod"` or `"sas"`)\cr the type of rounding to perform.
42		#' See [round_fmt()] for details.
43		#'
44		#' @importFrom htmltools tags
45		#'
46		#' @return A `shiny.tag` object representing `x` in HTML.
47		#'
48		#' @examples
49		#' tbl <- rtable(
50		#' header = LETTERS[1:3],
51		#' format = "xx",
52		#' rrow("r1", 1, 2, 3),
53		#' rrow("r2", 4, 3, 2, indent = 1),
54		#' rrow("r3", indent = 2)
55		#' )
56		#'
57		#' as_html(tbl)
58		#'
59		#' as_html(tbl, class_table = "table", class_tr = "row")
60		#'
61		#' as_html(tbl, bold = c("header", "row_names"))
62		#'
63		#' \dontrun{
64		#' Viewer(tbl)
65		#' }
66		#'
67		#' @export
68		as_html <- function(x,
69		width = NULL,
70		class_table = "table table-condensed table-hover",
71		class_tr = NULL,
72		class_th = NULL,
73		link_label = NULL,
74		bold = c("header"),
75		header_sep_line = TRUE,
76		no_spaces_between_cells = FALSE,
77		expand_newlines = FALSE,
78		round_type = if (is(x, "VTableTree")) obj_round_type(x) else valid_round_type) {
79	12x	if (is.null(x)) {
80	!	return(tags$p("Empty Table"))
81		}
82
83	12x	stopifnot(is(x, "VTableTree"))
84
85	12x	mat <- matrix_form(x, indent_rownames = TRUE, expand_newlines = expand_newlines, round_type = round_type)
86
87	12x	nlh <- mf_nlheader(mat)
88	12x	nc <- ncol(x) + 1
89	12x	nr <- length(mf_lgrouping(mat))
90
91		# Structure is a list of lists with rows (one for each line grouping) and cols as dimensions
92	12x	cells <- matrix(rep(list(list()), (nr * nc)), ncol = nc)
93
94	12x	for (i in seq_len(nr)) {
95	179x	for (j in seq_len(nc)) {
96	1045x	curstrs <- mf_strings(mat)[i, j]
97	1045x	curspn <- mf_spans(mat)[i, j]
98	1045x	algn <- mf_aligns(mat)[i, j]
99
100	1045x	inhdr <- i <= nlh
101	1045x	tagfun <- if (inhdr) tags$th else tags$td
102	1045x	cells[i, j][[1]] <- tagfun(
103	1045x	class = if (inhdr) class_th else class_tr,
104	1045x	style = paste0("text-align: ", algn, ";"),
105	1045x	style = if (inhdr && !"header" %in% bold) "font-weight: normal;",
106	1045x	style = if (i == nlh && header_sep_line) "border-bottom: 1px solid black;",
107	1045x	colspan = if (curspn != 1) curspn,
108	1045x	insert_brs(curstrs)
109		)
110		}
111		}
112
113	12x	if (header_sep_line) {
114	12x	cells[nlh][[1]] <- htmltools::tagAppendAttributes(
115	12x	cells[nlh, 1][[1]],
116	12x	style = "border-bottom: 1px solid black;"
117		)
118		}
119
120		# Create a map between line numbers and line groupings, adjusting abs_rownumber with nlh
121	12x	map <- data.frame(lines = seq_len(nr), abs_rownumber = mat$line_grouping)
122	12x	row_info_df <- data.frame(indent = mat$row_info$indent, abs_rownumber = mat$row_info$abs_rownumber + nlh)
123	12x	map <- merge(map, row_info_df, by = "abs_rownumber")
124
125		# add indent values for headerlines
126	12x	map <- rbind(data.frame(abs_rownumber = 1:nlh, indent = 0, lines = 0), map)
127
128
129		# Row labels style
130	12x	for (i in seq_len(nr)) {
131	179x	indent <- ifelse(any(map$lines == i), map$indent[map$lines == i][1], -1)
132
133		# Apply indentation
134	179x	if (indent > 0) {
135	127x	cells[i, 1][[1]] <- htmltools::tagAppendAttributes(
136	127x	cells[i, 1][[1]],
137	127x	style = paste0("padding-left: ", indent * 3, "ch;")
138		)
139		}
140
141		# Apply bold font weight if "row_names" is in 'bold'
142	179x	if ("row_names" %in% bold) {
143	4x	cells[i, 1][[1]] <- htmltools::tagAppendAttributes(
144	4x	cells[i, 1][[1]],
145	4x	style = "font-weight: bold;"
146		)
147		}
148		}
149
150		# label rows style
151	12x	if ("label_rows" %in% bold) {
152	!	which_lbl_rows <- which(mat$row_info$node_class == "LabelRow")
153	!	cells[which_lbl_rows + nlh, ] <- lapply(
154	!	cells[which_lbl_rows + nlh, ],
155	!	htmltools::tagAppendAttributes,
156	!	style = "font-weight: bold;"
157		)
158		}
159
160		# content rows style
161	12x	if ("content_rows" %in% bold) {
162	!	which_cntnt_rows <- which(mat$row_info$node_class %in% c("ContentRow", "DataRow"))
163	!	cells[which_cntnt_rows + nlh, ] <- lapply(
164	!	cells[which_cntnt_rows + nlh, ],
165	!	htmltools::tagAppendAttributes,
166	!	style = "font-weight: bold;"
167		)
168		}
169
170	12x	if (any(!mat$display)) {
171		# Check that expansion kept the same display info
172	2x	check_expansion <- c()
173	2x	for (ii in unique(mat$line_grouping)) {
174	121x	rows <- which(mat$line_grouping == ii)
175	121x	check_expansion <- c(
176	121x	check_expansion,
177	121x	apply(mat$display[rows, , drop = FALSE], 2, function(x) all(x) \|\| all(!x))
178		)
179		}
180
181	2x	if (!all(check_expansion)) {
182	!	stop(
183	!	"Found that a group of rows have different display options even if ",
184	!	"they belong to the same line group. This should not happen. Please ",
185	!	"file an issue or report to the maintainers."
186	!	) # nocov
187		}
188
189	2x	for (ii in unique(mat$line_grouping)) {
190	121x	rows <- which(mat$line_grouping == ii)
191	121x	should_display_col <- apply(mat$display[rows, , drop = FALSE], 2, any)
192	121x	cells[ii, !should_display_col] <- NA_integer_
193		}
194		}
195
196	12x	rows <- apply(cells, 1, function(row) {
197	179x	tags$tr(
198	179x	class = class_tr,
199	179x	style = "white-space: pre;",
200	179x	Filter(function(x) !identical(x, NA_integer_), row)
201		)
202		})
203
204	12x	hsep_line <- tags$hr(class = "solid")
205
206	12x	hdrtag <- div_helper(
207	12x	class = "rtables-titles-block",
208	12x	list(
209	12x	div_helper(
210	12x	class = "rtables-main-titles-block",
211	12x	lapply(main_title(x), if ("main_title" %in% bold) tags$b else tags$p,
212	12x	class = "rtables-main-title"
213		)
214		),
215	12x	div_helper(
216	12x	class = "rtables-subtitles-block",
217	12x	lapply(subtitles(x), if ("subtitles" %in% bold) tags$b else tags$p,
218	12x	class = "rtables-subtitle"
219		)
220		)
221		)
222		)
223
224	12x	tabletag <- do.call(
225	12x	tags$table,
226	12x	c(
227	12x	rows,
228	12x	list(
229	12x	class = class_table,
230	12x	style = paste(
231	12x	if (no_spaces_between_cells) "border-collapse: collapse;",
232	12x	if (!is.null(width)) paste("width:", width)
233		),
234	12x	tags$caption(sprintf("(\\#tag:%s)", link_label),
235	12x	style = "caption-side: top;",
236	12x	.noWS = "after-begin"
237		)
238		)
239		)
240		)
241
242	12x	rfnotes <- div_helper(
243	12x	class = "rtables-ref-footnotes-block",
244	12x	lapply(mat$ref_footnotes, tags$p,
245	12x	class = "rtables-referential-footnote"
246		)
247		)
248
249	12x	mftr <- div_helper(
250	12x	class = "rtables-main-footers-block",
251	12x	lapply(main_footer(x), tags$p,
252	12x	class = "rtables-main-footer"
253		)
254		)
255
256	12x	pftr <- div_helper(
257	12x	class = "rtables-prov-footers-block",
258	12x	lapply(prov_footer(x), tags$p,
259	12x	class = "rtables-prov-footer"
260		)
261		)
262
263		## XXX this omits the divs entirely if they are empty. Do we want that or do
264		## we want them to be there but empty??
265	12x	ftrlst <- list(
266	12x	if (length(mat$ref_footnotes) > 0) rfnotes,
267	12x	if (length(mat$ref_footnotes) > 0) hsep_line,
268	12x	if (length(main_footer(x)) > 0) mftr,
269	12x	if (length(main_footer(x)) > 0 && length(prov_footer(x)) > 0) tags$br(), # line break
270	12x	if (length(prov_footer(x)) > 0) pftr
271		)
272
273	!	if (!is.null(unlist(ftrlst))) ftrlst <- c(list(hsep_line), ftrlst)
274	12x	ftrlst <- ftrlst[!vapply(ftrlst, is.null, TRUE)]
275
276	12x	ftrtag <- div_helper(
277	12x	class = "rtables-footers-block",
278	12x	ftrlst
279		)
280
281	12x	div_helper(
282	12x	class = "rtables-all-parts-block",
283	12x	list(
284	12x	tags$head(
285	12x	tags$style(
286	12x	".rtables-all-parts-block table tr { border-top: 1px solid #ddd;}"
287		)
288		),
289	12x	hdrtag,
290	12x	tabletag,
291	12x	ftrtag
292		)
293		)
294		}

1		treestruct <- function(obj, ind = 0L) {
2	19x	nc <- ncol(obj)
3	19x	cat(rep(" ", times = ind),
4	19x	sprintf("[%s] %s", class(obj), obj_name(obj)),
5	19x	sep = ""
6		)
7	19x	if (!is(obj, "ElementaryTable") && nrow(obj@content) > 0) {
8	6x	crows <- nrow(content_table(obj))
9	6x	ccols <- if (crows == 0) 0 else nc
10	6x	cat(sprintf(
11	6x	" [cont: %d x %d]",
12	6x	crows, ccols
13		))
14		}
15	19x	if (is(obj, "VTableTree") && length(tree_children(obj))) {
16	19x	kids <- tree_children(obj)
17	19x	if (are(kids, "TableRow")) {
18	9x	cat(sprintf(
19	9x	" (%d x %d)\n",
20	9x	length(kids), nc
21		))
22		} else {
23	10x	cat("\n")
24	10x	lapply(kids, treestruct, ind = ind + 1)
25		}
26		}
27	19x	invisible(NULL)
28		}
29
30		setGeneric(
31		"ploads_to_str",
32	103x	function(x, collapse = ":") standardGeneric("ploads_to_str")
33		)
34
35		setMethod(
36		"ploads_to_str", "Split",
37		function(x, collapse = ":") {
38	52x	paste(sapply(spl_payload(x), ploads_to_str),
39	52x	collapse = collapse
40		)
41		}
42		)
43
44		setMethod(
45		"ploads_to_str", "CompoundSplit",
46		function(x, collapse = ":") {
47	6x	paste(sapply(spl_payload(x), ploads_to_str),
48	6x	collapse = collapse
49		)
50		}
51		)
52
53		setMethod(
54		"ploads_to_str", "list",
55		function(x, collapse = ":") {
56	!	stop("Please contact the maintainer")
57		}
58		)
59
60		setMethod(
61		"ploads_to_str", "SplitVector",
62		function(x, collapse = ":") {
63	8x	sapply(x, ploads_to_str)
64		}
65		)
66
67		setMethod(
68		"ploads_to_str", "ANY",
69		function(x, collapse = ":") {
70	37x	paste(x)
71		}
72		)
73
74	49x	setGeneric("payloadmsg", function(spl) standardGeneric("payloadmsg"))
75
76		setMethod(
77		"payloadmsg", "VarLevelSplit",
78		function(spl) {
79	47x	spl_payload(spl)
80		}
81		)
82
83		setMethod(
84		"payloadmsg", "MultiVarSplit",
85	2x	function(spl) "var"
86		)
87
88		setMethod(
89		"payloadmsg", "VarLevWBaselineSplit",
90		function(spl) {
91	!	paste0(
92	!	spl_payload(spl), "[bsl ",
93	!	spl@ref_group_value, # XXX XXX
94		"]"
95		)
96		}
97		)
98
99		setMethod(
100		"payloadmsg", "ManualSplit",
101	!	function(spl) "mnl"
102		)
103
104		setMethod(
105		"payloadmsg", "AllSplit",
106	!	function(spl) "all"
107		)
108
109		setMethod(
110		"payloadmsg", "ANY",
111		function(spl) {
112	!	warning("don't know how to make payload print message for Split of class", class(spl))
113	!	"XXX"
114		}
115		)
116
117		spldesc <- function(spl, value = "") {
118	32x	value <- rawvalues(value)
119	32x	payloadmsg <- payloadmsg(spl)
120	32x	format <- "%s (%s)"
121	32x	sprintf(
122	32x	format,
123	32x	value,
124	32x	payloadmsg
125		)
126		}
127
128		layoutmsg <- function(obj) {
129		## if(!is(obj, "VLayoutNode"))
130		## stop("how did a non layoutnode object get in docatlayout??")
131
132	28x	pos <- tree_pos(obj)
133	28x	spllst <- pos_splits(pos)
134	28x	spvallst <- pos_splvals(pos)
135	28x	if (is(obj, "LayoutAxisTree")) {
136	12x	kids <- tree_children(obj)
137	12x	return(unlist(lapply(kids, layoutmsg)))
138		}
139
140	16x	msg <- paste(
141	16x	collapse = " -> ",
142	16x	mapply(spldesc,
143	16x	spl = spllst,
144	16x	value = spvallst
145		)
146		)
147	16x	msg
148		}
149
150		setMethod(
151		"show", "LayoutAxisTree",
152		function(object) {
153	2x	msg <- layoutmsg(object)
154	2x	cat(msg, "\n")
155	2x	invisible(object)
156		}
157		)
158
159
160		#' Display column tree structure
161		#'
162		#' Displays the tree structure of the columns of a
163		#' table or column structure object.
164		#'
165		#' @inheritParams gen_args
166		#'
167		#' @return Nothing, called for its side effect of displaying
168		#' a summary to the terminal.
169		#'
170		#' @examples
171		#' lyt <- basic_table() %>%
172		#' split_cols_by("ARM") %>%
173		#' split_cols_by("STRATA1") %>%
174		#' split_cols_by("SEX", nested = FALSE) %>%
175		#' analyze("AGE")
176		#'
177		#' tbl <- build_table(lyt, ex_adsl)
178		#' coltree_structure(tbl)
179		#' @export
180		coltree_structure <- function(obj) {
181	1x	ctree <- coltree(obj)
182	1x	cat(layoutmsg2(ctree))
183		}
184
185		lastposmsg <- function(pos) {
186	6x	spls <- pos_splits(pos)
187	6x	splvals <- value_names(pos_splvals(pos))
188	6x	indiv_msgs <- unlist(mapply(function(spl, valnm) paste(obj_name(spl), valnm, sep = ": "),
189	6x	spl = spls,
190	6x	valnm = splvals,
191	6x	SIMPLIFY = FALSE
192		))
193	6x	paste(indiv_msgs, collapse = " -> ")
194		}
195
196		layoutmsg2 <- function(obj, level = 1) {
197	7x	nm <- obj_name(obj)
198	7x	pos <- tree_pos(obj)
199	7x	nopos <- identical(pos, EmptyTreePos)
200
201	7x	msg <- paste0(strrep(" ", times = 2 * (level - 1)), "[", nm, "] (", if (nopos) "no pos" else lastposmsg(pos), ")\n")
202	7x	if (is(obj, "LayoutAxisTree")) {
203	3x	kids <- tree_children(obj)
204	3x	msg <- c(msg, unlist(lapply(kids, layoutmsg2, level = level + 1)))
205		}
206	7x	msg
207		}
208
209	46x	setGeneric("spltype_abbrev", function(obj) standardGeneric("spltype_abbrev"))
210
211		setMethod(
212		"spltype_abbrev", "VarLevelSplit",
213	4x	function(obj) "lvls"
214		)
215
216		setMethod(
217		"spltype_abbrev", "VarLevWBaselineSplit",
218	5x	function(obj) paste("ref_group", obj@ref_group_value)
219		)
220
221		setMethod(
222		"spltype_abbrev", "MultiVarSplit",
223	!	function(obj) "vars"
224		)
225
226		setMethod(
227		"spltype_abbrev", "VarStaticCutSplit",
228	10x	function(obj) "scut"
229		)
230
231		setMethod(
232		"spltype_abbrev", "VarDynCutSplit",
233	5x	function(obj) "dcut"
234		)
235		setMethod(
236		"spltype_abbrev", "AllSplit",
237	15x	function(obj) "all obs"
238		)
239		## setMethod("spltype_abbrev", "NULLSplit",
240		## function(obj) "no obs")
241
242		setMethod(
243		"spltype_abbrev", "AnalyzeVarSplit",
244	1x	function(obj) " analysis "
245		)
246
247		setMethod(
248		"spltype_abbrev", "CompoundSplit",
249	!	function(obj) paste("compound", paste(sapply(spl_payload(obj), spltype_abbrev), collapse = " "))
250		)
251
252		setMethod(
253		"spltype_abbrev", "AnalyzeMultiVars",
254	6x	function(obj) " multivar analysis "
255		)
256		setMethod(
257		"spltype_abbrev", "AnalyzeColVarSplit",
258	!	function(obj) " col-var analysis "
259		)
260
261		docat_splitvec <- function(object, indent = 0) {
262	8x	if (indent > 0) {
263	!	cat(rep(" ", times = indent), sep = "")
264		}
265	8x	if (length(object) == 1L && is(object[[1]], "VTableNodeInfo")) {
266	!	tab <- object[[1]]
267	!	msg <- sprintf(
268	!	"A Pre-Existing Table [%d x %d]",
269	!	nrow(tab), ncol(tab)
270		)
271		} else {
272	8x	plds <- ploads_to_str(object) ## lapply(object, spl_payload))
273
274	8x	tabbrev <- sapply(object, spltype_abbrev)
275	8x	msg <- paste(
276	8x	collapse = " -> ",
277	8x	paste0(plds, " (", tabbrev, ")")
278		)
279		}
280	8x	cat(msg, "\n")
281		}
282
283		setMethod(
284		"show", "SplitVector",
285		function(object) {
286	1x	cat("A SplitVector Pre-defining a Tree Structure\n\n")
287	1x	docat_splitvec(object)
288	1x	cat("\n")
289	1x	invisible(object)
290		}
291		)
292
293		docat_predataxis <- function(object, indent = 0) {
294	6x	lapply(object, docat_splitvec)
295		}
296
297		setMethod(
298		"show", "PreDataColLayout",
299		function(object) {
300	1x	cat("A Pre-data Column Layout Object\n\n")
301	1x	docat_predataxis(object)
302	1x	invisible(object)
303		}
304		)
305
306		setMethod(
307		"show", "PreDataRowLayout",
308		function(object) {
309	1x	cat("A Pre-data Row Layout Object\n\n")
310	1x	docat_predataxis(object)
311	1x	invisible(object)
312		}
313		)
314
315		setMethod(
316		"show", "PreDataTableLayouts",
317		function(object) {
318	2x	cat("A Pre-data Table Layout\n")
319	2x	cat("\nColumn-Split Structure:\n")
320	2x	docat_predataxis(object@col_layout)
321	2x	cat("\nRow-Split Structure:\n")
322	2x	docat_predataxis(object@row_layout)
323	2x	cat("\n")
324	2x	invisible(object)
325		}
326		)
327
328		setMethod(
329		"show", "InstantiatedColumnInfo",
330		function(object) {
331	2x	layoutmsg <- layoutmsg(coltree(object))
332	2x	cat("An InstantiatedColumnInfo object",
333	2x	"Columns:",
334	2x	layoutmsg,
335	2x	if (disp_ccounts(object)) {
336	2x	paste(
337	2x	"ColumnCounts:\n",
338	2x	paste(col_counts(object),
339	2x	collapse = ", "
340		)
341		)
342		},
343		"",
344	2x	sep = "\n"
345		)
346	2x	invisible(object)
347		}
348		)
349
350		#' @rdname int_methods
351		setMethod("print", "VTableTree", function(x, ...) {
352	10x	msg <- toString(x, ...)
353	9x	cat(msg)
354	9x	invisible(x)
355		})
356
357		#' @rdname int_methods
358		setMethod("show", "VTableTree", function(object) {
359	!	cat(toString(object))
360	!	invisible(object)
361		})
362
363		setMethod("show", "TableRow", function(object) {
364	1x	cat(sprintf(
365	1x	"[%s indent_mod %d]: %s %s\n",
366	1x	class(object),
367	1x	indent_mod(object),
368	1x	obj_label(object),
369	1x	paste(as.vector(get_formatted_cells(object)),
370	1x	collapse = " "
371		)
372		))
373	1x	invisible(object)
374		})

1		#' Variable associated with a split
2		#'
3		#' This function is intended for use when writing custom splitting logic. In cases where the split is associated with
4		#' a single variable, the name of that variable will be returned. At time of writing this includes splits generated
5		#' via the [split_rows_by()], [split_cols_by()], [split_rows_by_cuts()], [split_cols_by_cuts()],
6		#' [split_rows_by_cutfun()], and [split_cols_by_cutfun()] layout directives.
7		#'
8		#' @param spl (`VarLevelSplit`)\cr the split object.
9		#'
10		#' @return For splits with a single variable associated with them, returns the split. Otherwise, an error is raised.
11		#'
12		#' @export
13		#' @seealso \code{\link{make_split_fun}}
14	2x	setGeneric("spl_variable", function(spl) standardGeneric("spl_variable"))
15
16		#' @rdname spl_variable
17		#' @export
18	1x	setMethod("spl_variable", "VarLevelSplit", function(spl) spl_payload(spl))
19
20		#' @rdname spl_variable
21		#' @export
22	!	setMethod("spl_variable", "VarDynCutSplit", function(spl) spl_payload(spl))
23
24		#' @rdname spl_variable
25		#' @export
26	!	setMethod("spl_variable", "VarStaticCutSplit", function(spl) spl_payload(spl))
27
28		#' @rdname spl_variable
29		#' @export
30		setMethod(
31		"spl_variable", "Split",
32	1x	function(spl) stop("Split class ", class(spl), " not associated with a single variable.")
33		)
34
35		in_col_split <- function(spl_ctx) {
36	!	identical(
37	!	names(spl_ctx),
38	!	names(context_df_row(cinfo = NULL))
39		)
40		}
41
42		assert_splres_element <- function(pinfo, nm, len = NULL, component = NULL) {
43	63x	msg_2_append <- ""
44	63x	if (!is.null(component)) {
45	51x	msg_2_append <- paste0(
46	51x	"Invalid split function constructed by upstream call to ",
47	51x	"make_split_fun. Problem source: ",
48	51x	component, " argument."
49		)
50		}
51	63x	if (!(nm %in% names(pinfo))) {
52	!	stop(
53	!	"Split result does not have required element: ", nm, ".",
54	!	msg_2_append
55		)
56		}
57	63x	if (!is.null(len) && length(pinfo[[nm]]) != len) {
58	!	stop(
59	!	"Split result element ", nm, " does not have required length ", len, ".",
60	!	msg_2_append
61		)
62		}
63	63x	TRUE
64		}
65
66		validate_split_result <- function(pinfo, component = NULL) {
67	21x	assert_splres_element(pinfo, "datasplit", component = component)
68	21x	len <- length(pinfo$datasplit)
69	21x	assert_splres_element(pinfo, "values", len, component = component)
70	21x	assert_splres_element(pinfo, "labels", len, component = component)
71	21x	TRUE
72		}
73
74		#' Construct split result object
75		#'
76		#' These functions can be used to create or add to a split result in functions which implement core splitting or
77		#' post-processing within a custom split function.
78		#'
79		#' @param values (`character` or `list(SplitValue)`)\cr the values associated with each facet.
80		#' @param datasplit (`list(data.frame)`)\cr the facet data for each facet generated in the split.
81		#' @param labels (`character`)\cr the labels associated with each facet.
82		#' @param extras (`list` or `NULL`)\cr extra values associated with each of the facets which will be passed to
83		#' analysis functions applied within the facet.
84		#' @param subset_exprs (`list`)\cr A list of subsetting expressions (e.g.,
85		#' created with `quote()`) to be used during column subsetting.
86		#'
87		#' @return A named list representing the facets generated by the split with elements `values`, `datasplit`, and
88		#' `labels`, which are the same length and correspond to each other element-wise.
89		#'
90		#' @details
91		#' These functions performs various housekeeping tasks to ensure that the split result list is as the rtables
92		#' internals expect it, most of which are not relevant to end users.
93		#'
94		#' @examples
95		#' splres <- make_split_result(
96		#' values = c("hi", "lo"),
97		#' datasplit = list(hi = mtcars, lo = mtcars[1:10, ]),
98		#' labels = c("more data", "less data"),
99		#' subset_exprs = list(expression(TRUE), expression(seq_along(wt) <= 10))
100		#' )
101		#'
102		#' splres2 <- add_to_split_result(splres,
103		#' values = "med",
104		#' datasplit = list(med = mtcars[1:20, ]),
105		#' labels = "kinda some data",
106		#' subset_exprs = quote(seq_along(wt) <= 20)
107		#' )
108		#'
109		#' @family make_custom_split
110		#' @rdname make_split_result
111		#' @export
112		#' @family make_custom_split
113		make_split_result <- function(values, datasplit, labels, extras = NULL, subset_exprs = vector("list", length(values))) {
114	9x	if (length(values) == 1 && is(datasplit, "data.frame")) {
115	!	datasplit <- list(datasplit)
116		}
117	9x	ret <- list(values = values, datasplit = datasplit, labels = labels, subset_exprs = subset_exprs)
118	9x	if (!is.null(extras)) {
119	!	ret$extras <- extras
120		}
121	9x	.fixupvals(ret)
122		}
123
124		#' @param splres (`list`)\cr a list representing the result of splitting.
125		#'
126		#' @rdname make_split_result
127		#' @export
128		add_to_split_result <- function(splres, values, datasplit, labels, extras = NULL, subset_exprs = NULL) {
129	4x	validate_split_result(splres)
130	4x	newstuff <- make_split_result(values, datasplit, labels, extras, subset_exprs = list(subset_exprs))
131	4x	ret <- lapply(
132	4x	names(splres),
133	4x	function(nm) c(splres[[nm]], newstuff[[nm]])
134		)
135	4x	names(ret) <- names(splres)
136	4x	.fixupvals(ret)
137		}
138
139
140	19x	.can_take_spl_context <- function(f) any(c(".spl_context", "...") %in% names(formals(f)))
141
142		#' Create a custom splitting function
143		#'
144		#' @param pre (`list`)\cr zero or more functions which operate on the incoming data and return a new data frame that
145		#' should split via `core_split`. They will be called on the data in the order they appear in the list.
146		#' @param core_split (`function` or `NULL`)\cr if non-`NULL`, a function which accepts the same arguments that
147		#' `do_base_split` does, and returns the same type of named list. Custom functions which override this behavior
148		#' cannot be used in column splits.
149		#' @param post (`list`)\cr zero or more functions which should be called on the list output by splitting.
150		#'
151		#' @details
152		#' Custom split functions can be thought of as (up to) 3 different types of manipulations of the splitting process:
153		#'
154		#' 1. Pre-processing of the incoming data to be split.
155		#' 2. (Row-splitting only) Customization of the core mapping of incoming data to facets.
156		#' 3. Post-processing operations on the set of facets (groups) generated by the split.
157		#'
158		#' This function provides an interface to create custom split functions by implementing and specifying sets of
159		#' operations in each of those classes of customization independently.
160		#'
161		#' Pre-processing functions (1), must accept: `df`, `spl`, `vals`, and `labels`, and can optionally accept
162		#' `.spl_context`. They then manipulate `df` (the incoming data for the split) and return a modified data frame.
163		#' This modified data frame must contain all columns present in the incoming data frame, but can add columns if
164		#' necessary (though we note that these new columns cannot be used in the layout as split or analysis variables,
165		#' because they will not be present when validity checking is done).
166		#'
167		#' The preprocessing component is useful for things such as manipulating factor levels, e.g., to trim unobserved ones
168		#' or to reorder levels based on observed counts, etc.
169		#'
170		#' Core splitting functions override the fundamental
171		#' splitting procedure, and are only necessary in rare cases. These
172		#' must accept `spl`, `df`, `vals`, `labels`, and can optionally
173		#' accept `.spl_context`. They should return a split result object
174		#' constructed via `make_split_result()`.
175		#'
176		#' In particular, if the custom split function will be used in
177		#' column space, subsetting expressions (e.g., as returned by
178		#' `quote()` or `bquote` must be provided, while they are
179		#' optional (and largely ignored, currently) in row space.
180		#'
181		#'
182		#' Post-processing functions (3) must accept the result of the core split as their first argument (which can be
183		#' anything), in addition to `spl`, and `fulldf`, and can optionally accept `.spl_context`. They must each return a
184		#' modified version of the same structure specified above for core splitting.
185		#'
186		#' In both the pre- and post-processing cases, multiple functions can be specified. When this happens, they are applied
187		#' sequentially, in the order they appear in the list passed to the relevant argument (`pre` and `post`, respectively).
188		#'
189		#' @return A custom function that can be used as a split function.
190		#'
191		#' @seealso [custom_split_funs] for a more detailed discussion on what custom split functions do.
192		#'
193		#' @examples
194		#' mysplitfun <- make_split_fun(
195		#' pre = list(drop_facet_levels),
196		#' post = list(add_overall_facet("ALL", "All Arms"))
197		#' )
198		#'
199		#' basic_table(show_colcounts = TRUE) %>%
200		#' split_cols_by("ARM", split_fun = mysplitfun) %>%
201		#' analyze("AGE") %>%
202		#' build_table(subset(DM, ARM %in% c("B: Placebo", "C: Combination")))
203		#'
204		#' ## post (and pre) arguments can take multiple functions, here
205		#' ## we add an overall facet and the reorder the facets
206		#' reorder_facets <- function(splret, spl, fulldf, ...) {
207		#' ord <- order(names(splret$values))
208		#' make_split_result(
209		#' splret$values[ord],
210		#' splret$datasplit[ord],
211		#' splret$labels[ord]
212		#' )
213		#' }
214		#'
215		#' mysplitfun2 <- make_split_fun(
216		#' pre = list(drop_facet_levels),
217		#' post = list(
218		#' add_overall_facet("ALL", "All Arms"),
219		#' reorder_facets
220		#' )
221		#' )
222		#' basic_table(show_colcounts = TRUE) %>%
223		#' split_cols_by("ARM", split_fun = mysplitfun2) %>%
224		#' analyze("AGE") %>%
225		#' build_table(subset(DM, ARM %in% c("B: Placebo", "C: Combination")))
226		#'
227		#' very_stupid_core <- function(spl, df, vals, labels, .spl_context) {
228		#' make_split_result(c("stupid", "silly"),
229		#' datasplit = list(df[1:10, ], df[11:30, ]),
230		#' labels = c("first 10", "second 20")
231		#' )
232		#' }
233		#'
234		#' dumb_30_facet <- add_combo_facet("dumb",
235		#' label = "thirty patients",
236		#' levels = c("stupid", "silly")
237		#' )
238		#' nonsense_splfun <- make_split_fun(
239		#' core_split = very_stupid_core,
240		#' post = list(dumb_30_facet)
241		#' )
242		#'
243		#' ## recall core split overriding is not supported in column space
244		#' ## currently, but we can see it in action in row space
245		#'
246		#' lyt_silly <- basic_table() %>%
247		#' split_rows_by("ARM", split_fun = nonsense_splfun) %>%
248		#' summarize_row_groups() %>%
249		#' analyze("AGE")
250		#' silly_table <- build_table(lyt_silly, DM)
251		#' silly_table
252		#'
253		#' @family make_custom_split
254		#' @export
255		make_split_fun <- function(pre = list(), core_split = NULL, post = list()) {
256	13x	function(df,
257	13x	spl,
258	13x	vals = NULL,
259	13x	labels = NULL,
260	13x	trim = FALSE,
261	13x	.spl_context) {
262	17x	orig_columns <- names(df)
263	17x	for (pre_fn in pre) {
264	5x	if (.can_take_spl_context(pre_fn)) {
265	5x	df <- pre_fn(df = df, spl = spl, vals = vals, labels = labels, .spl_context = .spl_context)
266		} else {
267	!	df <- pre_fn(df = df, spl = spl, vals = vals, labels = labels)
268		}
269	3x	if (!is(df, "data.frame")) {
270	!	stop(
271	!	"Error in custom split function, pre-split step did not return a data.frame. ",
272	!	"See upstream call to make_split_fun for original source of error."
273		)
274		}
275		}
276
277	15x	if (!all(orig_columns %in% names(df))) {
278	!	stop(
279	!	"Preprocessing functions(s) in custom split function removed a column from the incoming data.",
280	!	" This is not supported. See upstread make_split_fun call (pre argument) for original source of error."
281		)
282		}
283
284	15x	if (is.null(core_split)) {
285	13x	ret <- do_base_split(spl = spl, df = df, vals = vals, labels = labels)
286		} else {
287	2x	ret <- core_split(spl = spl, df = df, vals = vals, labels = labels, .spl_context)
288	2x	validate_split_result(ret, component = "core_split")
289		}
290
291	15x	for (post_fn in post) {
292	14x	if (.can_take_spl_context(post_fn)) {
293	8x	ret <- post_fn(ret, spl = spl, .spl_context = .spl_context, fulldf = df)
294		} else {
295	6x	ret <- post_fn(ret, spl = spl, fulldf = df)
296		}
297		}
298	15x	validate_split_result(ret, "post")
299	15x	ret
300		}
301		}
302
303		#' Add a combination facet in post-processing
304		#'
305		#' Add a combination facet during the post-processing stage in a custom split fun.
306		#'
307		#' @param name (`string`)\cr name for the resulting facet (for use in pathing, etc.).
308		#' @param label (`string`)\cr label for the resulting facet.
309		#' @param levels (`character`)\cr vector of levels to combine within the resulting facet.
310		#' @param extra (`list`)\cr extra arguments to be passed to analysis functions applied within the resulting facet.
311		#'
312		#' @details
313		#' For `add_combo_facet`, the data associated with the resulting facet will be the data associated with the facets for
314		#' each level in `levels`, row-bound together. In particular, this means that if those levels are overlapping, data
315		#' that appears in both will be duplicated.
316		#'
317		#' @return A function which can be used within the `post` argument in [make_split_fun()].
318		#'
319		#' @seealso [make_split_fun()]
320		#'
321		#' @examples
322		#' mysplfun <- make_split_fun(post = list(
323		#' add_combo_facet("A_B",
324		#' label = "Arms A+B",
325		#' levels = c("A: Drug X", "B: Placebo")
326		#' ),
327		#' add_overall_facet("ALL", label = "All Arms")
328		#' ))
329		#'
330		#' lyt <- basic_table(show_colcounts = TRUE) %>%
331		#' split_cols_by("ARM", split_fun = mysplfun) %>%
332		#' analyze("AGE")
333		#'
334		#' tbl <- build_table(lyt, DM)
335		#'
336		#' @family make_custom_split
337		#' @export
338		add_combo_facet <- function(name, label = name, levels, extra = list()) {
339	3x	function(ret, spl, .spl_context, fulldf) {
340	4x	if (is(levels, "AllLevelsSentinel")) {
341	1x	subexpr <- expression(TRUE)
342	1x	datpart <- list(fulldf)
343		} else {
344	3x	subexpr <- .combine_value_exprs(ret$values[levels])
345	3x	datpart <- list(do.call(rbind, ret$datasplit[levels]))
346		}
347
348
349	4x	val <- LevelComboSplitValue(
350	4x	val = name, extr = extra, combolevels = levels, label = label,
351	4x	sub_expr = subexpr
352		)
353	4x	add_to_split_result(ret,
354	4x	values = list(val), labels = label,
355	4x	datasplit = datpart
356		)
357		}
358		}
359
360		.combine_value_exprs <- function(val_lst, spl) {
361	3x	exprs <- lapply(val_lst, value_expr)
362	3x	nulls <- vapply(exprs, is.null, TRUE)
363	3x	if (all(nulls)) {
364	1x	return(NULL) # default behavior all the way down the line, no need to do anything.
365	2x	} else if (any(nulls)) {
366	!	exprs[nulls] <- lapply(val_lst[nulls], function(vali) make_subset_expr(spl, vali))
367		}
368	2x	Reduce(.or_combine_exprs, exprs)
369		}
370
371		## no NULLS coming in here, everything has been populated
372		## by either custom subsetting expressions or the result of make_subset_expr(spl, val)
373		.or_combine_exprs <- function(ex1, ex2) {
374	2x	if (identical(ex1, expression(FALSE))) {
375	!	return(ex2)
376	2x	} else if (identical(ex2, expression(FALSE))) {
377	!	return(ex1)
378	2x	} else if (identical(ex1, expression(TRUE)) \|\| identical(ex2, expression(TRUE))) {
379	!	return(TRUE)
380		}
381	2x	as.expression(bquote((.(a)) \| .(b), list(a = ex1[[1]], b = ex2[[1]])))
382		}
383
384		#' @rdname add_combo_facet
385		#' @export
386		add_overall_facet <- function(name, label, extra = list()) {
387	1x	add_combo_facet(
388	1x	name = name, label = label, levels = select_all_levels,
389	1x	extra = extra
390		)
391		}
392
393		#' Trim levels of another variable from each facet (post-processing split step)
394		#'
395		#' @param innervar (`character`)\cr the variable(s) to trim (remove unobserved levels) independently within each facet.
396		#'
397		#' @return A function suitable for use in the `pre` (list) argument of `make_split_fun`.
398		#'
399		#' @seealso [make_split_fun()]
400		#'
401		#' @family make_custom_split
402		#' @export
403		trim_levels_in_facets <- function(innervar) {
404	1x	function(ret, ...) {
405	1x	for (var in innervar) {
406	1x	ret$datasplit <- lapply(ret$datasplit, function(df) {
407	2x	df[[var]] <- factor(df[[var]])
408	2x	df
409		})
410		}
411	1x	ret
412		}
413		}
414
415		#' Pre-processing function for use in `make_split_fun`
416		#'
417		#' This function is intended for use as a pre-processing component in `make_split_fun`, and should not be called
418		#' directly by end users.
419		#'
420		#' @param df (`data.frame`)\cr the incoming data corresponding with the parent facet.
421		#' @param spl (`VarLevelSplit`)\cr the split.
422		#' @param ... additional parameters passed internally.
423		#'
424		#' @seealso [make_split_fun()]
425		#'
426		#' @family make_custom_split
427		#' @export
428		drop_facet_levels <- function(df, spl, ...) {
429	2x	if (!is(spl, "VarLevelSplit") \|\| is.na(spl_payload(spl))) {
430	!	stop("Unable to determine faceting variable in drop_facet_levels application.")
431		}
432	2x	var <- spl_payload(spl)
433	2x	df[[var]] <- factor(df[[var]])
434	2x	df
435		}
436
437		#' Postprocessing split function behavior to generally restrict facets
438		#'
439		#' @param facets `(character)`\cr Vector of facet names
440		#' @param op `("keep", or "exclude")`\cr Whether `facets` names facets
441		#' to be (exclusively) kept (the default) or removed.
442		#' @param reorder `(flag)`\cr For `op == "keep"`, should the resulting
443		#' facets be reordered to the order they appear in
444		#' `facets`. Defaults to `TRUE`. Ignored if `op == "exclude"`.
445		#' @param quiet `(logical(1))`\cr Whether warnings should be given or
446		#' not (the default) when facets named in `facets` are not found
447		#' in the split result.
448		#'
449		#' @return a function suitable for use within the `post` argument of
450		#' [make_split_fun()].
451		#'
452		#' @details This is a function factory which creates a post-process
453		#' behavioral building block for use in [make_split_fun()].
454		#'
455		#' This factory provides the equivalent of both `keep_split_levels`
456		#' and `remove_split_levels` in a form suitable for use in
457		#' [make_split_fun()].
458		#'
459		#' When `op` is `"keep"` (the default), resulting facets are
460		#' restricted to only those named in `facets` when the generated
461		#' function is applied to a split result; in the case of `"exclude"`,
462		#' facets named in `facets` are removed so that only those not named
463		#' remain.
464		#'
465		#' The generated function will throw a warning if any of `facets` are
466		#' not found in the split result it receives during splitting, unless
467		#' it was created with `quiet = FALSE`.
468		#'
469		#' @seealso [make_split_fun()]
470		#'
471		#' @examples
472		#'
473		#' keep_spl <- make_split_fun(post = list(restrict_facets(c("M", "F"), op = "keep")))
474		#'
475		#' lyt <- basic_table() \|>
476		#' split_cols_by("SEX", split_fun = keep_spl) \|>
477		#' analyze("AGE")
478		#'
479		#' build_table(lyt, ex_adsl)
480		#'
481		#'
482		#' excl_undiff <- restrict_facets("UNDIFFERENTIATED", op = "exclude")
483		#' excl_spl <- make_split_fun(post = list(excl_undiff))
484		#'
485		#' lyt <- basic_table() \|>
486		#' split_cols_by("SEX", split_fun = excl_spl) \|>
487		#' analyze("AGE")
488		#'
489		#' build_table(lyt, ex_adsl)
490		#'
491		#' @family make_custom_split
492		#' @export
493		restrict_facets <- function(facets,
494		op = c("keep", "exclude"),
495		reorder = TRUE,
496		quiet = FALSE) {
497	6x	op <- match.arg(op)
498	6x	function(splret, spl, fulldf) {
499	6x	nms <- names(splret[[1]])
500	6x	mtch <- match(facets, nms)
501	6x	if (anyNA(mtch)) {
502	3x	if (!quiet) {
503	2x	warning(
504	2x	"restrict facets (op: ",
505	2x	op, ") could not find facets [",
506	2x	paste(facets[is.na(mtch)], collapse = ", "),
507	2x	"]. Ignoring these."
508		)
509		}
510	3x	mtch <- mtch[!is.na(mtch)]
511		}
512
513	6x	sel_vec <- mtch
514	6x	if (op == "exclude") {
515	2x	sel_vec <- -1 * sel_vec
516	4x	} else if (!reorder) { # op is keep
517	1x	sel_vec <- sort(sel_vec)
518		}
519	6x	ret <- lapply(
520	6x	splret,
521	6x	function(lst) lst[sel_vec]
522		)
523	6x	names(ret) <- names(splret)
524	6x	ret
525		}
526		}

1		#' Format `rcell` objects
2		#'
3		#' This is a wrapper for [formatters::format_value()] for use with `CellValue` objects
4		#'
5		#' @inheritParams lyt_args
6		#' @inheritParams gen_args
7		#' @param x (`CellValue` or `ANY`)\cr an object of class `CellValue`, or a raw value.
8		#' @param format (`string` or `function`)\cr the format label or formatter function to
9		#' apply to `x`.
10		#' @param output (`string`)\cr output type.
11		#' @param pr_row_format (`list`)\cr list of default formats coming from the general row.
12		#' @param pr_row_na_str (`list`)\cr list of default `"NA"` strings coming from the general row.
13		#' @param shell (`flag`)\cr whether the formats themselves should be returned instead of the
14		#' values with formats applied. Defaults to `FALSE`.
15		#'
16		#' @return Formatted text.
17		#'
18		#' @examples
19		#' cll <- CellValue(pi, format = "xx.xxx")
20		#' format_rcell(cll)
21		#'
22		#' # Cell values precedes the row values
23		#' cll <- CellValue(pi, format = "xx.xxx")
24		#' format_rcell(cll, pr_row_format = "xx.x")
25		#'
26		#' # Similarly for NA values
27		#' cll <- CellValue(NA, format = "xx.xxx", format_na_str = "This is THE NA")
28		#' format_rcell(cll, pr_row_na_str = "This is NA")
29		#'
30		#' @export
31		format_rcell <- function(x, format,
32		output = c("ascii", "html"),
33		na_str = obj_na_str(x) %\|\|% "NA",
34		pr_row_format = NULL,
35		pr_row_na_str = NULL,
36		round_type,
37		shell = FALSE) {
38		# Check for format and parent row format
39	94139x	format <- if (missing(format)) obj_format(x) else format
40	94139x	if (is.null(format) && !is.null(pr_row_format)) {
41	62784x	format <- pr_row_format
42		}
43	94139x	if (missing(round_type) && !is.null(obj_round_type(x))) {
44	17x	round_type <- obj_round_type(x)
45		}
46	94139x	if (missing(round_type) && is.null(obj_round_type(x))) {
47	!	round_type <- valid_round_type[1]
48		}
49		# Check for na_str from parent
50	94139x	if (is.null(obj_na_str(x)) && !is.null(pr_row_na_str)) {
51	77918x	na_str <- pr_row_na_str
52		}
53
54		# Main call to external function or shell
55	94139x	if (shell) {
56	22147x	return(format)
57		}
58	71992x	format_value(rawvalues(x),
59	71992x	format = format,
60	71992x	output = output,
61	71992x	na_str = na_str,
62	71992x	round_type = round_type
63		)
64		}

1		#' Create an `ElementaryTable` from a `data.frame`
2		#'
3		#' @param df (`data.frame`)\cr a data frame.
4		#'
5		#' @details
6		#' If row names are not defined in `df` (or they are simple numbers), then the row names are taken from the column
7		#' `label_name`, if it exists. If `label_name` exists, then it is also removed from the original data. This behavior
8		#' is compatible with [as_result_df()], when `as_is = TRUE` and the row names are not unique.
9		#'
10		#' @seealso [as_result_df()] for the inverse operation.
11		#'
12		#' @examples
13		#' df_to_tt(mtcars)
14		#'
15		#' @export
16		df_to_tt <- function(df) {
17	4x	colnms <- colnames(df)
18	4x	cinfo <- manual_cols(colnms)
19	4x	rnames <- rownames(df)
20	4x	havern <- !is.null(rnames)
21
22	4x	if ((!havern \|\| all(grepl("[0-9]+", rnames))) && "label_name" %in% colnms) {
23	2x	rnames <- df$label_name
24	2x	df <- df[, -match("label_name", colnms)]
25	2x	colnms <- colnames(df)
26	2x	cinfo <- manual_cols(colnms)
27	2x	havern <- TRUE
28		}
29
30	4x	kids <- lapply(seq_len(nrow(df)), function(i) {
31	124x	rni <- if (havern) rnames[i] else ""
32	124x	do.call(rrow, c(list(row.name = rni), unclass(df[i, ])))
33		})
34
35	4x	ElementaryTable(kids = kids, cinfo = cinfo)
36		}

1		#' @importFrom tools file_ext
2		NULL
3
4		#' Create enriched flat value table with paths
5		#'
6		#' This function creates a flat tabular file of cell values and corresponding paths via [path_enriched_df()]. It then
7		#' writes that data frame out as a `tsv` file.
8		#'
9		#' By default (i.e. when `value_func` is not specified, list columns where at least one value has length > 1 are
10		#' collapsed to character vectors by collapsing the list element with `"\|"`.
11		#'
12		#' @note
13		#' There is currently no round-trip capability for this type of export. You can read values exported this way back in
14		#' via `import_from_tsv` but you will receive only the `data.frame` version back, NOT a `TableTree`.
15		#'
16		#' @inheritParams gen_args
17		#' @inheritParams data.frame_export
18		#' @param file (`string`)\cr the path of the file to written to or read from.
19		#' @param sep (`string`)\cr defaults to `\t`. See [utils::write.table()] for more details.
20		#' @param ... (`any`)\cr additional arguments to be passed to [utils::write.table()].
21		#'
22		#' @return
23		#' * `export_as_tsv` returns `NULL` silently.
24		#' * `import_from_tsv` returns a `data.frame` with re-constituted list values.
25		#'
26		#' @seealso [path_enriched_df()] for the underlying function that does the work.
27		#'
28		#' @importFrom utils write.table read.table
29		#' @rdname tsv_io
30		#' @export
31		export_as_tsv <- function(tt, file = NULL, path_fun = collapse_path,
32		value_fun = collapse_values, sep = "\t", ...) {
33	1x	df <- path_enriched_df(tt, path_fun = path_fun, value_fun = value_fun)
34	1x	write.table(df, file, sep = sep, ...)
35		}
36
37		#' @rdname tsv_io
38		#' @export
39		import_from_tsv <- function(file) {
40	1x	rawdf <- read.table(file, header = TRUE, sep = "\t")
41	1x	as.data.frame(lapply(
42	1x	rawdf,
43	1x	function(col) {
44	7x	if (!any(grepl(.collapse_char, col, fixed = TRUE))) {
45	!	col
46		} else {
47	7x	I(strsplit(col, split = .collapse_char_esc))
48		}
49		}
50		))
51		}
52		# txt (formatters) --------------------------------------------------------------------
53		#' @importFrom formatters export_as_txt
54		#'
55		#' @examples
56		#' lyt <- basic_table() %>%
57		#' split_cols_by("ARM") %>%
58		#' analyze(c("AGE", "BMRKR2", "COUNTRY"))
59		#'
60		#' tbl <- build_table(lyt, ex_adsl)
61		#'
62		#' cat(export_as_txt(tbl, file = NULL, paginate = TRUE, lpp = 8))
63		#'
64		#' \dontrun{
65		#' tf <- tempfile(fileext = ".txt")
66		#' export_as_txt(tbl, file = tf)
67		#' system2("cat", tf)
68		#' }
69		#'
70		#' @export
71		formatters::export_as_txt
72
73		# pdf (formatters) ----------------------------------------------------------
74		#' @importFrom formatters export_as_pdf
75		#'
76		#' @examples
77		#' lyt <- basic_table() %>%
78		#' split_cols_by("ARM") %>%
79		#' analyze(c("AGE", "BMRKR2", "COUNTRY"))
80		#'
81		#' tbl <- build_table(lyt, ex_adsl)
82		#'
83		#' \dontrun{
84		#' tf <- tempfile(fileext = ".pdf")
85		#' export_as_pdf(tbl, file = tf, pg_height = 4)
86		#' tf <- tempfile(fileext = ".pdf")
87		#' export_as_pdf(tbl, file = tf, lpp = 8)
88		#' }
89		#'
90		#' @export
91		formatters::export_as_pdf

1		#' Change indentation of all `rrows` in an `rtable`
2		#'
3		#' Change indentation of all `rrows` in an `rtable`
4		#'
5		#' @param x (`VTableTree`)\cr an `rtable` object.
6		#' @param by (`integer`)\cr number to increase indentation of rows by. Can be negative. If final indentation is
7		#' less than 0, the indentation is set to 0.
8		#'
9		#' @return `x` with its indent modifier incremented by `by`.
10		#'
11		#' @examples
12		#' is_setosa <- iris$Species == "setosa"
13		#' m_tbl <- rtable(
14		#' header = rheader(
15		#' rrow(row.name = NULL, rcell("Sepal.Length", colspan = 2), rcell("Petal.Length", colspan = 2)),
16		#' rrow(NULL, "mean", "median", "mean", "median")
17		#' ),
18		#' rrow(
19		#' row.name = "All Species",
20		#' mean(iris$Sepal.Length), median(iris$Sepal.Length),
21		#' mean(iris$Petal.Length), median(iris$Petal.Length),
22		#' format = "xx.xx"
23		#' ),
24		#' rrow(
25		#' row.name = "Setosa",
26		#' mean(iris$Sepal.Length[is_setosa]), median(iris$Sepal.Length[is_setosa]),
27		#' mean(iris$Petal.Length[is_setosa]), median(iris$Petal.Length[is_setosa]),
28		#' format = "xx.xx"
29		#' )
30		#' )
31		#' indent(m_tbl)
32		#' indent(m_tbl, 2)
33		#'
34		#' @export
35		indent <- function(x, by = 1) {
36	9x	if (nrow(x) == 0 \|\| by == 0) {
37	9x	return(x)
38		}
39
40	!	indent_mod(x) <- indent_mod(x) + by
41	!	x
42		}
43
44		#' Clear all indent modifiers from a table
45		#'
46		#' @inheritParams gen_args
47		#'
48		#' @return The same class as `tt`, with all indent modifiers set to zero.
49		#'
50		#' @examples
51		#' lyt1 <- basic_table() %>%
52		#' summarize_row_groups("STUDYID", label_fstr = "overall summary") %>%
53		#' split_rows_by("AEBODSYS", child_labels = "visible") %>%
54		#' summarize_row_groups("STUDYID", label_fstr = "subgroup summary") %>%
55		#' analyze("AGE", indent_mod = -1L)
56		#'
57		#' tbl1 <- build_table(lyt1, ex_adae)
58		#' tbl1
59		#' clear_indent_mods(tbl1)
60		#'
61		#' @export
62		#' @rdname clear_imods
63	40x	setGeneric("clear_indent_mods", function(tt) standardGeneric("clear_indent_mods"))
64
65		#' @export
66		#' @rdname clear_imods
67		setMethod(
68		"clear_indent_mods", "VTableTree",
69		function(tt) {
70	25x	ct <- content_table(tt)
71	25x	if (!is.null(ct)) {
72	9x	content_table(tt) <- clear_indent_mods(ct)
73		}
74	25x	tree_children(tt) <- lapply(tree_children(tt), clear_indent_mods)
75	25x	indent_mod(tt) <- 0L
76	25x	tt
77		}
78		)
79
80		#' @export
81		#' @rdname clear_imods
82		setMethod(
83		"clear_indent_mods", "TableRow",
84		function(tt) {
85	15x	indent_mod(tt) <- 0L
86	15x	tt
87		}
88		)