Nothing
#' Crunch expressions internal
#'
#' See [`expressions`] for more details.
#'
#' @param x,e1,e2 inputs
#' @param table,na.rm,upper,lower,inclusive,selections,collapse,
#' cases,data,resolution,year,month,day,hours,minutes,seconds,min,max,categories,category_order,
#' subvariables,remove,remove_id,subreferences,subreferences_id
#' Other parameters used in some functions, see details of [`expressions`] for more details.
#' @return Most functions return a CrunchExpr or CrunchLogicalExpr.
#' `as.vector` returns an R vector.
#' @aliases expressions-internal %in% == != !
#' @name expressions-internal
#' @keywords internal
setGeneric("%in%")
# TODO: figure this out.
# Can't "roxygen" these because check says
# Functions or methods with usage in documentation object 'expressions' but not in code:
# == != !
#
# but if you try standardGeneric, it fails to build with
# Error in setGeneric("==", function(e1, e2) standardGeneric("==")) :
# ‘==’ dispatches internally; methods can be defined, but the generic
# function is implicit, and cannot be changed.
setGeneric("==")
setGeneric("!=")
setGeneric("!")
## "Ops" for Crunch Variables
##
## Most of the indirection here is to programatically create the Ops methods
## for the right combinations of multiple-dispatch signatures
math.exp <- function(e1, e2, operator, ...) {
## Generic function that creates CrunchExpr of `e1 %operator% e2`
if (identical(e1, logical(0)) || identical(e2, logical(0))) {
## If you reference a variable in a dataset that doesn't exist, you
## get NULL, and e.g. NULL == something becomes logical(0).
## That does awful things if you try to send to the server. So don't.
##
## Because of how this function is invoked, get the offending expression
## from the call before this one
halt(
"Invalid expression (probably a reference to a variable that ",
"doesn't exist): ", deparseAndFlatten(tail(sys.calls(), 2)[[1]])
)
}
ex <- zfunc(operator, e1, e2, ...)
ds.url <- unique(unlist(lapply(list(e1, e2), datasetReference))) %||% ""
out <- ExprConstructor(operator)(expression = ex, dataset_url = ds.url)
activeFilter(out) <- getOperationFilter(e1, e2)
return(out)
}
getOperationFilter <- function(...) {
## If any argument is Crunch objects with filters, pass those along,
## and if multiple do, make sure that they're the same
filters <- lapply(list(...), function(x) {
out <- try(activeFilter(x), silent = TRUE)
if (is.error(out)) out <- NULL
out
})
filters <- filters[!vapply(filters, is.null, logical(1))]
if (length(filters) == 0) return(NULL)
Reduce(
function(x, y) {
if (!identical(x, y)) {
halt("Cannot combine expressions with different filters")
}
x
},
filters
)
}
ExprConstructor <- function(operator) {
## Based on the operator function, make either CrunchExpr or CrunchLogicalExpr
logics <- c(
"in", "<", ">", ">=", "<=", "==", "!=", "and", "or", "ornm", "not",
"is_missing", "duplicates", "selected", "not_selected",
"between", "=><=", "all", "any", "anynm", "is_none_of_the_above",
"contains", "icontains", "~=", "is_valid", "any_missing",
"all_valid", "all_missing"
)
if (operator %in% logics) {
Constructor <- CrunchLogicalExpr
} else {
Constructor <- CrunchExpr
}
return(Constructor)
}
crunch.ops <- function(i, ...) {
## Create math.exp of Variable x R.object, R.object x Variable, or V x V
force(i)
return(function(e1, e2) math.exp(e1, e2, i, ...))
}
.sigs <- list(
c("TextVariable", "character"),
c("NumericVariable", "numeric"),
c("DatetimeVariable", "Date"),
c("DatetimeVariable", "POSIXt"),
## TODO: validate that the "character" is valid 8601?
c("DatetimeVariable", "character"),
## TODO: add cast(x, "numeric") around var for this?
c("CategoricalVariable", "numeric")
)
.rtypes <- unique(vapply(.sigs, function(a) a[[2]], character(1)))
.nomath <- which(!vapply(
.sigs,
function(a) a[[1]] %in% c("TextVariable", "CategoricalVariable"),
logical(1)
))
for (i in c("+", "-", "*", "/", "<", ">", ">=", "<=")) {
for (j in .nomath) {
setMethod(i, .sigs[[j]], crunch.ops(i))
setMethod(i, rev(.sigs[[j]]), crunch.ops(i))
}
for (j in setdiff(.rtypes, "character")) {
setMethod(i, c("CrunchExpr", j), crunch.ops(i))
setMethod(i, c(j, "CrunchExpr"), crunch.ops(i))
}
setMethod(i, c("CrunchVariable", "CrunchVariable"), crunch.ops(i))
setMethod(i, c("CrunchExpr", "CrunchVariable"), crunch.ops(i))
setMethod(i, c("CrunchVariable", "CrunchExpr"), crunch.ops(i))
setMethod(i, c("CrunchExpr", "CrunchExpr"), crunch.ops(i))
}
setMethod("-", c("DatetimeVariable", "DatetimeVariable"), crunch.ops("difftime"))
#' @rdname expressions-internal
#' @export
crunchDifftime <- function(e1, e2, resolution = NULL) {
isVarButNotType(e1, "Datetime", "crunchDifftime")
isVarButNotType(e2, "Datetime", "crunchDifftime")
crunch.ops("difftime", resolution)(e1, e2)
}
#' @rdname expressions-internal
#' @export
datetimeFromCols <- function(year, month, day, hour = NULL, minute = NULL, second = NULL) {
isVarButNotType(year, "Numeric", "datetimeFromCols")
isVarButNotType(month, "Numeric", "datetimeFromCols")
isVarButNotType(day, "Numeric", "datetimeFromCols")
if (!is.null(hour)) isVarButNotType(hour, "Numeric", "datetimeFromCols")
if (!is.null(minute)) isVarButNotType(minute, "Numeric", "datetimeFromCols")
if (!is.null(second)) isVarButNotType(second, "Numeric", "datetimeFromCols")
ex <- zfunc("datetime", year, month, day, hour, minute, second)
ds.url <- unique(unlist(lapply(list(year, month, day), datasetReference))) %||% ""
out <- ExprConstructor("datetime")(expression = ex, dataset_url = ds.url)
activeFilter(out) <- getOperationFilter(year, month, day, hour, minute, second)
return(out)
}
#' @rdname expressions-internal
#' @export
`%ornm%` <- function(e1, e2) {
crunch.ops("ornm")(e1, e2)
}
setMethod("&", c("CrunchExpr", "CrunchExpr"), crunch.ops("and"))
setMethod("&", c("logical", "CrunchExpr"), crunch.ops("and"))
setMethod("&", c("CrunchExpr", "logical"), crunch.ops("and"))
setMethod("|", c("CrunchExpr", "CrunchExpr"), crunch.ops("or"))
setMethod("|", c("logical", "CrunchExpr"), crunch.ops("or"))
setMethod("|", c("CrunchExpr", "logical"), crunch.ops("or"))
zfuncExpr <- function(fun, x, ...) {
## Wrap zfunc(fun, x) in a way that preserves x's active filter
## Returns CrunchExpr instead of zcl/list
## Currently only implemented for one arg with a filter (x)
out <- ExprConstructor(fun)(expression = zfunc(fun, x, ...),
dataset_url = datasetReference(x) %||% "")
activeFilter(out) <- activeFilter(x)
return(out)
}
#' Construct Crunch Expressions from Crunch Database Functions
#'
#' Crunch Expressions, i.e. `CrunchExpr` and `CrunchLogicalExpr`,
#' encapsulate derivations of Crunch variables, possibly composed of other functions
#' which are only evaluated when sent to the server when creating a variable using [`VarDef()`]
#' or using [`as.vector()`] to get data. The crunch database functions can be found in the
#' [Help Center](https://help.crunch.io/hc/en-us/articles/360042411792-Expressions),
#' and can be called directly via `crunchdbFunc()`m but many have also been wrapped
#' in native R functions, and are described in the details section below.
#'
#'
#' Logical expressions
#' - These logical operators `==`, `!=`, `&`, `|`, `!`,`%in%` work the same way as their
#' base R counterparts
#' - `is.selected(x)` return `CrunchLogicalExpr` whether a value is in a selected category
#' - `rowAny(x)` and `rowAll(x)` work row-wise on `MultipleResponse` Variables (and expressions),
#' though `na.rm` is not implemented for `all(x)`.
#' `%ornm%` is similar to `|`, but where "not selected" beats "missing" (so `FALSE %ornm% NA`
#' is `FALSE` instead of `NA` as it would be with `FALSE | NA`)
#'
#' Comparisons
#' - Comparison operators `<`, `<=`, `>`, `>=` work the same way as their base R counterparts.
#' - `crunchBetween(x, lower, upper, inclusive)` to provide lower and upper bounds in a single
#' expression.
#'
#' Missing data expressions
#' - `is.na(x)`, `is.valid(x)` return `CrunchLogicalExpr` whether a single variable (or expression
#' that creates one) is missing (or not missing).
#' - `rowAnyNA(x)`, `rowAllNA(x)` return `CrunchLogicalExpr` whether any/all values in an
#' array variable (or expression that creates one) are missing.
#' - `complete.cases(x)` returns an expression that is "selected" if all cases are non-missing,
#' "missing" if they are all missing, and "other" otherwise.
#'
#' Selection expressions
#' - `selectCategories(x, selections, collapse = TRUE)` takes a categorical variable (or array)
#' and marks categories as selected. `selections` should be a list of category names or
#' values. If `collapse` is `TRUE`, (the default), it collapses the categories to "selected",
#' "other" and "missing", but it is `FALSE`, then the old categories are preserved.
#' - `asSelected(x)` returns an expression that condenses a categorical into 3 categories
#' ("selected", "other" or "missing")
#' - `selectedDepth(x)` returns an expression that creates a numeric variable that counts the
#' number of selections across rows of an array variable (or expression that creates one)
#' - `arraySelections(x)` returns an expression that takes an array and creates an array with
#' each variable condensed to "selected", "other" or "missing" and an extra subvariable
#' "__any__" that indicates whether any is selected.
#' - `alterCategoriesExpr(x, categories = NULL, category_order = NULL, subvariables = NULL)`
#' Change the category names, order, or subvariable names of categorical or Array variables
#' (can only modify existing ones, not add or remove categories or subvariables).
#' `categories` is a `Categories` object or a list of lists, each with a `name` indicating
#' the new name, as well as an `id` or `old_name` to identify which category to modify.
#' `category_order` is either a numeric vector indicating category ids or a character vector
#' indicating the names of the categories in the order they should be displayed
#' (note that all categories must be specified). `subvariables` is a list of lists, each with
#' a `name` to rename the subvariable and an `alias`, `old_nam` or `id` to identify the
#' subvariable. When `x` is an expression, all categories and subvariables must be identified
#' by `id`.
#'
#' Array expressions
#' - `makeFrame(x, numeric = NULL)` an expression that creates an array from existing
#' variables or expressions, see `deriveArray()` for more details
#' - `arraySubsetExpr(x, subvars, subvar_id = c("alias", "name", "id"))` Take a subset of an
#' existing array variable, identifying the subvariables by alias, name, or id (if `x` is
#' an expression, you must use id).
#' - ```
#' alterArrayExpr(
#' x,
#' add = NULL,
#' order = NULL,
#' order_id = c("alias", "name", "id"),
#' remove = NULL,
#' remove_id = c("alias", "name", "id"),
#' subreferences = NULL,
#' subreferences_id = c("alias", "name", "id")
#' )
#' ```
#' Add, reorder, remove or rename subvariables on an an array variable `x`. The `add` argument is
#' a list of variables or expressions, optionally named with the id they should have. `order`
#' and `remove` are vectors of aliases, names or ids (specify which with `order_id`/`remove_id`).
#' The `subreferences` object is a list of lists that are named the alias, name, or id (again
#' specify which with `subreferences_id`) with metadata information like name and alias in the
#' list.
#'
#' Miscellaneous expressions
#' - `caseExpr(..., cases)` Create a categorical variable from
#' a set of logical expressions that when met are assigned to a category. See
#' [`makeCaseVariable()`] for more details.
#' - `bin(x)` returns a column's values binned into equidistant bins.
#' - `nchar(x)` returns a numeric value indicating the length of a string (or missing reason)
#' in a `TextVariable` (or expression that creates one)
#' - `unmissing(x)` for a `NumericVariable` (or expression that creates one) return the values of
#' the data, ignoring the ones set to missing.
#' - `trim(x, min, max)` for a `NumericVariable` (or expression that creates one) return values
#' that where all values less than `min` have been replaced with `min` and all values greater
#' than `max` have been
#' - `crunchDifftime(e1, e2, resolution)` Gets the difference between two datetimes as a number
#' with specified resolution units (one of `c("Y", "Q", "M", "W", "D", "h", "m", "s", "ms")`).
#' - `datetimeFromCols(year, month, day, hours, minutes, seconds)` create a `Datetime` variable
#' from numeric variables or expressions (`year`, `month`, and `day` are required, but `hours`,
#' `minutes`, and `seconds` are optional)
#' - `rollup(x, resolution)` sets the resolution of a datetime variable or expression, see
#' [`resolution()`]
#'
#' @name expressions
#' @param fun The name of the crunch database function to call
#' @param x An input, a crunch variable, expression or R object
#' @param ... Other arguments passed to the database function
#' @export
crunchdbFunc <- zfuncExpr
#' @rdname expressions-internal
#' @export
setMethod("!", "CrunchExpr", function(x) zfuncExpr("not", x))
#' @importFrom utils head tail
.seqCrunch <- function(x, table) {
## Given x %in% table, if table is numeric, see if we can/should collapse
## it into a range query rather than sending lots of distinct values
if (is.numeric(table) &&
length(table) > 2 &&
all(!is.na(table)) &&
identical(as.numeric(head(table, 1):tail(table, 1)), as.numeric(table))) {
# set beg(ining) and end appropriately in case we have been given a rev
# sequence (eg 20:1) ZCL returns nothing if asked for between 20 and 1
if (head(table, 1) < tail(table, 1)) {
beg <- head(table, 1)
end <- tail(table, 1)
} else {
beg <- tail(table, 1)
end <- head(table, 1)
}
return(zfunc(
"between",
x,
beg,
end,
list(value = I(c(TRUE, TRUE)))
))
} else {
return(zfunc(ifelse(length(table) == 1L, "==", "in"), x, table))
}
}
.inCrunch <- function(x, table) zfuncExpr("selected", math.exp(x, r2zcl(I(table)), "in"))
#' @rdname expressions-internal
#' @export
setMethod(
"%in%", c("CategoricalVariable", "character"),
function(x, table) .inCrunch(x, n2i(table, categories(x), strict = FALSE))
)
#' @rdname expressions-internal
#' @export
setMethod(
"%in%", c("CategoricalVariable", "factor"),
function(x, table) x %in% as.character(table)
)
## Iterated version of below:
for (i in seq_along(.sigs)) {
setMethod("%in%", .sigs[[i]], .inCrunch)
}
#' @rdname expressions-internal
#' @export
setMethod("%in%", c("TextVariable", "character"), .inCrunch)
#' @rdname expressions-internal
#' @export
setMethod("%in%", c("NumericVariable", "numeric"), .inCrunch)
#' @rdname expressions-internal
#' @export
setMethod("%in%", c("DatetimeVariable", "Date"), .inCrunch)
#' @rdname expressions-internal
#' @export
setMethod("%in%", c("DatetimeVariable", "POSIXt"), .inCrunch)
#' @rdname expressions-internal
#' @export
setMethod("%in%", c("DatetimeVariable", "character"), .inCrunch)
#' @rdname expressions-internal
#' @export
setMethod("%in%", c("CategoricalVariable", "numeric"), .inCrunch)
for (i in c("==", "!=")) {
for (j in seq_along(.sigs)) {
setMethod(i, .sigs[[j]], crunch.ops(i))
setMethod(i, rev(.sigs[[j]]), crunch.ops(i)) ## is this right?
}
for (j in .rtypes) {
setMethod(i, c("CrunchExpr", j), crunch.ops(i))
setMethod(i, c(j, "CrunchExpr"), crunch.ops(i))
}
setMethod(i, c("CrunchVariable", "CrunchVariable"), crunch.ops(i))
setMethod(i, c("CrunchExpr", "CrunchVariable"), crunch.ops(i))
setMethod(i, c("CrunchVariable", "CrunchExpr"), crunch.ops(i))
setMethod(i, c("CrunchExpr", "CrunchExpr"), crunch.ops(i))
}
#' @rdname expressions-internal
#' @export
setMethod("==", c("CategoricalVariable", "numeric"), function(e1, e2) {
if (length(e2) == 0) {
## The specified category doesn't exist. But `== BAD` breaks server
## However, "in []" is fine
return(math.exp(e1, e2, "in"))
}
return(math.exp(e1, e2, "=="))
})
#' @rdname expressions-internal
#' @export
setMethod("==", c("CategoricalVariable", "character"), function(e1, e2) {
e2 <- n2i(e2, categories(e1), strict = FALSE)
return(e1 == e2)
})
#' @rdname expressions-internal
#' @export
setMethod(
"==", c("CategoricalVariable", "factor"),
function(e1, e2) e1 == as.character(e2)
)
#' @rdname expressions-internal
#' @export
setMethod("!=", c("CategoricalVariable", "numeric"), function(e1, e2) {
if (length(e2) == 0) {
## The specified category was doesn't exist. But `== BAD` breaks server
## However, "in []" is fine. So do `not (in [])`
return(!math.exp(e1, e2, "in"))
}
return(math.exp(e1, e2, "!="))
})
#' @rdname expressions-internal
#' @export
setMethod("!=", c("CategoricalVariable", "character"), function(e1, e2) {
e2 <- n2i(e2, categories(e1), strict = FALSE)
return(e1 != e2)
})
#' @rdname expressions-internal
#' @export
setMethod(
"!=", c("CategoricalVariable", "factor"),
function(e1, e2) e1 != as.character(e2)
)
#' @rdname expressions-internal
#' @export
setMethod("is.na", "CrunchVarOrExpr", function(x) zfuncExpr("is_missing", x))
#' @rdname expressions-internal
#' @export
is.valid <- function(x) zfuncExpr("is_valid", x)
#' @rdname expressions-internal
#' @export
bin <- function(x) zfuncExpr("bin", x)
#' @rdname crunch-extract
#' @export
setMethod("[", c("CrunchExpr", "CrunchLogicalExpr"), .updateActiveFilter)
.updateActiveFilterLogical <- function(x, i, ...) {
if (length(i)) {
i <- CrunchLogicalExpr(
dataset_url = datasetReference(x),
expression = .dispatchFilter(i)
)
return(x[i])
} else {
## If you reference a variable in a dataset that doesn't exist, you
## get NULL, and e.g. NULL == something becomes logical(0).
## That does awful things if you try to send to the server. So don't.
halt("Invalid expression: ", deparseAndFlatten(match.call()$i))
}
}
#' @rdname crunch-extract
#' @export
setMethod("[", c("CrunchExpr", "logical"), .updateActiveFilterLogical)
#' @rdname crunch-extract
#' @export
setMethod("[", c("CrunchExpr", "numeric"), function(x, i, ...) {
i <- CrunchLogicalExpr(
dataset_url = datasetReference(x),
expression = .dispatchFilter(i)
)
return(x[i])
})
#' "which" method for CrunchLogicalExpr
#'
#' @param x CrunchLogicalExpr
#' @param arr.ind Ignored
#' @param useNames Ignored
#' @return Integer row indices where \code{x} is true. Note that this does not
#' return a Crunch expression. Use this when you need to translate to R values.
#' For filtering a Crunch expression by \code{x}, don't use \code{which}.
#' @aliases which
#' @name which
NULL
#' @rdname which
setMethod("which", "CrunchLogicalExpr", function(x, arr.ind, useNames) {
which(as.vector(x))
})
#' "duplicated" method for Crunch objects
#'
#' @param x `CrunchVariable` or `CrunchExpr`
#' @param incomparables Ignored
#' @param ... Ignored
#' @return A `CrunchLogicalExpr` that evaluates `TRUE` for all repeated
#' entries after the first occurrence of a value.
#' @name duplicated
#' @seealso [base::duplicated()]
#' @aliases duplicated
#' @export
NULL
#' @rdname duplicated
#' @export
setMethod("duplicated", "CrunchVariable", function(x, incomparables = FALSE, ...) {
zfuncExpr("duplicates", x)
})
#' @rdname duplicated
#' @export
setMethod("duplicated", "CrunchExpr", function(x, incomparables = FALSE, ...) {
zfuncExpr("duplicates", x)
})
#' @rdname expressions-internal
#' @export
selectCategories <- function(x, selections, collapse = TRUE) {
out <- zfuncExpr("select_categories", x, list(value = I(selections)))
if (collapse) out <- asSelected(out)
out
}
#' @rdname expressions-internal
#' @export
crunchBetween <- function(x, lower, upper, inclusive = c(TRUE, FALSE)) {
isVarButNotType(x, "Numeric", "crunchBetween")
zfuncExpr("between", x, lower, upper, list(value = I(inclusive)))
}
#' @rdname expressions-internal
#' @export
rowAll <- function(x, na.rm = FALSE) {
isVarButNotType(x, "Array", "rowAll")
zfuncExpr("all", x)
}
#' @rdname expressions-internal
#' @export
rowAny <- function(x, na.rm = FALSE) {
isVarButNotType(x, "Array", "rowAny")
func_name <- if (na.rm) "anynm" else "any"
zfuncExpr(func_name, x)
}
#' @rdname expressions-internal
#' @export
rowAnyNA <- function(x) {
isVarButNotType(x, "Array", "rowAnyNA")
zfuncExpr("any_missing", x)
}
#' @rdname expressions-internal
#' @export
rowAllNA <- function(x) {
isVarButNotType(x, "Array", "rowAllNA")
zfuncExpr("all_missing", x)
}
#' @rdname expressions-internal
#' @export
setMethod("complete.cases", c("CrunchVarOrExpr"), function(x, ...) {
isVarButNotType(x, "Array", "complete.cases")
if (length(list(...)) > 0) {
halt("crunch::complete.cases() only works on arrays so can only take a single argument")
}
zfuncExpr("complete_cases", x)
})
#' @rdname expressions-internal
#' @export
setMethod("is.selected", "CrunchVarOrExpr", function(x) {
isVarButNotType(x, "Categorical", "is.selected")
zfuncExpr("selected", x)
})
#' @rdname expressions-internal
#' @export
asSelected <- function(x) {
isVarButNotType(
x,
c("Categorical", "Categorical Array", "Multiple Response"),
"asSelected"
)
zfuncExpr("as_selected", x)
}
#' @rdname expressions-internal
#' @export
selectedDepth <- function(x) {
isVarButNotType(x, "Multiple Response", "selectedDepth")
zfuncExpr("selected_depth", x)
}
#' @rdname expressions-internal
#' @export
arraySelections <- function(x) {
isVarButNotType(x, "Multiple Response", "arraySelections")
zfuncExpr("selections", x)
}
#' @rdname expressions-internal
#' @export
setMethod("nchar", c("CrunchVarOrExpr"), function(x, type = "chars", allowNA = FALSE, keepNA = NA) {
isVarButNotType(x, "Text", "nchar")
if (type != "chars") warning("type argument ignored in `crunch::nchar()`")
if (allowNA) warning("allowNA argument ignored in `crunch::nchar()`")
if (!is.na(keepNA)) warning("keepNA argument ignored in `crunch::nchar()`")
zfuncExpr("char_length", x)
})
#' @rdname expressions-internal
#' @export
trim <- function(x, min, max) {
isVarButNotType(x, "Numeric", "trim")
zfuncExpr("trim", x, min, max)
}
#' @rdname expressions-internal
#' @export
alterCategoriesExpr <- function(
x,
categories = NULL,
category_order = NULL,
subvariables = NULL
) {
isVarButNotType(x, c("Array", "Categorical"), "alterCategoriesExpr")
args <- list(fun = "alter_categories", x)
if (!is.null(categories)) {
args$categories <- list(value = alter_cats_get_cat_ids(x, categories))
}
if (!is.null(category_order)) {
args$order <- list(value = alter_cats_get_order_ids(x, category_order))
}
if (!is.null(subvariables)) {
args$subvariables <- list(value = alter_cats_get_subvar_ids(x, subvariables))
}
do.call(zfuncExpr, args)
}
alter_cats_get_cat_ids <- function(x, categories) {
if (is.null(categories)) return(categories)
if (is.variable(x)) {
old_names <- setNames(as.list(ids(categories(x))), names(categories(x)))
} else {
old_names <- NULL
}
categories <- lapply(categories, function(cat) {
if ("id" %in% names(cat)) {
cat[!names(cat) %in% "selected"]
} else if ("old_name" %in% names(cat)) {
if (is.null(old_names)) {
halt("Must use category ids when modifying categories of an expression")
}
id <- getElement(old_names, cat$old_name)
if (is.null(id)) {
halt("Could not find category with old name '", cat$old_name, "'")
}
c(list(id = id), cat[!names(cat) %in% c("selected", "old_name")])
} else {
halt("Must specify either id or old_name for each category update")
}
})
}
alter_cats_get_order_ids <- function(x, category_order) {
if (is.null(category_order) | is.numeric(category_order)) {
category_order
} else if (is.character(category_order)) {
if (!is.variable(x)) {
halt("Must use category ids when reordering categories of an expression")
}
matches <- match(category_order, names(categories(x)))
if (any(is.na(matches))) {
halt(
"Categories ",
paste0("'", category_order[is.na(matches)], "'", collapse = ","),
" not found in data,"
)
}
ids(categories(x))[matches]
} else {
halt("Expected category_order to be numeric vector of ids or character vector of names")
}
}
alter_cats_get_subvar_ids <- function(x, subvariables) {
if (is.null(subvariables)) return(subvariables)
if (is.variable(x)) {
old_aliases <- setNames(as.list(ids(subvariables(x))), aliases(subvariables(x)))
old_names <- setNames(as.list(ids(subvariables(x))), names(subvariables(x)))
} else {
old_aliases <- NULL
old_names <- NULL
}
lapply(subvariables, function(sv) {
if (!"name" %in% names(sv)) halt("All subvariables must have a name to update")
if ("id" %in% names(sv)) {
list(id = as.character(sv$id), name = sv$name)
} else if (is.null(old_aliases)) {
halt("Must use subvariable ids when modifying subvariable names of an expression")
} else if ("alias" %in% names(sv)) {
id <- getElement(old_aliases, sv$alias)
if (is.null(id)) {
halt("Could not find subvariable with alias '", sv$alias, "'")
}
list(id = id, name = sv$name)
} else if ("old_name" %in% names(sv)) {
id <- getElement(old_names, sv$old_name)
if (is.null(id)) {
halt("Could not find subvariable with old name '", sv$old_name, "'")
}
list(id = id, name = sv$name)
}
})
}
#' @rdname expressions-internal
#' @export
alterArrayExpr <- function(
x,
add = NULL,
order = NULL,
order_id = c("alias", "name", "id"),
remove = NULL,
remove_id = c("alias", "name", "id"),
subreferences = NULL,
subreferences_id = c("alias", "name", "id")
) {
isVarButNotType(x, "Array", "alterArrayExpr")
remove_id <- match.arg(remove_id)
order_id <- match.arg(order_id)
subreferences_id <- match.arg(subreferences_id)
if (!is.null(add)) {
if (is.variable(add) || is.VarDef(add)) add <- list(add)
add_ids <- if (is.null(names(add))) new_array_ids(x, length(add)) else names(add)
add <- setNames(lapply(add, zcl), add_ids)
if (is.null(order)) {
if (!is.variable(x)) {
halt("Must set order when adding subvariables to an expression")
}
order <- c(ids(subvariables(x)), add_ids)
order_id <- "id"
}
}
if (!is.null(order)) {
order <- match_subvar_to_id(x, order, order_id, add)
}
remove <- match_subvar_to_id(x, remove, remove_id, add)
if (!is.null(subreferences)) {
names(subreferences) <- match_subvar_to_id(x, names(subreferences), subreferences_id, add)
}
args <- list(fun = "alter_array", x = x)
if (!is.null(add)) args$add <- list(map = I(add))
if (!is.null(order)) args$order <- list(value = I(order))
if (!is.null(remove)) args$remove <- list(value = I(remove))
if (!is.null(subreferences)) args$subreferences <- list(value = I(subreferences))
do.call(zfuncExpr, args)
}
new_array_ids <- function(array, num) {
if (is.variable(array)) {
existing_ids <- ids(subvariables(array))
} else {
existing_ids <- try({
arrayflat <- unlist(array)
unlist(arrayflat)[grepl("\\.map\\.", names(arrayflat))]
}, silent = TRUE)
if (inherits(existing_ids, "try-error")) existing_ids <- c()
}
max_numeric <- suppressWarnings(max(c(as.numeric(existing_ids), 0), na.rm = TRUE))
as.character(max_numeric + seq_len(num))
}
#' @rdname expressions-internal
#' @export
arraySubsetExpr <- function(x, subvars, subvar_id = c("alias", "name", "id")) {
isVarButNotType(x, "Array", "arraySubsetExpr")
subvar_id <- match.arg(subvar_id)
subvars <- match_subvar_to_id(x, subvars, subvar_id)
zfuncExpr("array_subset", x, list(value = I(subvars)))
}
match_subvar_to_id <- function(x, subvars, id_type = c("alias", "name", "id"), add = NULL) {
if (is.null(subvars)) return(subvars)
id_type <- match.arg(id_type)
if (!is.null(add)) {
add_refs <- list(
ids = names(add),
aliases = vapply(add, function(x) x$references$alias %||% "", ""),
names = vapply(add, function(x) x$references$name %||% "", "")
)
} else {
add_refs <- list(ids = NULL, aliases = NULL, names = NULL)
}
if (id_type == "id") {
if (!is.variable(x)) return(subvars) # no validation possible
matches <- match(subvars, c(ids(subvariables(x)), add_refs$ids))
} else if (!is.variable(x)) {
halt("Must provide subvariable ids when x is an expression")
} else if (id_type == "alias") {
matches <- match(subvars, c(aliases(subvariables(x)), add_refs$aliases))
} else if (id_type == "name") {
matches <- match(subvars, c(names(subvariables(x)), add_refs$names))
}
if (any(is.na(matches))) {
halt(
"Could not find subvariables with ", id_type, " ",
paste0("'", subvars[is.na(matches)], "'", collapse = ",")
)
}
c(ids(subvariables(x)), add_refs$ids)[matches]
}
#' @rdname crunch-is
#' @export
is.CrunchExpr <- function(x) inherits(x, "CrunchExpr")
#' @rdname crunch-is
#' @export
is.Expr <- is.CrunchExpr
isVarButNotType <- function(x, types, caller) {
if (is.null(x)) halt(
"Expected a crunch variable or expression but got `NULL`, did you misspell a variable?"
)
type_check <- lapply(types, function(type) {
switch(
type,
"Numeric" = is.Numeric,
"Text" = is.Text,
"Datetime" = is.Datetime,
"Categorical" = is.Categorical,
"Array" = is.Array,
"Categorical Array" = is.CategoricalArray,
"Multiple Response" = is.MultipleResponse,
halt("bad type check ", type)
)
})
if (is.variable(x) && !any(vapply(type_check, function(func) func(x), logical(1)))) {
type_str <- paste0("'", types, "'", collapse = ", ")
halt("variable must be of type ", type_str, " for ", caller, "().")
}
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.