rtables coverage - 90.75%

Files
Source

#' 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, ...)
## }

#' 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)

### 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")
})

#' @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 ((is.null(obj_format(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 || is.null(obj_format(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 ((is.null(obj_format(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)
)

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
}

.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
  }
  kids <- tryCatch(
    .make_tablerows(df,
      func = analysis_fun(spl),
      defrowlabs = defrlabel, # XXX
      cinfo = cinfo,
      datcol = spl_payload(spl),
      lev = lvl + 1L,
      format = 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
    )
  }
  lab <- obj_label(spl)
  ret <- TableTree(
    kids = kids,
    name = obj_name(spl),
    label = lab,
    lev = lvl,
    cinfo = cinfo,
    format = obj_format(spl),
    na_str = obj_na_str(spl),
    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(),
                        ...) {
  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)
  } 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)
    )
  }

  ## 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)
}

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.
#'
#' @inherit split_cols_by return
#'
#' @details
#' 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`.
#'
#' 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].
#'
#' @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,
                    na_str = NA_character_,
                    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)
  # 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
  }

  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
  )

  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
#' @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) {
  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)
  )

  ## 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
}

# 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_len(length(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
  )
}

## 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) {
    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
}

# 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)
  }
)

#' Create an `rtable` row
#'
#' @inheritParams compat_args
#' @param ... cell values.
#'
#' @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) {
  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)
    )
  }
}

#' Create an `rtable` row from a vector or list of values
#'
#' @inheritParams compat_args
#' @param ... values in vector/list form.
#'
#' @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) {
  dots <- list(...)
  args_list <- c(list(
    row.name = row.name, format = format,
    indent = indent, inset = inset
  ), 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.
#'
#' @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) {
  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
  )
}

#' @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
    )
  }
)

## 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"))

## 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
}
)

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"))
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 = "character",
    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"
  )
)

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_) {
  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_
  ) ## 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_) {
  ## 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
    pld <- mapply(AnalyzeVarSplit,
      var = var,
      split_name = child_names,
      split_label = split_label,
      afun = afun,
      defrowlab = defrowlab,
      cfun = cfun,
      cformat = cformat,
      ##                     split_format = split_format,
      inclNAs = inclNAs,
      MoreArgs = list(
        extra_args = extra_args,
        indent_mod = indent_mod,
        label_pos = show_kidlabs,
        split_format = split_format,
        split_na_str = split_na_str,
        section_div = section_div_if_multivar
      ), ## 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"
  )
)

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).
#'
#' @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_) {
  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
  )
}

#' 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_) {
  if ((missing(name) || is.null(name) || is.na(name) || nchar(name) == 0) && !missing(label)) {
    name <- label
  }
  vals <- lapply(vals, rcell)
  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
  )
  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
}


#' 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) {
  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
  )
  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) {
  check_ok_label(label)
  cinfo <- .calc_cinfo(cinfo, cont, kids)

  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
    )
  } 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
    ) ## 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"
  )
)

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) {
  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
  )
}

## 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
#' @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_) {
  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,
    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()

#' @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 = c("iec", "sas")) {
  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,
    round_type = round_type
  )
})

#' 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 = c("iec", "sas")) {
    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
    )
  }
)


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_len(length(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 = c("iec", "sas")) standardGeneric("get_formatted_cells")
)

#' @rdname gfc
setMethod(
  "get_formatted_cells", "TableTree",
  function(obj, shell = FALSE, round_type = c("iec", "sas")) {
    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 = c("iec", "sas")) {
    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 = c("iec", "sas")) {
    # 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 = c("iec", "sas")) {
    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")
}

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)
})

