Skip to content
Merged
Show file tree
Hide file tree
Changes from 2 commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
2 changes: 2 additions & 0 deletions NAMESPACE
Original file line number Diff line number Diff line change
Expand Up @@ -124,6 +124,7 @@ export(make_afun)
export(make_col_df)
export(make_split_fun)
export(make_split_result)
export(make_subset_expr)
export(manual_cols)
export(no_colinfo)
export(non_ref_rcell)
Expand All @@ -145,6 +146,7 @@ export(ref_msg)
export(ref_symbol)
export(remove_split_levels)
export(reorder_split_levels)
export(restrict_facets)
export(rheader)
export(rm_all_colcounts)
export(row_cells)
Expand Down
4 changes: 4 additions & 0 deletions NEWS.md
Original file line number Diff line number Diff line change
@@ -1,5 +1,9 @@
## rtables 0.6.15.9003

### New Features
* Added `restrict_facets` function factory for use with `make_split_fun`
* Exportd previously internal `make_subset_expr` for use when constructing custom splitting behavior

## rtables 0.6.15

### New Features
Expand Down
71 changes: 71 additions & 0 deletions R/make_split_fun.R
Original file line number Diff line number Diff line change
Expand Up @@ -433,3 +433,74 @@ drop_facet_levels <- function(df, spl, ...) {
df[[var]] <- factor(df[[var]])
df
}

#' Postprocessing split function behavior to generally restrict facets
#'
#' @param facets `(character)`\cr Vector of facet names
#' @param op `("keep", or "exclude")`\cr Whether `facets` names facets
#' to be (exclusively) kept (the default) or removed.
#' @param reorder `(flag)`\cr For `op == "keep"`, should the resulting
#' facets be reordered to the order they appear in
#' `facets`. Defaults to `TRUE`.
#' @param quiet `(logical(1))`\cr Whether warnings should be given or
#' not (the default) when facets named in `facets` are not found
#' in the split result.
#'
#' @return a function suitable for use within the `post` argument of
#' [make_split_fun()].
#'
#' @details This is a function factory which creates a post-process
#' behavioral building block for use in [make_split_fun()].
#'
#' This factory provides the equivalent of both `keep_split_levels`
#' and `remove_split_levels` in a form suitable for use in
#' [make_split_fun()].
#'
#' When `op` is `"keep"` (the default), resulting facets are
#' restricted to only those named in `facets` when the generated
#' function is applied to a split result; in the case of `"exclude"`,
#' facets named in `facets` are removed so that only those not named
#' remain.
#'
#' The generated function will throw a warning if any of `facets` are
#' not found in the split result it receives during splitting, unless
#' it was created with `quietly = FALSE`.
#'
#' @seealso [make_split_fun()]
#'
Comment thread
gmbecker marked this conversation as resolved.
#' @family make_custom_split
#' @export
restrict_facets <- function(facets,
op = c("keep", "exclude"),
reorder = TRUE,
quiet = FALSE) {
op <- match.arg(op)
function(splret, spl, fulldf) {
nms <- names(splret[[1]])
mtch <- match(facets, nms)
if (anyNA(mtch)) {
if (!quiet) {
warning(
"restrict facets (op: ",
op, ") could not find facets [",
paste(facets[is.na(mtch)], collapse = ", "),
"]. Ignoring these."
)
}
mtch <- mtch[!is.na(mtch)]
}

sel_vec <- mtch
if (op == "exclude") {
sel_vec <- -1 * sel_vec
} else if (!reorder) { # op is keep
sel_vec <- sort(sel_vec)
}
ret <- lapply(
splret,
function(lst) lst[sel_vec]
)
names(ret) <- names(splret)
ret
}
}
32 changes: 31 additions & 1 deletion R/make_subset_expr.R
Original file line number Diff line number Diff line change
Expand Up @@ -2,8 +2,31 @@
## which is the only reason expression(TRUE) is ok, because otherwise
## we (sometimes) run into
## factor()[TRUE] giving <NA> (i.e. length 1)

