R/tree_accessors.R

In Roche/rtables: Reporting Tables

## XXX Do we want add.labrows here or no?
## we have to choose one and stick to it.

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

## 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_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_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
#' 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("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
#' @export
setGeneric(
  "coltree",
  function(obj, df = NULL, rtpos = TreePos()) standardGeneric("coltree")
)

#' @rdname col_accessors
#' @exportMethod coltree
setMethod(
  "coltree", "InstantiatedColumnInfo",
  function(obj, df = NULL, rtpos = TreePos()) {
    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) coltree(clayout(obj), df, rtpos)
)

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

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

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

#' @rdname col_accessors
#' @export coltree
setMethod(
  "coltree", "TableRow",
  function(obj, df, rtpos) 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))
  }
)

#' @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) obj@counts[.path_to_pos(path, obj, cols = TRUE)]
)

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

#' @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) {
    obj@total_count <- 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
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<-", "PreDataTableLayouts",
  function(obj, value) {
    clyt <- clayout(obj)
    disp_ccounts(clyt) <- value
    clayout(obj) <- clyt
    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
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
  }
)

#' 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) {
  .Deprecated(
    new = "col_footnotes",
    old = "col_fnotes_here",
    msg = "col_fnotes_here was deprecated in {rtables} version 0.6.5.9011. Please use col_footnotes instead."
  )
  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) {
  .Deprecated(
    new = "col_footnotes<-",
    old = "col_fnotes_here<-",
    msg = "col_fnotes_here<- was deprecated in {rtables} version 0.6.5.9011. Please use col_footnotes<- instead."
  )
  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)
    }

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

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

setMethod("has_force_pag", "TableTree", function(obj) !is.na(ptitle_prefix(obj)))

setMethod("has_force_pag", "Split", function(obj) !is.na(ptitle_prefix(obj)))

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.
#'
#' @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 single characters to use as section dividers. Each character
#'   is repeated such that all section dividers span the width of the table. Each character that is
#'   not `NA_character_` will produce a trailing separator for each row of the table. `value` length
#'   should reflect the number of rows, or be between 1 and the number of splits/levels.
#'   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
#' Assigned value to section divider must be a character vector. If any value is `NA_character_`
#' the section divider will be absent for that row or section. 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 `FALSE`, the section
#' divider will be set for all the rows of the table.
#'
#' @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) {
  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) || is_content_table) {
    section_div <- trailing_section_div(obj)
    labelrow_div <- trailing_section_div(tt_labelrow(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(labelrow_div, rest_of_tree))
  } else {
    unname(section_div(tree_children(obj)))
  }
})

#' @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) {
  char_v <- as.character(value)
  tree_depths <- unname(vapply(collect_leaves(obj), tt_level, numeric(1)))
  max_tree_depth <- max(tree_depths)
  stopifnot(is.logical(only_sep_sections))
  .check_char_vector_for_section_div(char_v, max_tree_depth, nrow(obj))

  # Automatic establishment of intent
  if (length(char_v) < nrow(obj)) {
    only_sep_sections <- TRUE
  }

  # Case where only separators or splits need to change externally
  if (only_sep_sections && length(char_v) < nrow(obj)) {
    # Case where char_v is longer than the max depth
    char_v <- char_v[seq_len(min(max_tree_depth, length(char_v)))]
    # Filling up with NAs the rest of the tree depth section div chr vector
    missing_char_v_len <- max_tree_depth - length(char_v)
    char_v <- c(char_v, rep(NA_character_, missing_char_v_len))
  }

  # Retrieving if it is a contentRow (no need for labelrow to be visible in this case)
  content_row_tbl <- content_table(obj)
  is_content_table <- isS4(content_row_tbl) && nrow(content_row_tbl) > 0

  # Main table structure change
  if (labelrow_visible(obj) || is_content_table) {
    if (only_sep_sections) {
      # Only tables are modified
      trailing_section_div(tt_labelrow(obj)) <- NA_character_
      trailing_section_div(obj) <- char_v[1]
      section_div(tree_children(obj), only_sep_sections = only_sep_sections) <- char_v[-1]
    } else {
      # All leaves are modified
      trailing_section_div(tt_labelrow(obj)) <- char_v[1]
      trailing_section_div(obj) <- NA_character_
      section_div(tree_children(obj), only_sep_sections = only_sep_sections) <- char_v[-1]
    }
  } else {
    section_div(tree_children(obj), only_sep_sections = only_sep_sections) <- char_v
  }
  obj
})

#' @rdname section_div
#' @aliases section_div<-,list-method
setMethod("section_div<-", "list", function(obj, only_sep_sections = FALSE, value) {
  char_v <- as.character(value)
  for (i in seq_along(obj)) {
    stopifnot(is(obj[[i]], "VTableTree") || is(obj[[i]], "TableRow") || is(obj[[i]], "LabelRow"))
    list_element_size <- nrow(obj[[i]])
    if (only_sep_sections) {
      char_v_i <- char_v[seq_len(min(list_element_size, length(char_v)))]
      char_v_i <- c(char_v_i, rep(NA_character_, list_element_size - length(char_v_i)))
    } else {
      init <- (i - 1) * list_element_size + 1
      chunk_of_char_v_to_take <- seq(init, init + list_element_size - 1)
      char_v_i <- char_v[chunk_of_char_v_to_take]
    }
    section_div(obj[[i]], only_sep_sections = only_sep_sections) <- char_v_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
#' @aliases section_div<-,LabelRow-method
setMethod("section_div<-", "LabelRow", function(obj, only_sep_sections = FALSE, value) {
  trailing_section_div(obj) <- value
  obj
})

# Helper check function
.check_char_vector_for_section_div <- function(char_v, min_splits, max) {
  lcv <- length(char_v)
  if (lcv < 1 || lcv > max) {
    stop("section_div must be a vector of length between 1 and numer of table rows.")
  }
  if (lcv > min_splits && lcv < max) {
    warning(
      "section_div will be truncated to the number of splits (", min_splits, ")",
      " because it is shorter than the number of rows (", max, ")."
    )
  }
  nchar_check_v <- nchar(char_v)
  if (any(nchar_check_v > 1, na.rm = TRUE)) {
    stop("section_div must be a vector of single characters or NAs")
  }
}

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

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