#' Cell value constructors
#'
#' Construct a cell value and associate formatting, labeling, indenting, and column spanning information with it.
#'
#' @inheritParams compat_args
#' @inheritParams lyt_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) {
  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_
    ) # 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)
  )
}

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


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		# 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	2650x	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	2650x	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		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		#' 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		#' @param x (`ANY`)\cr cell value.
8		#' @param format (`string` or `function`)\cr the format label (string) or `formatters` function to apply to `x`.
9		#' See [formatters::list_valid_format_labels()] for currently supported format labels.
10		#' @param label (`string` or `NULL`)\cr label. If non-`NULL`, it will be looked at when determining row labels.
11		#' @param colspan (`integer(1)`)\cr column span value.
12		#' @param footnotes (`list` or `NULL`)\cr referential footnote messages for the cell.
13		#' @param stat_names (`character` or `NA`)\cr names for the statistics in the cell. It can be a vector of strings.
14		#' If `NA`, statistic names are not specified.
15		#'
16		#' @inherit CellValue return
17		#'
18		#' @note Currently column spanning is only supported for defining header structure.
19		#'
20		#' @examples
21		#' rcell(1, format = "xx.x")
22		#' rcell(c(1, 2), format = c("xx - xx"))
23		#' rcell(c(1, 2), stat_names = c("Rand1", "Rand2"))
24		#'
25		#' @rdname rcell
26		#' @export
27		rcell <- function(x,
28		format = NULL,
29		colspan = 1L,
30		label = NULL,
31		indent_mod = NULL,
32		footnotes = NULL,
33		align = NULL,
34		format_na_str = NULL,
35		stat_names = NULL) {
36	35993x	checkmate::assert_character(stat_names, null.ok = TRUE)
37	35993x	if (!is.null(align)) {
38	56x	check_aligns(align)
39		}
40	35993x	if (is(x, "CellValue")) {
41	21670x	if (!is.null(label)) {
42	1x	obj_label(x) <- label
43		}
44	21670x	if (colspan != 1L) {
45	1x	cell_cspan(x) <- colspan
46		}
47	21670x	if (!is.null(indent_mod)) {
48	1x	indent_mod(x) <- indent_mod
49		}
50	21670x	if (!is.null(format)) {
51	1x	obj_format(x) <- format
52		}
53	21670x	if (!is.null(footnotes)) {
54	374x	cell_footnotes(x) <- lapply(footnotes, RefFootnote)
55		}
56	21670x	if (!is.null(format_na_str)) {
57	!	obj_na_str(x) <- format_na_str
58		}
59	21670x	if (!is.null(stat_names)) {
60	8x	obj_stat_names(x) <- stat_names
61		}
62	21670x	ret <- x
63		} else {
64	14323x	if (is.null(label)) {
65	11237x	label <- obj_label(x)
66		}
67	14323x	if (is.null(format)) {
68	7971x	format <- obj_format(x)
69		}
70	14323x	if (is.null(indent_mod)) {
71	14323x	indent_mod <- indent_mod(x)
72		}
73	14323x	footnotes <- lapply(footnotes, RefFootnote)
74	14323x	ret <- CellValue(
75	14323x	val = x,
76	14323x	format = format,
77	14323x	colspan = colspan,
78	14323x	label = label,
79	14323x	indent_mod = indent_mod,
80	14323x	footnotes = footnotes,
81	14323x	format_na_str = format_na_str,
82	14323x	stat_names = stat_names %\|\|% NA_character_
83	14323x	) # RefFootnote(footnote))
84		}
85	35993x	if (!is.null(align)) {
86	56x	cell_align(ret) <- align
87		}
88	35993x	ret
89		}
90
91		#' @param is_ref (`flag`)\cr whether function is being used in the reference column (i.e. `.in_ref_col` should be
92		#' passed to this argument).
93		#' @param refval (`ANY`)\cr value to use when in the reference column. Defaults to `NULL`.
94		#'
95		#' @details
96		#' `non_ref_rcell` provides the common blank for cells in the reference column, this value otherwise, and should
97		#' be passed the value of `.in_ref_col` when it is used.
98		#'
99		#' @rdname rcell
100		#' @export
101		non_ref_rcell <- function(x, is_ref, format = NULL, colspan = 1L,
102		label = NULL, indent_mod = NULL,
103		refval = NULL,
104		align = "center",
105		format_na_str = NULL) {
106	2x	val <- if (is_ref) refval else x
107	2x	rcell(val,
108	2x	format = format, colspan = colspan, label = label,
109	2x	indent_mod = indent_mod, align = align,
110	2x	format_na_str = format_na_str
111		)
112		}
113
114		#' Create multiple rows in analysis or summary functions
115		#'
116		#' Define the cells that get placed into multiple rows in `afun`.
117		#'
118		#' @param ... single row defining expressions.
119		#' @param .list (`list`)\cr list cell content (usually `rcells`). The `.list` is concatenated to `...`.
120		#' @param .names (`character` or `NULL`)\cr names of the returned list/structure.
121		#' @param .labels (`character` or `NULL`)\cr labels for the defined rows.
122		#' @param .formats (`character` or `NULL`)\cr formats for the values.
123		#' @param .indent_mods (`integer` or `NULL`)\cr indent modifications for the defined rows.
124		#' @param .cell_footnotes (`list`)\cr referential footnote messages to be associated by name with cells.
125		#' @param .row_footnotes (`list`)\cr referential footnotes messages to be associated by name with rows.
126		#' @param .aligns (`character` or `NULL`)\cr alignments for the cells. Standard for `NULL` is `"center"`.
127		#' See [formatters::list_valid_aligns()] for currently supported alignments.
128		#' @param .format_na_strs (`character` or `NULL`)\cr NA strings for the cells.
129		#' @param .stat_names (`list`)\cr names for the statistics in the cells.
130		#' It can be a vector of values. If `list(NULL)`, statistic names are not specified and will
131		#' appear as `NA`.
132		#'
133		#' @note In post-processing, referential footnotes can also be added using row and column
134		#' paths with [`fnotes_at_path<-`].
135		#'
136		#' @return A `RowsVerticalSection` object (or `NULL`). The details of this object should be considered an
137		#' internal implementation detail.
138		#'
139		#' @seealso [analyze()]
140		#'
141		#' @examples
142		#' in_rows(1, 2, 3, .names = c("a", "b", "c"))
143		#' in_rows(1, 2, 3, .labels = c("a", "b", "c"))
144		#' in_rows(1, 2, 3, .names = c("a", "b", "c"), .labels = c("AAA", "BBB", "CCC"))
145		#' in_rows(
146		#' .list = list(a = c(NA, NA)),
147		#' .formats = "xx - xx",
148		#' .format_na_strs = list(c("asda", "lkjklj"))
149		#' )
150		#' in_rows(.list = list(a = c(NA, NA)), .format_na_strs = c("asda", "lkjklj"))
151		#'
152		#' in_rows(.list = list(a = 1, b = 2, c = 3))
153		#' in_rows(1, 2, .list = list(3), .names = c("a", "b", "c"))
154		#'
155		#' lyt <- basic_table() %>%
156		#' split_cols_by("ARM") %>%
157		#' analyze("AGE", afun = function(x) {
158		#' in_rows(
159		#' "Mean (sd)" = rcell(c(mean(x), sd(x)), format = "xx.xx (xx.xx)"),
160		#' "Range" = rcell(range(x), format = "xx.xx - xx.xx")
161		#' )
162		#' })
163		#'
164		#' tbl <- build_table(lyt, ex_adsl)
165		#' tbl
166		#'
167		#' @export
168		in_rows <- function(..., .list = NULL, .names = NULL,
169		.labels = NULL,
170		.formats = NULL,
171		.indent_mods = NULL,
172		.cell_footnotes = list(NULL),
173		.row_footnotes = list(NULL),
174		.aligns = NULL,
175		.format_na_strs = NULL,
176		.stat_names = list(NULL)) {
177	6610x	if (is.function(.formats)) {
178	!	.formats <- list(.formats)
179		}
180
181	6610x	l <- c(list(...), .list)
182
183	6610x	if (missing(.names) && missing(.labels)) {
184	2290x	if (length(l) > 0 && is.null(names(l))) {
185	!	stop("need a named list")
186		} else {
187	2290x	.names <- names(l)
188		}
189	2290x	stopifnot(!anyNA(.names))
190		}
191
192	6610x	if (length(l) == 0) {
193		if (
194	!	length(.labels) > 0 \|\|
195	!	length(.formats) > 0 \|\|
196	!	length(.names) > 0 \|\|
197	!	length(.indent_mods) > 0 \|\|
198	!	length(.format_na_strs) > 0 \|\|
199	!	(!all(is.na(.stat_names)) && length(.stat_names) > 0)
200		) {
201	!	stop(
202	!	"in_rows got 0 rows but length >0 of at least one of ",
203	!	".labels, .formats, .names, .indent_mods, .format_na_strs, .stat_names. ",
204	!	"Does your analysis/summary function handle the 0 row ",
205	!	"df/length 0 x case?"
206		)
207		}
208	!	l2 <- list()
209		} else {
210	6610x	if (is.null(.formats)) {
211	6140x	.formats <- list(NULL)
212		}
213	6610x	stopifnot(is.list(.cell_footnotes))
214	6610x	if (length(.cell_footnotes) != length(l)) {
215	1445x	.cell_footnotes <- c(
216	1445x	.cell_footnotes,
217	1445x	setNames(
218	1445x	rep(list(character()),
219	1445x	length.out = length(setdiff(
220	1445x	names(l),
221	1445x	names(.cell_footnotes)
222		))
223		),
224	1445x	setdiff(
225	1445x	names(l),
226	1445x	names(.cell_footnotes)
227		)
228		)
229		)
230	1445x	.cell_footnotes <- .cell_footnotes[names(l)]
231		}
232	6610x	if (is.null(.aligns)) {
233	6607x	.aligns <- list(NULL)
234		}
235
236	6610x	l2 <- mapply(rcell,
237	6610x	x = l, format = .formats,
238	6610x	footnotes = .cell_footnotes %\|\|% list(NULL),
239	6610x	align = .aligns,
240	6610x	format_na_str = .format_na_strs %\|\|% list(NULL),
241	6610x	stat_names = .stat_names %\|\|% list(NULL),
242	6610x	SIMPLIFY = FALSE
243		)
244		}
245	6610x	if (is.null(.labels)) {
246	3244x	objlabs <- vapply(l2, function(x) obj_label(x) %\|\|% "", "")
247	3244x	if (any(nzchar(objlabs))) {
248	69x	.labels <- objlabs
249		}
250		}
251
252	6610x	if (is.null(.names) && !is.null(names(l))) {
253	99x	.names <- names(l)
254		}
255	6610x	stopifnot(is.list(.row_footnotes))
256	6610x	if (length(.row_footnotes) != length(l2)) {
257	1445x	tmp <- .row_footnotes
258	1445x	.row_footnotes <- vector("list", length(l2))
259	1445x	pos <- match(names(tmp), .names)
260	1445x	nonna <- which(!is.na(pos))
261	1445x	.row_footnotes[pos] <- tmp[nonna]
262		# length(.row_footnotes) <- length(l2)
263		}
264	6610x	ret <- RowsVerticalSection(l2,
265	6610x	names = .names,
266	6610x	labels = .labels,
267	6610x	indent_mods = .indent_mods,
268	6610x	formats = .formats,
269	6610x	footnotes = .row_footnotes,
270	6610x	format_na_strs = .format_na_strs
271		)
272		## if(!is.null(.names))
273		## names(l2) <- .names
274		## else
275		## names(l2) <- names(l)
276	!	if (length(ret) == 0) NULL else ret
277
278		## if (length(l) == 0) NULL else l
279		}
280
281		.validate_nms <- function(vals, .stats, arg) {
282	268x	if (!is.null(arg)) {
283	112x	if (is.null(names(arg))) {
284	!	stopifnot(length(arg) == length(.stats))
285	!	names(arg) <- names(vals)
286		} else {
287	112x	lblpos <- match(names(arg), names(vals))
288	112x	stopifnot(!anyNA(lblpos))
289		}
290		}
291	268x	arg
292		}
293
294		#' Create a custom analysis function wrapping an existing function
295		#'
296		#' @param fun (`function`)\cr the function to be wrapped in a new customized analysis function.
297		#' `fun` should return a named `list`.
298		#' @param .stats (`character`)\cr names of elements to keep from `fun`'s full output.
299		#' @param .formats (`ANY`)\cr vector or list of formats to override any defaults applied by `fun`.
300		#' @param .labels (`character`)\cr vector of labels to override defaults returned by `fun`.
301		#' @param .indent_mods (`integer`)\cr named vector of indent modifiers for the generated rows.
302		#' @param .ungroup_stats (`character`)\cr vector of names, which must match elements of `.stats`.
303		#' @param ... additional arguments to `fun` which effectively become new defaults. These can still be
304		#' overridden by `extra_args` within a split.
305		#' @param .null_ref_cells (`flag`)\cr whether cells for the reference column should be `NULL`-ed by the
306		#' returned analysis function. Defaults to `TRUE` if `fun` accepts `.in_ref_col` as a formal argument. Note
307		#' this argument occurs after `...` so it must be fully specified by name when set.
308		#' @param .format_na_strs (`ANY`)\cr vector/list of `NA` strings to override any defaults applied by `fun`.
309		#'
310		#' @return A function suitable for use in [analyze()] with element selection, reformatting, and relabeling
311		#' performed automatically.
312		#'
313		#' @note
314		#' Setting `.ungroup_stats` to non-`NULL` changes the structure of the value(s) returned by `fun`, rather than
315		#' just labeling (`.labels`), formatting (`.formats`), and selecting amongst (`.stats`) them. This means that
316		#' subsequent `make_afun` calls to customize the output further both can and must operate on the new structure,
317		#' not the original structure returned by `fun`. See the final pair of examples below.
318		#'
319		#' @seealso [analyze()]
320		#'
321		#' @examples
322		#' s_summary <- function(x) {
323		#' stopifnot(is.numeric(x))
324		#'
325		#' list(
326		#' n = sum(!is.na(x)),
327		#' mean_sd = c(mean = mean(x), sd = sd(x)),
328		#' min_max = range(x)
329		#' )
330		#' }
331		#'
332		#' s_summary(iris$Sepal.Length)
333		#'
334		#' a_summary <- make_afun(
335		#' fun = s_summary,
336		#' .formats = c(n = "xx", mean_sd = "xx.xx (xx.xx)", min_max = "xx.xx - xx.xx"),
337		#' .labels = c(n = "n", mean_sd = "Mean (sd)", min_max = "min - max")
338		#' )
339		#'
340		#' a_summary(x = iris$Sepal.Length)
341		#'
342		#' a_summary2 <- make_afun(a_summary, .stats = c("n", "mean_sd"))
343		#'
344		#' a_summary2(x = iris$Sepal.Length)
345		#'
346		#' a_summary3 <- make_afun(a_summary, .formats = c(mean_sd = "(xx.xxx, xx.xxx)"))
347		#'
348		#' s_foo <- function(df, .N_col, a = 1, b = 2) {
349		#' list(
350		#' nrow_df = nrow(df),
351		#' .N_col = .N_col,
352		#' a = a,
353		#' b = b
354		#' )
355		#' }
356		#'
357		#' s_foo(iris, 40)
358		#'
359		#' a_foo <- make_afun(s_foo,
360		#' b = 4,
361		#' .formats = c(nrow_df = "xx.xx", ".N_col" = "xx.", a = "xx", b = "xx.x"),
362		#' .labels = c(
363		#' nrow_df = "Nrow df",
364		#' ".N_col" = "n in cols", a = "a value", b = "b value"
365		#' ),
366		#' .indent_mods = c(nrow_df = 2L, a = 1L)
367		#' )
368		#'
369		#' a_foo(iris, .N_col = 40)
370		#' a_foo2 <- make_afun(a_foo, .labels = c(nrow_df = "Number of Rows"))
371		#' a_foo2(iris, .N_col = 40)
372		#'
373		#' # grouping and further customization
374		#' s_grp <- function(df, .N_col, a = 1, b = 2) {
375		#' list(
376		#' nrow_df = nrow(df),
377		#' .N_col = .N_col,
378		#' letters = list(
379		#' a = a,
380		#' b = b
381		#' )
382		#' )
383		#' }
384		#' a_grp <- make_afun(s_grp,
385		#' b = 3,
386		#' .labels = c(
387		#' nrow_df = "row count",
388		#' .N_col = "count in column"
389		#' ),
390		#' .formats = c(nrow_df = "xx.", .N_col = "xx."),
391		#' .indent_mods = c(letters = 1L),
392		#' .ungroup_stats = "letters"
393		#' )
394		#' a_grp(iris, 40)
395		#' a_aftergrp <- make_afun(a_grp,
396		#' .stats = c("nrow_df", "b"),
397		#' .formats = c(b = "xx.")
398		#' )
399		#' a_aftergrp(iris, 40)
400		#'
401		#' s_ref <- function(x, .in_ref_col, .ref_group) {
402		#' list(
403		#' mean_diff = mean(x) - mean(.ref_group)
404		#' )
405		#' }
406		#'
407		#' a_ref <- make_afun(s_ref,
408		#' .labels = c(mean_diff = "Mean Difference from Ref")
409		#' )
410		#' a_ref(iris$Sepal.Length, .in_ref_col = TRUE, 1:10)
411		#' a_ref(iris$Sepal.Length, .in_ref_col = FALSE, 1:10)
412		#'
413		#' @export
414		make_afun <- function(fun,
415		.stats = NULL,
416		.formats = NULL,
417		.labels = NULL,
418		.indent_mods = NULL,
419		.ungroup_stats = NULL,
420		.format_na_strs = NULL,
421		...,
422		.null_ref_cells = ".in_ref_col" %in% names(formals(fun))) {
423		## there is a LOT more computing-on-the-language hackery in here that I
424		## would prefer, but currently this is the way I see to do everything we
425		## want to do.
426
427		## too clever by three-quarters (because half wasn't enough)
428		## gross scope hackery
429	23x	fun_args <- force(list(...))
430	23x	fun_fnames <- names(formals(fun))
431
432		## force EVERYTHING otherwise calling this within loops is the stuff of
433		## nightmares
434	23x	force(.stats)
435	23x	force(.formats)
436	23x	force(.format_na_strs)
437	23x	force(.labels)
438	23x	force(.indent_mods)
439	23x	force(.ungroup_stats)
440	23x	force(.null_ref_cells) ## this one probably isn't needed?
441
442	23x	ret <- function(x, ...) { ## remember formals get clobbered here
443
444		## this helper will grab the value and wrap it in a named list if
445		## we need the variable and return list() otherwise.
446		## We define it in here so that the scoping hackery works correctly
447	66x	.if_in_formals <- function(nm, ifnot = list(), named_lwrap = TRUE) {
448	660x	val <- if (nm %in% fun_fnames) get(nm) else ifnot
449	660x	if (named_lwrap && !identical(val, ifnot)) {
450	78x	setNames(list(val), nm)
451		} else {
452	582x	val
453		}
454		}
455
456	66x	custargs <- fun_args
457
458		## special handling cause I need it at the bottom as well
459	66x	in_rc_argl <- .if_in_formals(".in_ref_col")
460	66x	.in_ref_col <- if (length(in_rc_argl) > 0) in_rc_argl[[1]] else FALSE
461
462	66x	sfunargs <- c(
463		## these are either named lists containing the arg, or list()
464		## depending on whether fun accept the argument or not
465	66x	.if_in_formals("x"),
466	66x	.if_in_formals("df"),
467	66x	.if_in_formals(".N_col"),
468	66x	.if_in_formals(".N_total"),
469	66x	.if_in_formals(".N_row"),
470	66x	.if_in_formals(".ref_group"),
471	66x	in_rc_argl,
472	66x	.if_in_formals(".df_row"),
473	66x	.if_in_formals(".var"),
474	66x	.if_in_formals(".ref_full")
475		)
476
477	66x	allvars <- setdiff(fun_fnames, c("...", names(sfunargs)))
478		## values int he actual call to this function override customization
479		## done by the constructor. evalparse is to avoid a "... in wrong context" NOTE
480	66x	if ("..." %in% fun_fnames) {
481	5x	exargs <- eval(parser_helper(text = "list(...)"))
482	5x	custargs[names(exargs)] <- exargs
483	5x	allvars <- unique(c(allvars, names(custargs)))
484		}
485
486	66x	for (var in allvars) {
487		## not missing, i.e. specified in the direct call, takes precedence
488	22x	if (var %in% fun_fnames && eval(parser_helper(text = paste0("!missing(", var, ")")))) {
489	5x	sfunargs[[var]] <- get(var)
490	17x	} else if (var %in% names(custargs)) { ## not specified in the call, but specified in the constructor
491	4x	sfunargs[[var]] <- custargs[[var]]
492		}
493		## else left out so we hit the original default we inherited from fun
494		}
495
496	66x	rawvals <- do.call(fun, sfunargs)
497
498		## note single brackets here so its a list
499		## no matter what. thats important!
500	66x	final_vals <- if (is.null(.stats)) rawvals else rawvals[.stats]
501
502	66x	if (!is.list(rawvals)) {
503	!	stop("make_afun expects a function fun that always returns a list")
504		}
505	66x	if (!is.null(.stats)) {
506	10x	stopifnot(all(.stats %in% names(rawvals)))
507		} else {
508	56x	.stats <- names(rawvals)
509		}
510	66x	if (!is.null(.ungroup_stats) && !all(.ungroup_stats %in% .stats)) {
511	!	stop(
512	!	"Stats specified for ungrouping not included in non-null .stats list: ",
513	!	setdiff(.ungroup_stats, .stats)
514		)
515		}
516
517	66x	.labels <- .validate_nms(final_vals, .stats, .labels)
518	66x	.formats <- .validate_nms(final_vals, .stats, .formats)
519	66x	.indent_mods <- .validate_nms(final_vals, .stats, .indent_mods)
520	66x	.format_na_strs <- .validate_nms(final_vals, .stats, .format_na_strs)
521
522	66x	final_labels <- value_labels(final_vals)
523	66x	final_labels[names(.labels)] <- .labels
524
525	66x	final_formats <- lapply(final_vals, obj_format)
526	66x	final_formats[names(.formats)] <- .formats
527
528	66x	final_format_na_strs <- lapply(final_vals, obj_na_str)
529	66x	final_format_na_strs[names(.format_na_strs)] <- .format_na_strs
530
531	66x	if (is(final_vals, "RowsVerticalSection")) {
532	20x	final_imods <- indent_mod(final_vals)
533		} else {
534	46x	final_imods <- vapply(final_vals, indent_mod, 1L)
535		}
536	66x	final_imods[names(.indent_mods)] <- .indent_mods
537
538	66x	if (!is.null(.ungroup_stats)) {
539	2x	for (nm in .ungroup_stats) {
540	3x	tmp <- final_vals[[nm]]
541	3x	if (is(tmp, "CellValue")) {
542	1x	tmp <- tmp[[1]]
543	23x	} ## unwrap it
544	3x	final_vals <- insert_replace(final_vals, nm, tmp)
545	3x	stopifnot(all(nzchar(names(final_vals))))
546
547	3x	final_labels <- insert_replace(
548	3x	final_labels,
549	3x	nm,
550	3x	setNames(
551	3x	value_labels(tmp),
552	3x	names(tmp)
553		)
554		)
555	3x	final_formats <- insert_replace(
556	3x	final_formats,
557	3x	nm,
558	3x	setNames(
559	3x	rep(final_formats[nm],
560	3x	length.out = length(tmp)
561		),
562	3x	names(tmp)
563		)
564		)
565	3x	final_format_na_strs <- insert_replace(
566	3x	final_format_na_strs,
567	3x	nm,
568	3x	setNames(
569	3x	rep(final_format_na_strs[nm],
570	3x	length.out = length(tmp)
571		),
572	3x	names(tmp)
573		)
574		)
575	3x	final_imods <- insert_replace(
576	3x	final_imods,
577	3x	nm,
578	3x	setNames(
579	3x	rep(final_imods[nm],
580	3x	length.out = length(tmp)
581		),
582	3x	names(tmp)
583		)
584		)
585		}
586		}
587	66x	rcells <- mapply(
588	66x	function(x, f, l, na_str) {
589	197x	if (is(x, "CellValue")) {
590	65x	obj_label(x) <- l
591	65x	obj_format(x) <- f
592	65x	obj_na_str(x) <- na_str
593		# indent_mod(x) <- im
594	65x	x
595	132x	} else if (.null_ref_cells) {
596	!	non_ref_rcell(x,
597	!	is_ref = .in_ref_col,
598	!	format = f, label = l,
599	!	format_na_str = na_str
600	!	) # , indent_mod = im)
601		} else {
602	132x	rcell(x, format = f, label = l, format_na_str = na_str) # , indent_mod = im)
603		}
604		},
605	66x	f = final_formats, x = final_vals,
606	66x	l = final_labels,
607	66x	na_str = final_format_na_strs,
608		# im = final_imods,
609	66x	SIMPLIFY = FALSE
610		)
611	66x	in_rows(.list = rcells, .indent_mods = final_imods) ## , .labels = .labels)
612		}
613	23x	formals(ret) <- formals(fun)
614	23x	ret
615		}
616
617		insert_replace <- function(x, nm, newvals = x[[nm]]) {
618	15x	i <- match(nm, names(x))
619	15x	if (is.na(i)) {
620	!	stop("name not found")
621		}
622	15x	bef <- if (i > 1) 1:(i - 1) else numeric()
623	15x	aft <- if (i < length(x)) (i + 1):length(x) else numeric()
624	15x	ret <- c(x[bef], newvals, x[aft])
625	15x	names(ret) <- c(names(x)[bef], names(newvals), names(x)[aft])
626	15x	ret
627		}
628
629		parser_helper <- function(text, envir = parent.frame(2)) {
630	545x	parse(text = text, keep.source = FALSE)
631		}
632
633		length_w_name <- function(x, .parent_splval) {
634	!	in_rows(length(x),
635	!	.names = value_labels(.parent_splval)
636		)
637		}