#' Make subset expression for a split-value pair
#'
#' @param spl `(Split)`\cr A split object.
#' @param val `(SplitValue or string)`\cr The value, either as a
#' `SplitValue` object or the raw value as a string.
#'
#' @details
#'
#' If `val` is a `SplitValue` object which already contains a
#' subsetting expression with length `>0`, that is immediately
#' returned. Otherwise, the appropriate subsetting expression is
#' constructed based on the split type of `spl` and the value `val`.
#'
#' @note this is occasionally useful when constructing custom
#' splitting behavior which may used for column splitting but
#' generally should not be called directly by the end user.
#'
#' @return A subseting expression to be used to restrict data to a
#' particular column during tabulation.
Comment thread
gmbecker marked this conversation as resolved.
#' @export

Comment thread
gmbecker marked this conversation as resolved.
setGeneric("make_subset_expr", function(spl, val) standardGeneric("make_subset_expr"))

#' @rdname make_subset_expr
setMethod(
"make_subset_expr", "VarLevelSplit",
function(spl, val) {
Expand All @@ -26,6 +49,7 @@ setMethod(
}
)

#' @rdname make_subset_expr
setMethod(
"make_subset_expr", "MultiVarSplit",
function(spl, val) {
Expand All @@ -41,6 +65,7 @@ setMethod(
}
)

#' @rdname make_subset_expr
setMethod(
"make_subset_expr", "AnalyzeVarSplit",
function(spl, val) {
Expand All @@ -55,6 +80,7 @@ setMethod(
}
)

#' @rdname make_subset_expr
setMethod(
"make_subset_expr", "AnalyzeColVarSplit",
function(spl, val) {
Expand All @@ -65,6 +91,7 @@ setMethod(
## XXX these are going to be ridiculously slow
## FIXME

#' @rdname make_subset_expr
setMethod(
"make_subset_expr", "VarStaticCutSplit",
function(spl, val) {
Expand All @@ -86,6 +113,7 @@ setMethod(
)

## NB this assumes spl_cutlabels(spl) is in order!!!!!!
#' @rdname make_subset_expr
setMethod(
"make_subset_expr", "CumulativeCutSplit",
function(spl, val) {
Expand Down Expand Up @@ -123,18 +151,20 @@ setMethod(
## fun = spl@cut_fun))
## })

#' @rdname make_subset_expr
setMethod(
"make_subset_expr", "AllSplit",
function(spl, val) expression(TRUE)
)

## probably don't need this

#' @rdname make_subset_expr
setMethod(
"make_subset_expr", "expression",
function(spl, val) spl
)

#' @rdname make_subset_expr
setMethod(
"make_subset_expr", "character",
function(spl, val) {
Expand Down
1 change: 0 additions & 1 deletion R/tt_paginate.R
Original file line number Diff line number Diff line change
Expand Up @@ -237,7 +237,6 @@ setMethod(
max_width = NULL,
fontspec = NULL,
col_gap = 3) {

new_dev <- open_font_dev(fontspec)
if (new_dev) {
on.exit(close_font_dev())
Expand Down
2 changes: 2 additions & 0 deletions _pkgdown.yml
Original file line number Diff line number Diff line change
Expand Up @@ -175,9 +175,11 @@ reference:
- make_split_fun
- drop_facet_levels
- trim_levels_in_facets
- restrict_facets
- add_combo_facet
- make_split_result
- spl_variable
- make_subset_expr

- title: Cell Formatting related Functions
desc: cell formatting.
Expand Down
1 change: 1 addition & 0 deletions man/add_combo_facet.Rd

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

1 change: 1 addition & 0 deletions man/drop_facet_levels.Rd

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

1 change: 1 addition & 0 deletions man/make_split_fun.Rd

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

2 changes: 2 additions & 0 deletions man/make_split_result.Rd

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

59 changes: 59 additions & 0 deletions man/make_subset_expr.Rd

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

63 changes: 63 additions & 0 deletions man/restrict_facets.Rd

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

3 changes: 2 additions & 1 deletion man/trim_levels_in_facets.Rd

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

Loading
Loading