| 1 |
#' Checks `varname` argument and convert to call |
|
| 2 |
#' |
|
| 3 |
#' Checks `varname` type and parse if it's a `character`. |
|
| 4 |
#' |
|
| 5 |
#' @param varname (`name` or `call` or `character(1)`) |
|
| 6 |
#' name of the variable |
|
| 7 |
#' |
|
| 8 |
#' @returns the parsed `varname`. |
|
| 9 |
#' |
|
| 10 |
#' @keywords internal |
|
| 11 |
#' |
|
| 12 |
call_check_parse_varname <- function(varname) {
|
|
| 13 | 10x |
checkmate::assert( |
| 14 | 10x |
checkmate::check_string(varname), |
| 15 | 10x |
checkmate::check_class(varname, "call"), |
| 16 | 10x |
checkmate::check_class(varname, "name") |
| 17 |
) |
|
| 18 | 10x |
if (is.character(varname)) {
|
| 19 | 9x |
parsed <- parse(text = varname, keep.source = FALSE) |
| 20 | 9x |
if (length(parsed) == 1) {
|
| 21 | 9x |
varname <- as.name(varname) |
| 22 |
} else {
|
|
| 23 | ! |
stop( |
| 24 | ! |
sprintf( |
| 25 | ! |
"Problem with parsing '%s'. Not able to process multiple calls", |
| 26 | ! |
varname |
| 27 |
) |
|
| 28 |
) |
|
| 29 |
} |
|
| 30 |
} |
|
| 31 | 10x |
varname |
| 32 |
} |
|
| 33 | ||
| 34 |
#' Choices condition call |
|
| 35 |
#' |
|
| 36 |
#' Compose choices condition call from inputs. |
|
| 37 |
#' |
|
| 38 |
#' @details |
|
| 39 |
#' `choices` can be vector of any type but for some output might be converted: |
|
| 40 |
#' * `factor` call is composed on choices converted to `character`; |
|
| 41 |
#' * `Date` call is composed on choices converted to `character` using |
|
| 42 |
#' `format(choices)`; |
|
| 43 |
#' * `POSIXct`, `POSIXlt` call is composed on choices converted to `character` using |
|
| 44 |
#' `format(choices)`. |
|
| 45 |
#' |
|
| 46 |
#' One has to be careful here as formatted date-time variable might loose |
|
| 47 |
#' some precision (see `format` argument in [format.POSIXlt()] and output call |
|
| 48 |
#' could be insufficient for exact comparison. In this case one should specify |
|
| 49 |
#' `varname = trunc(<varname>)` and possibly convert `choices` to `character`). |
|
| 50 |
#' |
|
| 51 |
#' @param varname (`name` or `call` or `character(1)`) |
|
| 52 |
#' name of the variable. |
|
| 53 |
#' @param choices (`vector`) |
|
| 54 |
#' `varname` values to match using the `==` (single value) or `%in%` (vector) |
|
| 55 |
#' condition. |
|
| 56 |
#' |
|
| 57 |
#' @return `call`. |
|
| 58 |
#' |
|
| 59 |
#' @keywords internal |
|
| 60 |
#' |
|
| 61 |
call_condition_choice <- function(varname, choices) {
|
|
| 62 | 6x |
varname <- call_check_parse_varname(varname) |
| 63 | ||
| 64 | 6x |
if (is.factor(choices)) {
|
| 65 | ! |
choices <- as.character(choices) |
| 66 | 6x |
} else if (inherits(choices, "Date")) {
|
| 67 | 1x |
choices <- format(choices) |
| 68 | 5x |
} else if (inherits(choices, c("POSIXct", "POSIXlt"))) {
|
| 69 | 1x |
choices <- format(choices) |
| 70 |
} |
|
| 71 | ||
| 72 | ||
| 73 | 6x |
if (length(choices) == 1) {
|
| 74 | 2x |
call("==", varname, unname(choices))
|
| 75 |
} else {
|
|
| 76 | 4x |
c_call <- do.call( |
| 77 | 4x |
"call", |
| 78 | 4x |
append(list("c"), unname(choices))
|
| 79 |
) |
|
| 80 |
# c_call needed because it needs to be vector call |
|
| 81 |
# instead of vector. SummarizedExperiment.subset |
|
| 82 |
# handles only vector calls |
|
| 83 | 4x |
call("%in%", as.name(varname), c_call)
|
| 84 |
} |
|
| 85 |
} |
|
| 86 | ||
| 87 |
#' `numeric` range condition call |
|
| 88 |
#' |
|
| 89 |
#' Compose `numeric` range condition call from inputs. |
|
| 90 |
#' |
|
| 91 |
#' @param varname (`name` or `character(1)`) |
|
| 92 |
#' name of the variable. |
|
| 93 |
#' |
|
| 94 |
#' @param range (`numeric(2)`) |
|
| 95 |
#' range of the variable. |
|
| 96 |
#' |
|
| 97 |
#' @return `call`. |
|
| 98 |
#' |
|
| 99 |
#' @keywords internal |
|
| 100 |
#' |
|
| 101 |
call_condition_range <- function(varname, range) {
|
|
| 102 | 1x |
checkmate::assert_numeric(range, len = 2, sorted = TRUE) |
| 103 | ||
| 104 | 1x |
varname <- call_check_parse_varname(varname) |
| 105 | 1x |
call( |
| 106 |
"&", |
|
| 107 | 1x |
call(">=", varname, unname(range[1])),
|
| 108 | 1x |
call("<=", varname, unname(range[2]))
|
| 109 |
) |
|
| 110 |
} |
|
| 111 | ||
| 112 |
#' `logical` variable condition call |
|
| 113 |
#' |
|
| 114 |
#' Compose `logical` variable condition call from inputs. |
|
| 115 |
#' |
|
| 116 |
#' @param varname (`name` or `character(1)`) |
|
| 117 |
#' name of the variable |
|
| 118 |
#' |
|
| 119 |
#' @param choice (`logical(1)`) |
|
| 120 |
#' chosen value |
|
| 121 |
#' |
|
| 122 |
#' @return `call`. |
|
| 123 |
#' |
|
| 124 |
#' @keywords internal |
|
| 125 |
#' |
|
| 126 |
call_condition_logical <- function(varname, choice) {
|
|
| 127 | 1x |
checkmate::assert_flag(choice) |
| 128 | 1x |
varname <- call_check_parse_varname(varname) |
| 129 | ||
| 130 | 1x |
if (choice) {
|
| 131 | 1x |
varname |
| 132 | ! |
} else if (!choice) {
|
| 133 | ! |
call("!", varname)
|
| 134 |
} else {
|
|
| 135 | ! |
stop( |
| 136 | ! |
"Unknown filter state", toString(choice), |
| 137 | ! |
" for logical var ", as.character(varname) |
| 138 |
) |
|
| 139 |
} |
|
| 140 |
} |
|
| 141 | ||
| 142 |
#' `POSIXct` range condition call |
|
| 143 |
#' |
|
| 144 |
#' Compose `POSIXct` range condition call from inputs. |
|
| 145 |
#' |
|
| 146 |
#' @param varname (`name` or `character(1)`) name of the variable. |
|
| 147 |
#' @param range (`POSIXct`) range of the variable. |
|
| 148 |
#' Be aware that output uses truncated range format `"%Y-%m-%d %H:%M:%S"`, |
|
| 149 |
#' which means that some precision might be lost. |
|
| 150 |
#' @param timezone (`character(1)`) specifies the time zone to be used for the conversion. |
|
| 151 |
#' By default `Sys.timezone()` is used. |
|
| 152 |
#' |
|
| 153 |
#' @return `call`. |
|
| 154 |
#' |
|
| 155 |
#' @keywords internal |
|
| 156 |
#' |
|
| 157 |
call_condition_range_posixct <- function(varname, range, timezone = Sys.timezone()) {
|
|
| 158 | 1x |
checkmate::assert_posixct(range, len = 2, sorted = TRUE) |
| 159 | 1x |
checkmate::assert_string(timezone) |
| 160 | 1x |
varname <- call_check_parse_varname(varname) |
| 161 | ||
| 162 | 1x |
range[1] <- trunc(range[1], units = c("secs"))
|
| 163 | 1x |
range[2] <- trunc(range[2] + 1, units = c("secs"))
|
| 164 | ||
| 165 | 1x |
range <- format.POSIXct( |
| 166 | 1x |
unname(range), |
| 167 | 1x |
format = "%Y-%m-%d %H:%M:%S", |
| 168 | 1x |
tz = timezone |
| 169 |
) |
|
| 170 | ||
| 171 | 1x |
call( |
| 172 |
"&", |
|
| 173 | 1x |
call(">=", varname, call("as.POSIXct", range[1], tz = timezone)),
|
| 174 | 1x |
call("<", varname, call("as.POSIXct", range[2], tz = timezone))
|
| 175 |
) |
|
| 176 |
} |
|
| 177 | ||
| 178 |
#' `Date` range condition call |
|
| 179 |
#' |
|
| 180 |
#' Compose `Date` range condition call from inputs. |
|
| 181 |
#' |
|
| 182 |
#' @param varname (`name` or `character(1)`) name of the variable. |
|
| 183 |
#' @param range (`Date`) range of the variable. |
|
| 184 |
#' |
|
| 185 |
#' @return `call`. |
|
| 186 |
#' |
|
| 187 |
#' @keywords internal |
|
| 188 |
#' |
|
| 189 |
call_condition_range_date <- function(varname, range) {
|
|
| 190 | 1x |
checkmate::assert_date(range, len = 2) |
| 191 | 1x |
checkmate::assert_true(range[2] >= range[1]) |
| 192 | 1x |
varname <- call_check_parse_varname(varname) |
| 193 | ||
| 194 | 1x |
call( |
| 195 |
"&", |
|
| 196 | 1x |
call(">=", varname, call("as.Date", as.character(range[1]))),
|
| 197 | 1x |
call("<=", varname, call("as.Date", as.character(range[2])))
|
| 198 |
) |
|
| 199 |
} |
|
| 200 | ||
| 201 |
#' Combine calls by operator |
|
| 202 |
#' |
|
| 203 |
#' Combine list of calls by specific operator. |
|
| 204 |
#' |
|
| 205 |
#' @param operator (`character(1)` or `name`) name / symbol of the operator. |
|
| 206 |
#' @param calls (`list` of calls) list containing calls to be combined by `operator`. |
|
| 207 |
#' |
|
| 208 |
#' @return A combined `call`. |
|
| 209 |
#' |
|
| 210 |
#' @keywords internal |
|
| 211 |
#' |
|
| 212 |
calls_combine_by <- function(operator, calls) {
|
|
| 213 | 30x |
checkmate::assert_string(operator) |
| 214 | 30x |
stopifnot( |
| 215 | 30x |
all( |
| 216 | 30x |
vapply( |
| 217 | 30x |
X = calls, |
| 218 | 30x |
FUN.VALUE = logical(1), |
| 219 | 30x |
FUN = function(x) is.language(x) || is.logical(x) |
| 220 |
) |
|
| 221 |
) |
|
| 222 |
) |
|
| 223 | 30x |
Reduce( |
| 224 | 30x |
x = calls, |
| 225 | 30x |
f = function(x, y) call(operator, x, y) |
| 226 |
) |
|
| 227 |
} |
|
| 228 | ||
| 229 |
#' `dplyr::select` call |
|
| 230 |
#' |
|
| 231 |
#' Create `dplyr::select` call from `dataname` and `variables` |
|
| 232 |
#' @param dataname (`character(1)`) name of the dataset |
|
| 233 |
#' @param variables (`list` of `character`) variables to select. If list is named then |
|
| 234 |
#' variables will be renamed if their name is different than its value |
|
| 235 |
#' (this produces a call `select(..., <name> = <value>)`). |
|
| 236 |
#' @keywords internal |
|
| 237 |
.call_dplyr_select <- function(dataname, variables) {
|
|
| 238 | 31x |
as.call( |
| 239 | 31x |
c( |
| 240 | 31x |
list( |
| 241 | 31x |
str2lang("dplyr::select"),
|
| 242 | 31x |
str2lang(dataname) |
| 243 |
), |
|
| 244 | 31x |
lapply(unname(variables), as.name) |
| 245 |
) |
|
| 246 |
) |
|
| 247 |
} |
|
| 248 | ||
| 249 |
#' `dplyr::filter` call |
|
| 250 |
#' |
|
| 251 |
#' Create a `dplyr::filter` call |
|
| 252 |
#' @param x (`list`) containing `variables` and `values` |
|
| 253 |
#' @keywords internal |
|
| 254 |
.call_dplyr_filter <- function(x) {
|
|
| 255 | 10x |
if (any(!names(x) %in% c("variables", "values"))) {
|
| 256 | 10x |
predicates <- lapply(unname(x), .predicates) |
| 257 | 10x |
predicates <- Filter(length, predicates) |
| 258 |
} else {
|
|
| 259 | ! |
predicates <- .predicates(x) |
| 260 |
} |
|
| 261 | ||
| 262 | 10x |
as.call(c(list(str2lang("dplyr::filter")), predicates))
|
| 263 |
} |
|
| 264 | ||
| 265 |
.predicates <- function(x) {
|
|
| 266 | 10x |
if (is.numeric(x$values) && .is_ranged(x$values)) {
|
| 267 | 1x |
call_condition_range(varname = x$variables, range = x$values) |
| 268 | 9x |
} else if (inherits(x$values, "Date") && .is_ranged(x$values)) {
|
| 269 | 1x |
call_condition_range_date(varname = x$variables, range = x$values) |
| 270 | 8x |
} else if (inherits(x$values, "POSIXct") && .is_ranged(x$values)) {
|
| 271 | 1x |
call_condition_range_posixct(varname = x$variables, range = x$values) |
| 272 | 7x |
} else if (is.logical(x$values)) {
|
| 273 | 1x |
call_condition_logical(varname = x$variables, choice = x$values) |
| 274 |
} else if ( |
|
| 275 | 6x |
checkmate::test_list(x$operators, types = "operator", min.len = 1) && |
| 276 | 6x |
.is_operator_selected(x$operators, x$variables) |
| 277 |
) {
|
|
| 278 | ! |
if (length(x$operators) > 1) {
|
| 279 | ! |
showNotification("Only a single complex operator can be used at a time when filtering by values.", type = "error")
|
| 280 | ! |
return(NULL) |
| 281 |
} |
|
| 282 | ! |
if (length(x$variables) > 1) {
|
| 283 | ! |
showNotification( |
| 284 | ! |
"A complex operator filter cannot be combined with other variables. Filtering by the first variable only.", |
| 285 | ! |
type = "error" |
| 286 |
) |
|
| 287 | ! |
return(NULL) |
| 288 |
} |
|
| 289 | ! |
call_condition_operators(x$operators[[1]], choices = x$values) |
| 290 | 6x |
} else if (length(x$variables)) {
|
| 291 | 6x |
if (is.factor(x$values)) {
|
| 292 | ! |
x$values <- as.numeric(levels(x$values))[x$values] |
| 293 |
} |
|
| 294 | ||
| 295 | 6x |
variable <- if (length(x$variables) > 1) {
|
| 296 | 1x |
as.call( |
| 297 | 1x |
list( |
| 298 | 1x |
quote(apply), |
| 299 | 1x |
as.call( |
| 300 | 1x |
c( |
| 301 | 1x |
list(quote(data.frame)), |
| 302 | 1x |
unname(lapply(x$variables, as.name)) |
| 303 |
) |
|
| 304 |
), |
|
| 305 | 1x |
1, |
| 306 | 1x |
quote(toString) |
| 307 |
) |
|
| 308 |
) |
|
| 309 |
} else {
|
|
| 310 | 5x |
x$variables |
| 311 |
} |
|
| 312 | 6x |
call_condition_choice(varname = variable, choices = x$values) |
| 313 |
} |
|
| 314 |
} |
|
| 315 | ||
| 316 |
.call_mutate_operators <- function(variables, operators_ix, dataname, operators) {
|
|
| 317 | ! |
operators <- rlang::set_names(operators, vapply(operators, attr, which = "var_name", FUN.VALUE = character(1))) |
| 318 | ! |
select_new <- variables[operators_ix] |
| 319 | ! |
select_tmp <- unname(unlist(operators[select_new])) |
| 320 | ! |
select_call <- .call_dplyr_select( |
| 321 | ! |
dataname = dataname, |
| 322 | ! |
variables = unique(c(variables[!operators_ix], select_tmp)) |
| 323 |
) |
|
| 324 | ||
| 325 | ! |
select_call |
| 326 |
} |
| 1 |
#' @export |
|
| 2 |
print.pick <- function(x, ...) {
|
|
| 3 | 4x |
cat(format(x, indent = 0)) |
| 4 | 4x |
invisible(x) |
| 5 |
} |
|
| 6 | ||
| 7 |
#' @export |
|
| 8 |
print.picks <- function(x, ...) {
|
|
| 9 | 2x |
cat(format(x, indent = 0)) |
| 10 | 2x |
invisible(x) |
| 11 |
} |
|
| 12 | ||
| 13 |
#' @export |
|
| 14 |
format.picks <- function(x, indent = 0, ...) {
|
|
| 15 | 3x |
out <- .indent(sprintf("%s\n", .bold("<picks>")), indent)
|
| 16 | 3x |
for (i in seq_along(x)) {
|
| 17 | 5x |
element_name <- names(x)[i] |
| 18 | 5x |
out <- paste0(out, .indent(sprintf(" %s:\n", .bold(sprintf("<%s>", element_name))), indent))
|
| 19 | 5x |
out <- paste0(out, .format_pick_content(x[[i]], indent + 4)) |
| 20 | 5x |
out <- paste0(out, .format_pick_attributes(x[[i]], indent + 4)) |
| 21 |
} |
|
| 22 | 3x |
out |
| 23 |
} |
|
| 24 | ||
| 25 |
#' @export |
|
| 26 |
format.pick <- function(x, indent = 0, ...) {
|
|
| 27 | 9x |
element_class <- setdiff(class(x), "pick")[1] |
| 28 | 9x |
out <- .indent(sprintf("%s\n", .bold(sprintf("<%s>", element_class))), indent)
|
| 29 | 9x |
out <- paste0(out, .format_pick_content(x, indent + 2)) |
| 30 | 9x |
out <- paste0(out, .format_pick_attributes(x, indent + 2)) |
| 31 | 9x |
out |
| 32 |
} |
|
| 33 | ||
| 34 |
.format_pick_content <- function(x, indent = 0) {
|
|
| 35 | 14x |
out <- .indent(sprintf("%s %s\n", "choices:", .format_pick_value(x$choices)), indent)
|
| 36 | 14x |
out <- paste0(out, .indent(sprintf("%s %s\n", "selected:", .format_pick_value(x$selected)), indent))
|
| 37 | 14x |
out |
| 38 |
} |
|
| 39 | ||
| 40 |
.format_pick_attributes <- function(x, indent = 0) {
|
|
| 41 | 14x |
attrs <- attributes(x) |
| 42 | 14x |
attrs_to_show <- attrs[!names(attrs) %in% c("class", "names")]
|
| 43 | 14x |
if (length(attrs_to_show) > 0) {
|
| 44 | 14x |
attrs_str <- vapply(names(attrs_to_show), function(name) {
|
| 45 | 45x |
value <- attrs_to_show[[name]] |
| 46 | 45x |
sprintf("%s=%s", name, paste(value, collapse = ","))
|
| 47 | 14x |
}, character(1)) |
| 48 | 14x |
paste0(.indent(.italic(paste(attrs_str, collapse = ", ")), indent), "\n") |
| 49 |
} else {
|
|
| 50 |
"" |
|
| 51 |
} |
|
| 52 |
} |
|
| 53 | ||
| 54 |
.format_pick_value <- function(x) {
|
|
| 55 | 28x |
if (rlang::is_quosure(x) || is.function(x)) {
|
| 56 | 4x |
rlang::as_label(x) |
| 57 | 24x |
} else if (length(x) == 0) {
|
| 58 |
"~" |
|
| 59 |
} else {
|
|
| 60 | 24x |
paste(x, collapse = ", ") |
| 61 |
} |
|
| 62 |
} |
|
| 63 | ||
| 64 |
.indent <- function(x, n) {
|
|
| 65 | 59x |
paste(formatC("", width = n), x)
|
| 66 |
} |
|
| 67 | ||
| 68 |
.bold <- function(x) {
|
|
| 69 | 17x |
sprintf("\033[1m%s\033[0m", x)
|
| 70 |
} |
|
| 71 | ||
| 72 |
.italic <- function(x) {
|
|
| 73 | 14x |
sprintf("\033[3m%s\033[0m", x)
|
| 74 |
} |
| 1 |
#' Interactive picks |
|
| 2 |
#' |
|
| 3 |
#' @description |
|
| 4 |
#' |
|
| 5 |
#' Creates UI and server components for interactive [picks()] in Shiny modules. The module is based on |
|
| 6 |
#' configuration provided via [picks()] and its responsibility is to determine relevant input |
|
| 7 |
#' values |
|
| 8 |
#' |
|
| 9 |
#' |
|
| 10 |
#' The module supports both single and combined `picks`: |
|
| 11 |
#' - Single `picks` objects for a single input |
|
| 12 |
#' - Named lists of `picks` objects for multiple inputs |
|
| 13 |
#' |
|
| 14 |
#' @param id (`character(1)`) Shiny module ID |
|
| 15 |
#' @param picks (`picks` or `list`) object created by `picks()` or a named list of such objects |
|
| 16 |
#' @param container (`character(1)` or `function`) UI container type. Can be one of `htmltools::tags` |
|
| 17 |
#' functions. By default, elements are wrapped in a package-specific drop-down. |
|
| 18 |
#' @param data (`reactive`) Reactive expression returning the data object to be used for populating choices |
|
| 19 |
#' |
|
| 20 |
#' @return |
|
| 21 |
#' - `picks_ui()`: UI elements for the input controls |
|
| 22 |
#' - `picks_srv()`: Server-side reactive logic returning the processed data |
|
| 23 |
#' |
|
| 24 |
#' @details |
|
| 25 |
#' The module uses S3 method dispatch to handle different ways to provide `picks`: |
|
| 26 |
#' - `.picks` methods handle single `picks`` object |
|
| 27 |
#' - `.list` methods handle multiple `picks` objects |
|
| 28 |
#' |
|
| 29 |
#' The UI component (`picks_ui`) creates the visual elements, while the |
|
| 30 |
#' server component (`picks_srv`) manages the reactive logic, |
|
| 31 |
#' |
|
| 32 |
#' @seealso [picks()] for creating `picks`` objects |
|
| 33 |
#' |
|
| 34 |
#' @name picks_module |
|
| 35 |
NULL |
|
| 36 | ||
| 37 |
#' @rdname picks_module |
|
| 38 |
#' @export |
|
| 39 |
picks_ui <- function(id, picks, container = "badge_dropdown") {
|
|
| 40 | 5x |
checkmate::assert_string(id) |
| 41 | 5x |
UseMethod("picks_ui", picks)
|
| 42 |
} |
|
| 43 | ||
| 44 |
#' @rdname picks_module |
|
| 45 |
#' @export |
|
| 46 |
picks_ui.list <- function(id, picks, container) {
|
|
| 47 | ! |
checkmate::assert_list(picks, names = "unique") |
| 48 | ! |
ns <- shiny::NS(id) |
| 49 | ! |
sapply( |
| 50 | ! |
Filter(length, names(picks)), |
| 51 | ! |
USE.NAMES = TRUE, |
| 52 | ! |
function(name) picks_ui(ns(name), picks[[name]], container = container) |
| 53 |
) |
|
| 54 |
} |
|
| 55 | ||
| 56 |
#' @rdname picks_module |
|
| 57 |
#' @export |
|
| 58 |
picks_ui.picks <- function(id, picks, container) {
|
|
| 59 | 5x |
ns <- shiny::NS(id) |
| 60 | 5x |
badge_label <- shiny::uiOutput(ns("summary"), container = htmltools::tags$span)
|
| 61 | 5x |
content <- lapply(picks, function(x) .pick_ui(id = ns(methods::is(x)))) |
| 62 | 5x |
htmltools::tags$div( |
| 63 | 5x |
if (missing(container)) {
|
| 64 | 4x |
if (all(vapply(picks, is_pick_fixed, logical(1)))) {
|
| 65 | 1x |
fixed_picks(id = ns("inputs"), badge_label)
|
| 66 |
} else {
|
|
| 67 | 3x |
badge_dropdown(id = ns("inputs"), label = badge_label, htmltools::tagList(content))
|
| 68 |
} |
|
| 69 |
} else {
|
|
| 70 | 1x |
if (!any(sapply(htmltools::tags, identical, container))) {
|
| 71 | ! |
stop("Container should be one of `htmltools::tags`")
|
| 72 |
} |
|
| 73 | 1x |
container(content) |
| 74 |
} |
|
| 75 |
) |
|
| 76 |
} |
|
| 77 | ||
| 78 |
#' @rdname picks_module |
|
| 79 |
#' @export |
|
| 80 |
picks_srv <- function(id = "", picks, data) {
|
|
| 81 | 72x |
checkmate::assert_string(id) |
| 82 | 72x |
checkmate::assert_class(data, "reactive") |
| 83 | 69x |
UseMethod("picks_srv", picks)
|
| 84 |
} |
|
| 85 | ||
| 86 |
#' @rdname picks_module |
|
| 87 |
#' @export |
|
| 88 |
picks_srv.list <- function(id, picks, data) {
|
|
| 89 | 12x |
checkmate::assert_named(picks, type = "unique") |
| 90 | 10x |
sapply( |
| 91 | 10x |
names(Filter(length, picks)), |
| 92 | 10x |
USE.NAMES = TRUE, |
| 93 | 10x |
function(name) picks_srv(name, picks[[name]], data) |
| 94 |
) |
|
| 95 |
} |
|
| 96 | ||
| 97 |
#' @rdname picks_module |
|
| 98 |
#' @export |
|
| 99 |
picks_srv.picks <- function(id, picks, data) {
|
|
| 100 | 55x |
shiny::moduleServer(id, function(input, output, session) {
|
| 101 | 55x |
picks_resolved <- shiny::reactiveVal( |
| 102 | 55x |
restoreValue( |
| 103 | 55x |
session$ns("picks"),
|
| 104 | 55x |
resolver(picks, shiny::isolate(data())) |
| 105 |
) |
|
| 106 |
) |
|
| 107 | ||
| 108 | 52x |
session$onBookmark(function(state) {
|
| 109 | ! |
logger::log_debug("picks_srv@onBookmark: storing current picks")
|
| 110 | ! |
state$values$picks <- picks_resolved() |
| 111 |
}) |
|
| 112 | ||
| 113 | 52x |
exportTestValues( |
| 114 | 52x |
open_id_fmt = session$ns("%s-selected_open"),
|
| 115 | 52x |
selected_id_fmt = session$ns("%s-selected"),
|
| 116 | 52x |
range_id_fmt = session$ns("%s-range"),
|
| 117 | 52x |
picks_resolved = picks_resolved() |
| 118 |
) |
|
| 119 | ||
| 120 | 52x |
badge <- shiny::reactive({
|
| 121 | 40x |
lapply( |
| 122 | 40x |
picks_resolved(), |
| 123 | 40x |
function(x) {
|
| 124 | 70x |
label <- if (inherits(x, "values")) {
|
| 125 | 6x |
if (!setequal(x$choices, x$selected)) {
|
| 126 | 4x |
bsicons::bs_icon("funnel")
|
| 127 |
} |
|
| 128 | 70x |
} else if (length(x$selected)) {
|
| 129 | 62x |
toString(x$selected) |
| 130 |
} else {
|
|
| 131 |
"~" |
|
| 132 |
} |
|
| 133 | 70x |
label |
| 134 |
} |
|
| 135 |
) |
|
| 136 |
}) |
|
| 137 | ||
| 138 | 52x |
output$summary <- shiny::renderUI({
|
| 139 | 40x |
badge_value <- badge() |
| 140 | 40x |
hover_text <- paste( |
| 141 | 40x |
vapply( |
| 142 | 40x |
names(badge_value)[names(badge_value) %in% c("datasets", "variables")],
|
| 143 | 40x |
function(x) sprintf("%s: %s", x, paste(badge_value[[x]], collapse = ", ")),
|
| 144 | 40x |
FUN.VALUE = character(1) |
| 145 |
), |
|
| 146 | 40x |
collapse = "\n" |
| 147 |
) |
|
| 148 | 40x |
htmltools::tags$span(title = hover_text, tagList(badge_value)) |
| 149 |
}) |
|
| 150 | ||
| 151 | 52x |
Reduce( |
| 152 | 52x |
function(this_data, slot_name) { # this_data is a (drilled-down) data for current pick
|
| 153 | 100x |
choices <- reactiveVal(isolate(picks_resolved())[[slot_name]]$choices) |
| 154 | 100x |
selected <- reactiveVal(isolate(picks_resolved())[[slot_name]]$selected) |
| 155 | 100x |
all_choices <- shiny::reactive(determine(x = picks[[slot_name]], data = this_data())$x$choices) |
| 156 | ||
| 157 | 100x |
observeEvent(all_choices(), ignoreInit = TRUE, {
|
| 158 | 13x |
current_selected <- picks_resolved()[[slot_name]]$selected |
| 159 | 13x |
new_selected <- if (is.numeric(current_selected) && is.numeric(all_choices())) {
|
| 160 | 1x |
c( |
| 161 | 1x |
max(current_selected[1], all_choices()[1], na.rm = TRUE), |
| 162 | 1x |
min(current_selected[2], all_choices()[2], na.rm = TRUE) |
| 163 |
) |
|
| 164 |
} else {
|
|
| 165 | 12x |
intersect(current_selected, all_choices()) |
| 166 |
} |
|
| 167 | ||
| 168 | 13x |
.update_rv( |
| 169 | 13x |
selected, new_selected, |
| 170 | 13x |
sprintf("picks_srv@1 %s$%s$selected is outside of the possible choices", id, slot_name)
|
| 171 |
) |
|
| 172 | 13x |
.update_rv( |
| 173 | 13x |
choices, all_choices(), |
| 174 | 13x |
sprintf("picks_srv@1 %s$%s$choices is outside of the possible choices", id, slot_name)
|
| 175 |
) |
|
| 176 |
}) |
|
| 177 | ||
| 178 | 100x |
observeEvent(picks_resolved()[[slot_name]], ignoreInit = TRUE, ignoreNULL = FALSE, {
|
| 179 | 21x |
.update_rv(choices, picks_resolved()[[slot_name]]$choices, log = "picks_srv@1 update input choices") |
| 180 | 21x |
.update_rv(selected, picks_resolved()[[slot_name]]$selected, log = "picks_srv@1 update input selected") |
| 181 |
}) |
|
| 182 | ||
| 183 | 100x |
args <- attributes(picks[[slot_name]]) |
| 184 | 100x |
args <- args[!names(args) %in% c("names", "class")]
|
| 185 | 100x |
.pick_srv( |
| 186 | 100x |
id = slot_name, |
| 187 | 100x |
pick_type = slot_name, |
| 188 | 100x |
choices = choices, |
| 189 | 100x |
selected = selected, |
| 190 | 100x |
args = args[!names(args) %in% c("names", "class")],
|
| 191 | 100x |
data = this_data |
| 192 |
) |
|
| 193 | ||
| 194 |
# this works as follows: |
|
| 195 |
# Each observer is observes input$selected of i-th element of picks ($datasets, $variables, ...) |
|
| 196 | 100x |
shiny::observeEvent( |
| 197 | 100x |
selected(), |
| 198 | 100x |
ignoreInit = TRUE, # because picks_resolved is already resolved and `selected()` is being set |
| 199 | 100x |
ignoreNULL = FALSE, # because input$selected can be empty |
| 200 |
{
|
|
| 201 | 16x |
.resolve( |
| 202 | 16x |
selected(), |
| 203 | 16x |
slot_name = slot_name, |
| 204 | 16x |
picks_resolved = picks_resolved, |
| 205 | 16x |
old_picks = picks, |
| 206 | 16x |
data = data() # data() object needed as we resolve the WHOLE picks INSTEAD OF one picks element. |
| 207 |
) |
|
| 208 |
} |
|
| 209 |
) |
|
| 210 | ||
| 211 | 100x |
shiny::reactive(.extract(x = picks_resolved()[[slot_name]], this_data())) |
| 212 |
}, |
|
| 213 | 52x |
x = names(picks), |
| 214 | 52x |
init = data |
| 215 |
) |
|
| 216 | ||
| 217 | 52x |
picks_resolved |
| 218 |
}) |
|
| 219 |
} |
|
| 220 | ||
| 221 |
.pick_ui <- function(id) {
|
|
| 222 | 11x |
ns <- shiny::NS(id) |
| 223 | 11x |
uiOutput(ns("selected_container"))
|
| 224 |
} |
|
| 225 | ||
| 226 |
.pick_srv <- function(id, pick_type, choices, selected, data, args) {
|
|
| 227 | 100x |
checkmate::assert_string(id) |
| 228 | 100x |
checkmate::assert_class(choices, "reactiveVal") |
| 229 | 100x |
checkmate::assert_class(selected, "reactiveVal") |
| 230 | 100x |
checkmate::assert_list(args) |
| 231 | ||
| 232 | 100x |
shiny::moduleServer(id, function(input, output, session) {
|
| 233 | 100x |
choices_opt_content <- shiny::reactive({
|
| 234 | 38x |
if (pick_type != "values") {
|
| 235 | 36x |
sapply( |
| 236 | 36x |
choices(), |
| 237 | 36x |
function(choice) {
|
| 238 | 121x |
icon <- toString(icon(.picker_icon(data()[[choice]]), lib = "font-awesome")) |
| 239 | 121x |
label <- attr(data()[[choice]], "label") |
| 240 | 121x |
paste( |
| 241 | 121x |
icon, |
| 242 | 121x |
choice, |
| 243 | 121x |
if (!is.null(label) && !is.na(label) && !identical(label, choice)) {
|
| 244 | 4x |
toString(tags$small(label, class = "text-muted")) |
| 245 |
} |
|
| 246 |
) |
|
| 247 |
} |
|
| 248 |
) |
|
| 249 |
} |
|
| 250 |
}) |
|
| 251 | ||
| 252 | 100x |
output$selected_container <- renderUI({
|
| 253 | 54x |
logger::log_debug(".pick_srv@1 rerender {pick_type} input")
|
| 254 | 54x |
.validate_is_eager(choices()) |
| 255 | 54x |
.validate_is_eager(selected()) |
| 256 | 54x |
if (!length(choices()) || isTRUE(args$fixed)) {
|
| 257 | 12x |
NULL |
| 258 | 42x |
} else if (.is_ranged(choices()) && inherits(choices(), "Date")) {
|
| 259 | 1x |
.pick_ui_date( |
| 260 | 1x |
session$ns("range"),
|
| 261 | 1x |
label = sprintf("Select %s range:", pick_type),
|
| 262 | 1x |
choices = choices(), |
| 263 | 1x |
selected = selected(), |
| 264 | 1x |
args = args |
| 265 |
) |
|
| 266 | 41x |
} else if (.is_ranged(choices()) && inherits(choices(), "POSIXct")) {
|
| 267 | 1x |
.pick_ui_posixct( |
| 268 | 1x |
session$ns("range"),
|
| 269 | 1x |
label = sprintf("Select %s range:", pick_type),
|
| 270 | 1x |
choices = choices(), |
| 271 | 1x |
selected = selected(), |
| 272 | 1x |
args = args |
| 273 |
) |
|
| 274 | 40x |
} else if (.is_ranged(choices())) {
|
| 275 | 1x |
.pick_ui_numeric( |
| 276 | 1x |
session$ns("range"),
|
| 277 | 1x |
label = sprintf("Select %s range:", pick_type),
|
| 278 | 1x |
choices = choices(), |
| 279 | 1x |
selected = selected(), |
| 280 | 1x |
args = args |
| 281 |
) |
|
| 282 |
} else {
|
|
| 283 | 39x |
.pick_ui_categorical( |
| 284 | 39x |
session$ns("selected"),
|
| 285 | 39x |
label = sprintf("Select %s:", pick_type),
|
| 286 | 39x |
choices = choices(), |
| 287 | 39x |
selected = selected(), |
| 288 | 39x |
multiple = args$multiple, |
| 289 | 39x |
choicesOpt = list(content = isolate(choices_opt_content())), |
| 290 | 39x |
args = args[!names(args) %in% c("multiple")]
|
| 291 |
) |
|
| 292 |
} |
|
| 293 | 100x |
}) |> bindEvent(choices()) # never change on selected() |
| 294 | ||
| 295 |
# for numeric / date / posixct range |
|
| 296 | 100x |
range_debounced <- shiny::reactive(input$range) |> debounce(1000) |
| 297 | 100x |
shiny::observeEvent(range_debounced(), {
|
| 298 | ! |
new_value <- input$range |
| 299 | ! |
if (inherits(choices(), "POSIXct")) {
|
| 300 | ! |
new_value <- as.POSIXct(new_value) |
| 301 |
} |
|
| 302 | ! |
.update_rv( |
| 303 | ! |
selected, |
| 304 | ! |
.as_ranged(new_value), |
| 305 | ! |
log = ".pick_srv@2 update selected after input changed" |
| 306 |
) |
|
| 307 |
}) |
|
| 308 | ||
| 309 | ||
| 310 |
# for non-numeric |
|
| 311 | 100x |
shiny::observeEvent(input$selected_open, {
|
| 312 |
# Update when closes and the input is different from what it was selected |
|
| 313 | 11x |
if (!isTRUE(input$selected_open) && !isTRUE(all.equal(input$selected, sort(selected())))) {
|
| 314 |
# ↓ pickerInput returns "" when nothing selected. This can cause failure during col select (x[,""]) |
|
| 315 | 9x |
new_selected <- if (length(input$selected) && !identical(input$selected, "")) as.vector(input$selected) |
| 316 | 9x |
if (args$ordered) {
|
| 317 | 3x |
new_selected <- c(intersect(selected(), new_selected), setdiff(new_selected, selected())) |
| 318 |
} |
|
| 319 | 9x |
.update_rv(selected, new_selected, log = ".pick_srv@1 update selected after input changed") |
| 320 |
} |
|
| 321 |
}) |
|
| 322 | 100x |
selected |
| 323 |
}) |
|
| 324 |
} |
|
| 325 | ||
| 326 |
.pick_ui_date <- function(id, label, choices, selected, args) {
|
|
| 327 | 1x |
shiny::dateRangeInput( |
| 328 | 1x |
inputId = id, |
| 329 | 1x |
label = label, |
| 330 | 1x |
min = choices[1], |
| 331 | 1x |
max = utils::tail(choices, 1), |
| 332 | 1x |
start = selected[1], |
| 333 | 1x |
end = utils::tail(selected, 1) |
| 334 |
) |
|
| 335 |
} |
|
| 336 | ||
| 337 |
.pick_ui_posixct <- function(id, label, choices, selected, args) {
|
|
| 338 | 1x |
shiny::dateRangeInput( |
| 339 | 1x |
inputId = id, |
| 340 | 1x |
label = label, |
| 341 | 1x |
min = as.Date(choices[1]), |
| 342 | 1x |
max = as.Date(utils::tail(choices, 1)), |
| 343 | 1x |
start = as.Date(selected[1]), |
| 344 | 1x |
end = as.Date(utils::tail(selected, 1)) |
| 345 |
) |
|
| 346 |
} |
|
| 347 | ||
| 348 |
.pick_ui_numeric <- function(id, label, choices, selected, args) {
|
|
| 349 | 1x |
shinyWidgets::numericRangeInput( |
| 350 | 1x |
inputId = id, |
| 351 | 1x |
label = label, |
| 352 | 1x |
min = unname(choices[1]), |
| 353 | 1x |
max = unname(utils::tail(choices, 1)), |
| 354 | 1x |
value = unname(selected) |
| 355 |
) |
|
| 356 |
} |
|
| 357 | ||
| 358 |
.pick_ui_categorical <- function(id, label, choices, selected, multiple, choicesOpt, args) { # nolint
|
|
| 359 | 39x |
htmltools::div( |
| 360 | 39x |
style = "max-width: 500px;", |
| 361 | 39x |
shinyWidgets::pickerInput( |
| 362 | 39x |
inputId = id, |
| 363 | 39x |
label = label, |
| 364 | 39x |
choices = choices, |
| 365 | 39x |
selected = selected, |
| 366 | 39x |
multiple = multiple, |
| 367 | 39x |
choicesOpt = choicesOpt, |
| 368 | 39x |
options = c( |
| 369 | 39x |
list( |
| 370 | 39x |
"actions-box" = !multiple, |
| 371 | 39x |
"live-search" = length(choices) > 10, |
| 372 | 39x |
"none-selected-text" = "- Nothing selected -", |
| 373 | 39x |
"show-subtext" = TRUE |
| 374 |
), |
|
| 375 | 39x |
args |
| 376 |
) |
|
| 377 |
) |
|
| 378 |
) |
|
| 379 |
} |
|
| 380 | ||
| 381 |
#' Update reactive values with log |
|
| 382 |
#' |
|
| 383 |
#' Update reactive values only if values differ to avoid unnecessary reactive trigger |
|
| 384 |
#' @param rv (`reactiveVal`) |
|
| 385 |
#' @param value (`vector`) |
|
| 386 |
#' @param log (`character(1)`) message to `log_debug` |
|
| 387 |
#' @keywords internal |
|
| 388 |
.update_rv <- function(rv, value, log) {
|
|
| 389 | 77x |
if (!isTRUE(all.equal(rv(), value, tolerance = 1e-15))) { # tolerance 1e-15 is a max precision in widgets.
|
| 390 | 23x |
logger::log_debug(log) |
| 391 | 23x |
rv(value) |
| 392 |
} |
|
| 393 |
} |
|
| 394 | ||
| 395 |
#' Resolve downstream after selected changes |
|
| 396 |
#' |
|
| 397 |
#' @description |
|
| 398 |
#' When select input at position `i` changes: |
|
| 399 |
#' - All slots after position i in `picks_resolved` are reset to their unresolved (delayed) state, |
|
| 400 |
#' because later slots depend on earlier ones. Slots before and at position i are kept as-is. |
|
| 401 |
#' For example, changing variables (i=2) resets everything after it but keeps dataset (i=1) intact. |
|
| 402 |
#' - The new selection replaces the old value at slot i. |
|
| 403 |
#' - Resolve is called, which evaluates only the slots that are still in an unresolved state. |
|
| 404 |
#' - The updated picks replace the current `reactiveValue`. |
|
| 405 |
#' Thanks to this design reactive values are triggered only once |
|
| 406 |
#' @param selected (`vector`) rather `character`, or `factor`. `numeric(2)` for `values()` based on numeric column. |
|
| 407 |
#' @param slot_name (`character(1)`) one of `c("datasets", "variables", "values")`
|
|
| 408 |
#' @param picks_resolved (`reactiveVal`) |
|
| 409 |
#' @param old_picks (`picks`) |
|
| 410 |
#' @param data (`any` asserted further in `resolver`) |
|
| 411 |
#' @keywords internal |
|
| 412 |
.resolve <- function(selected, slot_name, picks_resolved, old_picks, data) {
|
|
| 413 | 16x |
checkmate::assert_vector(selected, null.ok = TRUE) |
| 414 | 16x |
checkmate::assert_string(slot_name) |
| 415 | 16x |
checkmate::assert_class(picks_resolved, "reactiveVal") |
| 416 | 16x |
checkmate::assert_class(old_picks, "picks") |
| 417 |
# Input and new selection is the same |
|
| 418 | 16x |
if (isTRUE(all.equal(unclass(selected), unclass(picks_resolved()[[slot_name]]$selected), tolerance = 1e-15))) {
|
| 419 | 6x |
return(NULL) |
| 420 |
} |
|
| 421 | 10x |
logger::log_info("picks_server@1 selected has changed. Resolving downstream...")
|
| 422 | ||
| 423 | 10x |
new_picks_unresolved <- old_picks |
| 424 |
# ↓ everything after `slot_idx` is to resolve |
|
| 425 | 10x |
slot_idx <- which(names(old_picks) == slot_name) |
| 426 | 10x |
new_picks_unresolved[seq_len(slot_idx - 1)] <- picks_resolved()[seq_len(slot_idx - 1)] |
| 427 | ||
| 428 | 10x |
if (.is_ranged(selected)) {
|
| 429 | ! |
selected <- ranged(selected[1], selected[2]) |
| 430 |
} |
|
| 431 | 10x |
new_picks_unresolved[[slot_idx]]$selected <- selected |
| 432 | ||
| 433 | 10x |
resolver_warnings <- character(0) |
| 434 | 10x |
new_picks_resolved <- withCallingHandlers( |
| 435 | 10x |
resolver(new_picks_unresolved, data), |
| 436 | 10x |
warning = function(w) {
|
| 437 | 1x |
resolver_warnings <<- paste(conditionMessage(w), collapse = " ") |
| 438 |
} |
|
| 439 |
) |
|
| 440 | 10x |
if (length(resolver_warnings)) {
|
| 441 | 1x |
showNotification(resolver_warnings, type = "error") |
| 442 |
} |
|
| 443 | ||
| 444 | 10x |
picks_resolved(new_picks_resolved) |
| 445 |
} |
|
| 446 | ||
| 447 |
#' Restore value from bookmark. |
|
| 448 |
#' |
|
| 449 |
#' Get value from bookmark or return default. |
|
| 450 |
#' |
|
| 451 |
#' Bookmarks can store not only inputs but also arbitrary values. |
|
| 452 |
#' These values are stored by `onBookmark` callbacks and restored by `onBookmarked` callbacks, |
|
| 453 |
#' and they are placed in the `values` environment in the `session$restoreContext` field. |
|
| 454 |
#' Using `teal_data_module` makes it impossible to run the callbacks |
|
| 455 |
#' because the app becomes ready before modules execute and callbacks are registered. |
|
| 456 |
#' In those cases the stored values can still be recovered from the `session` object directly. |
|
| 457 |
#' |
|
| 458 |
#' Note that variable names in the `values` environment are prefixed with module name space names, |
|
| 459 |
#' therefore, when using this function in modules, `value` must be run through the name space function. |
|
| 460 |
#' |
|
| 461 |
#' @param value (`character(1)`) name of value to restore |
|
| 462 |
#' @param default fallback value |
|
| 463 |
#' |
|
| 464 |
#' @return |
|
| 465 |
#' In an application restored from a server-side bookmark, |
|
| 466 |
#' the variable specified by `value` from the `values` environment. |
|
| 467 |
#' Otherwise `default`. |
|
| 468 |
#' |
|
| 469 |
#' @keywords internal |
|
| 470 |
#' |
|
| 471 |
restoreValue <- function(value, default) { # nolint: object_name.
|
|
| 472 | 55x |
checkmate::assert_character("value")
|
| 473 | 55x |
session_default <- shiny::getDefaultReactiveDomain() |
| 474 | 55x |
session_parent <- .subset2(session_default, "parent") |
| 475 | 55x |
session <- if (is.null(session_parent)) session_default else session_parent |
| 476 | ||
| 477 | 55x |
if (isTRUE(session$restoreContext$active) && exists(value, session$restoreContext$values, inherits = FALSE)) {
|
| 478 | ! |
session$restoreContext$values[[value]] |
| 479 |
} else {
|
|
| 480 | 55x |
default |
| 481 |
} |
|
| 482 |
} |
|
| 483 | ||
| 484 |
#' `pickerInput` choices icons |
|
| 485 |
#' |
|
| 486 |
#' Icons describing a class of the choice |
|
| 487 |
#' @param x (`any`) object which class will determine icon |
|
| 488 |
#' @return html-tag in form of `character(1)` |
|
| 489 |
#' @keywords internal |
|
| 490 |
.picker_icon <- function(x) {
|
|
| 491 | 121x |
UseMethod(".picker_icon")
|
| 492 |
} |
|
| 493 | ||
| 494 |
#' @keywords internal |
|
| 495 |
#' @export |
|
| 496 | 61x |
.picker_icon.numeric <- function(x) "arrow-up-1-9" |
| 497 | ||
| 498 |
#' @keywords internal |
|
| 499 |
#' @export |
|
| 500 | 4x |
.picker_icon.integer <- function(x) "arrow-up-1-9" |
| 501 | ||
| 502 |
#' @keywords internal |
|
| 503 |
#' @export |
|
| 504 | 1x |
.picker_icon.logical <- function(x) "pause" |
| 505 | ||
| 506 |
#' @keywords internal |
|
| 507 |
#' @export |
|
| 508 | 2x |
.picker_icon.Date <- function(x) "calendar" |
| 509 | ||
| 510 |
#' @keywords internal |
|
| 511 |
#' @export |
|
| 512 | 2x |
.picker_icon.POSIXct <- function(x) "calendar" |
| 513 | ||
| 514 |
#' @keywords internal |
|
| 515 |
#' @export |
|
| 516 | ! |
.picker_icon.POSIXlt <- function(x) "calendar" |
| 517 | ||
| 518 |
#' @keywords internal |
|
| 519 |
#' @export |
|
| 520 | 12x |
.picker_icon.factor <- function(x) "chart-bar" |
| 521 | ||
| 522 |
#' @keywords internal |
|
| 523 |
#' @export |
|
| 524 | 1x |
.picker_icon.character <- function(x) "font" |
| 525 | ||
| 526 |
#' @keywords internal |
|
| 527 |
#' @export |
|
| 528 | ! |
.picker_icon.primary_key <- function(x) "key" |
| 529 | ||
| 530 |
#' @keywords internal |
|
| 531 |
#' @export |
|
| 532 | 38x |
.picker_icon.data.frame <- function(x) "table" |
| 533 | ||
| 534 |
#' @keywords internal |
|
| 535 |
#' @export |
|
| 536 | ! |
.picker_icon.default <- function(x) "circle-question" |
| 1 |
#' Choices/selected settings |
|
| 2 |
#' |
|
| 3 |
#' Define choices and default selection for variables. `picks` allows app-developer to specify |
|
| 4 |
#' `datasets`, `variables` and `values` to be selected by app-user during Shiny session. |
|
| 5 |
#' Functions are based on the idea of `choices/selected` where app-developer provides `choices` |
|
| 6 |
#' and what is `selected` by default. App-user changes `selected` interactively (see [`picks_module`]). |
|
| 7 |
#' |
|
| 8 |
#' @param choices (`tidyselect::language` or `character`) |
|
| 9 |
#' Available values to choose. |
|
| 10 |
#' @param selected (`tidyselect::language` or `character`) |
|
| 11 |
#' Choices to be selected. |
|
| 12 |
#' @param multiple (`logical(1)`) if more than one selection is possible. |
|
| 13 |
#' @param fixed (`logical(1)`) selection will be fixed and not possible to change interactively. |
|
| 14 |
#' @param ordered (`logical(1)`) if the selected should follow the selection order. If `FALSE` |
|
| 15 |
#' `selected` returned from `srv_module_input()` would be ordered according to order in `choices`. |
|
| 16 |
#' @param ... for `picks(...)`: hierarchical structure that contains `datasets()` as first element |
|
| 17 |
#' and optionally `variables()` and `values()` |
|
| 18 |
#' |
|
| 19 |
#' for `variables(...)` and `values(...)`: additional arguments delivered to `pickerInput` |
|
| 20 |
#' @param check_dataset (`logical(1)`) whether to check that the first element of `picks` is `datasets()`. |
|
| 21 |
#' This is useful to set to `FALSE` when creating picks objects that have a required dataset that is not |
|
| 22 |
#' selected by the user and defined in the module itself. |
|
| 23 |
#' @details |
|
| 24 |
#' # `tidyselect` support |
|
| 25 |
#' |
|
| 26 |
#' Both `choices` and `selected` parameters support `tidyselect` syntax, enabling dynamic |
|
| 27 |
#' and flexible variable selection patterns. This allows choices to be determined at runtime |
|
| 28 |
#' based on data characteristics rather than hard-coded values. |
|
| 29 |
#' |
|
| 30 |
#' ## Using `tidyselect` for `choices` and `selected` |
|
| 31 |
#' |
|
| 32 |
#' When `choices` uses `tidyselect`, the available options are determined dynamically based on actually |
|
| 33 |
#' selected data: |
|
| 34 |
#' |
|
| 35 |
#' - `tidyselect::everything()` - All variables/datasets |
|
| 36 |
#' - `tidyselect::starts_with("prefix")` - Variables starting with a prefix
|
|
| 37 |
#' - `tidyselect::ends_with("suffix")` - Variables ending with a suffix
|
|
| 38 |
#' - `tidyselect::contains("pattern")` - Variables containing a pattern
|
|
| 39 |
#' - `tidyselect::matches("regex")` - Variables matching a regular expression
|
|
| 40 |
#' - `tidyselect::where(predicate)` - Variables/datasets satisfying a predicate function |
|
| 41 |
#' - `tidyselect::all_of(vars)` - All specified variables (error if missing) |
|
| 42 |
#' - `tidyselect::any_of(vars)` - Any specified variables (silent if missing) |
|
| 43 |
#' - Range selectors like `Sepal.Length:Petal.Width` - Variables between two positions |
|
| 44 |
#' - Integer indices (e.g., `1L`, `1L:3L`, `c(1L, 3L, 5L)`) - Select by position. Be careful, must be integer! |
|
| 45 |
#' |
|
| 46 |
#' The `selected` parameter can use the same syntax but it will be applied to the subset defined in choices. This |
|
| 47 |
#' means that `choices = is.numeric, selected = is.factor` or `choices = c("a", "b", "c"), selected = c("d", "e")`
|
|
| 48 |
#' will imply en empty `selected`. |
|
| 49 |
#' |
|
| 50 |
#' **Warning:** Using explicit character values for `selected` with dynamic `choices` may |
|
| 51 |
#' cause issues if the selected values are not present in the dynamically determined choices. |
|
| 52 |
#' Prefer using numeric indices (e.g., `1` for first variable) when `choices` is dynamic. |
|
| 53 |
#' |
|
| 54 |
#' # Structure and element dependencies |
|
| 55 |
#' |
|
| 56 |
#' The `picks()` function creates a hierarchical structure where elements depend on their |
|
| 57 |
#' predecessors, enabling cascading reactive updates during Shiny sessions. |
|
| 58 |
#' |
|
| 59 |
#' ## Element hierarchy |
|
| 60 |
#' |
|
| 61 |
#' A `picks` object must follow this order: |
|
| 62 |
#' |
|
| 63 |
#' 1. **`datasets()`** - to select a dataset. Always the first element (required). |
|
| 64 |
#' 2. **`variables()`** - To select columns from the chosen dataset. |
|
| 65 |
#' 3. **`values()`** - To select specific values from the chosen variable(s). |
|
| 66 |
#' |
|
| 67 |
#' Each element's choices are evaluated within the context of its predecessor's selection. |
|
| 68 |
#' |
|
| 69 |
#' ## How dependencies work |
|
| 70 |
#' |
|
| 71 |
#' - **Fixed dataset**: When `datasets(choices = "iris")` specifies one dataset, the |
|
| 72 |
#' `variables()` choices are evaluated against that dataset columns. |
|
| 73 |
#' |
|
| 74 |
#' - **Multiple dataset choices**: When `datasets(choices = c("iris", "mtcars"))` allows multiple
|
|
| 75 |
#' options, `variables()` choices are re-evaluated each time the user selects a different |
|
| 76 |
#' dataset. This creates a reactive dependency where variable choices update automatically. |
|
| 77 |
#' |
|
| 78 |
#' - **Dynamic dataset choices**: When using `datasets(choices = tidyselect::where(is.data.frame))`, |
|
| 79 |
#' all available data frames are discovered at runtime, and variable choices adapt to |
|
| 80 |
#' whichever dataset the user selects. |
|
| 81 |
#' |
|
| 82 |
#' - **Variable to values**: Similarly, `values()` choices are evaluated based on the |
|
| 83 |
#' selected variable(s), allowing users to filter specific levels or values. When multiple |
|
| 84 |
#' variables are selected, then values will be a concatenation of the columns. |
|
| 85 |
#' |
|
| 86 |
#' ## Best practices |
|
| 87 |
#' |
|
| 88 |
#' - Always start with `datasets()` - this is enforced by validation |
|
| 89 |
#' - Use dynamic `choices` in `variables()` when working with multiple datasets to ensure |
|
| 90 |
#' compatibility across different data structures |
|
| 91 |
#' - Prefer `tidyselect::everything()` or `tidyselect::where()` predicates for flexible |
|
| 92 |
#' variable selection that works across datasets with different schemas |
|
| 93 |
#' - Use numeric indices for `selected` when `choices` are dynamic to avoid referencing |
|
| 94 |
#' variables that may not exist in all datasets |
|
| 95 |
#' |
|
| 96 |
#' ## Important: `values()` requires type-aware configuration |
|
| 97 |
#' |
|
| 98 |
#' ### Why `values()` is different from `datasets()` and `variables()` |
|
| 99 |
#' |
|
| 100 |
#' `datasets()` and `variables()` operate on named lists of objects, meaning they work with character-based |
|
| 101 |
#' identifiers. This allows you to use text-based selectors like `starts_with("S")` or `contains("prefix")`
|
|
| 102 |
#' consistently for both datasets and variable names. |
|
| 103 |
#' |
|
| 104 |
#' `values()` is fundamentally different because it operates on the **actual data content** within a |
|
| 105 |
#' selected variable (column). The type of data in the column determines what kind of filtering makes sense: |
|
| 106 |
#' |
|
| 107 |
#' - **`numeric` columns** (e.g., `age`, `height`, `price`) contain numbers |
|
| 108 |
#' - **`character`/`factor` columns** (e.g., `country`, `category`, `status`) contain categorical values |
|
| 109 |
#' - **`Date`/`POSIXct` columns** contain temporal data |
|
| 110 |
#' - **`logical` columns** contain TRUE/FALSE values |
|
| 111 |
#' |
|
| 112 |
#' ### Type-specific UI controls |
|
| 113 |
#' |
|
| 114 |
#' The `values()` function automatically renders different UI controls based on data type: |
|
| 115 |
#' |
|
| 116 |
#' - **`numeric` data**: Creates a `sliderInput` for range selection |
|
| 117 |
#' - `choices` must be a numeric vector of length 2: `c(min, max)` |
|
| 118 |
#' - `selected` must be a numeric vector of length 2: `c(selected_min, selected_max)` |
|
| 119 |
#' |
|
| 120 |
#' - **Categorical data** (`character`/`factor`): Creates a `pickerInput` for discrete selection |
|
| 121 |
#' - `choices` can be a character vector or predicate function |
|
| 122 |
#' - `selected` can be specific values or a predicate function |
|
| 123 |
#' |
|
| 124 |
#' - **`Date`/`POSIXct` data**: Creates date/datetime range selectors |
|
| 125 |
#' - `choices` must be a Date or `POSIXct` vector of length 2 |
|
| 126 |
#' |
|
| 127 |
#' - **`logical` data**: Creates a checkbox or picker for TRUE/FALSE selection |
|
| 128 |
#' |
|
| 129 |
#' ### Developer responsibility |
|
| 130 |
#' |
|
| 131 |
#' **App developers must ensure `values()` configuration matches the variable type:** |
|
| 132 |
#' |
|
| 133 |
#' 1. **Know your data**: Understand what type of variable(s) users might select |
|
| 134 |
#' 2. **Configure appropriately**: Set `choices` and `selected` to match expected data types |
|
| 135 |
#' 3. **Use predicates for flexibility**: When variable type is dynamic, use predicate functions |
|
| 136 |
#' like `function(x) !is.na(x)` (the default) to handle multiple types safely |
|
| 137 |
#' |
|
| 138 |
#' ### Examples of correct usage |
|
| 139 |
#' |
|
| 140 |
#' ```r |
|
| 141 |
#' # For a numeric variable (e.g., age) |
|
| 142 |
#' picks( |
|
| 143 |
#' datasets(choices = "demographic"), |
|
| 144 |
#' variables(choices = "age", multiple = FALSE), |
|
| 145 |
#' values(choices = c(0, 100), selected = c(18, 65)) |
|
| 146 |
#' ) |
|
| 147 |
#' |
|
| 148 |
#' # For a categorical variable (e.g., country) |
|
| 149 |
#' picks( |
|
| 150 |
#' datasets(choices = "demographic"), |
|
| 151 |
#' variables(choices = "country", multiple = FALSE), |
|
| 152 |
#' values(choices = c("USA", "Canada", "Mexico"), selected = "USA")
|
|
| 153 |
#' ) |
|
| 154 |
#' |
|
| 155 |
#' # Safe approach when variable type is unknown - use predicates |
|
| 156 |
#' picks( |
|
| 157 |
#' datasets(choices = "demographic"), |
|
| 158 |
#' variables(choices = tidyselect::everything(), selected = 1L), |
|
| 159 |
#' values(choices = function(x) !is.na(x), selected = function(x) !is.na(x)) |
|
| 160 |
#' ) |
|
| 161 |
#' ``` |
|
| 162 |
#' |
|
| 163 |
#' ### Common mistakes to avoid |
|
| 164 |
#' |
|
| 165 |
#' ```r |
|
| 166 |
#' # WRONG: Using string selectors for numeric data |
|
| 167 |
#' values(choices = starts_with("5")) # Doesn't make sense for numeric data!
|
|
| 168 |
#' |
|
| 169 |
#' # WRONG: Providing categorical choices for a numeric variable |
|
| 170 |
#' values(choices = c("low", "medium", "high")) # Won't work if variable is numeric!
|
|
| 171 |
#' |
|
| 172 |
#' # WRONG: Providing numeric range for categorical variable |
|
| 173 |
#' values(choices = c(0, 100)) # Won't work if variable is factor/character! |
|
| 174 |
#' ``` |
|
| 175 |
#' |
|
| 176 |
#' ## Example: Three-level hierarchy |
|
| 177 |
#' |
|
| 178 |
#' ```r |
|
| 179 |
#' picks( |
|
| 180 |
#' datasets(choices = c("iris", "mtcars"), selected = "iris"),
|
|
| 181 |
#' variables(choices = tidyselect::where(is.numeric), selected = 1L), |
|
| 182 |
#' values(choices = tidyselect::everything(), selected = seq_len(10)) |
|
| 183 |
#' ) |
|
| 184 |
#' ``` |
|
| 185 |
#' |
|
| 186 |
#' In this example: |
|
| 187 |
#' - User first selects a dataset (`iris` or `mtcars`) |
|
| 188 |
#' - Variable choices update to show only numeric columns from selected dataset |
|
| 189 |
#' - After selecting a variable, value choices show all unique values from that column |
|
| 190 |
#' |
|
| 191 |
#' @examples |
|
| 192 |
#' # Select columns from iris dataset using range selector |
|
| 193 |
#' picks( |
|
| 194 |
#' datasets(choices = "iris"), |
|
| 195 |
#' variables(choices = Sepal.Length:Petal.Width, selected = 1L) |
|
| 196 |
#' ) |
|
| 197 |
#' |
|
| 198 |
#' # Single variable selection from iris dataset |
|
| 199 |
#' picks( |
|
| 200 |
#' datasets(choices = "iris", selected = "iris"), |
|
| 201 |
#' variables(choices = c("Sepal.Length", "Sepal.Width"), selected = "Sepal.Length", multiple = FALSE)
|
|
| 202 |
#' ) |
|
| 203 |
#' |
|
| 204 |
#' # Dynamic selection: any variable from iris, first selected by default |
|
| 205 |
#' picks( |
|
| 206 |
#' datasets(choices = "iris", selected = "iris"), |
|
| 207 |
#' variables(choices = tidyselect::everything(), selected = 1L, multiple = FALSE) |
|
| 208 |
#' ) |
|
| 209 |
#' |
|
| 210 |
#' # Multiple dataset choices: variable choices will update when dataset changes |
|
| 211 |
#' picks( |
|
| 212 |
#' datasets(choices = c("iris", "mtcars"), selected = "iris"),
|
|
| 213 |
#' variables(choices = tidyselect::everything(), selected = 1L, multiple = FALSE) |
|
| 214 |
#' ) |
|
| 215 |
#' |
|
| 216 |
#' # Select from any dataset, filter by numeric variables |
|
| 217 |
#' picks( |
|
| 218 |
#' datasets(choices = c("iris", "mtcars"), selected = 1L),
|
|
| 219 |
#' variables(choices = tidyselect::where(is.numeric), selected = 1L) |
|
| 220 |
#' ) |
|
| 221 |
#' |
|
| 222 |
#' # Fully dynamic: auto-discover datasets and variables |
|
| 223 |
#' picks( |
|
| 224 |
#' datasets(choices = tidyselect::where(is.data.frame), selected = 1L), |
|
| 225 |
#' variables(choices = tidyselect::everything(), selected = 1L, multiple = FALSE) |
|
| 226 |
#' ) |
|
| 227 |
#' |
|
| 228 |
#' # Select categorical variables with length constraints |
|
| 229 |
#' picks( |
|
| 230 |
#' datasets(choices = tidyselect::everything(), selected = 1L), |
|
| 231 |
#' variables(choices = is_categorical(min.len = 2, max.len = 15), selected = seq_len(2)) |
|
| 232 |
#' ) |
|
| 233 |
#' |
|
| 234 |
#' @export |
|
| 235 |
picks <- function(..., check_dataset = TRUE) {
|
|
| 236 | 169x |
picks <- rlang::dots_list(..., .ignore_empty = "trailing") |
| 237 | 169x |
checkmate::assert_list(picks, types = "pick", min.len = 1) |
| 238 | 166x |
checkmate::assert_flag(check_dataset) |
| 239 | 166x |
.check_picks(picks, check_dataset) |
| 240 | 162x |
names(picks) <- vapply(picks, FUN = methods::is, FUN.VALUE = character(1)) |
| 241 | 162x |
structure(picks, class = c("picks", "list"))
|
| 242 |
} |
|
| 243 | ||
| 244 |
#' @rdname picks |
|
| 245 |
#' @export |
|
| 246 |
datasets <- function(choices = tidyselect::everything(), |
|
| 247 |
selected = 1L, |
|
| 248 |
fixed = NULL, |
|
| 249 |
...) {
|
|
| 250 | 221x |
checkmate::assert( |
| 251 | 221x |
.check_tidyselect(choices), |
| 252 | 221x |
.check_predicate(choices), |
| 253 | 221x |
checkmate::check_character(choices, min.len = 1) |
| 254 |
) |
|
| 255 | 216x |
checkmate::assert( |
| 256 | 216x |
.check_tidyselect(selected), |
| 257 | 216x |
.check_predicate(selected), |
| 258 | 216x |
checkmate::check_character(selected, len = 1, null.ok = TRUE) |
| 259 |
) |
|
| 260 | ||
| 261 | 215x |
if (is.null(fixed)) {
|
| 262 | 209x |
fixed <- !.is_tidyselect(choices) && !.is_predicate(choices) && length(choices) == 1 |
| 263 |
} |
|
| 264 | ||
| 265 | 215x |
out <- .pick( |
| 266 | 215x |
choices = if (.is_tidyselect(choices)) rlang::enquo(choices) else choices, |
| 267 | 215x |
selected = if (.is_tidyselect(selected)) rlang::enquo(selected) else selected, |
| 268 | 215x |
multiple = FALSE, |
| 269 | 215x |
fixed = fixed, |
| 270 |
... |
|
| 271 |
) |
|
| 272 | 214x |
class(out) <- c("datasets", class(out))
|
| 273 | 214x |
out |
| 274 |
} |
|
| 275 | ||
| 276 |
#' @rdname picks |
|
| 277 |
#' @export |
|
| 278 |
variables <- function(choices = tidyselect::everything(), |
|
| 279 |
selected = 1L, |
|
| 280 |
multiple = NULL, |
|
| 281 |
fixed = NULL, |
|
| 282 |
ordered = FALSE, |
|
| 283 |
...) {
|
|
| 284 | 167x |
checkmate::assert( |
| 285 | 167x |
.var.name = "choices", |
| 286 | 167x |
.check_tidyselect(choices), |
| 287 | 167x |
.check_predicate(choices), |
| 288 | 167x |
checkmate::check_character(choices, min.len = 1) |
| 289 |
) |
|
| 290 | 167x |
checkmate::assert( |
| 291 | 167x |
.var.name = "selected", |
| 292 | 167x |
.check_tidyselect(selected), |
| 293 | 167x |
.check_predicate(selected), |
| 294 | 167x |
checkmate::check_character(selected, min.len = 1, null.ok = TRUE) |
| 295 |
) |
|
| 296 | 167x |
checkmate::assert_flag(multiple, null.ok = TRUE) |
| 297 | 167x |
checkmate::assert_flag(fixed, null.ok = TRUE) |
| 298 | 167x |
checkmate::assert_flag(ordered) |
| 299 | 167x |
if (is.null(multiple)) {
|
| 300 | 140x |
multiple <- !(.is_tidyselect(selected) || .is_predicate(selected)) && length(selected) > 1 |
| 301 |
} |
|
| 302 | 167x |
if (is.null(fixed)) {
|
| 303 | 156x |
fixed <- !(.is_tidyselect(choices) || .is_predicate(choices)) && length(choices) == 1 |
| 304 |
} |
|
| 305 | ||
| 306 | 167x |
out <- .pick( |
| 307 | 167x |
choices = if (.is_tidyselect(choices)) rlang::enquo(choices) else choices, |
| 308 | 167x |
selected = if (.is_tidyselect(selected)) rlang::enquo(selected) else selected, |
| 309 | 167x |
multiple = multiple, |
| 310 | 167x |
fixed = fixed, |
| 311 | 167x |
ordered = ordered, |
| 312 | 167x |
`allow-clear` = !.is_tidyselect(selected) && !.is_predicate(selected) && (is.null(selected) || multiple), |
| 313 |
... |
|
| 314 |
) |
|
| 315 | 167x |
class(out) <- c("variables", class(out))
|
| 316 | 167x |
out |
| 317 |
} |
|
| 318 | ||
| 319 |
#' @rdname picks |
|
| 320 |
#' @export |
|
| 321 |
values <- function(choices = function(x) !is.na(x), |
|
| 322 |
selected = function(x) !is.na(x), |
|
| 323 |
multiple = TRUE, |
|
| 324 |
fixed = NULL, |
|
| 325 |
...) {
|
|
| 326 | 83x |
choices <- tryCatch(choices, error = function(e) {
|
| 327 | 83x |
if ( |
| 328 | 2x |
grepl( |
| 329 | 2x |
"must be used within a \\*selecting\\* function|object .+ not found|operations are possible", |
| 330 | 2x |
e$message |
| 331 |
) |
|
| 332 |
) {
|
|
| 333 | 2x |
stop("`values()` does not support tidyselect expressions in `choices`.", call. = FALSE)
|
| 334 |
} |
|
| 335 | ! |
stop(e) |
| 336 |
}) |
|
| 337 | 81x |
checkmate::assert( |
| 338 | 81x |
.var.name = "choices", |
| 339 | 81x |
.check_predicate(choices), |
| 340 | 81x |
checkmate::check_character(choices, min.len = 1, unique = TRUE), |
| 341 | 81x |
checkmate::check_factor(choices, min.len = 1), |
| 342 | 81x |
checkmate::check_logical(choices, min.len = 1, unique = TRUE), |
| 343 | 81x |
checkmate::check_numeric(choices, min.len = 1, finite = TRUE), |
| 344 | 81x |
checkmate::check_date(choices, min.len = 1), # should be sorted but determine |
| 345 | 81x |
checkmate::check_posixct(choices, min.len = 1) |
| 346 |
) |
|
| 347 | 78x |
checkmate::assert( |
| 348 | 78x |
.var.name = "selected", |
| 349 | 78x |
.check_predicate(selected), |
| 350 | 78x |
checkmate::check_null(selected), |
| 351 | 78x |
checkmate::check_character(selected, min.len = 1, unique = TRUE), |
| 352 | 78x |
checkmate::check_factor(selected, min.len = 1), |
| 353 | 78x |
checkmate::check_logical(selected, min.len = 1, unique = TRUE), |
| 354 | 78x |
checkmate::check_numeric(selected, min.len = 1, finite = TRUE), |
| 355 | 78x |
checkmate::check_date(selected, min.len = 1), |
| 356 | 78x |
checkmate::check_posixct(selected, min.len = 1) |
| 357 |
) |
|
| 358 | 78x |
checkmate::assert_flag(multiple) |
| 359 | 78x |
checkmate::assert_flag(fixed, null.ok = TRUE) |
| 360 | ||
| 361 | 78x |
if (is.null(fixed)) {
|
| 362 | 76x |
fixed <- !.is_predicate(choices) && length(choices) == 1 |
| 363 |
} |
|
| 364 | ||
| 365 | 78x |
out <- .pick( |
| 366 | 78x |
choices = choices, |
| 367 | 78x |
selected = selected, |
| 368 | 78x |
multiple = multiple, |
| 369 | 78x |
fixed = fixed, |
| 370 |
... |
|
| 371 |
) |
|
| 372 | 78x |
class(out) <- c("values", class(out))
|
| 373 | 78x |
out |
| 374 |
} |
|
| 375 | ||
| 376 |
#' Pick class constructor |
|
| 377 |
#' |
|
| 378 |
#' Create a `pick` object |
|
| 379 |
#' @inheritParams picks |
|
| 380 |
#' @keywords internal |
|
| 381 |
.pick <- function(choices, |
|
| 382 |
selected, |
|
| 383 |
multiple = length(selected) > 1, |
|
| 384 |
ordered = FALSE, |
|
| 385 |
fixed = FALSE, |
|
| 386 |
...) {
|
|
| 387 | 460x |
is_choices_delayed <- rlang::is_quosure(choices) || .is_predicate(choices) |
| 388 | 460x |
is_selected_eager <- is.character(selected) |
| 389 | 460x |
if (is_choices_delayed && is_selected_eager) {
|
| 390 | 4x |
warning( |
| 391 | 4x |
warningCondition( |
| 392 | 4x |
paste0( |
| 393 | 4x |
deparse(sys.call(-1)), |
| 394 | 4x |
"\n - Setting explicit `selected` while `choices` are delayed (set using `tidyselect`) doesn't ", |
| 395 | 4x |
"guarantee that `selected` is a subset of `choices`." |
| 396 |
), |
|
| 397 | 4x |
class = c("pick_delayed", "picks_delayed"),
|
| 398 | 4x |
call. = FALSE |
| 399 |
) |
|
| 400 |
) |
|
| 401 |
} |
|
| 402 | ||
| 403 | 460x |
if (is.character(choices) && is.character(selected) && any(!selected %in% choices)) {
|
| 404 | 1x |
not_in_choices <- setdiff(selected, choices) |
| 405 | 1x |
stop(sprintf( |
| 406 | 1x |
"Some `selected`:{%s}\nare not a subset of `choices`: {%s}",
|
| 407 | 1x |
toString(sQuote(not_in_choices)), |
| 408 | 1x |
toString(sQuote(choices)) |
| 409 |
)) |
|
| 410 |
} |
|
| 411 | ||
| 412 | 459x |
structure( |
| 413 | 459x |
list(choices = choices, selected = selected), |
| 414 | 459x |
multiple = multiple, |
| 415 | 459x |
ordered = ordered, |
| 416 | 459x |
fixed = fixed, |
| 417 |
..., |
|
| 418 | 459x |
class = "pick" |
| 419 |
) |
|
| 420 |
} |
|
| 421 | ||
| 422 |
#' Is an object created using `tidyselect` |
|
| 423 |
#' |
|
| 424 |
#' @description |
|
| 425 |
#' `choices` and `selected` can be provided using `tidyselect`, (e.g. [tidyselect::everything()] |
|
| 426 |
#' [tidyselect::where()], [tidyselect::starts_with()]). These functions can't be called |
|
| 427 |
#' independently but rather as an argument of function which consumes them. |
|
| 428 |
#' `.is_tidyselect` safely determines if `x` can be evaluated with `tidyselect::eval_select()` |
|
| 429 |
#' @param x `choices` or `selected` |
|
| 430 |
#' @return `logical(1)` |
|
| 431 |
#' @keywords internal |
|
| 432 |
.is_tidyselect <- function(x) {
|
|
| 433 | 3763x |
out <- suppressWarnings(tryCatch(x, error = function(e) e)) |
| 434 | 3763x |
inherits(out, "error") && grepl("must be used within a \\*selecting\\* function", out$message) || # e.g. everything
|
| 435 | 3763x |
inherits(out, "error") && grepl("object .+ not found", out$message) || # e.g. var:var2
|
| 436 | 3763x |
inherits(out, "error") && grepl("operations are possible", out$message) || # e.g. where() | where()
|
| 437 | 3763x |
checkmate::test_integerish(out, min.len = 1) # e.g. 1L:5L |
| 438 |
} |
|
| 439 | ||
| 440 |
.is_predicate <- function(x) {
|
|
| 441 | 1556x |
!.is_tidyselect(x) && |
| 442 |
( |
|
| 443 | 1556x |
checkmate::test_function(x, nargs = 1) || |
| 444 | 1556x |
checkmate::test_function(x) && identical(names(formals(x)), "...") |
| 445 |
) |
|
| 446 |
} |
|
| 447 | ||
| 448 |
.check_tidyselect <- function(x) {
|
|
| 449 | 771x |
if (!.is_tidyselect(x)) {
|
| 450 | 508x |
"choices/selected has not been created using tidyselect-helper" |
| 451 |
} else {
|
|
| 452 | 263x |
TRUE |
| 453 |
} |
|
| 454 |
} |
|
| 455 | ||
| 456 |
.check_predicate <- function(x) {
|
|
| 457 | 667x |
if (!.is_predicate(x)) {
|
| 458 | 546x |
"choices/selected has not been created using predicate function (single arg function returning TRUE or FALSE)" |
| 459 |
} else {
|
|
| 460 | 121x |
TRUE |
| 461 |
} |
|
| 462 |
} |
|
| 463 | ||
| 464 | ||
| 465 |
#' Is picks delayed |
|
| 466 |
#' |
|
| 467 |
#' Determine whether list of picks/picks or pick are delayed. |
|
| 468 |
#' When `"pick"` is created it could be either: |
|
| 469 |
#' - `quosure` when `tidyselect` helper used (delayed) |
|
| 470 |
#' - `function` when predicate function provided (delayed) |
|
| 471 |
#' - `atomic` when vector of choices/selected provided (eager) |
|
| 472 |
#' @param x (`list`, `list of picks`, `picks`, `pick`, `$choices`, `$selected`) |
|
| 473 |
#' @keywords internal |
|
| 474 |
.is_delayed <- function(x) {
|
|
| 475 | 2030x |
UseMethod(".is_delayed")
|
| 476 |
} |
|
| 477 | ||
| 478 |
#' @export |
|
| 479 |
.is_delayed.list <- function(x) {
|
|
| 480 | 101x |
any(vapply(x, .is_delayed, logical(1))) |
| 481 |
} |
|
| 482 | ||
| 483 |
#' @export |
|
| 484 |
.is_delayed.pick <- function(x) {
|
|
| 485 | 492x |
.is_delayed(x$choices) | .is_delayed(x$selected) |
| 486 |
} |
|
| 487 | ||
| 488 |
#' @export |
|
| 489 |
.is_delayed.default <- function(x) {
|
|
| 490 | 1437x |
rlang::is_quosure(x) | |
| 491 | 1437x |
is.function(x) |
| 492 |
} |
|
| 493 | ||
| 494 |
.check_picks <- function(x, check_dataset) {
|
|
| 495 | 166x |
if (check_dataset && !inherits(x[[1]], "datasets")) {
|
| 496 | 2x |
stop("picks() requires datasets() as the first element", call. = FALSE)
|
| 497 |
} |
|
| 498 | ||
| 499 |
# Check if values exists and is preceded by variables |
|
| 500 | 164x |
element_classes <- vapply(x, FUN = methods::is, FUN.VALUE = character(1)) |
| 501 | 164x |
values_idx <- which(element_classes == "values") |
| 502 | ||
| 503 | 164x |
if (length(values_idx) > 0) {
|
| 504 | 57x |
variables_idx <- which(element_classes == "variables") |
| 505 | 57x |
if (length(variables_idx) == 0) {
|
| 506 | 1x |
stop("picks() requires variables() before values()", call. = FALSE)
|
| 507 |
} |
|
| 508 | 56x |
if (values_idx != variables_idx + 1) {
|
| 509 | 1x |
stop("values() must immediately follow variables() in picks()", call. = FALSE)
|
| 510 |
} |
|
| 511 |
} |
|
| 512 | ||
| 513 |
# Avoid double loop with [.picks checks that would make it fail |
|
| 514 | 162x |
previous_has_dynamic_choices <- c(FALSE, vapply(x, FUN.VALUE = logical(1), FUN = .is_delayed)) |
| 515 | ||
| 516 | 162x |
has_eager_choices <- c(vapply(x, Negate(function(x) .is_delayed(x$choices)), logical(1)), FALSE) |
| 517 | 162x |
if (any(previous_has_dynamic_choices & has_eager_choices)) {
|
| 518 | 4x |
idx_wrong <- which(previous_has_dynamic_choices & has_eager_choices)[1] |
| 519 | 4x |
warning( |
| 520 | 4x |
warningCondition( |
| 521 | 4x |
paste0( |
| 522 | 4x |
element_classes[idx_wrong], " has eager choices (character) while ", |
| 523 | 4x |
element_classes[idx_wrong - 1], " has dynamic choices. ", |
| 524 | 4x |
"It is not guaranteed that explicitly defined choices will be a ", |
| 525 | 4x |
"subset of data selected in a previous element." |
| 526 |
), |
|
| 527 | 4x |
call. = FALSE, |
| 528 | 4x |
class = "picks_delayed" |
| 529 |
) |
|
| 530 |
) |
|
| 531 |
} |
|
| 532 | 162x |
TRUE |
| 533 |
} |
|
| 534 | ||
| 535 |
#' @export |
|
| 536 |
`[.picks` <- function(x, i, ...) {
|
|
| 537 | 23x |
nm <- NextMethod("[", object = x)
|
| 538 | 23x |
if (length(nm)) {
|
| 539 | 18x |
class(nm) <- class(x) |
| 540 |
} |
|
| 541 | 23x |
nm |
| 542 |
} |
| 1 |
#' Resolve `picks` |
|
| 2 |
#' |
|
| 3 |
#' Resolve iterates through each `picks` element and determines values . |
|
| 4 |
#' @param x ([picks()]) settings for picks. |
|
| 5 |
#' @param data ([teal_data()] `environment` or `list`) any data collection supporting object extraction with `[[`. |
|
| 6 |
#' Used to determine values of unresolved `picks`. |
|
| 7 |
#' |
|
| 8 |
#' @returns resolved `picks`. |
|
| 9 |
#' @export |
|
| 10 |
#' |
|
| 11 |
#' @examples |
|
| 12 |
#' x <- picks(datasets(tidyselect::where(is.data.frame)), variables("a", "a"))
|
|
| 13 |
#' data <- list( |
|
| 14 |
#' df1 = data.frame(a = as.factor(LETTERS[1:5]), b = letters[1:5]), |
|
| 15 |
#' df2 = data.frame(a = LETTERS[1:5], b = 1:5), |
|
| 16 |
#' m = matrix() |
|
| 17 |
#' ) |
|
| 18 |
#' resolver(x = x, data = data) |
|
| 19 |
resolver <- function(x, data) {
|
|
| 20 | 71x |
checkmate::assert_class(x, "picks") |
| 21 | 71x |
checkmate::assert( |
| 22 | 71x |
is.environment(data), |
| 23 | 71x |
checkmate::check_list(data, names = "unique") |
| 24 |
) |
|
| 25 | 68x |
data_i <- data |
| 26 | 68x |
for (i in seq_along(x)) {
|
| 27 | 138x |
determined_i <- determine(x[[i]], data = data_i) |
| 28 | 138x |
data_i <- determined_i$data |
| 29 | 138x |
x[[i]] <- determined_i$x |
| 30 |
} |
|
| 31 | 68x |
x |
| 32 |
} |
|
| 33 | ||
| 34 |
#' A method that should take a type and resolve it. |
|
| 35 |
#' |
|
| 36 |
#' Generic that makes the minimal check on spec. |
|
| 37 |
#' Responsible of subsetting/extract the data received and check that the type matches |
|
| 38 |
#' @param x The specification to resolve. |
|
| 39 |
#' @param data The minimal data required. |
|
| 40 |
#' @return A list with two elements, the `type` resolved and the data extracted. |
|
| 41 |
#' @keywords internal |
|
| 42 |
determine <- function(x, data) {
|
|
| 43 | 202x |
if (is.null(data)) { # this happens when <previous>$selected=NULL
|
| 44 | 4x |
return(list(x = .nullify_pick(x))) |
| 45 |
} |
|
| 46 | 198x |
UseMethod("determine")
|
| 47 |
} |
|
| 48 | ||
| 49 |
#' @export |
|
| 50 |
determine.datasets <- function(x, data) {
|
|
| 51 | 100x |
checkmate::assert(is.environment(data), is.list(data)) |
| 52 | 100x |
data <- as.list(data) |
| 53 | 100x |
x$choices <- .determine_choices(x = x$choices, data = data) |
| 54 | 100x |
x$selected <- .determine_selected( |
| 55 | 100x |
x = x$selected, |
| 56 | 100x |
data = data[intersect(x$choices, names(data))], |
| 57 | 100x |
multiple = attr(x, "multiple") |
| 58 |
) |
|
| 59 | 100x |
list(x = x, data = .extract(x, data)) |
| 60 |
} |
|
| 61 | ||
| 62 |
#' @export |
|
| 63 |
determine.variables <- function(x, data) {
|
|
| 64 | 72x |
checkmate::assert_multi_class(data, c("data.frame", "tbl_df", "data.table", "DataFrame"))
|
| 65 | 72x |
if (ncol(data) <= 0L) {
|
| 66 | 1x |
warning("Selected dataset has no columns", call. = FALSE)
|
| 67 | 1x |
return(list(x = .nullify_pick(x))) |
| 68 |
} |
|
| 69 | ||
| 70 | 71x |
old <- select_env$operators |
| 71 | 71x |
select_env$active <- TRUE |
| 72 | 71x |
on.exit(select_env$operators <- old, add = TRUE) |
| 73 | 71x |
on.exit(select_env$active <- FALSE, add = TRUE) |
| 74 | ||
| 75 | 71x |
x$choices <- .determine_choices(x$choices, data = data) |
| 76 |
# change data to add columns that combine interaction vars |
|
| 77 | 71x |
custom_operators <- unique(select_env$operators) %||% x$operators |
| 78 | ||
| 79 | 71x |
for (ix in seq_along(custom_operators)) {
|
| 80 | ! |
new_choice <- rlang::set_names(attr(custom_operators[[ix]], "var_name", TRUE)) |
| 81 | ! |
data <- .operator_mutate(custom_operators[[ix]], new_choice, data) |
| 82 | ! |
x$choices <- c(x$choices, new_choice) |
| 83 | ! |
x$operators <- custom_operators |
| 84 |
} |
|
| 85 | ||
| 86 | 71x |
x$selected <- .determine_selected( |
| 87 | 71x |
x$selected, |
| 88 | 71x |
data = data[intersect(x$choices, colnames(data))], |
| 89 | 71x |
multiple = attr(x, "multiple") |
| 90 |
) |
|
| 91 | 71x |
list(x = x, data = .extract(x, data)) |
| 92 |
} |
|
| 93 | ||
| 94 |
#' @export |
|
| 95 |
determine.values <- function(x, data) {
|
|
| 96 | 26x |
data <- if (ncol(data) > 1) {
|
| 97 | 3x |
apply(data, 1, toString) |
| 98 |
} else {
|
|
| 99 | 23x |
data[[1]] |
| 100 |
} |
|
| 101 | ||
| 102 | 26x |
data <- stats::setNames(unique(data), unique(data)) |
| 103 | 26x |
is_ranged <- if (.is_ranged(x$choices) || .is_ranged(x$selected)) {
|
| 104 | 12x |
TRUE |
| 105 |
} else {
|
|
| 106 | 14x |
FALSE |
| 107 |
} |
|
| 108 | ||
| 109 | 26x |
if (is_ranged && !is.numeric(data) && !inherits(data, c("Date", "POSIXct"))) {
|
| 110 | ! |
warning( |
| 111 | ! |
"Column used with `ranged()` must be numeric, Date, or POSIXct, but got: ", |
| 112 | ! |
paste(class(data), collapse = "/"), |
| 113 | ! |
". Please adjust `variables(choices)` to only select supported column types.", |
| 114 | ! |
call. = FALSE |
| 115 |
) |
|
| 116 | ! |
x$choices <- NULL |
| 117 | ! |
x$selected <- NULL |
| 118 | ! |
return(list(x = x)) |
| 119 |
} |
|
| 120 | ||
| 121 | 26x |
x$choices <- .determine_choices(x$choices, data = data) # .determine_* uses names |
| 122 | 26x |
x$selected <- if (length(x$choices)) {
|
| 123 | 22x |
.determine_selected(x$selected, data = stats::setNames(x$choices, x$choices), multiple = attr(x, "multiple")) |
| 124 |
} |
|
| 125 | ||
| 126 |
# Only return max and minimal value |
|
| 127 | 26x |
if (is_ranged) {
|
| 128 | 12x |
if (!is.null(x$choices)) {
|
| 129 | 10x |
x$choices <- .as_ranged(x$choices) |
| 130 |
} |
|
| 131 | 12x |
if (!is.null(x$selected)) {
|
| 132 | 10x |
x$selected <- .as_ranged(range(x$selected, na.rm = TRUE)) |
| 133 |
} |
|
| 134 |
} |
|
| 135 | ||
| 136 | 26x |
list(x = x) # no picks element possible after picks(..., values) (no need to pass data further) |
| 137 |
} |
|
| 138 | ||
| 139 | ||
| 140 |
#' Evaluate delayed choices |
|
| 141 |
#' |
|
| 142 |
#' @param data (`list`, `data.frame`, `vector`) |
|
| 143 |
#' @param x (`character`, `quosure`, `function(x)`) to determine `data` elements to extract. |
|
| 144 |
#' @param multiple (`logical(1)`) whether multiple selection is possible. |
|
| 145 |
#' |
|
| 146 |
#' @details |
|
| 147 |
#' |
|
| 148 |
#' ## Various ways to evaluate choices/selected. |
|
| 149 |
#' |
|
| 150 |
#' Function resolves `x` to determine `choices` or `selected`. `x` is matched in multiple ways with |
|
| 151 |
#' `data` to return valid choices: |
|
| 152 |
#' - `x (character)`: values are matched with names of data and only intersection is returned. |
|
| 153 |
#' - `x (tidyselect-helper)`: using [tidyselect::eval_select] |
|
| 154 |
#' - `x (function)`: function is executed on each element of `data` to determine where function returns TRUE |
|
| 155 |
#' |
|
| 156 |
#' Mechanism is robust in a sense that it never fails (`tryCatch`) and returns `NULL` if no-match found. `NULL` |
|
| 157 |
#' in [determine()] is handled gracefully, by setting `NULL` to all following components of `picks`. |
|
| 158 |
#' |
|
| 159 |
#' In the examples below you can replace `.determine_delayed` with `.determine_choices` or `.determine_selected`. |
|
| 160 |
#' |
|
| 161 |
#' - `character`: refers to the object name in `data`, for example |
|
| 162 |
#' ``` |
|
| 163 |
#' .determine_delayed(data = iris, x = "Species") |
|
| 164 |
#' .determine_delayed(data = iris, x = c("Species", "inexisting"))
|
|
| 165 |
#' .determine_delayed(data = list2env(list(iris = iris, mtcars = mtcars)), x = "iris") |
|
| 166 |
#' ``` |
|
| 167 |
#' - `quosure`: delayed (quoted) `tidyselect-helper` to be evaluated through `tidyselect::eval_select`. For example |
|
| 168 |
#' ``` |
|
| 169 |
#' .determine_delayed(data = iris, x = rlang::quo(tidyselect::starts_with("Sepal")))
|
|
| 170 |
#' .determine_delayed(data = iris, x = rlang::quo(1:2)) |
|
| 171 |
#' .determine_delayed(data = iris, x = rlang::quo(Petal.Length:Sepal.Length)) |
|
| 172 |
#' ``` |
|
| 173 |
#' - `function(x)`: predicate function returning a logical flag. Evaluated for each `data` element. For example |
|
| 174 |
#' ``` |
|
| 175 |
#' |
|
| 176 |
#' .determine_delayed(data = iris, x = is.numeric) |
|
| 177 |
#' .determine_delayed(data = letters, x = function(x) x > "c") |
|
| 178 |
#' .determine_delayed(data = list2env(list(iris = iris, mtcars = mtcars, a = "a")), x = is.data.frame) |
|
| 179 |
#' ``` |
|
| 180 |
#' |
|
| 181 |
#' @return `character` containing names/levels of `data` elements which match `x`, with two differences: |
|
| 182 |
#' - `.determine_choices` returns vector named after data labels |
|
| 183 |
#' - `.determine_selected` cuts vector to scalar when `multiple = FALSE` |
|
| 184 |
#' |
|
| 185 |
#' @keywords internal |
|
| 186 |
.determine_choices <- function(x, data) {
|
|
| 187 | 197x |
out <- .determine_delayed(data = data, x = x) |
| 188 | 197x |
if (!is.null(names(data)) && !is.atomic(data) && is.character(out) && is.null(names(out))) {
|
| 189 |
# only named non-atomic can have label |
|
| 190 |
# don't rename if names provided by app dev |
|
| 191 | 133x |
labels <- vapply( |
| 192 | 133x |
out, |
| 193 | 133x |
FUN = function(choice) c(attr(data[[choice]], "label"), choice)[1], |
| 194 | 133x |
FUN.VALUE = character(1) |
| 195 |
) |
|
| 196 | 133x |
stats::setNames(out, labels) |
| 197 |
} else {
|
|
| 198 | 64x |
out |
| 199 |
} |
|
| 200 |
} |
|
| 201 | ||
| 202 |
#' @rdname dot-determine_choices |
|
| 203 |
.determine_selected <- function(x, data, multiple = FALSE) {
|
|
| 204 | 193x |
if (!is.null(x) && length(data)) {
|
| 205 | 192x |
out <- .determine_delayed(data = data, x = x) |
| 206 | 192x |
if (!isTRUE(multiple) && length(out) > 1) {
|
| 207 | 1x |
warning( |
| 208 | 1x |
"`multiple` has been set to `FALSE`, while selected contains multiple values, forcing to select first:", |
| 209 | 1x |
rlang::as_label(x) |
| 210 |
) |
|
| 211 | 1x |
out <- out[1] |
| 212 |
} |
|
| 213 | 192x |
out |
| 214 |
} |
|
| 215 |
} |
|
| 216 | ||
| 217 |
#' @rdname dot-determine_choices |
|
| 218 |
.determine_delayed <- function(x, data) {
|
|
| 219 | 389x |
if (length(dim(data)) == 2L) { # for example matrix
|
| 220 | 141x |
data <- as.data.frame(data) |
| 221 |
} |
|
| 222 | 389x |
out <- tryCatch( # app developer might provide failing function |
| 223 | 389x |
if (is.atomic(x) && length(x)) {
|
| 224 |
# don't need to evaluated eager choices - just make sure choices are subset of possible |
|
| 225 | 252x |
x[which(x %in% .possible_choices(data))] |
| 226 | 389x |
} else if (is.function(x)) {
|
| 227 | 46x |
if (inherits(x, "des-delayed")) {
|
| 228 | 2x |
x(data) |
| 229 |
} else {
|
|
| 230 | 44x |
idx_match <- unique(which(vapply(data, x, logical(1)))) |
| 231 | 44x |
.possible_choices(data[idx_match]) |
| 232 |
} |
|
| 233 | 389x |
} else if (rlang::is_quosure(x)) {
|
| 234 |
# app developer might provide failing function |
|
| 235 | 90x |
idx_match <- unique(tidyselect::eval_select(expr = x, data)) |
| 236 | 90x |
.possible_choices(data[idx_match]) |
| 237 |
}, |
|
| 238 | 389x |
error = function(e) NULL # not returning error to avoid design complication to handle errors |
| 239 |
) |
|
| 240 | ||
| 241 | 389x |
out <- out[!is.infinite(out)] |
| 242 | 389x |
out <- out[!is.na(out)] |
| 243 | ||
| 244 | 389x |
if (length(out) == 0) {
|
| 245 | 5x |
warning( |
| 246 | 5x |
"None of the `choices/selected`: ", rlang::as_label(x), "\n", |
| 247 | 5x |
"are subset of: ", toString(.possible_choices(data), width = 30), "\n", |
| 248 | 5x |
"Emptying choices..." |
| 249 |
) |
|
| 250 | 5x |
return(NULL) |
| 251 |
} |
|
| 252 |
# unique() for idx containing duplicated values |
|
| 253 | 384x |
if (is.atomic(out) && length(out)) out # this function should return atomic vector of length > 1 or NULL |
| 254 |
} |
|
| 255 | ||
| 256 |
#' @rdname dot-determine_choices |
|
| 257 |
.possible_choices <- function(data) {
|
|
| 258 | 391x |
if (is.factor(data)) {
|
| 259 | 6x |
levels(data) |
| 260 | 385x |
} else if (is.atomic(data)) {
|
| 261 | 46x |
unique(data) |
| 262 |
} else {
|
|
| 263 | 339x |
names(data) |
| 264 |
} |
|
| 265 |
} |
|
| 266 | ||
| 267 |
.extract <- function(x, data) {
|
|
| 268 | 203x |
if (length(x$selected) == 0) {
|
| 269 | 3x |
NULL # this nullifies following pick-elements. See determine (generic) |
| 270 | 200x |
} else if (length(x$selected) == 1 && inherits(x, "datasets")) {
|
| 271 | 124x |
data[[x$selected]] |
| 272 | 76x |
} else if (all(x$selected %in% names(data))) {
|
| 273 | 76x |
data[x$selected] |
| 274 |
} |
|
| 275 |
} |
|
| 276 | ||
| 277 |
.nullify_pick <- function(x) {
|
|
| 278 | 5x |
x$choices <- NULL |
| 279 | 5x |
x$selected <- NULL |
| 280 | 5x |
x |
| 281 |
} |
|
| 282 | ||
| 283 |
.range_without_warnings <- function(..., pattern = "no non-missing arguments to (min|max)") {
|
|
| 284 | ! |
withCallingHandlers( |
| 285 | ! |
range(...), |
| 286 | ! |
warning = function(w) {
|
| 287 | ! |
if (grepl(pattern, conditionMessage(w))) invokeRestart("muffleWarning")
|
| 288 |
} |
|
| 289 |
) |
|
| 290 |
} |
| 1 |
#' Convert data_extract_spec to picks |
|
| 2 |
#' |
|
| 3 |
#' @description |
|
| 4 |
#' `r lifecycle::badge("experimental")`
|
|
| 5 |
#' Helper functions to ease transition between [teal.transform::data_extract_spec()] and [picks()]. |
|
| 6 |
#' @inheritParams teal::teal_transform_module |
|
| 7 |
#' @param x (`data_extract_spec`, `select_spec`, `filter_spec`) object to convert to [`picks`] |
|
| 8 |
#' @param quiet (`logical(1)`) whether to suppress warnings about non-convertible elements. |
|
| 9 |
#' @details |
|
| 10 |
#' With introduction of [`picks`], [`data_extract_spec`] will no longer serve a primary tool to |
|
| 11 |
#' define variable choices and default selection in teal-modules and eventually [`data_extract_spec`] |
|
| 12 |
#' will be deprecated. |
|
| 13 |
#' To ease the transition to the new tool, we provide `as.picks` method which can handle 1:1 |
|
| 14 |
#' conversion from [`data_extract_spec`] to [`picks`]. Unfortunately, when [`data_extract_spec`] |
|
| 15 |
#' contains [`filter_spec`] then `as.picks` is unable to provide reliable [`picks`] equivalent. |
|
| 16 |
#' |
|
| 17 |
#' @examples |
|
| 18 |
#' # convert des with eager select_spec |
|
| 19 |
#' as.picks( |
|
| 20 |
#' teal.transform::data_extract_spec( |
|
| 21 |
#' dataname = "iris", |
|
| 22 |
#' teal.transform::select_spec( |
|
| 23 |
#' choices = c("Sepal.Length", "Sepal.Width", "Species"),
|
|
| 24 |
#' selected = c("Sepal.Length", "Species"),
|
|
| 25 |
#' multiple = TRUE, |
|
| 26 |
#' ordered = TRUE |
|
| 27 |
#' ) |
|
| 28 |
#' ) |
|
| 29 |
#' ) |
|
| 30 |
#' |
|
| 31 |
#' # convert des with delayed select_spec |
|
| 32 |
#' as.picks( |
|
| 33 |
#' teal.transform::data_extract_spec( |
|
| 34 |
#' dataname = "iris", |
|
| 35 |
#' teal.transform::select_spec( |
|
| 36 |
#' choices = teal.transform::variable_choices("iris"),
|
|
| 37 |
#' selected = teal.transform::first_choice(), |
|
| 38 |
#' multiple = TRUE, |
|
| 39 |
#' ordered = TRUE |
|
| 40 |
#' ) |
|
| 41 |
#' ) |
|
| 42 |
#' ) |
|
| 43 |
#' |
|
| 44 |
#' as.picks( |
|
| 45 |
#' teal.transform::data_extract_spec( |
|
| 46 |
#' dataname = "iris", |
|
| 47 |
#' teal.transform::select_spec( |
|
| 48 |
#' choices = teal.transform::variable_choices( |
|
| 49 |
#' "iris", |
|
| 50 |
#' subset = function(data) names(Filter(is.numeric, data)) |
|
| 51 |
#' ), |
|
| 52 |
#' selected = teal.transform::first_choice(), |
|
| 53 |
#' multiple = TRUE, |
|
| 54 |
#' ordered = TRUE |
|
| 55 |
#' ) |
|
| 56 |
#' ) |
|
| 57 |
#' ) |
|
| 58 |
#' |
|
| 59 |
#' @export |
|
| 60 |
as.picks <- function(x, quiet = FALSE) { # nolint: object_name_linter.
|
|
| 61 | 26x |
checkmate::assert_flag(quiet) |
| 62 | 26x |
if (inherits(x, c("picks", "pick"))) {
|
| 63 | ! |
x |
| 64 | 26x |
} else if (checkmate::test_list(x, c("data_extract_spec", "filter_spec"))) {
|
| 65 | 3x |
Filter(length, lapply(x, as.picks, quiet = quiet)) |
| 66 | 23x |
} else if (inherits(x, "data_extract_spec")) {
|
| 67 | 4x |
args <- Filter( |
| 68 | 4x |
length, |
| 69 | 4x |
list( |
| 70 | 4x |
datasets(choices = x$dataname, fixed = TRUE), |
| 71 | 4x |
as.picks(x$select, quiet = quiet), |
| 72 | 4x |
as.picks(x$filter, quiet = quiet) |
| 73 |
) |
|
| 74 |
) |
|
| 75 | 4x |
do.call(picks, args) |
| 76 | 19x |
} else if (inherits(x, "select_spec")) {
|
| 77 | 6x |
.select_spec_to_variables(x) |
| 78 | 13x |
} else if (inherits(x, "choices_selected")) {
|
| 79 | 2x |
.choices_selected_to_variables(x) |
| 80 | 11x |
} else if (inherits(x, "filter_spec") && !quiet) {
|
| 81 |
# filter_spec is necessary linked with `select` (selected variables) |
|
| 82 |
# so in most of the cases it can't beconverted into variables/values |
|
| 83 |
# because filter_spec can be specified on the variable(s) different than select_spec for example (pseudocode): |
|
| 84 |
# select_spec "AVAL" |
|
| 85 |
# filter_spec "PARAMCD" |
|
| 86 | 1x |
warning( |
| 87 | 1x |
"`filter_spec` are not convertible to picks - please use `transformers` argument", |
| 88 | 1x |
" and create `teal_transform_module` containing necessary filter. See `?teal_transform_filter`" |
| 89 |
) |
|
| 90 | ||
| 91 | 1x |
NULL |
| 92 | 10x |
} else if (!is.null(x) && !quiet) {
|
| 93 | 1x |
warning(sprintf("'%s' are not convertible to picks", class(x)[1]))
|
| 94 | 1x |
NULL |
| 95 |
} else {
|
|
| 96 | 9x |
NULL |
| 97 |
} |
|
| 98 |
} |
|
| 99 | ||
| 100 |
#' @rdname as.picks |
|
| 101 |
#' @examples |
|
| 102 |
#' # teal_transform_module build on teal.transform |
|
| 103 |
#' |
|
| 104 |
#' teal_transform_filter( |
|
| 105 |
#' teal.transform::data_extract_spec( |
|
| 106 |
#' dataname = "iris", |
|
| 107 |
#' filter = teal.transform::filter_spec( |
|
| 108 |
#' vars = "Species", |
|
| 109 |
#' choices = c("setosa", "versicolor", "virginica"),
|
|
| 110 |
#' selected = c("setosa", "versicolor")
|
|
| 111 |
#' ) |
|
| 112 |
#' ) |
|
| 113 |
#' ) |
|
| 114 |
#' |
|
| 115 |
#' teal_transform_filter( |
|
| 116 |
#' picks( |
|
| 117 |
#' datasets(choices = "iris", select = "iris"), |
|
| 118 |
#' variables(choices = "Species", "Species"), |
|
| 119 |
#' values( |
|
| 120 |
#' choices = c("setosa", "versicolor", "virginica"),
|
|
| 121 |
#' selected = c("setosa", "versicolor")
|
|
| 122 |
#' ) |
|
| 123 |
#' ) |
|
| 124 |
#' ) |
|
| 125 |
#' |
|
| 126 |
#' @export |
|
| 127 |
teal_transform_filter <- function(x, label = "Filter") {
|
|
| 128 | 5x |
checkmate::assert_multi_class(x, c("data_extract_spec", "picks"))
|
| 129 | 4x |
if (inherits(x, "data_extract_spec")) {
|
| 130 | 2x |
lapply(.as.picks.filter(x), teal_transform_filter, label = label) |
| 131 |
} else {
|
|
| 132 | 2x |
checkmate::assert_true("values" %in% names(x))
|
| 133 | 2x |
teal::teal_transform_module( |
| 134 | 2x |
label = label, |
| 135 | 2x |
ui = function(id) {
|
| 136 | 1x |
ns <- NS(id) |
| 137 | 1x |
picks_ui(ns("transformer"), picks = x, container = div)
|
| 138 |
}, |
|
| 139 | 2x |
server = function(id, data) {
|
| 140 | 1x |
shiny::moduleServer(id, function(input, output, session) {
|
| 141 | 1x |
selector <- picks_srv("transformer", picks = x, data = data)
|
| 142 | 1x |
shiny::reactive({
|
| 143 | 1x |
shiny::req(data(), selector()) |
| 144 | 1x |
filter_call <- .make_filter_call( |
| 145 | 1x |
datasets = selector()$datasets$selected, |
| 146 | 1x |
variables = selector()$variables$selected, |
| 147 | 1x |
values = selector()$values$selected |
| 148 |
) |
|
| 149 | 1x |
teal.code::eval_code(data(), filter_call) |
| 150 |
}) |
|
| 151 |
}) |
|
| 152 |
} |
|
| 153 |
) |
|
| 154 |
} |
|
| 155 |
} |
|
| 156 | ||
| 157 |
.as.picks.filter <- function(x, dataname) { # nolint: object_name_linter.
|
|
| 158 | 6x |
if (inherits(x, "filter_spec")) {
|
| 159 | 2x |
if (inherits(x$choices, "delayed_data")) {
|
| 160 | 1x |
warning( |
| 161 | 1x |
"teal.transform::filter_spec(choices) doesn't support delayed_data when using with teal_transform_filter. ", |
| 162 | 1x |
"Setting to all possible choices..." |
| 163 |
) |
|
| 164 | 1x |
x$choices <- function(x) TRUE |
| 165 |
} |
|
| 166 | 2x |
if (inherits(x$selected, "delayed_data")) {
|
| 167 | ! |
warning( |
| 168 | ! |
"teal.transform::filter_spec(selected) doesn't support delayed_data when using with teal_transform_filter. ", |
| 169 | ! |
"Setting to all possible choices..." |
| 170 |
) |
|
| 171 | ! |
x$selected <- function(x) TRUE |
| 172 |
} |
|
| 173 | 2x |
picks( |
| 174 | 2x |
datasets(choices = dataname, selected = dataname), |
| 175 | 2x |
variables(choices = x$vars_choices, selected = x$vars_selected, multiple = FALSE), # can't be multiple |
| 176 | 2x |
values(choices = x$choices, selected = x$selected, multiple = x$multiple) |
| 177 |
) |
|
| 178 | 4x |
} else if (checkmate::test_list(x, "filter_spec")) {
|
| 179 | 2x |
lapply(x, .as.picks.filter, dataname = dataname) |
| 180 | 2x |
} else if (inherits(x, "data_extract_spec")) {
|
| 181 | 2x |
.as.picks.filter(x$filter, dataname = x$dataname) |
| 182 | ! |
} else if (checkmate::test_list(x, c("data_extract_spec", "list", "NULL"))) {
|
| 183 | ! |
unlist( |
| 184 | ! |
lapply(Filter(length, x), .as.picks.filter), |
| 185 | ! |
recursive = FALSE |
| 186 |
) |
|
| 187 |
} |
|
| 188 |
} |
|
| 189 | ||
| 190 |
.make_filter_call <- function(datasets, variables, values) {
|
|
| 191 | 1x |
checkmate::assert_character(datasets) |
| 192 | 1x |
checkmate::assert_character(variables) |
| 193 | 1x |
checkmate::assert_character(values) |
| 194 | 1x |
substitute( |
| 195 | 1x |
dataname <- dplyr::filter(dataname, varname %in% values), # nolint: object_usage_linter. |
| 196 | 1x |
list( |
| 197 | 1x |
dataname = as.name(datasets), |
| 198 | 1x |
varname = if (length(variables) == 1) {
|
| 199 | 1x |
as.name(variables) |
| 200 |
} else {
|
|
| 201 | ! |
as.call( |
| 202 | ! |
c( |
| 203 | ! |
quote(paste), |
| 204 | ! |
lapply(variables, as.name), |
| 205 | ! |
list(sep = ", ") |
| 206 |
) |
|
| 207 |
) |
|
| 208 |
}, |
|
| 209 | 1x |
values = values |
| 210 |
) |
|
| 211 |
) |
|
| 212 |
} |
|
| 213 | ||
| 214 |
.select_spec_to_variables <- function(x) {
|
|
| 215 | 8x |
if (length(x)) {
|
| 216 | 8x |
args <- list( |
| 217 | 8x |
choices = if (inherits(x$choices, "delayed_data")) {
|
| 218 | 3x |
out <- x$choices$subset |
| 219 | 3x |
if (is.null(out)) {
|
| 220 | 1x |
function(x) TRUE # same effect as tidyselect::everything |
| 221 |
} else {
|
|
| 222 | 2x |
class(out) <- "des-delayed" |
| 223 | 2x |
out |
| 224 |
} |
|
| 225 |
} else {
|
|
| 226 | 5x |
x$choices |
| 227 |
}, |
|
| 228 | 8x |
selected = if (inherits(x$selected, "delayed_choices")) {
|
| 229 | ! |
out <- x$selected |
| 230 | ! |
class(out) <- "des-delayed" |
| 231 | ! |
out |
| 232 | 8x |
} else if (inherits(x$selected, "delayed_data")) {
|
| 233 | 3x |
out <- x$selected$subset |
| 234 | 3x |
if (is.null(out)) {
|
| 235 | 1x |
1L |
| 236 |
} else {
|
|
| 237 | 2x |
class(out) <- "des-delayed" |
| 238 | 2x |
out |
| 239 |
} |
|
| 240 |
} else {
|
|
| 241 | 5x |
unname(x$selected) |
| 242 |
}, |
|
| 243 | 8x |
ordered = x$ordered, |
| 244 | 8x |
multiple = x$multiple, |
| 245 | 8x |
fixed = x$fixed |
| 246 |
) |
|
| 247 | 8x |
if (is.null(args$ordered)) { # Must be logical or missing for variables() to set default value
|
| 248 | 2x |
args <- args[names(args) != c("ordered")]
|
| 249 |
} |
|
| 250 | 8x |
do.call(variables, args) |
| 251 |
} |
|
| 252 |
} |
|
| 253 | ||
| 254 |
.choices_selected_to_variables <- function(x) {
|
|
| 255 | 2x |
x$choices <- as.character(x$choices) |
| 256 | 1x |
if (!is.null(x$selected)) x$selected <- as.character(x$selected) |
| 257 | 2x |
.select_spec_to_variables(x) |
| 258 |
} |
| 1 |
#' Declare interaction variable pairs for `tidyselect` |
|
| 2 |
#' |
|
| 3 |
#' Used inside `tidyselect` expressions to declare a pair of variables that |
|
| 4 |
#' interact with each other. The pair is recorded in the selection environment |
|
| 5 |
#' and the positions of both variables within the available variables are |
|
| 6 |
#' returned. |
|
| 7 |
#' |
|
| 8 |
#' @param var1 An unquoted variable name. |
|
| 9 |
#' @param var2 An unquoted variable name that interacts with `var1`. |
|
| 10 |
#' @param vars Character vector of available variable names, retrieved |
|
| 11 |
#' automatically via [tidyselect::peek_vars()]. |
|
| 12 |
#' |
|
| 13 |
#' @return An integer vector of length 2 giving the positions of `var1` and |
|
| 14 |
#' `var2` in `vars`, or `NA` where a variable is not found. |
|
| 15 |
#' |
|
| 16 |
#' @export |
|
| 17 |
interaction_vars <- function(var1, var2, vars = tidyselect::peek_vars(fn = "interaction_vars")) {
|
|
| 18 | 3x |
new_var <- c(as.character(substitute(var1)), as.character(substitute(var2))) |
| 19 | 3x |
result <- match(new_var, vars) |
| 20 | 3x |
if (isTRUE(select_env$active)) { # Only set operators under `teal.picks` evaluation context
|
| 21 | 2x |
new_operator <- structure( |
| 22 | 2x |
new_var, |
| 23 | 2x |
class = c("interaction", "operator"),
|
| 24 | 2x |
var_name = sprintf("%s:%s", new_var[[1]], new_var[[2]])
|
| 25 |
) |
|
| 26 | 2x |
select_env$operators <- select_env$operators %||% list() |
| 27 | 2x |
select_env$operators[[length(select_env$operators) + 1]] <- new_operator |
| 28 |
} else {
|
|
| 29 | 1x |
warning( |
| 30 | 1x |
"interaction_vars() should only be used within a tidyselect context in teal.picks.", |
| 31 | 1x |
" The interaction will not be recorded, and the variables will be treated as independent.", |
| 32 | 1x |
call. = FALSE |
| 33 |
) |
|
| 34 |
} |
|
| 35 | 3x |
result |
| 36 |
} |
|
| 37 | ||
| 38 |
.operator_mutate <- function(x, new_choice, data) {
|
|
| 39 | ! |
UseMethod(".operator_mutate")
|
| 40 |
} |
|
| 41 | ||
| 42 |
#' @method .operator_mutate interaction |
|
| 43 |
#' @keywords internal |
|
| 44 |
.operator_mutate.interaction <- function(x, new_choice, data) {
|
|
| 45 | ! |
checkmate::assert_character(x, len = 2) |
| 46 | ! |
checkmate::assert_string(new_choice) |
| 47 | ! |
checkmate::assert_data_frame(data) |
| 48 | ! |
dplyr::mutate( |
| 49 | ! |
data, |
| 50 | ! |
!!new_choice := rlang::eval_bare(.operator_mutate_args(x)) |
| 51 |
) |
|
| 52 |
} |
|
| 53 | ||
| 54 |
#' @method call_condition_operators interaction |
|
| 55 |
#' @keywords internal |
|
| 56 |
call_condition_operators.interaction <- function(x, choices) {
|
|
| 57 | ! |
checkmate::assert_character(x, len = 2) |
| 58 | ! |
checkmate::assert_character(choices) |
| 59 | ! |
as.call( |
| 60 | ! |
list( |
| 61 | ! |
quote(`%in%`), |
| 62 | ! |
as.call( |
| 63 | ! |
list(quote(paste), as.name(x[1]), as.name(x[2]), sep = ":") |
| 64 |
), |
|
| 65 | ! |
unname(choices) |
| 66 |
) |
|
| 67 |
) |
|
| 68 |
} |
|
| 69 | ||
| 70 |
call_condition_operators <- function(x, choices) {
|
|
| 71 | ! |
UseMethod("call_condition_operators")
|
| 72 |
} |
|
| 73 | ||
| 74 |
.operator_mutate_args <- function(x) {
|
|
| 75 | ! |
UseMethod(".operator_mutate_args")
|
| 76 |
} |
|
| 77 | ||
| 78 |
#' @method .operator_mutate interaction |
|
| 79 |
#' @keywords internal |
|
| 80 |
.operator_mutate_args.interaction <- function(x) {
|
|
| 81 | ! |
checkmate::assert_character(x, len = 2) |
| 82 | ! |
as.call(c(list(quote(paste)), lapply(x, as.name), list(sep = ":"))) |
| 83 |
} |
|
| 84 | ||
| 85 | ||
| 86 |
# Environment to store interaction variable pairs during `tidyselect` evaluation |
|
| 87 |
# This is used to communicate between the `interaction_vars()` function and the resolver that |
|
| 88 |
# processes the picks with variables that interact. |
|
| 89 |
# The resolver will look for this information in the environment to know which variables are |
|
| 90 |
# meant to interact and need to be combined in the data. |
|
| 91 |
select_env <- new.env(parent = emptyenv()) |
|
| 92 | ||
| 93 |
.is_operator_selected <- function(operators, x) {
|
|
| 94 | ! |
if (length(operators) == 0L || length(x) == 0L) {
|
| 95 | ! |
return(FALSE) |
| 96 |
} |
|
| 97 | ! |
any(vapply(operators, attr, "var_name", FUN.VALUE = character(1L), USE.NAMES = FALSE) %in% x) |
| 98 |
} |
| 1 |
#' Merge Server Function for Dataset Integration |
|
| 2 |
#' |
|
| 3 |
#' @description |
|
| 4 |
#' `merge_srv` is a powerful Shiny server function that orchestrates the merging of multiple datasets |
|
| 5 |
#' based on user selections from `picks` objects. It creates a reactive merged dataset (`teal_data` object) |
|
| 6 |
#' and tracks which variables from each selector are included in the final merged output. |
|
| 7 |
#' |
|
| 8 |
#' This function serves as the bridge between user interface selections (managed by selectors) and |
|
| 9 |
#' the actual data merging logic. It automatically handles: |
|
| 10 |
#' - Dataset joining based on join keys |
|
| 11 |
#' - Variable selection and renaming to avoid conflicts |
|
| 12 |
#' - Reactive updates when user selections change |
|
| 13 |
#' - Generation of reproducible R code for the merge operation |
|
| 14 |
#' |
|
| 15 |
#' @param id (`character(1)`) Module ID for the Shiny module namespace |
|
| 16 |
#' @param data (`reactive`) A reactive expression returning a [teal.data::teal_data] object containing |
|
| 17 |
#' the source datasets to be merged. This object must have join keys defined via |
|
| 18 |
#' [teal.data::join_keys()] to enable proper dataset relationships. |
|
| 19 |
#' @param selectors (`named list`) A named list of selector objects. Each element can be: |
|
| 20 |
#' - A `picks` object defining dataset and variable selections |
|
| 21 |
#' - A `reactive` expression returning a `picks` object |
|
| 22 |
#' The names of this list are used as identifiers for tracking which variables come from which selector. |
|
| 23 |
#' @param output_name (`character(1)`) Name of the merged dataset that will be created in the |
|
| 24 |
#' returned `teal_data` object. Default is `"anl"`. This name will be used in the generated R code. |
|
| 25 |
#' @param join_fun (`character(1)`) The joining function to use for merging datasets. Must be a |
|
| 26 |
#' qualified function name (e.g., `"dplyr::left_join"`, `"dplyr::inner_join"`, `"dplyr::full_join"`). |
|
| 27 |
#' Default is `"dplyr::inner_join"`. The function must accept `by` and `suffix` parameters. |
|
| 28 |
#' |
|
| 29 |
#' @return A `list` with two reactive elements: |
|
| 30 |
#' - `data`A `reactive` returning a [teal.data::teal_data] object containing the merged dataset. |
|
| 31 |
#' The merged dataset is named according to `output_name` parameter. The `teal_data` object includes: |
|
| 32 |
#' - The merged dataset with all selected variables |
|
| 33 |
#' - Complete R code to reproduce the merge operation |
|
| 34 |
#' - Updated join keys reflecting the merged dataset structure |
|
| 35 |
#' - `variables` A `reactive` returning a named list mapping selector names to their selected |
|
| 36 |
#' variables in the merged dataset. The structure is: |
|
| 37 |
#' `list(selector_name_1 = c("var1", "var2"), selector_name_2 = c("var3", "var4"), ...)`.
|
|
| 38 |
#' Variable names reflect any renaming that occurred during the merge to avoid conflicts. |
|
| 39 |
#' |
|
| 40 |
#' @section How It Works: |
|
| 41 |
#' |
|
| 42 |
#' The `merge_srv` function performs the following steps: |
|
| 43 |
#' |
|
| 44 |
#' 1. **Receives Input Data**: Takes a reactive `teal_data` object containing source datasets with |
|
| 45 |
#' defined join keys |
|
| 46 |
#' |
|
| 47 |
#' 2. **Processes Selectors**: Evaluates each selector (whether static `picks` or reactive) to |
|
| 48 |
#' determine which datasets and variables are selected |
|
| 49 |
#' |
|
| 50 |
#' 3. **Determines Merge Order**: Uses topological sort based on the `join_keys` to determine |
|
| 51 |
#' the optimal order for merging datasets. |
|
| 52 |
#' |
|
| 53 |
#' 4. **Handles Variable Conflicts**: Automatically renames variables when: |
|
| 54 |
#' - Multiple selectors choose variables with the same name from different datasets |
|
| 55 |
#' - Foreign key variables would conflict with existing variables |
|
| 56 |
#' - Renaming follows the pattern `{column-name}_{dataset-name}`
|
|
| 57 |
#' |
|
| 58 |
#' 5. **Performs Merge**: Generates and executes merge code that: |
|
| 59 |
#' - Selects only required variables from each dataset |
|
| 60 |
#' - Applies any filters defined in selectors |
|
| 61 |
#' - Joins datasets using specified join function and join keys |
|
| 62 |
#' - Maintains reproducibility through generated R code |
|
| 63 |
#' |
|
| 64 |
#' 6. **Updates Join Keys**: Creates new join key relationships for the merged dataset (`"anl"`) |
|
| 65 |
#' relative to remaining datasets in the `teal_data` object |
|
| 66 |
#' |
|
| 67 |
#' 7. **Tracks Variables**: Keeps track of the variable names in the merged dataset |
|
| 68 |
#' |
|
| 69 |
#' @section Usage Pattern: |
|
| 70 |
#' |
|
| 71 |
#' ```r |
|
| 72 |
#' # In your Shiny server function |
|
| 73 |
#' merged <- merge_srv( |
|
| 74 |
#' id = "merge", |
|
| 75 |
#' data = shiny::reactive(my_teal_data), |
|
| 76 |
#' selectors = list( |
|
| 77 |
#' selector1 = picks(...), |
|
| 78 |
#' selector2 = shiny::reactive(picks(...)) |
|
| 79 |
#' ), |
|
| 80 |
#' output_name = "anl", |
|
| 81 |
#' join_fun = "dplyr::left_join" |
|
| 82 |
#' ) |
|
| 83 |
#' |
|
| 84 |
#' # Access merged data |
|
| 85 |
#' merged_data <- merged$data() # teal_data object with merged dataset |
|
| 86 |
#' anl <- merged_data[["anl"]] # The actual merged data.frame/tibble |
|
| 87 |
#' |
|
| 88 |
#' # Get variable mapping |
|
| 89 |
#' vars <- merged$variables() |
|
| 90 |
#' # Returns: list(selector1 = c("VAR1", "VAR2"), selector2 = c("VAR3", "VAR4_ADSL"))
|
|
| 91 |
#' |
|
| 92 |
#' # Get reproducible code |
|
| 93 |
#' code <- teal.code::get_code(merged_data) |
|
| 94 |
#' ``` |
|
| 95 |
#' |
|
| 96 |
#' @section Merge Logic Details: |
|
| 97 |
#' |
|
| 98 |
#' **Dataset Order**: Datasets are merged in topological order based on join keys. The first dataset |
|
| 99 |
#' acts as the "left" side of the join, and subsequent datasets are joined one by one. |
|
| 100 |
#' |
|
| 101 |
#' **Join Keys**: The function uses join keys from the source `teal_data` object to determine: |
|
| 102 |
#' - Which datasets can be joined together |
|
| 103 |
#' - Which columns to use for joining (the `by` parameter) |
|
| 104 |
#' - Whether datasets need intermediate joins (not yet implemented) |
|
| 105 |
#' |
|
| 106 |
#' **Variable Selection**: For each dataset being merged: |
|
| 107 |
#' - Selects user-chosen variables from selectors |
|
| 108 |
#' - Includes foreign key variables needed for joining (even if not explicitly selected) |
|
| 109 |
#' - Removes duplicate foreign keys after join (they're already in the left dataset) |
|
| 110 |
#' |
|
| 111 |
#' **Conflict Resolution**: When variable names conflict: |
|
| 112 |
#' - Variables from later datasets get suffixed with `_dataname` |
|
| 113 |
#' - Foreign keys that match are merged (not duplicated) |
|
| 114 |
#' - The mapping returned in `merge_vars` reflects the final names |
|
| 115 |
#' |
|
| 116 |
#' @section Integration with Selectors: |
|
| 117 |
#' |
|
| 118 |
#' `merge_srv` is designed to work with [picks_srv()] which creates selector objects: |
|
| 119 |
#' |
|
| 120 |
#' ```r |
|
| 121 |
#' # Create selectors in server |
|
| 122 |
#' selectors <- picks_srv( |
|
| 123 |
#' picks = list( |
|
| 124 |
#' adsl = picks(...), |
|
| 125 |
#' adae = picks(...) |
|
| 126 |
#' ), |
|
| 127 |
#' data = data |
|
| 128 |
#' ) |
|
| 129 |
#' |
|
| 130 |
#' # Pass to merge_srv |
|
| 131 |
#' merged <- merge_srv( |
|
| 132 |
#' id = "merge", |
|
| 133 |
#' data = data, |
|
| 134 |
#' selectors = selectors |
|
| 135 |
#' ) |
|
| 136 |
#' ``` |
|
| 137 |
#' |
|
| 138 |
#' @seealso |
|
| 139 |
#' - [picks_srv()] for creating selectors |
|
| 140 |
#' - [teal.data::join_keys()] for defining dataset relationships |
|
| 141 |
#' |
|
| 142 |
#' @examples |
|
| 143 |
#' # Complete example with CDISC data |
|
| 144 |
#' library(teal.picks) |
|
| 145 |
#' library(teal.data) |
|
| 146 |
#' library(shiny) |
|
| 147 |
#' |
|
| 148 |
#' # Prepare data with join keys |
|
| 149 |
#' data <- teal_data() |
|
| 150 |
#' data <- within(data, {
|
|
| 151 |
#' ADSL <- teal.data::rADSL |
|
| 152 |
#' ADAE <- teal.data::rADAE |
|
| 153 |
#' }) |
|
| 154 |
#' join_keys(data) <- default_cdisc_join_keys[c("ADSL", "ADAE")]
|
|
| 155 |
#' |
|
| 156 |
#' # Create Shiny app |
|
| 157 |
#' ui <- fluidPage( |
|
| 158 |
#' picks_ui("adsl", picks(datasets("ADSL"), variables())),
|
|
| 159 |
#' picks_ui("adae", picks(datasets("ADAE"), variables())),
|
|
| 160 |
#' verbatimTextOutput("code"),
|
|
| 161 |
#' verbatimTextOutput("vars")
|
|
| 162 |
#' ) |
|
| 163 |
#' |
|
| 164 |
#' server <- function(input, output, session) {
|
|
| 165 |
#' # Create selectors |
|
| 166 |
#' selectors <- list( |
|
| 167 |
#' adsl = picks_srv("adsl",
|
|
| 168 |
#' data = shiny::reactive(data), |
|
| 169 |
#' picks = picks(datasets("ADSL"), variables())
|
|
| 170 |
#' ), |
|
| 171 |
#' adae = picks_srv("adae",
|
|
| 172 |
#' data = shiny::reactive(data), |
|
| 173 |
#' picks = picks(datasets("ADAE"), variables())
|
|
| 174 |
#' ) |
|
| 175 |
#' ) |
|
| 176 |
#' |
|
| 177 |
#' # Merge datasets |
|
| 178 |
#' merged <- merge_srv( |
|
| 179 |
#' id = "merge", |
|
| 180 |
#' data = shiny::reactive(data), |
|
| 181 |
#' selectors = selectors, |
|
| 182 |
#' output_name = "anl", |
|
| 183 |
#' join_fun = "dplyr::left_join" |
|
| 184 |
#' ) |
|
| 185 |
#' |
|
| 186 |
#' # Display results |
|
| 187 |
#' output$code <- renderPrint({
|
|
| 188 |
#' cat(teal.code::get_code(merged$data())) |
|
| 189 |
#' }) |
|
| 190 |
#' |
|
| 191 |
#' output$vars <- renderPrint({
|
|
| 192 |
#' merged$variables() |
|
| 193 |
#' }) |
|
| 194 |
#' } |
|
| 195 |
#' if (interactive()) {
|
|
| 196 |
#' shinyApp(ui, server) |
|
| 197 |
#' } |
|
| 198 |
#' |
|
| 199 |
#' @export |
|
| 200 |
merge_srv <- function(id, |
|
| 201 |
data, |
|
| 202 |
selectors, |
|
| 203 |
output_name = "anl", |
|
| 204 |
join_fun = "dplyr::inner_join") {
|
|
| 205 | 31x |
checkmate::assert_list(selectors, "reactive", names = "named") |
| 206 | 29x |
checkmate::assert_class(data, "reactive") |
| 207 | 28x |
checkmate::assert_string(output_name) |
| 208 | 28x |
checkmate::assert_string(join_fun) |
| 209 | 28x |
shiny::moduleServer(id, function(input, output, session) {
|
| 210 |
# selectors is a list of reactive picks. |
|
| 211 | 28x |
selectors_unwrapped <- shiny::reactive({
|
| 212 | 24x |
lapply(selectors, function(x) shiny::req(x())) |
| 213 |
}) |
|
| 214 | ||
| 215 | 28x |
data_r <- shiny::reactive({
|
| 216 | 23x |
shiny::req(data(), selectors_unwrapped()) |
| 217 | 23x |
.qenv_merge( |
| 218 | 23x |
data(), |
| 219 | 23x |
selectors = selectors_unwrapped(), |
| 220 | 23x |
output_name = output_name, |
| 221 | 23x |
join_fun = join_fun |
| 222 |
) |
|
| 223 |
}) |
|
| 224 | ||
| 225 | 28x |
variables_selected <- shiny::eventReactive( |
| 226 | 28x |
selectors_unwrapped(), |
| 227 |
{
|
|
| 228 | 11x |
shiny::req(selectors_unwrapped()) |
| 229 | 11x |
lapply( |
| 230 | 11x |
.merge_summary_list(selectors_unwrapped(), join_keys = teal.data::join_keys(data()))$mapping, |
| 231 | 11x |
function(selector) unname(selector$variables) |
| 232 |
) |
|
| 233 |
} |
|
| 234 |
) |
|
| 235 | ||
| 236 | 28x |
list(data = data_r, variables = variables_selected) |
| 237 |
}) |
|
| 238 |
} |
|
| 239 | ||
| 240 | ||
| 241 |
#' @keywords internal |
|
| 242 |
.qenv_merge <- function(x, |
|
| 243 |
selectors, |
|
| 244 |
output_name = "anl", |
|
| 245 |
join_fun = "dplyr::left_join") {
|
|
| 246 | 23x |
checkmate::assert_class(x, "teal_data") |
| 247 | 23x |
checkmate::assert_list(selectors, "picks", names = "named") |
| 248 | 23x |
checkmate::assert_string(join_fun) |
| 249 | ||
| 250 |
# Early validation of merge keys between datasets |
|
| 251 | 23x |
merge_summary <- .merge_summary_list(selectors, join_keys = teal.data::join_keys(x)) |
| 252 | ||
| 253 | 20x |
expr <- .merge_expr(merge_summary = merge_summary, output_name = output_name, join_fun = join_fun, x = x) |
| 254 | ||
| 255 | 20x |
merged_q <- teal.code::eval_code(x, expr) |
| 256 | 20x |
teal.data::join_keys(merged_q) <- merge_summary$join_keys |
| 257 | 20x |
merged_q |
| 258 |
} |
|
| 259 | ||
| 260 | ||
| 261 |
#' @keywords internal |
|
| 262 |
.merge_expr <- function(merge_summary, |
|
| 263 |
output_name = "anl", |
|
| 264 |
join_fun = "dplyr::left_join", |
|
| 265 |
x) {
|
|
| 266 | 20x |
checkmate::assert_list(merge_summary) |
| 267 | 20x |
checkmate::assert_string(output_name) |
| 268 | 20x |
checkmate::assert_string(join_fun) |
| 269 | ||
| 270 | 20x |
join_keys <- merge_summary$join_keys |
| 271 | 20x |
mapping <- merge_summary$mapping |
| 272 | 20x |
mapping <- lapply(mapping, function(x) {
|
| 273 |
# because we need `$new_name = $old_name` to rename in select call |
|
| 274 | 35x |
x$variables <- stats::setNames(names(x$variables), unname(x$variables)) |
| 275 | 35x |
x |
| 276 |
}) |
|
| 277 | 20x |
datanames <- unique(unlist(lapply(mapping, `[[`, "datasets"))) |
| 278 | ||
| 279 | 20x |
datasets_vars <- .mapping_input_to_datasets(mapping) |
| 280 | ||
| 281 | 20x |
calls <- expression() |
| 282 | 20x |
anl_datanames <- character(0) # to follow what anl is composed of (to determine keys) |
| 283 | 20x |
anl_primary_keys <- character(0) # to determine accumulated keys of anl |
| 284 | 20x |
for (i in seq_along(datanames)) {
|
| 285 | 31x |
dataname <- datanames[i] |
| 286 | 31x |
selectors_dataset <- Filter(function(x) {
|
| 287 | 71x |
x$datasets == dataname |
| 288 | 31x |
}, mapping) |
| 289 | 31x |
this_mapping <- datasets_vars[[dataname]] |
| 290 | ||
| 291 | 31x |
this_foreign_keys <- .fk(join_keys, dataname) |
| 292 | 31x |
this_primary_keys <- join_keys[dataname, dataname] |
| 293 | 31x |
this_variables <- if (length(this_foreign_keys) == 0L) {
|
| 294 | 14x |
union(this_primary_keys, this_mapping$variables) |
| 295 |
} else {
|
|
| 296 | 17x |
union(this_foreign_keys, this_mapping$variables) |
| 297 |
} |
|
| 298 | 31x |
this_variables <- this_variables[!duplicated(unname(this_variables))] # because unique drops names |
| 299 | 31x |
operators <- attr(this_mapping, "operators", exact = TRUE) |
| 300 | 31x |
operators_names <- vapply(operators, attr, which = "var_name", FUN.VALUE = character(1)) |
| 301 | 31x |
operators_ix <- this_variables %in% operators_names |
| 302 | 31x |
this_call <- if (any(operators_ix)) {
|
| 303 | ! |
.call_mutate_operators(this_variables, operators_ix, dataname, operators) |
| 304 |
} else {
|
|
| 305 | 31x |
.call_dplyr_select(dataname = dataname, variables = this_variables) |
| 306 |
} |
|
| 307 | ||
| 308 |
# Update data with operators to determine filtering on interaction variables |
|
| 309 | 31x |
for (ix in which(operators_names %in% this_variables)) {
|
| 310 | ! |
x <- teal.code::eval_code( |
| 311 | ! |
x, |
| 312 | ! |
substitute( |
| 313 | ! |
obj_name <- .operator_mutate(cols, var_name, obj_name), # nolint: object_usage_linter. |
| 314 | ! |
env = list( |
| 315 | ! |
cols = operators[[ix]], |
| 316 | ! |
var_name = attr(operators[[ix]], "var_name", TRUE), |
| 317 | ! |
obj_name = as.name(dataname) |
| 318 |
) |
|
| 319 |
) |
|
| 320 |
) |
|
| 321 |
} |
|
| 322 | ||
| 323 | 31x |
selector_filter_dataset <- lapply(selectors_dataset, .trim_filter_mapping, dataname = dataname, data = x) |
| 324 | 31x |
filter_datset_value <- vapply(selector_filter_dataset, function(x) {
|
| 325 | 35x |
!is.null(x$values) |
| 326 | 31x |
}, TRUE) |
| 327 | 31x |
selector_filter_dataset <- selector_filter_dataset[filter_datset_value & lengths(selector_filter_dataset) > 1L] |
| 328 | ||
| 329 | 31x |
if (length(selector_filter_dataset)) {
|
| 330 | 10x |
this_call <- calls_combine_by("%>%", c(this_call, .call_dplyr_filter(selector_filter_dataset)))
|
| 331 |
} |
|
| 332 | ||
| 333 | 31x |
if (i > 1) {
|
| 334 | 11x |
anl_vs_this <- setdiff(anl_primary_keys, this_primary_keys) |
| 335 | 11x |
this_vs_anl <- setdiff(this_primary_keys, anl_primary_keys) |
| 336 | 11x |
if (length(anl_vs_this) && length(this_vs_anl)) {
|
| 337 | ! |
warning("cartesian join - happens when primary keys A is not a subset of B and B is not a subset of A")
|
| 338 |
} |
|
| 339 | 11x |
this_call <- as.call( |
| 340 | 11x |
list( |
| 341 | 11x |
str2lang(join_fun), |
| 342 | 11x |
y = this_call, |
| 343 | 11x |
by = join_keys["anl", dataname], |
| 344 | 11x |
suffix = c("", sprintf("_%s", dataname))
|
| 345 |
) |
|
| 346 |
) |
|
| 347 |
} |
|
| 348 | ||
| 349 | 31x |
anl_datanames <- c(anl_datanames, dataname) |
| 350 | 31x |
anl_primary_keys <- union(anl_primary_keys, this_primary_keys) |
| 351 | 31x |
calls <- c(calls, this_call) |
| 352 |
} |
|
| 353 | ||
| 354 | 20x |
call("<-", str2lang(output_name), calls_combine_by("%>%", calls))
|
| 355 |
} |
|
| 356 | ||
| 357 | ||
| 358 |
#' Analyse selectors and concludes a merge parameters |
|
| 359 |
#' |
|
| 360 |
#' @return list containing: |
|
| 361 |
#' - mapping (`named list`) containing selected values in each selector. This `mapping` |
|
| 362 |
#' is sorted according to correct datasets merge order. `variables` contains names of the |
|
| 363 |
#' variables in `ANL` |
|
| 364 |
#' - join_keys (`join_keys`) updated `join_keys` containing keys of `ANL` |
|
| 365 |
#' |
|
| 366 |
#' @keywords internal |
|
| 367 |
.merge_summary_list <- function(selectors, join_keys) {
|
|
| 368 | 34x |
checkmate::assert_list(selectors, "picks") |
| 369 | 34x |
checkmate::assert_class(join_keys, "join_keys") |
| 370 | ||
| 371 | 34x |
.validate_is_eager(selectors) |
| 372 | 32x |
.validate_join_keys(selectors, join_keys) |
| 373 | ||
| 374 | 28x |
mapping <- lapply( # what has been selected in each selector |
| 375 | 28x |
selectors, |
| 376 | 28x |
function(selector) {
|
| 377 | 55x |
result <- lapply(selector, function(x) {
|
| 378 | 123x |
stats::setNames(x$selected, x$selected) |
| 379 |
}) |
|
| 380 | 55x |
result$operators <- selector$variables$operators |
| 381 | 55x |
result |
| 382 |
} |
|
| 383 |
) |
|
| 384 | ||
| 385 | 28x |
mapped_datanames <- unlist(lapply(mapping, `[[`, "datasets"), use.names = FALSE) |
| 386 | 28x |
mapping_by_dataset <- split(mapping, mapped_datanames) |
| 387 | ||
| 388 | 28x |
datanames <- unique(mapped_datanames) |
| 389 | 28x |
if (length(datanames) > 1) {
|
| 390 |
# datanames are handed over in order of selectors but |
|
| 391 |
# they must be in topological order - otherwise join might not be possible |
|
| 392 | 10x |
datanames <- c( |
| 393 | 10x |
intersect(names(join_keys), datanames), # join_keys are in topological order |
| 394 | 10x |
setdiff(datanames, names(join_keys)) # non-joinable datasets at the end |
| 395 |
) |
|
| 396 | ||
| 397 |
# mapping will be reused so needs to be reordered as well |
|
| 398 | 10x |
mapping <- mapping[order(match(mapped_datanames, datanames))] |
| 399 |
} |
|
| 400 | 28x |
remaining_datanames <- datanames |
| 401 | 28x |
join_keys <- join_keys[datanames] |
| 402 | 28x |
anl_colnames <- character(0) |
| 403 | 28x |
for (dataname in datanames) {
|
| 404 |
# glossary: |
|
| 405 |
# dataset/dataname: dataset (or its name) in the current iteration (datasets are merged in a loop) |
|
| 406 |
# anl datasets/datanames: datasets (or names) which anl is composed of (this is a cumulative process) |
|
| 407 |
# remaining datasets/datanames: datasets (or names) which are about to be merged |
|
| 408 |
# |
|
| 409 |
# Rules: |
|
| 410 |
# 1. anl "inherits" foreign keys from anl datasets to remaining datasets |
|
| 411 |
# 2. foreign keys of current dataset are added to anl join_keys but only if no relation from anl already. |
|
| 412 |
# 3. foreign keys should be renamed if duplicated with anl colnames |
|
| 413 |
# 4. (for later) selected datasets might not be directly mergable, we need to find the "path" which |
|
| 414 |
# will probably involve add intermediate datasets in between to perform merge |
|
| 415 |
# 5. selected variables are added to anl. |
|
| 416 |
# 6. duplicated variables added to anl should be renamed |
|
| 417 | 46x |
remaining_datanames <- setdiff(remaining_datanames, dataname) |
| 418 | ||
| 419 |
# ↓ 1. anl "inherits" foreign keys from anl datasets to remaining datasets |
|
| 420 | 46x |
this_join_keys <- do.call( |
| 421 | 46x |
teal.data::join_keys, |
| 422 | 46x |
lapply( |
| 423 | 46x |
remaining_datanames, |
| 424 | 46x |
function(dataset_2) {
|
| 425 | 29x |
new_keys <- join_keys[dataname, dataset_2] |
| 426 |
# ↓ 2. foreign keys of current dataset are added to anl join_keys but only if no relation from anl already |
|
| 427 | 29x |
if (length(new_keys) && !dataset_2 %in% names(join_keys[["anl"]])) {
|
| 428 |
# ↓ 3. foreign keys should be renamed if duplicated with anl colnames |
|
| 429 | 18x |
new_key_names <- .suffix_duplicated_vars( |
| 430 | 18x |
vars = names(new_keys), # names because we change the key of dataset_1 (not dataset_2) |
| 431 | 18x |
all_vars = anl_colnames, |
| 432 | 18x |
suffix = dataname |
| 433 |
) |
|
| 434 | 18x |
names(new_keys) <- new_key_names |
| 435 | 18x |
teal.data::join_key(dataset_1 = "anl", dataset_2 = dataset_2, keys = new_keys) |
| 436 |
} |
|
| 437 |
} |
|
| 438 |
) |
|
| 439 |
) |
|
| 440 | 46x |
join_keys <- c(this_join_keys, join_keys) |
| 441 | ||
| 442 | 46x |
mapping_ds <- mapping_by_dataset[[dataname]] |
| 443 | 46x |
mapping_ds <- lapply(mapping_ds, function(x) {
|
| 444 | 55x |
new_vars <- .suffix_duplicated_vars( |
| 445 |
# is dropped by merge call. We should refer this selected foreign-key-variable |
|
| 446 |
# to equivalent key variable added in previous iteration (existing anl foreign key) |
|
| 447 |
# 6. duplicated variables added to anl should be renamed |
|
| 448 | 55x |
vars = x$variables, |
| 449 | 55x |
all_vars = anl_colnames, |
| 450 | 55x |
suffix = dataname |
| 451 |
) |
|
| 452 | ||
| 453 |
# if foreign key of this dataset is selected and if this foreign key took a part in the merge |
|
| 454 |
# then this key is dropped and we need to refer to the first variable |
|
| 455 | 55x |
existing_fk <- join_keys[dataname, "anl"] # keys that are already in anl |
| 456 | 55x |
existing_fk_selected <- intersect(names(existing_fk), x$variables) |
| 457 | 55x |
new_vars[existing_fk_selected] <- existing_fk[existing_fk_selected] |
| 458 | 55x |
x$variables <- new_vars |
| 459 | 55x |
x |
| 460 |
}) |
|
| 461 | 46x |
mapping[names(mapping_ds)] <- mapping_ds |
| 462 | ||
| 463 | 46x |
this_colnames <- unique(unlist(lapply(mapping_ds, `[[`, "variables"))) |
| 464 | 46x |
anl_colnames <- c(anl_colnames, this_colnames) |
| 465 | ||
| 466 | 46x |
anl_colnames <- union(anl_colnames, .fk(join_keys, "anl")) |
| 467 |
} |
|
| 468 | ||
| 469 | 28x |
list(mapping = mapping, join_keys = join_keys) |
| 470 |
} |
|
| 471 | ||
| 472 |
.fk <- function(x, dataname) {
|
|
| 473 | 77x |
this_jk <- x[[dataname]] |
| 474 | 77x |
unique(unlist(lapply(this_jk[!names(this_jk) %in% dataname], names))) |
| 475 |
} |
|
| 476 | ||
| 477 |
.suffix_duplicated_vars <- function(vars, all_vars, suffix) {
|
|
| 478 | 73x |
names <- names(vars) |
| 479 | 73x |
idx_duplicated <- vars %in% all_vars |
| 480 | 73x |
if (any(idx_duplicated)) {
|
| 481 |
# make sure that names are unchanged! |
|
| 482 | 12x |
vars[idx_duplicated] <- sprintf("%s_%s", vars[idx_duplicated], suffix)
|
| 483 |
} |
|
| 484 | 73x |
vars |
| 485 |
} |
|
| 486 | ||
| 487 |
#' Check if datasets can be merged in topological order |
|
| 488 |
#' |
|
| 489 |
#' Determines the topological order from join_keys, then checks that each dataset |
|
| 490 |
#' can be joined with at least one of the previously accumulated datasets. |
|
| 491 |
#' |
|
| 492 |
#' @inheritParams merge_srv |
|
| 493 |
#' @param join_keys (`join_keys`) The join keys object |
|
| 494 |
#' |
|
| 495 |
#' @keywords internal |
|
| 496 |
.validate_join_keys <- function(selectors, join_keys) {
|
|
| 497 | 32x |
validate(need( |
| 498 | 32x |
inherits(join_keys, "join_keys"), |
| 499 | 32x |
"Provided data doesn't have join_keys specified" |
| 500 |
)) |
|
| 501 | ||
| 502 | 32x |
datanames <- unique(unlist(lapply(selectors, function(selector) selector$datasets$selected))) |
| 503 |
# No validation needed for single dataset |
|
| 504 | 32x |
if (length(datanames) <= 1) {
|
| 505 | 18x |
return(TRUE) |
| 506 |
} |
|
| 507 | ||
| 508 |
# Get topological order from join_keys (this is the canonical ordering) |
|
| 509 | 14x |
topological_order <- names(join_keys) |
| 510 | ||
| 511 |
# Filter to only selected datasets and maintain topological order |
|
| 512 | 14x |
ordered_datasets <- intersect(topological_order, datanames) |
| 513 | ||
| 514 |
# Check if any dataset has no keys defined at all |
|
| 515 | 14x |
if (length(ordered_datasets) != length(datanames)) {
|
| 516 | 2x |
datasets_without_keys <- setdiff(datanames, ordered_datasets) |
| 517 | 2x |
validate( |
| 518 | 2x |
need( |
| 519 | 2x |
FALSE, |
| 520 | 2x |
sprintf( |
| 521 | 2x |
"Cannot merge datasets. The following dataset%s no join keys defined: %s.\n\nPlease define `join_keys`.", |
| 522 | 2x |
if (length(datasets_without_keys) == 1) " has" else "s have", |
| 523 | 2x |
paste(sprintf("'%s'", datasets_without_keys), collapse = ", ")
|
| 524 |
) |
|
| 525 |
) |
|
| 526 |
) |
|
| 527 |
} |
|
| 528 | ||
| 529 |
# Iteratively check if each dataset can join with accumulated datasets |
|
| 530 | 12x |
accumulated <- ordered_datasets[1] |
| 531 | ||
| 532 | 12x |
for (i in seq(2, length(ordered_datasets))) {
|
| 533 | 20x |
current_dataset <- ordered_datasets[i] |
| 534 | 20x |
can_join <- FALSE |
| 535 | ||
| 536 |
# Check if current dataset has join keys with ANY accumulated dataset |
|
| 537 | 20x |
for (prev_dataset in accumulated) {
|
| 538 | 31x |
if (length(join_keys[current_dataset, prev_dataset]) > 0) {
|
| 539 | 18x |
can_join <- TRUE |
| 540 | 18x |
break |
| 541 |
} |
|
| 542 |
} |
|
| 543 | ||
| 544 | 20x |
if (!can_join) {
|
| 545 | 2x |
validate( |
| 546 | 2x |
need( |
| 547 | 2x |
FALSE, |
| 548 | 2x |
sprintf( |
| 549 | 2x |
paste( |
| 550 | 2x |
"Cannot merge dataset '%s'. No join keys found between '%s' and any of the accumulated datasets:", |
| 551 | 2x |
"%s.\n\nPlease define join keys using teal.data::join_keys()." |
| 552 |
), |
|
| 553 | 2x |
current_dataset, |
| 554 | 2x |
current_dataset, |
| 555 | 2x |
paste(sprintf("'%s'", accumulated), collapse = ", ")
|
| 556 |
) |
|
| 557 |
) |
|
| 558 |
) |
|
| 559 |
} |
|
| 560 | ||
| 561 |
# Add current dataset to accumulated |
|
| 562 | 18x |
accumulated <- c(accumulated, current_dataset) |
| 563 |
} |
|
| 564 | ||
| 565 | 10x |
TRUE |
| 566 |
} |
|
| 567 | ||
| 568 |
.validate_is_eager <- function(x) {
|
|
| 569 | 142x |
validate(need( |
| 570 | 142x |
!.is_delayed(x), |
| 571 | 142x |
"selected values have not been resolved correctly. Please report this issue to an app-developer." |
| 572 |
)) |
|
| 573 |
} |
|
| 574 | ||
| 575 |
.trim_filter_mapping <- function(mapping, dataname, data) {
|
|
| 576 | 35x |
if (is.null(mapping$variables) || is.null(mapping$values)) {
|
| 577 | 24x |
return(mapping) |
| 578 |
} |
|
| 579 | ||
| 580 | 11x |
dataset <- data[[dataname]] |
| 581 | 11x |
variables <- mapping[["variables"]] |
| 582 | 11x |
values <- mapping[["values"]] |
| 583 | ||
| 584 | 11x |
if (length(variables) > 1) {
|
| 585 |
# create new temporary variables that pastes together all variables |
|
| 586 | 1x |
dataset <- cbind(".tmp_var" = apply(dataset[, mapping$variables], 1, paste, collapse = ", "))
|
| 587 | 1x |
dataset <- as.data.frame(dataset) |
| 588 | 1x |
variables <- ".tmp_var" |
| 589 |
} |
|
| 590 | ||
| 591 | 11x |
is_unfiltered <- !.is_ranged(values) && all(dataset[[variables]] %in% values) || |
| 592 | 11x |
.is_ranged(values) && all( |
| 593 | 11x |
dataset[[variables]] >= values[[1]] & dataset[[variables]] <= values[[2]] |
| 594 |
) |
|
| 595 | ||
| 596 | 11x |
if (is_unfiltered) {
|
| 597 | 1x |
return(list()) |
| 598 |
} |
|
| 599 | 10x |
mapping |
| 600 |
} |
|
| 601 | ||
| 602 |
.mapping_input_to_datasets <- function(selectors) {
|
|
| 603 | 20x |
datasets <- lapply(selectors, `[[`, "datasets") |
| 604 | 20x |
datasets <- unlist(datasets, FALSE, FALSE) |
| 605 | ||
| 606 | 20x |
maps <- vector("list", length = length(unique(datasets)))
|
| 607 | 20x |
names(maps) <- unique(datasets) |
| 608 | ||
| 609 | 20x |
for (input in selectors) {
|
| 610 | 35x |
input_dataset <- input$datasets |
| 611 | 35x |
if (is.null(maps[[input_dataset]])) {
|
| 612 | 31x |
maps[[input_dataset]] <- list() |
| 613 |
} |
|
| 614 | ||
| 615 | 35x |
if (length(input_dataset) > 1L) {
|
| 616 | ! |
stop("Multiple datasets for a given input.")
|
| 617 |
} |
|
| 618 | ||
| 619 | 35x |
input_selection <- input[setdiff(names(input), "datasets")] |
| 620 | 35x |
if (!is.null(input_selection$variables)) {
|
| 621 | 35x |
new_variables <- c(maps[[input_dataset]]$variables, input_selection$variables) |
| 622 | ||
| 623 | 35x |
maps[[input_dataset]]$variables <- new_variables[!duplicated(unname(new_variables))] |
| 624 |
} |
|
| 625 | 35x |
if (!is.null(input_selection$values)) {
|
| 626 | 11x |
new_values <- c(maps[[input_dataset]]$values, input_selection$values) |
| 627 | 11x |
maps[[input_dataset]]$values <- new_values[!duplicated(unname(new_values))] |
| 628 |
} |
|
| 629 | 35x |
attr(maps[[input_dataset]], "operators") <- input_selection$operators |
| 630 |
} |
|
| 631 | 20x |
maps |
| 632 |
} |
| 1 |
#' `tidyselect` helpers |
|
| 2 |
#' |
|
| 3 |
#' @description |
|
| 4 |
#' #' `r lifecycle::badge("experimental")`
|
|
| 5 |
#' Predicate functions simplifying `picks` specification. |
|
| 6 |
#' @examples |
|
| 7 |
#' # select factor column but exclude foreign keys |
|
| 8 |
#' variables(choices = is_categorical(min.len = 2, max.len = 10)) |
|
| 9 |
#' |
|
| 10 |
#' @name tidyselectors |
|
| 11 |
#' @rdname tidyselectors |
|
| 12 |
#' @param min.len (`integer(1)`) minimal number of unique values |
|
| 13 |
#' @param max.len (`integer(1)`) maximal number of unique values |
|
| 14 |
#' @export |
|
| 15 |
#' @examples |
|
| 16 |
#' p <- picks( |
|
| 17 |
#' datasets(is.data.frame, 2L), |
|
| 18 |
#' variables(is_categorical(2, 10)) |
|
| 19 |
#' ) |
|
| 20 |
#' resolver(data = list(mtcars = mtcars, iris = iris), x = p) |
|
| 21 |
is_categorical <- function(min.len, max.len) {
|
|
| 22 |
# todo: consider making a function which can exit earlier when max.len > length(unique(x)) < min.len |
|
| 23 |
# without a need to compute unique on the whole vector. |
|
| 24 | 8x |
if (missing(max.len) && missing(min.len)) {
|
| 25 | 1x |
function(x) is.factor(x) || is.character(x) |
| 26 | 7x |
} else if (!missing(max.len) && missing(min.len)) {
|
| 27 | 2x |
checkmate::assert_int(max.len, lower = 0) |
| 28 | 1x |
function(x) (is.factor(x) || is.character(x)) && length(unique(x)) <= max.len |
| 29 | 5x |
} else if (!missing(min.len) && missing(max.len)) {
|
| 30 | 2x |
checkmate::assert_int(min.len, lower = 0) |
| 31 | 1x |
function(x) (is.factor(x) || is.character(x)) && length(unique(x)) >= min.len |
| 32 |
} else {
|
|
| 33 | 3x |
checkmate::assert_int(min.len, lower = 0) |
| 34 | 3x |
checkmate::assert_int(max.len, lower = 0) |
| 35 | 3x |
checkmate::assert_true(max.len >= min.len) |
| 36 | 2x |
function(x) {
|
| 37 | 6x |
(is.factor(x) || is.character(x)) && {
|
| 38 | 5x |
n <- length(unique(x)) |
| 39 | 5x |
n >= min.len && n <= max.len |
| 40 |
} |
|
| 41 |
} |
|
| 42 |
} |
|
| 43 |
} |
|
| 44 | ||
| 45 | ||
| 46 |
#' Select a range |
|
| 47 |
#' |
|
| 48 |
#' Helper to work with ranges. Setting `choices` or `selected` to range using |
|
| 49 |
#' `ranged()` in any of them will automatically create a `numeric`, `Date` or `POSIXct` |
|
| 50 |
#' input to filter. `variables(choices)` must only refer to `numeric`, `Date`, or `POSIXct` |
|
| 51 |
#' columns. An informative error is raised if the resolved column type is unsupported. |
|
| 52 |
#' @param min (`numeric(1)`) Minimal value. |
|
| 53 |
#' @param max (`numeric(1)`) Maximal value. |
|
| 54 |
#' @export |
|
| 55 |
#' @examples |
|
| 56 |
#' p <- picks( |
|
| 57 |
#' datasets(choices = "mtcars"), |
|
| 58 |
#' variables(choices = is.numeric, selected = 1), |
|
| 59 |
#' values(choices = ranged(), ranged(20, 30)) |
|
| 60 |
#' ) |
|
| 61 |
#' resolver(data = list("mtcars label" = mtcars), x = p)
|
|
| 62 |
ranged <- function(min = -Inf, max = Inf) {
|
|
| 63 | 23x |
checkmate::assert_number(min) |
| 64 | 21x |
checkmate::assert_number(max) |
| 65 | 19x |
if (min > max) {
|
| 66 | 1x |
stop("`min` must be lower than `max`")
|
| 67 |
} |
|
| 68 | 18x |
.as_ranged( |
| 69 | 18x |
function(x) {
|
| 70 | 102x |
!is.na(x) & x <= max & x >= min |
| 71 |
} |
|
| 72 |
) |
|
| 73 |
} |
|
| 74 | ||
| 75 |
#' Check if choices/selected is a range. |
|
| 76 |
#' |
|
| 77 |
#' @noRd |
|
| 78 |
.is_ranged <- function(x) {
|
|
| 79 | 206x |
inherits(x, "ranged") |
| 80 |
} |
|
| 81 | ||
| 82 |
#' Set "ranged" class to the object. Be watchful as |
|
| 83 |
#' it is used in two contexts. |
|
| 84 |
#' 1. Unresolved range in `values`'s `choices` and `selected` - setting a range predicate to |
|
| 85 |
#' be resolved in `determine` |
|
| 86 |
#' 2. Resolved range - sets a class to the `choices` and `selected` to inform that resolved vector |
|
| 87 |
#' is a range, to show a `numericRangeInput` and to filter values by `lower >= x <= upper` |
|
| 88 |
#' |
|
| 89 |
#' @noRd |
|
| 90 |
.as_ranged <- function(x) {
|
|
| 91 | 38x |
class(x) <- c(class(x), "ranged") |
| 92 | 38x |
x |
| 93 |
} |
| 1 |
#' Merge module |
|
| 2 |
#' |
|
| 3 |
#' Example [`teal::module`] containing interactive inputs and displaying results of merge. |
|
| 4 |
#' |
|
| 5 |
#' @inheritParams teal::module |
|
| 6 |
#' @param picks (`list` of `picks`) |
|
| 7 |
#' @examples |
|
| 8 |
#' library(teal) |
|
| 9 |
#' |
|
| 10 |
#' data <- within(teal.data::teal_data(), {
|
|
| 11 |
#' iris <- iris |
|
| 12 |
#' mtcars <- mtcars |
|
| 13 |
#' }) |
|
| 14 |
#' |
|
| 15 |
#' app <- init( |
|
| 16 |
#' data = data, |
|
| 17 |
#' modules = modules( |
|
| 18 |
#' modules( |
|
| 19 |
#' label = "Testing modules", |
|
| 20 |
#' tm_merge( |
|
| 21 |
#' label = "non adam", |
|
| 22 |
#' picks = list( |
|
| 23 |
#' a = picks( |
|
| 24 |
#' datasets("iris", "iris"),
|
|
| 25 |
#' variables( |
|
| 26 |
#' choices = c("Sepal.Length", "Species"),
|
|
| 27 |
#' selected = |
|
| 28 |
#' ), |
|
| 29 |
#' values() |
|
| 30 |
#' ) |
|
| 31 |
#' ) |
|
| 32 |
#' ) |
|
| 33 |
#' ) |
|
| 34 |
#' ) |
|
| 35 |
#' ) |
|
| 36 |
#' if (interactive()) {
|
|
| 37 |
#' shinyApp(app$ui, app$server, enableBookmarking = "server") |
|
| 38 |
#' } |
|
| 39 |
#' |
|
| 40 |
#' @export |
|
| 41 |
tm_merge <- function(label = "merge-module", picks, transformators = list()) {
|
|
| 42 | ! |
teal::module( |
| 43 | ! |
label = label, |
| 44 | ! |
ui = function(id, picks) {
|
| 45 | ! |
ns <- shiny::NS(id) |
| 46 | ! |
tags$div( |
| 47 | ! |
tags$div( |
| 48 | ! |
class = "row g-2", |
| 49 | ! |
lapply(names(picks), function(id) {
|
| 50 | ! |
tags$div( |
| 51 | ! |
class = "col-auto", |
| 52 | ! |
tags$strong(tags$label(id)), |
| 53 | ! |
teal.picks::picks_ui( |
| 54 | ! |
id = ns(id), |
| 55 | ! |
picks = picks[[id]] |
| 56 |
) |
|
| 57 |
) |
|
| 58 |
}) |
|
| 59 |
), |
|
| 60 | ! |
shiny::div( |
| 61 | ! |
shiny::tags$label("Join keys"),
|
| 62 | ! |
shiny::verbatimTextOutput(ns("join_keys")),
|
| 63 | ! |
shiny::tags$label("Mapped"),
|
| 64 | ! |
shiny::verbatimTextOutput(ns("mapped")),
|
| 65 | ! |
shiny::tags$label("Source code"),
|
| 66 | ! |
shiny::verbatimTextOutput(ns("src")),
|
| 67 | ! |
shiny::tags$label("Merge result"),
|
| 68 | ! |
shiny::tableOutput(ns("table_merged"))
|
| 69 |
) |
|
| 70 |
) |
|
| 71 |
}, |
|
| 72 | ! |
server = function(id, data, picks) {
|
| 73 | ! |
shiny::moduleServer(id, function(input, output, session) {
|
| 74 | ! |
selectors <- picks_srv(id, picks = picks, data = data) |
| 75 | ||
| 76 | ! |
merged <- merge_srv("merge", data = data, selectors = selectors)
|
| 77 | ||
| 78 | ! |
table_q <- shiny::reactive({
|
| 79 | ! |
shiny::req(merged$data()) |
| 80 | ! |
within(merged$data(), anl, selectors = selectors) |
| 81 |
}) |
|
| 82 | ||
| 83 | ! |
output$table_merged <- shiny::renderTable({
|
| 84 | ! |
shiny::req(table_q()) |
| 85 | ! |
teal.code::get_outputs(table_q())[[1]] |
| 86 |
}) |
|
| 87 | ||
| 88 | ! |
output$src <- renderPrint({
|
| 89 | ! |
cat(teal.code::get_code(shiny::req(table_q()))) |
| 90 |
}) |
|
| 91 | ||
| 92 | ! |
output$mapped <- renderText(yaml::as.yaml(merged$variables())) |
| 93 | ||
| 94 | ! |
output$join_keys <- renderPrint(teal.data::join_keys(merged$data())) |
| 95 | ||
| 96 | ! |
table_q |
| 97 |
}) |
|
| 98 |
}, |
|
| 99 | ! |
ui_args = list(picks = picks), |
| 100 | ! |
server_args = list(picks = picks), |
| 101 | ! |
transformators = transformators |
| 102 |
) |
|
| 103 |
} |
| 1 |
#' Assert level |
|
| 2 |
#' |
|
| 3 |
#' @param x `picks` object |
|
| 4 |
#' @param class Class of the last element of picks |
|
| 5 |
#' @inheritParams checkmate::makeAssertionFunction |
|
| 6 |
#' @inheritParams checkmate::assert |
|
| 7 |
#' @rdname assert_last_level |
|
| 8 |
#' @returns For `check_last_level` a logical value or a string. |
|
| 9 |
#' For `assert_last_level` invisibly the object checked or an error. |
|
| 10 |
#' @export |
|
| 11 |
#' @examples |
|
| 12 |
#' x <- picks(datasets(), variables(), values()) |
|
| 13 |
#' assert_last_level(x, "values") |
|
| 14 |
check_last_level <- function(x, class) {
|
|
| 15 | 5x |
checkmate::assert_character(class, len = 1, any.missing = FALSE) |
| 16 | 5x |
check <- inherits(x, "picks") && inherits(x[[length(x)]], class) |
| 17 | 5x |
if (isFALSE(check)) {
|
| 18 | 4x |
return(sprintf("This is not a picks object that ends in %s", class))
|
| 19 |
} |
|
| 20 | 1x |
check |
| 21 |
} |
|
| 22 | ||
| 23 |
#' @export |
|
| 24 |
#' @rdname assert_last_level |
|
| 25 |
assert_last_level <- checkmate::makeAssertionFunction(check_last_level) |
| 1 |
#' Drop-down badge |
|
| 2 |
#' |
|
| 3 |
#' Drop-down button in a form of a badge with `bg-primary` as default style |
|
| 4 |
#' Clicking badge shows a drop-down containing any `HTML` element. Folded drop-down |
|
| 5 |
#' doesn't trigger display output which means that items rendered using `render*` |
|
| 6 |
#' will be recomputed only when drop-down is show. |
|
| 7 |
#' |
|
| 8 |
#' @param id (`character(1)`) shiny module's id |
|
| 9 |
#' @param label (`shiny.tag`) Label displayed on a badge. |
|
| 10 |
#' @param content (`shiny.tag`) Content of a drop-down. |
|
| 11 |
#' @keywords internal |
|
| 12 |
badge_dropdown <- function(id, label, content) {
|
|
| 13 | 3x |
ns <- shiny::NS(id) |
| 14 | 3x |
htmltools::tagList( |
| 15 | 3x |
htmltools::singleton(htmltools::tags$head( |
| 16 | 3x |
htmltools::includeCSS(system.file("badge-dropdown", "style.css", package = "teal.picks")),
|
| 17 | 3x |
htmltools::includeScript(system.file("badge-dropdown", "script.js", package = "teal.picks"))
|
| 18 |
)), |
|
| 19 | 3x |
htmltools::tags$div( |
| 20 | 3x |
class = "badge-dropdown-wrapper", |
| 21 | 3x |
htmltools::tags$span( |
| 22 | 3x |
id = ns("summary_badge"),
|
| 23 | 3x |
class = "badge bg-primary rounded-pill badge-dropdown", |
| 24 | 3x |
style = "cursor: pointer;", |
| 25 | 3x |
tags$span(class = "badge-dropdown-label", label), |
| 26 | 3x |
tags$span(class = "badge-dropdown-icon", bsicons::bs_icon("caret-down-fill")),
|
| 27 | 3x |
onclick = sprintf("toggleBadgeDropdown('%s', '%s')", ns("summary_badge"), ns("inputs_container"))
|
| 28 |
), |
|
| 29 | 3x |
htmltools::tags$div( |
| 30 | 3x |
content, |
| 31 | 3x |
id = ns("inputs_container"),
|
| 32 | 3x |
style = htmltools::css( |
| 33 | 3x |
display = "none", |
| 34 | 3x |
position = "absolute", |
| 35 | 3x |
background = "white", |
| 36 | 3x |
border = "1px solid #ccc", |
| 37 | 3x |
`border-radius` = "4px", |
| 38 | 3x |
`box-shadow` = "0 2px 10px rgba(0,0,0,0.1)", |
| 39 | 3x |
padding = "10px", |
| 40 | 3x |
`z-index` = "1050", # z-index set to 1000+50 to ensure that is above encoding panel on 1 column layout. |
| 41 | 3x |
`min-width` = "200px", |
| 42 | 3x |
transition = "opacity 0.2s ease", |
| 43 | 3x |
opacity = 0 |
| 44 |
) |
|
| 45 |
) |
|
| 46 |
) |
|
| 47 |
) |
|
| 48 |
} |
|
| 49 | ||
| 50 |
#' Create ui component for fixed ui picks without user selection |
|
| 51 |
#' @param id (`character(1)`) shiny module's id |
|
| 52 |
#' @param label (`shiny.tag`) Label displayed on the component |
|
| 53 |
#' @keywords internal |
|
| 54 |
#' @noRd |
|
| 55 |
fixed_picks <- function(id, label) {
|
|
| 56 | 1x |
ns <- shiny::NS(id) |
| 57 | ||
| 58 | 1x |
htmltools::tags$div( |
| 59 | 1x |
id = ns("fixed_picks_badge"),
|
| 60 | 1x |
class = "fixed-picks", |
| 61 | 1x |
htmltools::tags$label(label), |
| 62 | 1x |
htmltools::tags$i(bsicons::bs_icon("lock-fill"))
|
| 63 |
) |
|
| 64 |
} |
| 1 |
.onLoad <- function(libname, pkgname) { # nolint
|
|
| 2 |
# Set up the teal logger instance |
|
| 3 | ! |
teal.logger::register_logger("teal.slice")
|
| 4 | ! |
teal.logger::register_handlers("teal.slice")
|
| 5 | ||
| 6 |
# Manual import instead of using backports and adding 1 more dependency |
|
| 7 | ! |
if (getRversion() < "4.4") {
|
| 8 | ! |
assign("%||%", rlang::`%||%`, envir = getNamespace(pkgname))
|
| 9 |
} |
|
| 10 | ||
| 11 | ! |
invisible() |
| 12 |
} |
| 1 |
#' Generator function so that the functions can be generated programmatically. |
|
| 2 |
#' @noRd |
|
| 3 |
.check_pick_generator <- function(attr_name) {
|
|
| 4 | ! |
rlang::new_function( |
| 5 | ! |
rlang::pairlist2(x = ), |
| 6 | ! |
substitute( |
| 7 |
{
|
|
| 8 | ! |
checkmate::assert_class(x, classes = c("pick"))
|
| 9 | ! |
checkmate::assert_flag(attr(x, attr_name, exact = TRUE)) |
| 10 | ! |
isTRUE(attr(x, attr_name, exact = TRUE)) |
| 11 |
}, |
|
| 12 | ! |
env = list(attr_name = attr_name) |
| 13 |
), |
|
| 14 | ! |
env = parent.frame() |
| 15 |
) |
|
| 16 |
} |
|
| 17 | ||
| 18 |
#' Helper functions for pick |
|
| 19 |
#' @description |
|
| 20 |
#' Helper functions for pick objects generated from |
|
| 21 |
#' [datasets()], [variables()] or [values()]: |
|
| 22 |
#' @name helper_functions_pick |
|
| 23 |
#' @param x (`datasets`, `variables` or `values`) pick to check. |
|
| 24 |
#' @return `TRUE` if the pick has the attribute set to `TRUE`, |
|
| 25 |
#' `FALSE` otherwise. |
|
| 26 | ||
| 27 | ||
| 28 |
#' @rdname helper_functions_pick |
|
| 29 |
#' @description |
|
| 30 |
#' - `is_pick_multiple()` checks if a pick has the `multiple` attribute set to `TRUE`. |
|
| 31 |
#' @examples |
|
| 32 |
#' p <- picks(datasets("iris"), variables(), values())
|
|
| 33 |
#' |
|
| 34 |
#' is_pick_multiple(p$variables) |
|
| 35 |
#' @export |
|
| 36 |
is_pick_multiple <- .check_pick_generator("multiple")
|
|
| 37 | ||
| 38 |
#' @rdname helper_functions_pick |
|
| 39 |
#' @description |
|
| 40 |
#' - `is_pick_fixed()` checks if a pick has the `fixed` attribute set to `TRUE`. |
|
| 41 |
#' @examples |
|
| 42 |
#' |
|
| 43 |
#' is_pick_fixed(p$variables) |
|
| 44 |
#' @export |
|
| 45 |
is_pick_fixed <- .check_pick_generator("fixed")
|
|
| 46 | ||
| 47 |
#' @rdname helper_functions_pick |
|
| 48 |
#' @description |
|
| 49 |
#' - `is_pick_ordered()` checks if a pick has the `ordered` attribute set to `TRUE`. |
|
| 50 |
#' @examples |
|
| 51 |
#' |
|
| 52 |
#' is_pick_ordered(p$variables) |
|
| 53 |
#' @export |
|
| 54 |
is_pick_ordered <- .check_pick_generator("ordered")
|