1		do_recursive_replace <- function(tab, path, incontent = FALSE, value) { ## rows = NULL,
2		## cols = NULL, value) {
3		## don't want this in the recursive function
4		## so thats why we have the do_ variant
5	285x	if (is.character(path) && length(path) > 1) {
6	212x	path <- as.list(path)
7		}
8	285x	if (length(path) > 0 && path[[1]] == obj_name(tab)) {
9	144x	path <- path[-1]
10		}
11	285x	recursive_replace(tab, path, value) ## incontent, rows, cols,value)
12		}
13
14		## different cases we want to support:
15		## 1. Replace entire children for a particular node/position in the tree
16		## 2. Replace entire rows at a particular (ElementaryTable) position within the
17		## tree
18		## 3. Replace specific cell values within a set of row x column positions within
19		## an ElementaryTable at a particular position within the tree
20		## 3. replace entire content table at a node position
21		## 4. replace entire rows within the content table at a particular node position
22		## in the tree
23		## 5. replace data cell values for specific row/col positions within the content
24		## table at a particular position within the tree
25
26		## XXX This is wrong, what happens if a split (or more accurately, value)
27		## happens more than once in the overall tree???
28		recursive_replace <- function(tab, path, value) { ## incontent = FALSE, rows = NULL, cols = NULL, value) {
29	1176x	if (length(path) == 0) { ## done recursing
30		## if(is.null(rows) && is.null(cols)) { ## replacing whole subtree a this position
31		## if(incontent) {
32		## newkid = tab
33		## content_table(newkid) = value
34		## } else
35	313x	newkid <- value
36		## newkid has either thee content table
37		## replaced on the old kid or is the new
38		## kid
39		# } ## else { ## rows or cols (or both) non-null
40		## if(incontent) {
41		## ctab = content_table(tab)
42		## ctab[rows, cols] = value
43		## content_table(tab) = ctab
44		## newkid = tab
45
46		## } else {
47		## allkids = tree_children(tab)
48		## stopifnot(are(allkids, "TableRow"))
49		## newkid = tab
50		## newkid[rows, cols] = value
51		## }
52		## }
53	313x	newkid
54	863x	} else if (path[[1]] == "@content") {
55	25x	ctb <- content_table(tab)
56	25x	ctb <- recursive_replace(ctb,
57	25x	path = path[-1],
58		## rows = rows,
59		## cols = cols,
60	25x	value = value
61		)
62	25x	content_table(tab) <- ctb
63	25x	tab
64		} else { ## length(path) > 1, more recursing to do
65	838x	kidel <- path[[1]]
66		## broken up for debugabiliity, could be a single complex
67		## expression
68		## for now only the last step supports selecting
69		## multiple kids
70	838x	stopifnot(
71	838x	length(kidel) == 1,
72	838x	is.character(kidel) \|\| is.factor(kidel)
73		)
74	838x	knms <- names(tree_children(tab))
75	838x	if (!(kidel %in% knms)) {
76	!	stop(sprintf("position element %s not in names of next level children", kidel))
77	838x	} else if (sum(kidel == knms) > 1) {
78	!	stop(sprintf("position element %s appears more than once, not currently supported", kidel))
79		}
80	!	if (is.factor(kidel)) kidel <- levels(kidel)[kidel]
81	838x	newkid <- recursive_replace(
82	838x	tree_children(tab)[[kidel]],
83	838x	path[-1],
84		## incontent = incontent,
85		## rows = rows,
86		## cols = cols,
87	838x	value
88		)
89	838x	tree_children(tab)[[kidel]] <- newkid
90	838x	tab
91		}
92		}
93
94	1x	coltree_split <- function(ctree) ctree@split
95
96		col_fnotes_at_path <- function(ctree, path, fnotes) {
97	2x	if (length(path) == 0) {
98	1x	col_footnotes(ctree) <- fnotes
99	1x	return(ctree)
100		}
101
102	1x	if (identical(path[1], obj_name(coltree_split(ctree)))) {
103	1x	path <- path[-1]
104		} else {
105	!	stop(paste("Path appears invalid at step:", path[1]))
106		}
107
108	1x	kids <- tree_children(ctree)
109	1x	kidel <- path[[1]]
110	1x	knms <- names(kids)
111	1x	stopifnot(kidel %in% knms)
112	1x	newkid <- col_fnotes_at_path(kids[[kidel]],
113	1x	path[-1],
114	1x	fnotes = fnotes
115		)
116	1x	kids[[kidel]] <- newkid
117	1x	tree_children(ctree) <- kids
118	1x	ctree
119		}
120
121		#' Insert row at path
122		#'
123		#' Insert a row into an existing table directly before or directly after an existing data (i.e., non-content and
124		#' non-label) row, specified by its path.
125		#'
126		#' @inheritParams gen_args
127		#' @param after (`flag`)\cr whether `value` should be added as a row directly before (`FALSE`, the default) or after
128		#' (`TRUE`) the row specified by `path`.
129		#'
130		#' @seealso [DataRow()], [rrow()]
131		#'
132		#' @examples
133		#' lyt <- basic_table() %>%
134		#' split_rows_by("COUNTRY", split_fun = keep_split_levels(c("CHN", "USA"))) %>%
135		#' analyze("AGE")
136		#'
137		#' tbl <- build_table(lyt, DM)
138		#'
139		#' tbl2 <- insert_row_at_path(
140		#' tbl, c("COUNTRY", "CHN", "AGE", "Mean"),
141		#' rrow("new row", 555)
142		#' )
143		#' tbl2
144		#'
145		#' tbl3 <- insert_row_at_path(tbl2, c("COUNTRY", "CHN", "AGE", "Mean"),
146		#' rrow("new row redux", 888),
147		#' after = TRUE
148		#' )
149		#' tbl3
150		#'
151		#' @export
152		setGeneric("insert_row_at_path",
153		signature = c("tt", "value"),
154		function(tt, path, value, after = FALSE) {
155	6x	standardGeneric("insert_row_at_path")
156		}
157		)
158
159		#' @rdname insert_row_at_path
160		setMethod(
161		"insert_row_at_path", c("VTableTree", "DataRow"),
162		function(tt, path, value, after = FALSE) {
163	6x	if (no_colinfo(value)) {
164	6x	col_info(value) <- col_info(tt)
165		} else {
166	!	chk_compat_cinfos(tt, value)
167		}
168		## retained for debugging
169	6x	origpath <- path # nolint
170	6x	idx_row <- tt_at_path(tt, path)
171	6x	if (!is(idx_row, "DataRow")) {
172	4x	stop(
173	4x	"path must resolve fully to a non-content data row. Insertion of ",
174	4x	"rows elsewhere in the tree is not currently supported."
175		)
176		}
177
178	2x	posnm <- tail(path, 1)
179
180	2x	path <- head(path, -1)
181
182	2x	subtt <- tt_at_path(tt, path)
183	2x	kids <- tree_children(subtt)
184	2x	ind <- which(names(kids) == posnm)
185	2x	if (length(ind) != 1L) {
186		## nocov start
187		stop(
188		"table children do not appear to be named correctly at this ",
189		"path. This should not happen, please contact the maintainer of ",
190		"rtables."
191		)
192		## nocov end
193		}
194	2x	if (after) {
195	1x	ind <- ind + 1
196		}
197
198	2x	sq <- seq_along(kids)
199	2x	tree_children(subtt) <- c(
200	2x	kids[sq < ind],
201	2x	setNames(list(value), obj_name(value)),
202	2x	kids[sq >= ind]
203		)
204	2x	tt_at_path(tt, path) <- subtt
205	2x	tt
206		}
207		)
208
209		# nocov start
210		#' @rdname insert_row_at_path
211		setMethod(
212		"insert_row_at_path", c("VTableTree", "ANY"),
213		function(tt, path, value) {
214		stop(
215		"Currently only insertion of DataRow objects is supported. Got ",
216		"object of class ", class(value), ". Please use rrow() or DataRow() ",
217		"to construct your row before insertion."
218		)
219		}
220		)
221
222		# nocov end
223
224		#' Label at path
225		#'
226		#' Accesses or sets the label at a path.
227		#'
228		#' @inheritParams gen_args
229		#'
230		#' @details
231		#' If `path` resolves to a single row, the label for that row is retrieved or set. If, instead, `path` resolves to a
232		#' subtable, the text for the row-label associated with that path is retrieved or set. In the subtable case, if the
233		#' label text is set to a non-`NA` value, the `labelrow` will be set to visible, even if it was not before. Similarly,
234		#' 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
235		#' appear at all when the table is printed.
236		#'
237		#' @note When changing the row labels for content rows, it is important to path all the way to the row. Paths
238		#' ending in `"@content"` will not exhibit the behavior you want, and are thus an error. See [row_paths()] for help
239		#' determining the full paths to content rows.
240		#'
241		#' @examples
242		#' lyt <- basic_table() %>%
243		#' split_rows_by("COUNTRY", split_fun = keep_split_levels(c("CHN", "USA"))) %>%
244		#' analyze("AGE")
245		#'
246		#' tbl <- build_table(lyt, DM)
247		#'
248		#' label_at_path(tbl, c("COUNTRY", "CHN"))
249		#'
250		#' label_at_path(tbl, c("COUNTRY", "USA")) <- "United States"
251		#' tbl
252		#'
253		#' @export
254		label_at_path <- function(tt, path) {
255	29x	obj_label(tt_at_path(tt, path))
256		}
257
258		#' @export
259		#' @rdname label_at_path
260		`label_at_path<-` <- function(tt, path, value) {
261	32x	if (!is(tt, "VTableTree")) {
262	!	stop("tt must be a TableTree or ElementaryTable object")
263		}
264	32x	if (is.null(value) \|\| is.na(value)) {
265	1x	value <- NA_character_
266		}
267	32x	subt <- tt_at_path(tt, path)
268	32x	obj_label(subt) <- value
269	32x	tt_at_path(tt, path) <- subt
270	32x	tt
271		}
272
273		#' Access or set table elements at specified path
274		#'
275		#' @inheritParams gen_args
276		#' @param ... unused.
277		#'
278		#' @export
279		#' @rdname ttap
280	504x	setGeneric("tt_at_path", function(tt, path, ...) standardGeneric("tt_at_path"))
281
282		#' @inheritParams tt_at_path
283		#'
284		#' @export
285		#' @rdname int_methods
286		setMethod(
287		"tt_at_path", "VTableTree",
288		function(tt, path, ...) {
289	504x	stopifnot(
290	504x	is(path, "character"),
291	504x	length(path) > 0,
292	504x	!anyNA(path)
293		)
294
295	504x	if (path[1] == "root" && obj_name(tt) != "root") {
296	3x	path <- path[-1]
297		}
298		## handle pathing that hits the root split by name
299	504x	if (obj_name(tt) == path[1]) {
300	404x	path <- path[-1]
301		}
302
303		# Extract sub-tables from the tree
304	504x	.extract_through_path(tt, path)
305		}
306		)
307
308		# Recursive helper function to retrieve sub-tables from the tree
309		## need to generalize this if we ever use it in a place other than tt_at_path
310		## currently tt_at_path doesn't support "*"
311		.extract_through_path <- function(cur_tbl, cur_path, no_stop = FALSE) {
312	504x	while (length(cur_path > 0)) {
313	1542x	kids <- tree_children(cur_tbl)
314	1542x	curname <- cur_path[1]
315	1542x	kids_names <- sapply(kids, obj_name)
316	1542x	if (curname == "@content") {
317	70x	cur_tbl <- content_table(cur_tbl)
318	1472x	} else if (curname %in% kids_names) {
319		## we're now guarnateed that there will only be one match
320	1468x	cur_tbl <- kids[kids_names == curname][[1]]
321	4x	} else if (!no_stop && curname == "*") {
322	1x	stop("Paths including '*' wildcards are not currently supported by tt_at_path.")
323	3x	} else if (!no_stop) {
324	3x	stop(
325	3x	"Path appears invalid for this tree at step '", curname, "'. Please use only",
326	3x	" row names and NOT row labels. You can retrieve them with `row_paths_summary()$path`."
327		)
328		} else {
329	!	return(NULL)
330		}
331	1538x	cur_path <- cur_path[-1]
332		}
333	500x	cur_tbl
334		}
335
336		tt_type_ok <- function(obj, type) {
337	1562x	switch(type,
338	735x	any = TRUE,
339	422x	row = is(obj, "TableRow"),
340	305x	table = is(obj, "VTableTree"),
341	100x	elemtable = is(obj, "ElementaryTable")
342		)
343		}
344
345		#' Pathing
346		#'
347		#' Pathing is a method of using known structure within a table
348		#' to specify elements within it in a self-describing, semantically
349		#' meaningful way.
350		#'
351		#' @details A Path consists of a character vector of one or more elements which
352		#' will be used to descend the tree structure of a table's row or column space.
353		#'
354		#' Existing paths will match the layout used to make the table in the form of
355