From e0e1571cde466313449944692487aa548215f3f0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Mon, 3 Mar 2025 09:09:46 +0100 Subject: [PATCH 001/142] Add some initial definitions --- NAMESPACE | 14 +++++ R/delayed.R | 8 +++ R/ops_transform.R | 87 +++++++++++++++++++++++++++++ R/resolver.R | 3 + R/types.R | 69 +++++++++++++++++++++++ tests/testthat/test-ops_transform.R | 26 +++++++++ 6 files changed, 207 insertions(+) create mode 100644 R/delayed.R create mode 100644 R/ops_transform.R create mode 100644 R/resolver.R create mode 100644 R/types.R create mode 100644 tests/testthat/test-ops_transform.R diff --git a/NAMESPACE b/NAMESPACE index 209b1855..2f1d66ad 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,5 +1,13 @@ # Generated by roxygen2: do not edit by hand +S3method("&",dataset) +S3method("&",transform) +S3method("&",variable) +S3method("|",dataset) +S3method(chooseOpsMethod,dataset) +S3method(chooseOpsMethod,transform) +S3method(chooseOpsMethod,value) +S3method(chooseOpsMethod,variable) S3method(data_extract_multiple_srv,FilteredData) S3method(data_extract_multiple_srv,list) S3method(data_extract_multiple_srv,reactive) @@ -12,6 +20,7 @@ S3method(merge_expression_module,reactive) S3method(merge_expression_srv,list) S3method(merge_expression_srv,reactive) S3method(print,choices_labeled) +S3method(print,dataset) S3method(print,delayed_choices_selected) S3method(print,delayed_data_extract_spec) S3method(print,delayed_filter_spec) @@ -19,6 +28,8 @@ S3method(print,delayed_select_spec) S3method(print,delayed_value_choices) S3method(print,delayed_variable_choices) S3method(print,filter_spec) +S3method(print,value) +S3method(print,variable) S3method(resolve,default) S3method(resolve,delayed_choices_selected) S3method(resolve,delayed_data_extract_spec) @@ -45,6 +56,7 @@ export(data_extract_spec) export(data_extract_srv) export(data_extract_ui) export(datanames_input) +export(dataset) export(filter_spec) export(first_choice) export(first_choices) @@ -68,7 +80,9 @@ export(select_spec) export(select_spec.default) export(select_spec.delayed_data) export(split_by_sep) +export(transform) export(value_choices) +export(variable) export(variable_choices) import(shiny) importFrom(dplyr,"%>%") diff --git a/R/delayed.R b/R/delayed.R new file mode 100644 index 00000000..9d421b09 --- /dev/null +++ b/R/delayed.R @@ -0,0 +1,8 @@ +delay <- function(x) { + class(x) <- "delayed" + x +} + +is.delayed <- function(x) { + inherits(x, "delayed") +} diff --git a/R/ops_transform.R b/R/ops_transform.R new file mode 100644 index 00000000..fd190982 --- /dev/null +++ b/R/ops_transform.R @@ -0,0 +1,87 @@ +#' @export +`&.transform` <- function(e1, e2) { + + if (is.transform(e1) && is.dataset(e2)) { + o <- e1 + o$dataset <- unique(c(e1$dataset, e2$dataset)) + } else if (is.transform(e1) && is.variable(e2)) { + o <- e1 + o$variable <- unique(c(e1$variable, e2$variable)) + } else if (is.transform(e1) && is.value(e2)) { + o <- e1 + o$value <- unique(c(e1$variable, e2$value)) + } + class(o) <- c("delayed", "transform") + o +} + +#' @export +`&.dataset` <- function(e1, e2) { + e1_var <- e1[["names"]] + e2_var <- e2[["names"]] + + if (is.character(e1_var) && is.character(e2_var)) { + x <- list(dataset = unique(c(e1_var, e2_var))) + } + class(x) <- c("delayed", "transform") + x +} + + +#' @export +`&.variable` <- function(e1, e2) { + dataset_n_var <- is.dataset(e1) && is.variable(e2) + e1_var <- e1[["names"]] + e2_var <- e2[["names"]] + + if (dataset_n_var && is.character(e1_var) && is.character(e2_var)) { + x <- list(dataset = e1_var, variable = e2_var) + } + if (is.variable(e1) && is.variable(e2)) { + x <- list(dataset = NA, variable = unique(c(e1_var, e2_var))) + } + + if (is.variable(e1) && is.dataset(e2)) { + x <- list(dataset = e2_var, variable = e1_var) + } + if (is.variable(e2) && is.dataset(e1)) { + x <- list(dataset = e1_var, variable = e2_var) + } + class(x) <- c("delayed", "transform") + x +} + +#' @export +`|.dataset` <- function(e1, e2) { + list() + + + class(x) <- c("delayed", "transform") + x +} + +#' @export +chooseOpsMethod.transform <- function(x, y, mx, my, cl, reverse) { + !is.transform(x) +} + +#' @export +chooseOpsMethod.dataset <- function(x, y, mx, my, cl, reverse) { + # cat("\nx\n") + # print(mx) + # cat("\ny\n") + # print(my) + # cat("\ncl\n") + # print(cl) + # cat("\nreverse\n") + # print(reverse) + is.transform(x) +} + +#' @export +chooseOpsMethod.variable <- function(x, y, mx, my, cl, reverse) TRUE + +#' @export +chooseOpsMethod.value <- function(x, y, mx, my, cl, reverse) TRUE + +# ?Ops diff --git a/R/resolver.R b/R/resolver.R new file mode 100644 index 00000000..e81a6535 --- /dev/null +++ b/R/resolver.R @@ -0,0 +1,3 @@ +# resolver.dataset +# resolver.variable +# resolver.value diff --git a/R/types.R b/R/types.R new file mode 100644 index 00000000..46041f3f --- /dev/null +++ b/R/types.R @@ -0,0 +1,69 @@ +#' @export +transform <- function() { + o <- list(dataset = NA, variables = NA, values = NA) + class(o) <- c("delayed", "transform") + o +} + +is.transform <- function(x) { + inherits(x, "transform") +} + +#' @export +dataset <- function(x, select = first_choice) { + o <- list(names = x, select = select) + class(o) <- c("delayed", "dataset") + o +} + +is.dataset <- function(x) { + inherits(x, "dataset") +} + +#' @export +print.dataset <- function(x) { + if (is.delayed(x)) { + cat("Delayed dataset for:", x$names) + } else { + cat("Dataset for:", x$names) + } +} + +#' @export +variable <- function(x, select = first_choice) { + o <- list(names = x, select = select) + class(o) <- c("delayed", "variable") + o +} + +is.variable <- function(x) { + inherits(x, "variable") +} + +#' @export +print.variable <- function(x) { + if (is.delayed(x)) { + cat("Delayed variable for:", x$names) + } else { + cat("Variable for:", x$names) + } +} + +value <- function(x, select = first_choice) { + o <- list(names = x, select = select) + class(o) <- c("delayed", "value") + o +} + +is.value <- function(x) { + inherits(x, "value") +} + +#' @export +print.value <- function(x) { + if (is.delayed(x)) { + cat("Delayed value for:", x$names) + } else { + cat("Value for:", x$names) + } +} diff --git a/tests/testthat/test-ops_transform.R b/tests/testthat/test-ops_transform.R new file mode 100644 index 00000000..79701230 --- /dev/null +++ b/tests/testthat/test-ops_transform.R @@ -0,0 +1,26 @@ +test_that("datasets Ops work", { + dataset1 <- dataset("ABC") + dataset2 <- dataset("ABC2") + datasets <- dataset1 & dataset1 + expect_equal(datasets$dataset, "ABC") + datasets <- dataset1 & dataset2 + expect_equal(datasets$dataset, c("ABC", "ABC2")) + datasets2 <- datasets & dataset2 + expect_equal(datasets$dataset, c("ABC", "ABC2")) +}) + +test_that("variables Ops work", { + var1 <- variable("abc") + var2 <- variable("abc2") + vars <- var1 & var1 + expect_equal(vars$variable, "abc") + vars <- var1 & var2 + expect_equal(vars$variable, c("abc", "abc2")) +}) + +test_that("variables, datsets Ops work", { + dataset1 <- dataset("ABC2") + var1 <- variable("abc") + expect_equal(dataset1 & var1, var1 & dataset1) + expect_equal(vars$variable, c("ABC", "ABC2")) +}) From 707224eed1c704020da905ec4704c36bcc803ace Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Mon, 3 Mar 2025 18:08:19 +0100 Subject: [PATCH 002/142] Add some infrastructure --- NAMESPACE | 28 ++-- R/delayed.R | 59 ++++++- R/ops_transform.R | 100 ++++------- R/resolver.R | 246 +++++++++++++++++++++++++++- R/types.R | 136 +++++++++++---- man/resolver.Rd | 32 ++++ tests/testthat/test-delayed.R | 17 ++ tests/testthat/test-ops_transform.R | 134 ++++++++++++--- tests/testthat/test-resolver.R | 64 ++++++++ 9 files changed, 669 insertions(+), 147 deletions(-) create mode 100644 man/resolver.Rd create mode 100644 tests/testthat/test-delayed.R create mode 100644 tests/testthat/test-resolver.R diff --git a/NAMESPACE b/NAMESPACE index 2f1d66ad..72e9fbd7 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,13 +1,12 @@ # Generated by roxygen2: do not edit by hand -S3method("&",dataset) S3method("&",transform) -S3method("&",variable) +S3method("[","type<-") +S3method("[",type) +S3method("[[","type<-") +S3method("[[",type) S3method("|",dataset) -S3method(chooseOpsMethod,dataset) -S3method(chooseOpsMethod,transform) -S3method(chooseOpsMethod,value) -S3method(chooseOpsMethod,variable) +S3method(c,type) S3method(data_extract_multiple_srv,FilteredData) S3method(data_extract_multiple_srv,list) S3method(data_extract_multiple_srv,reactive) @@ -15,12 +14,13 @@ S3method(data_extract_srv,FilteredData) S3method(data_extract_srv,list) S3method(filter_spec_internal,default) S3method(filter_spec_internal,delayed_data) +S3method(is.delayed,default) +S3method(is.delayed,type) S3method(merge_expression_module,list) S3method(merge_expression_module,reactive) S3method(merge_expression_srv,list) S3method(merge_expression_srv,reactive) S3method(print,choices_labeled) -S3method(print,dataset) S3method(print,delayed_choices_selected) S3method(print,delayed_data_extract_spec) S3method(print,delayed_filter_spec) @@ -28,8 +28,6 @@ S3method(print,delayed_select_spec) S3method(print,delayed_value_choices) S3method(print,delayed_variable_choices) S3method(print,filter_spec) -S3method(print,value) -S3method(print,variable) S3method(resolve,default) S3method(resolve,delayed_choices_selected) S3method(resolve,delayed_data_extract_spec) @@ -56,7 +54,7 @@ export(data_extract_spec) export(data_extract_srv) export(data_extract_ui) export(datanames_input) -export(dataset) +export(datasets) export(filter_spec) export(first_choice) export(first_choices) @@ -67,6 +65,7 @@ export(get_extract_datanames) export(get_merge_call) export(get_relabel_call) export(is.choices_selected) +export(is.delayed) export(is_single_dataset) export(last_choice) export(last_choices) @@ -76,14 +75,19 @@ export(merge_expression_module) export(merge_expression_srv) export(no_selected_as_NULL) export(resolve_delayed) +export(resolver) export(select_spec) export(select_spec.default) export(select_spec.delayed_data) export(split_by_sep) -export(transform) export(value_choices) -export(variable) +export(values) export(variable_choices) +export(variables) +export(variables.MultiAssayExperiment) +export(variables.data.frame) +export(variables.default) +export(variables.matrix) import(shiny) importFrom(dplyr,"%>%") importFrom(lifecycle,badge) diff --git a/R/delayed.R b/R/delayed.R index 9d421b09..f67c7e2c 100644 --- a/R/delayed.R +++ b/R/delayed.R @@ -1,8 +1,63 @@ delay <- function(x) { - class(x) <- "delayed" + class(x) <- c("delayed", class(x)) x } -is.delayed <- function(x) { +#' @export +#' @method is.delayed type +is.delayed.type <- function(x) { + !all(is.character(x$names)) || !all(is.character(x$select)) +} + +#' @export is.delayed +#' @method is.delayed transform +is.delayed.transform <- function(x) { + is.delayed(x$datasets) || is.delayed(x$variables) || is.delayed(x$values) +} + +#' @export +#' @method is.delayed default +is.delayed.default <- function(x) { inherits(x, "delayed") } + +#' @export +is.delayed <- function(x) { + UseMethod("is.delayed") +} + +resolved <- function(x, variable){ + s <- all(is.character(x$names)) && all(is.character(x$select)) + + if (!s && !all(x$select %in% x$names)) { + stop("Selected ", variable, " not available") + } + + cl <- class(x) + class(x) <- setdiff(cl, "delayed") + x +} + +get_datanames <- function(x) { + if (is.transform(x) && !is.delayed(x$datasets)) { + x$datasets$names + } else { + NULL + } +} + +get_variables <- function(x) { + if (is.transform(x) && !is.delayed(x$datasets) && !is.delayed(x$variables)) { + x$variables$names + } else { + NULL + } +} + +get_values <- function(x) { + if (is.transform(x) && !is.delayed(x)) { + x$values$names + } else { + NULL + } +} diff --git a/R/ops_transform.R b/R/ops_transform.R index fd190982..5a97d3df 100644 --- a/R/ops_transform.R +++ b/R/ops_transform.R @@ -1,87 +1,47 @@ #' @export `&.transform` <- function(e1, e2) { - - if (is.transform(e1) && is.dataset(e2)) { - o <- e1 - o$dataset <- unique(c(e1$dataset, e2$dataset)) - } else if (is.transform(e1) && is.variable(e2)) { - o <- e1 - o$variable <- unique(c(e1$variable, e2$variable)) - } else if (is.transform(e1) && is.value(e2)) { - o <- e1 - o$value <- unique(c(e1$variable, e2$value)) + if (!is.transform(e1) || !is.transform(e2)) { + stop("Method not available") } - class(o) <- c("delayed", "transform") - o -} - -#' @export -`&.dataset` <- function(e1, e2) { - e1_var <- e1[["names"]] - e2_var <- e2[["names"]] - - if (is.character(e1_var) && is.character(e2_var)) { - x <- list(dataset = unique(c(e1_var, e2_var))) + o <- transform() + if (has_dataset(e1) || has_dataset(e2)) { + o$datasets <- c(e1$datasets, e2$datasets) + o$datasets <- o$datasets[!is.na(o$datasets)] } - class(x) <- c("delayed", "transform") - x -} - - -#' @export -`&.variable` <- function(e1, e2) { - dataset_n_var <- is.dataset(e1) && is.variable(e2) - e1_var <- e1[["names"]] - e2_var <- e2[["names"]] - - if (dataset_n_var && is.character(e1_var) && is.character(e2_var)) { - x <- list(dataset = e1_var, variable = e2_var) + if (has_variable(e1) || has_variable(e2)) { + o$variables <- c(e1$variables, e2$variables) + o$variables <- o$variables[!is.na(o$variables)] } - if (is.variable(e1) && is.variable(e2)) { - x <- list(dataset = NA, variable = unique(c(e1_var, e2_var))) + if (has_value(e1) || has_value(e2)) { + o$values <- c(e1$values, e2$values) + o$values <- o$values[!is.na(o$values)] } - if (is.variable(e1) && is.dataset(e2)) { - x <- list(dataset = e2_var, variable = e1_var) - } - if (is.variable(e2) && is.dataset(e1)) { - x <- list(dataset = e1_var, variable = e2_var) - } - class(x) <- c("delayed", "transform") - x + class(o) <- c("delayed", "transform") + o } #' @export `|.dataset` <- function(e1, e2) { - list() - - + if (!is.transform(e1) || !is.transform(e2)) { + stop("Method not available") + } + s <- transform() class(x) <- c("delayed", "transform") x } -#' @export -chooseOpsMethod.transform <- function(x, y, mx, my, cl, reverse) { - !is.transform(x) -} - -#' @export -chooseOpsMethod.dataset <- function(x, y, mx, my, cl, reverse) { - # cat("\nx\n") - # print(mx) - # cat("\ny\n") - # print(my) - # cat("\ncl\n") - # print(cl) - # cat("\nreverse\n") - # print(reverse) - is.transform(x) -} - -#' @export -chooseOpsMethod.variable <- function(x, y, mx, my, cl, reverse) TRUE - -#' @export -chooseOpsMethod.value <- function(x, y, mx, my, cl, reverse) TRUE +# #' @export +# chooseOpsMethod.transform <- function(x, y, mx, my, cl, reverse) { +# # cat("\nx\n") +# # print(mx) +# # cat("\ny\n") +# # print(my) +# # cat("\ncl\n") +# # print(cl) +# # cat("\nreverse\n") +# # print(reverse) +# is.transform(x) +# } # ?Ops diff --git a/R/resolver.R b/R/resolver.R index e81a6535..0645206f 100644 --- a/R/resolver.R +++ b/R/resolver.R @@ -1,3 +1,243 @@ -# resolver.dataset -# resolver.variable -# resolver.value +#' Resolve the specification +#' +#' Given the specification of some data to extract find if they are available or not. +#' +#' @param spec A object extraction specification. +#' @param data A `qenv()`, or `teal.data::teal_data()` object. +#' +#' @returns A transform but resolved +#' @export +#' +#' @examples +#' dataset1 <- datasets("df", function(x){head(x, 1)}) +#' dataset2 <- datasets(is.matrix, function(x){head(x, 1)}) +#' spec <- dataset1 & variables("a", "a") +#' td <- within(teal.data::teal_data(), { +#' df <- data.frame(a = as.factor(LETTERS[1:5]), b = letters[1:5]) +#' m <- matrix() +#' }) +#' resolver(dataset2, td) +#' resolver(spec, td) +#' spec <- dataset1 & variables("a", is.factor) +#' resolver(spec, td) +resolver <- function(spec, data, ...) { + if (!is(data, "qenv")) { + stop("Please use qenv() or teal_data() objects.") + } + stopifnot(is.transform(spec), has_dataset(spec)) + specf <- spec + if (has_dataset(specf)) { + specf <- resolver.datasets(specf, data) + } else { + specf$datasets <- NULL + } + + if (has_variable(specf) && !is.delayed(specf$datasets)) { + specf <- resolver.variables(specf, data) + } else { + specf$variables <- NULL + } + + if (has_value(specf) && !is.delayed(specf$datasets) && !is.delayed(specf$variables)) { + specf <- resolver.values(specf, data) + } else { + specf$values <- NULL + } + + class(specf) <- setdiff(class(specf), "delayed") + specf +} + +functions_names <- function(unresolved, reference) { + + if (length(unresolved) == 1 && is.function(unresolved)) { + out <- tryCatch(unresolved(reference), error = function(x) unresolved) + if (is.logical(out) && length(out) == length(reference)) { + return(reference[out]) + } else { + return(NULL) + } + } + + is_fc <- vapply(unresolved, is.function, logical(1L)) + fc_unresolved <- unresolved[is_fc] + x <- vector("character") + for (f in fc_unresolved) { + + y <- tryCatch(f(reference), error = function(x) f ) + if (!is.logical(y)) { + stop("Provided functions should return a logical object.") + } + x <- c(x, reference[y[!is.na(y)]]) + } + unique(unlist(c(unresolved[!is_fc], x), FALSE, FALSE)) +} + +functions_data <- function(unresolved, data) { + if (length(unresolved) == 1 && is.function(unresolved)){ + out <- tryCatch(vapply(data, unresolved, logical(1L)), error = function(x) unresolved) + if (is.logical(out) && length(out) == length(data)) { + return(names(data)[out]) + } else { + return(NULL) + } + } + + fc_unresolved <- unresolved[vapply(unresolved, is.function, logical(1L))] + + # This is for variables + names <- names(data) + l <- lapply(fc_unresolved, function(f) {names[which(f(data))]}) + unique(unlist(l, FALSE, FALSE)) +} + +resolver.datasets <- function(spec, data) { + if (!is(data, "qenv")) { + stop("Please use qenv() or teal_data() objects.") + } + + sdatasets <- spec$datasets + data_names <- names(data) + + if (is.delayed(sdatasets) && all(is.character(sdatasets$names))) { + match <- intersect(data_names, sdatasets$names) + missing <- setdiff(sdatasets$names, data_names) + if (length(missing)) { + stop("Missing datasets ", paste(sQuote(missing), collapse = ", "), " were specified.") + } + sdatasets$names <- match + if (length(match) == 0) { + stop("No selected datasets matching the conditions requested") + } else if (length(match) == 1) { + sdatasets$select <- match + } else { + new_select <- c(functions_names(sdatasets$select, sdatasets$names), + functions_data(sdatasets$select, data[sdatasets$names])) + sdatasets$select <- unique(new_select[!is.na(new_select)]) + } + } else if (is.delayed(sdatasets)) { + new_names <- c(functions_names(sdatasets$names, data_names), + functions_data(sdatasets$names, data)) + sdatasets$names <- unique(new_names[!is.na(new_names)]) + + if (length(sdatasets$names) == 0) { + stop("No selected datasets matching the conditions requested") + } else if (length(sdatasets$names) == 1) { + svariables$select <- sdatasets$names + } else { + new_select <- c(functions_names(sdatasets$select, sdatasets$names), + functions_data(sdatasets$select, data[sdatasets$names])) + + sdatasets$select <- unique(new_select[!is.na(new_select)]) + } + } + + spec$datasets <- resolved(sdatasets, "dataset") + spec +} + +resolver.variables <- function(spec, data) { + if (!is(data, "qenv")) { + stop("Please use qenv() or teal_data() objects.") + } + + if (is.delayed(spec$datasets)) { + stop("Datasets not resolved yet") + } + datasets <- spec$datasets$select + data_selected <- data(data, datasets) + dataset <- data_selected[[datasets]] + names_data <- names(dataset) + + svariables <- spec$variables + + if (is.delayed(svariables) && all(is.character(svariables$names))) { + match <- intersect(names_data, svariables$names) + missing <- setdiff(svariables$names, names_data) + if (length(missing)) { + stop("Missing variables ", paste(sQuote(missing), collapse = ", "), " were specified.") + } + svariables$names <- match + if (length(match) == 1) { + svariables$select <- match + } else { + new_select <- c(functions_names(svariables$select, svariables$names), + functions_data(svariables$select, dataset)) + svariables$select <- unique(new_select[!is.na(new_select)]) + } + } else if (is.delayed(svariables)) { + new_names <- c(functions_names(svariables$names, names_data), + functions_data(svariables$names, dataset)) + svariables$names <- unique(new_names[!is.na(new_names)]) + if (length(match) == 1) { + svariables$select <- svariables$names + } else { + new_select <- c(functions_names(svariables$select, svariables$names), + functions_data(svariables$select, dataset)) + svariables$select <- unique(new_select[!is.na(new_select)]) + } + } + spec$variables <- resolved(svariables, "variables") + spec +} + +resolver.values <- function(spec, data) { + if (!is(data, "qenv")) { + stop("Please use qenv() or teal_data() objects.") + } + + variables <- spec$variables$names + svalues <- spec$values + spec$variables <- if (is.delayed(svalues) && all(is.character(svalues$names))) { + match <- intersect(datasets, svalues$names) + missing <- setdiff(svalues$names, datasets) + if (length(missing)) { + stop("Missing values ", paste(sQuote(missing), collapse = ", "), " were specified.") + } + svalues$names <- match + svalues$select <- functions_names(svalues$select, match) + svalues + } else if (is.delayed(svalues)) { + svalues$names <- functions_names(svalues$names, datasets) + svalues$select <- functions_names(svalues$select, svalues$names) + svalues + } + + spec$values <- resolved(svalues, "values") + spec +} + +#' @export +data.MultiAssayExperiment <- function(x, variable) { + # length(variable) == 1L + cd <- colData(x) + cd[[variable]] +} + +#' @export +data.matrix <- function(x, variable) { + # length(variable) == 1L + x[, variable, drop = TRUE] +} + +#' @export +#' @method data data.frame +data.data.frame <- function(x, variable) { + # length(variable) == 1L + x[, variable, drop = TRUE] +} + +#' @export +data.qenv <- function(x, variable) { + x[variable] +} + +#' @export +data.default <- function(x, variable) { + x[, variable, drop = TRUE] +} + +#' @export +data <- function(x, variable) { + UseMethod("data") +} diff --git a/R/types.R b/R/types.R index 46041f3f..d488dab2 100644 --- a/R/types.R +++ b/R/types.R @@ -1,6 +1,5 @@ -#' @export transform <- function() { - o <- list(dataset = NA, variables = NA, values = NA) + o <- list(datasets = na_type(), variables = na_type(), values = na_type()) class(o) <- c("delayed", "transform") o } @@ -9,61 +8,128 @@ is.transform <- function(x) { inherits(x, "transform") } -#' @export -dataset <- function(x, select = first_choice) { - o <- list(names = x, select = select) - class(o) <- c("delayed", "dataset") - o +has_dataset <- function(x) { + !anyNA(x[["datasets"]]) +} + +has_variable <- function(x) { + !anyNA(x[["variables"]]) } -is.dataset <- function(x) { - inherits(x, "dataset") +has_value <- function(x) { + !anyNA(x[["values"]]) +} + +na_type <- function() { + out <- NA + class(out) <- "type" + out } #' @export -print.dataset <- function(x) { - if (is.delayed(x)) { - cat("Delayed dataset for:", x$names) - } else { - cat("Dataset for:", x$names) - } +datasets <- function(x, select = first_choice) { + stopifnot(is.character(x) || is.function(x) || (is.list(x) && all(vapply(x, is.function, logical(1L))))) + stopifnot(is.character(select) || is.function(select) || (is.list(select) && all(vapply(select, is.function, logical(1L))))) + + type <- list(names = x, select = select) + class(type) <- c("delayed", "datasets", "type", "list") + o <- list(datasets = type, variables = na_type(), values = na_type()) + class(o) <- c("delayed", "transform", "list") + o } + #' @export -variable <- function(x, select = first_choice) { - o <- list(names = x, select = select) - class(o) <- c("delayed", "variable") +variables <- function(x, select = first_choice) { + stopifnot(is.character(x) || is.function(x) || (is.list(x) && all(vapply(x, is.function, logical(1L))))) + stopifnot(is.character(select) || is.function(select) || (is.list(select) && all(vapply(select, is.function, logical(1L))))) + + type <- list(names = x, select = select) + class(type) <- c("delayed", "variables", "type") + o <- list(datasets = na_type(), variables = type, values = na_type()) + class(o) <- c("delayed", "transform") o } -is.variable <- function(x) { - inherits(x, "variable") +#' @export +values <- function(x, select = first_choice) { + stopifnot(is.character(x) || is.function(x) || (is.list(x) && all(vapply(x, is.function, logical(1L))))) + stopifnot(is.character(select) || is.function(select) || (is.list(select) && all(vapply(select, is.function, logical(1L))))) + + type <- list(names = x, select = select) + class(type) <- c("delayed", "values", "type") + o <- list(datasets = na_type(), variables = na_type(), values = type) + class(o) <- c("delayed", "transform") + o } #' @export -print.variable <- function(x) { - if (is.delayed(x)) { - cat("Delayed variable for:", x$names) +c.type <- function(...) { + c1 <- class(..1) + c2 <- class(..2) + classes <- unique(c(c1, c2)) + other_classes <- setdiff(classes, c("delayed", "type")) + + if ("delayed" %in% classes) { + classes <- c("delayed", other_classes, "type") } else { - cat("Variable for:", x$names) + classes <- c(other_classes, "type") + } + + out <- NextMethod("c") + + if (all(is.na(out))) { + return(na_type()) + } else if (anyNA(out)) { + out <- out[!is.na(out)] } + nam <- names(out) + names <- nam == "names" + selects <- nam == "select" + + out <- list(names = unlist(out[names], FALSE, FALSE), + select = unlist(out[selects], FALSE, FALSE)) + + l <- lapply(out, unique) + class(l) <- classes + l } -value <- function(x, select = first_choice) { - o <- list(names = x, select = select) - class(o) <- c("delayed", "value") - o +#' @export +`[.type` <- function(x, i, j, ..., exact = TRUE) { + cx <- class(x) + out <- NextMethod("[") + class(out) <- cx + out } -is.value <- function(x) { - inherits(x, "value") +#' @export +`[.type<-` <- function(x, i, j, ..., value) { + cx <- class(x) + if (!"type" %in% class(value)) { + stop("Modifying the specification with invalid objects") + } + out <- NextMethod("[") + class(out) <- cx + out } #' @export -print.value <- function(x) { - if (is.delayed(x)) { - cat("Delayed value for:", x$names) - } else { - cat("Value for:", x$names) +`[[.type` <- function(x, i, ..., drop = TRUE) { + cx <- class(x) + out <- NextMethod("[[") + class(out) <- cx + out +} + + +#' @export +`[[.type<-` <- function(x, i, value) { + cx <- class(x) + if (!"type" %in% class(value)) { + stop("Modifying the specification with invalid objects") } + out <- NextMethod("[") + class(out) <- cx + out } diff --git a/man/resolver.Rd b/man/resolver.Rd new file mode 100644 index 00000000..1063d0ef --- /dev/null +++ b/man/resolver.Rd @@ -0,0 +1,32 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/resolver.R +\name{resolver} +\alias{resolver} +\title{Resolve the specification} +\usage{ +resolver(spec, data, ...) +} +\arguments{ +\item{spec}{A object extraction specification.} + +\item{data}{A \code{qenv()}, or \code{teal.data::teal_data()} object.} +} +\value{ +A transform but resolved +} +\description{ +Given the specification of some data to extract find if they are available or not. +} +\examples{ +dataset1 <- datasets("df", function(x){head(x, 1)}) +dataset2 <- datasets(is.matrix, function(x){head(x, 1)}) +spec <- dataset1 & variables("a", "a") +td <- within(teal.data::teal_data(), { + df <- data.frame(a = as.factor(LETTERS[1:5]), b = letters[1:5]) + m <- matrix() +}) +resolver(dataset2, td) +resolver(spec, td) +spec <- dataset1 & variables("a", is.factor) +resolver(spec, td) +} diff --git a/tests/testthat/test-delayed.R b/tests/testthat/test-delayed.R new file mode 100644 index 00000000..b9408a34 --- /dev/null +++ b/tests/testthat/test-delayed.R @@ -0,0 +1,17 @@ +test_that("delay works", { + out <- 1 + dout <- delay(out) + expect_s3_class(dout, "delayed") + expect_true(is.delayed(dout)) + expect_equal(resolved(dout), out) +}) + +test_that("is.delayed works", { + d <- datasets("a") + v <- variables("b") + expect_true(is.delayed(d)) + expect_true(is.delayed(datasets("a", "a"))) + expect_true(is.delayed(v)) + expect_true(is.delayed(variables("b", "b"))) + expect_true(is.delayed(d & v)) +}) diff --git a/tests/testthat/test-ops_transform.R b/tests/testthat/test-ops_transform.R index 79701230..847c0b55 100644 --- a/tests/testthat/test-ops_transform.R +++ b/tests/testthat/test-ops_transform.R @@ -1,26 +1,110 @@ -test_that("datasets Ops work", { - dataset1 <- dataset("ABC") - dataset2 <- dataset("ABC2") - datasets <- dataset1 & dataset1 - expect_equal(datasets$dataset, "ABC") - datasets <- dataset1 & dataset2 - expect_equal(datasets$dataset, c("ABC", "ABC2")) - datasets2 <- datasets & dataset2 - expect_equal(datasets$dataset, c("ABC", "ABC2")) -}) - -test_that("variables Ops work", { - var1 <- variable("abc") - var2 <- variable("abc2") - vars <- var1 & var1 - expect_equal(vars$variable, "abc") - vars <- var1 & var2 - expect_equal(vars$variable, c("abc", "abc2")) -}) - -test_that("variables, datsets Ops work", { - dataset1 <- dataset("ABC2") - var1 <- variable("abc") - expect_equal(dataset1 & var1, var1 & dataset1) - expect_equal(vars$variable, c("ABC", "ABC2")) +basic_ops <- function(fun) { + FUN <- match.fun(fun) + type1 <- FUN("ABC") + type2 <- FUN("ABC2") + types <- type1 & type1 + out <- list(names = "ABC", select = list(first_choice)) + class(out) <- c("delayed", fun, "type") + expect_equal(types[[fun]], out) + types <- type1 & type2 + expect_equal(types[[fun]]$names, c("ABC", "ABC2")) + types2 <- types & type2 + expect_equal(types[[fun]]$names, c("ABC", "ABC2")) + expect_s3_class(types[[fun]], class(out)) + type3 <- FUN("ABC2", select = all_choices) + types <- type1 & type3 + expect_length(types[[fun]]$select, 2) + type2b <- FUN(first_choice) + type2c <- FUN(last_choice) + out <- type2b & type2c + expect_length(out[[fun]]$names, 2) + expect_error(FUN("ABC") & 1) + out <- type1 & type2b +} + +test_that("datasets & work", { + basic_ops("datasets") +}) + + +test_that("variables & work", { + basic_ops("variables") +}) + +test_that("values & work", { + basic_ops("values") +}) + +test_that("datsets & variables work", { + dataset1 <- datasets("ABC2") + var1 <- variables("abc") + vars <- dataset1 & var1 + vars2 <- var1 & dataset1 + expect_equal(vars, vars2) + expect_equal(vars$datasets$names, "ABC2") + expect_equal(vars$variables$names, "abc") + expect_error(vars & 1) +}) + +test_that("datsets & values work", { + dataset1 <- datasets("ABC2") + val1 <- values("abc") + vars <- dataset1 & val1 + vars2 <- val1 & dataset1 + expect_equal(vars, vars2) + expect_equal(vars$datasets$names, "ABC2") + expect_equal(vars$values$names, "abc") + expect_error(vars & 1) +}) + +test_that("variables & values work", { + var1 <- variables("ABC2") + val1 <- values("abc") + vars <- var1 & val1 + vars2 <- val1 & var1 + expect_equal(vars, vars2) + expect_equal(vars$variables$names, "ABC2") + expect_equal(vars$values$names, "abc") + expect_error(vars & 1) +}) + +test_that("datasets & variables & values work", { + dataset1 <- datasets("ABC2") + var1 <- variables("ABC2") + val1 <- values("abc") + vars <- dataset1 & var1 & val1 + vars2 <- val1 & var1 & dataset1 + expect_equal(vars, vars2) + expect_equal(vars$datasets$names, "ABC2") + expect_equal(vars$variables$names, "ABC2") + expect_equal(vars$values$names, "abc") + expect_error(vars & 1) +}) + + + +test_that("datasets", { + first <- function(x){ + if (length(x) > 0) { + false <- rep(FALSE, length.out = length(x)) + false[1] <- TRUE + return(false) + } + return(FALSE) + } + + dataset1 <- datasets("df", first) + expect_true(is(dataset1$datasets$names, "vector")) + dataset2 <- datasets(is.matrix, first) + expect_true(is(dataset2$datasets$names, "vector")) + dataset3 <- datasets(is.data.frame, first) + mix <- dataset1 & dataset2 + expect_true(is(mix$datasets$names, "vector")) +}) + +test_that("variables", { + var1 <- variables("a", first) + var2 <- variables(is.factor, first) + var3 <- variables(is.factor, function(x){head(x, 1)}) + var4 <- variables(is.matrix, function(x){head(x, 1)}) }) diff --git a/tests/testthat/test-resolver.R b/tests/testthat/test-resolver.R new file mode 100644 index 00000000..7dfea733 --- /dev/null +++ b/tests/testthat/test-resolver.R @@ -0,0 +1,64 @@ +test_that("resolver datasets works", { + f <- function(x){head(x, 1)} + first <- function(x){ + if (length(x) > 0) { + false <- rep(FALSE, length.out = length(x)) + false[1] <- TRUE + return(false) + } + return(FALSE) + } + + dataset1 <- datasets("df", f) + dataset2 <- datasets("df", first) + dataset3 <- datasets(is.matrix, first) + dataset4 <- datasets("df", mean) + dataset5 <- datasets(median, mean) + td <- within(teal.data::teal_data(), { + df <- data.frame(a = LETTERS[1:5], b = factor(letters[1:5]), c = factor(letters[1:5])) + m <- cbind(b = 1:5, c = 10:14) + m2 <- cbind(a = LETTERS[1:2], b = LETTERS[4:5]) + }) + expect_no_error(resolver(dataset1, td)) + resolver(dataset2, td) + out <- resolver(dataset3, td) + expect_length(out$datasets$select, 1L) # Because we use first + expect_no_error(resolver(dataset4, td)) + expect_error(resolver(dataset5, td)) +}) + +test_that("resolver variables works", { + first <- function(x){ + if (length(x) > 0) { + false <- rep(FALSE, length.out = length(x)) + false[1] <- TRUE + return(false) + } + return(FALSE) + } + + dataset1 <- datasets("df", first) + dataset2 <- datasets(is.matrix, first) + dataset3 <- datasets(is.data.frame, first) + var1 <- variables("a", first) + var2 <- variables(is.factor, first) + var3 <- variables(is.factor, function(x){head(x, 1)}) + var4 <- variables(is.matrix, function(x){head(x, 1)}) + td <- within(teal.data::teal_data(), { + df <- data.frame(a = LETTERS[1:5], b = factor(letters[1:5]), c = factor(letters[1:5])) + m <- cbind(b = 1:5, c = 10:14) + m2 <- cbind(a = LETTERS[1:2], b = LETTERS[4:5]) + }) + + resolver(dataset1 & var1, td) + resolver(dataset1 & var2, td) + expect_error(resolver(dataset1 & var3, td)) + + resolver(dataset2 & var1, td) + resolver(dataset2 & var2, td) + resolver(dataset2 & var3, td) + + resolver(dataset3 & var1, td) + resolver(dataset3 & var2, td) + resolver(dataset3 & var3, td) +}) From 9f9aacb7358a5d5f1adbe100bfd92c82432bb353 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Wed, 5 Mar 2025 10:38:11 +0100 Subject: [PATCH 003/142] Resolution tested up to variables --- NAMESPACE | 10 +++-- R/resolver.R | 66 ++++++++++++++--------------- R/types.R | 31 ++++++++++---- tests/testthat/test-delayed.R | 5 ++- tests/testthat/test-ops_transform.R | 36 +++------------- tests/testthat/test-resolver.R | 46 +++++++++----------- tests/testthat/test-types.R | 39 +++++++++++++++++ 7 files changed, 128 insertions(+), 105 deletions(-) create mode 100644 tests/testthat/test-types.R diff --git a/NAMESPACE b/NAMESPACE index 72e9fbd7..2eaaa365 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -7,6 +7,11 @@ S3method("[[","type<-") S3method("[[",type) S3method("|",dataset) S3method(c,type) +S3method(data,MultiAssayExperiment) +S3method(data,data.frame) +S3method(data,default) +S3method(data,matrix) +S3method(data,qenv) S3method(data_extract_multiple_srv,FilteredData) S3method(data_extract_multiple_srv,list) S3method(data_extract_multiple_srv,reactive) @@ -49,6 +54,7 @@ export(check_no_multiple_selection) export(choices_labeled) export(choices_selected) export(compose_and_enable_validators) +export(data) export(data_extract_multiple_srv) export(data_extract_spec) export(data_extract_srv) @@ -84,10 +90,6 @@ export(value_choices) export(values) export(variable_choices) export(variables) -export(variables.MultiAssayExperiment) -export(variables.data.frame) -export(variables.default) -export(variables.matrix) import(shiny) importFrom(dplyr,"%>%") importFrom(lifecycle,badge) diff --git a/R/resolver.R b/R/resolver.R index 0645206f..ab63f4d7 100644 --- a/R/resolver.R +++ b/R/resolver.R @@ -49,16 +49,6 @@ resolver <- function(spec, data, ...) { } functions_names <- function(unresolved, reference) { - - if (length(unresolved) == 1 && is.function(unresolved)) { - out <- tryCatch(unresolved(reference), error = function(x) unresolved) - if (is.logical(out) && length(out) == length(reference)) { - return(reference[out]) - } else { - return(NULL) - } - } - is_fc <- vapply(unresolved, is.function, logical(1L)) fc_unresolved <- unresolved[is_fc] x <- vector("character") @@ -74,20 +64,26 @@ functions_names <- function(unresolved, reference) { } functions_data <- function(unresolved, data) { - if (length(unresolved) == 1 && is.function(unresolved)){ - out <- tryCatch(vapply(data, unresolved, logical(1L)), error = function(x) unresolved) - if (is.logical(out) && length(out) == length(data)) { - return(names(data)[out]) - } else { - return(NULL) - } - } - fc_unresolved <- unresolved[vapply(unresolved, is.function, logical(1L))] # This is for variables names <- names(data) - l <- lapply(fc_unresolved, function(f) {names[which(f(data))]}) + datasets <- names(data) + l <- lapply(fc_unresolved, function(f) { + v <- vapply(datasets, function(d) { + # Extract the data and apply the user supplied function + out <- f(data(data, d)) + if (!is.logical(out)) { + stop("Provided functions should return a logical object.") + } + if (length(out) > 1L) { + # Function resolution is unconventional... + return(FALSE) + } + out + }, logical(1L)) + datasets[v] + }) unique(unlist(l, FALSE, FALSE)) } @@ -123,13 +119,13 @@ resolver.datasets <- function(spec, data) { if (length(sdatasets$names) == 0) { stop("No selected datasets matching the conditions requested") } else if (length(sdatasets$names) == 1) { - svariables$select <- sdatasets$names - } else { - new_select <- c(functions_names(sdatasets$select, sdatasets$names), - functions_data(sdatasets$select, data[sdatasets$names])) - - sdatasets$select <- unique(new_select[!is.na(new_select)]) + sdatasets$select <- sdatasets$names } + + new_select <- c(functions_names(sdatasets$select, sdatasets$names), + functions_data(sdatasets$select, data[sdatasets$names])) + + sdatasets$select <- unique(new_select[!is.na(new_select)]) } spec$datasets <- resolved(sdatasets, "dataset") @@ -146,8 +142,7 @@ resolver.variables <- function(spec, data) { } datasets <- spec$datasets$select data_selected <- data(data, datasets) - dataset <- data_selected[[datasets]] - names_data <- names(dataset) + names_data <- names(data_selected) svariables <- spec$variables @@ -162,19 +157,20 @@ resolver.variables <- function(spec, data) { svariables$select <- match } else { new_select <- c(functions_names(svariables$select, svariables$names), - functions_data(svariables$select, dataset)) + functions_data(svariables$select, data_selected)) svariables$select <- unique(new_select[!is.na(new_select)]) } } else if (is.delayed(svariables)) { new_names <- c(functions_names(svariables$names, names_data), - functions_data(svariables$names, dataset)) + functions_data(svariables$names, data_selected)) svariables$names <- unique(new_names[!is.na(new_names)]) - if (length(match) == 1) { + # browser() + if (length(svariables$names) == 1) { svariables$select <- svariables$names } else { - new_select <- c(functions_names(svariables$select, svariables$names), - functions_data(svariables$select, dataset)) - svariables$select <- unique(new_select[!is.na(new_select)]) + new_select <- c(functions_names(svariables$select, svariables$names), + functions_data(svariables$select, data_selected)) + svariables$select <- unique(new_select[!is.na(new_select)]) } } spec$variables <- resolved(svariables, "variables") @@ -229,7 +225,7 @@ data.data.frame <- function(x, variable) { #' @export data.qenv <- function(x, variable) { - x[variable] + x[[variable]] } #' @export diff --git a/R/types.R b/R/types.R index d488dab2..a5fdc0ba 100644 --- a/R/types.R +++ b/R/types.R @@ -30,7 +30,12 @@ na_type <- function() { datasets <- function(x, select = first_choice) { stopifnot(is.character(x) || is.function(x) || (is.list(x) && all(vapply(x, is.function, logical(1L))))) stopifnot(is.character(select) || is.function(select) || (is.list(select) && all(vapply(select, is.function, logical(1L))))) - + if (is.function(x)) { + x <- list(x) + } + if (is.function(select)) { + select <- list(select) + } type <- list(names = x, select = select) class(type) <- c("delayed", "datasets", "type", "list") o <- list(datasets = type, variables = na_type(), values = na_type()) @@ -43,9 +48,14 @@ datasets <- function(x, select = first_choice) { variables <- function(x, select = first_choice) { stopifnot(is.character(x) || is.function(x) || (is.list(x) && all(vapply(x, is.function, logical(1L))))) stopifnot(is.character(select) || is.function(select) || (is.list(select) && all(vapply(select, is.function, logical(1L))))) - + if (is.function(x)) { + x <- list(x) + } + if (is.function(select)) { + select <- list(select) + } type <- list(names = x, select = select) - class(type) <- c("delayed", "variables", "type") + class(type) <- c("delayed", "variables", "type", "list") o <- list(datasets = na_type(), variables = type, values = na_type()) class(o) <- c("delayed", "transform") o @@ -55,9 +65,14 @@ variables <- function(x, select = first_choice) { values <- function(x, select = first_choice) { stopifnot(is.character(x) || is.function(x) || (is.list(x) && all(vapply(x, is.function, logical(1L))))) stopifnot(is.character(select) || is.function(select) || (is.list(select) && all(vapply(select, is.function, logical(1L))))) - + if (is.function(x)) { + x <- list(x) + } + if (is.function(select)) { + select <- list(select) + } type <- list(names = x, select = select) - class(type) <- c("delayed", "values", "type") + class(type) <- c("delayed", "values", "type", "list") o <- list(datasets = na_type(), variables = na_type(), values = type) class(o) <- c("delayed", "transform") o @@ -68,12 +83,12 @@ c.type <- function(...) { c1 <- class(..1) c2 <- class(..2) classes <- unique(c(c1, c2)) - other_classes <- setdiff(classes, c("delayed", "type")) + other_classes <- setdiff(classes, c("delayed", "type", "list")) if ("delayed" %in% classes) { - classes <- c("delayed", other_classes, "type") + classes <- c("delayed", other_classes, "type", "list") } else { - classes <- c(other_classes, "type") + classes <- c(other_classes, "type", "list") } out <- NextMethod("c") diff --git a/tests/testthat/test-delayed.R b/tests/testthat/test-delayed.R index b9408a34..99bd1889 100644 --- a/tests/testthat/test-delayed.R +++ b/tests/testthat/test-delayed.R @@ -1,5 +1,5 @@ test_that("delay works", { - out <- 1 + out <- list(names = character(), select = character()) dout <- delay(out) expect_s3_class(dout, "delayed") expect_true(is.delayed(dout)) @@ -9,8 +9,9 @@ test_that("delay works", { test_that("is.delayed works", { d <- datasets("a") v <- variables("b") + da <- datasets("a", "a") expect_true(is.delayed(d)) - expect_true(is.delayed(datasets("a", "a"))) + expect_true(is.delayed(da)) expect_true(is.delayed(v)) expect_true(is.delayed(variables("b", "b"))) expect_true(is.delayed(d & v)) diff --git a/tests/testthat/test-ops_transform.R b/tests/testthat/test-ops_transform.R index 847c0b55..c8c3ff36 100644 --- a/tests/testthat/test-ops_transform.R +++ b/tests/testthat/test-ops_transform.R @@ -1,12 +1,15 @@ basic_ops <- function(fun) { FUN <- match.fun(fun) type1 <- FUN("ABC") - type2 <- FUN("ABC2") types <- type1 & type1 out <- list(names = "ABC", select = list(first_choice)) - class(out) <- c("delayed", fun, "type") + class(out) <- c("delayed", fun, "type", "list") expect_equal(types[[fun]], out) + type2 <- FUN("ABC2") types <- type1 & type2 + out <- list(names = c("ABC", "ABC2"), select = list(first_choice)) + class(out) <- c("delayed", fun, "type", "list") + expect_equal(types[[fun]], out) expect_equal(types[[fun]]$names, c("ABC", "ABC2")) types2 <- types & type2 expect_equal(types[[fun]]$names, c("ABC", "ABC2")) @@ -20,6 +23,7 @@ basic_ops <- function(fun) { expect_length(out[[fun]]$names, 2) expect_error(FUN("ABC") & 1) out <- type1 & type2b + expect_true(is(out[[fun]]$names, "vector")) } test_that("datasets & work", { @@ -80,31 +84,3 @@ test_that("datasets & variables & values work", { expect_equal(vars$values$names, "abc") expect_error(vars & 1) }) - - - -test_that("datasets", { - first <- function(x){ - if (length(x) > 0) { - false <- rep(FALSE, length.out = length(x)) - false[1] <- TRUE - return(false) - } - return(FALSE) - } - - dataset1 <- datasets("df", first) - expect_true(is(dataset1$datasets$names, "vector")) - dataset2 <- datasets(is.matrix, first) - expect_true(is(dataset2$datasets$names, "vector")) - dataset3 <- datasets(is.data.frame, first) - mix <- dataset1 & dataset2 - expect_true(is(mix$datasets$names, "vector")) -}) - -test_that("variables", { - var1 <- variables("a", first) - var2 <- variables(is.factor, first) - var3 <- variables(is.factor, function(x){head(x, 1)}) - var4 <- variables(is.matrix, function(x){head(x, 1)}) -}) diff --git a/tests/testthat/test-resolver.R b/tests/testthat/test-resolver.R index 7dfea733..cba32daa 100644 --- a/tests/testthat/test-resolver.R +++ b/tests/testthat/test-resolver.R @@ -1,14 +1,14 @@ -test_that("resolver datasets works", { - f <- function(x){head(x, 1)} - first <- function(x){ - if (length(x) > 0) { - false <- rep(FALSE, length.out = length(x)) - false[1] <- TRUE - return(false) - } - return(FALSE) +f <- function(x){head(x, 1)} +first <- function(x){ + if (length(x) > 0) { + false <- rep(FALSE, length.out = length(x)) + false[1] <- TRUE + return(false) } + return(FALSE) +} +test_that("resolver datasets works", { dataset1 <- datasets("df", f) dataset2 <- datasets("df", first) dataset3 <- datasets(is.matrix, first) @@ -20,7 +20,7 @@ test_that("resolver datasets works", { m2 <- cbind(a = LETTERS[1:2], b = LETTERS[4:5]) }) expect_no_error(resolver(dataset1, td)) - resolver(dataset2, td) + expect_no_error(resolver(dataset2, td)) out <- resolver(dataset3, td) expect_length(out$datasets$select, 1L) # Because we use first expect_no_error(resolver(dataset4, td)) @@ -28,15 +28,6 @@ test_that("resolver datasets works", { }) test_that("resolver variables works", { - first <- function(x){ - if (length(x) > 0) { - false <- rep(FALSE, length.out = length(x)) - false[1] <- TRUE - return(false) - } - return(FALSE) - } - dataset1 <- datasets("df", first) dataset2 <- datasets(is.matrix, first) dataset3 <- datasets(is.data.frame, first) @@ -50,15 +41,18 @@ test_that("resolver variables works", { m2 <- cbind(a = LETTERS[1:2], b = LETTERS[4:5]) }) - resolver(dataset1 & var1, td) + expect_no_error(resolver(dataset1 & var1, td)) resolver(dataset1 & var2, td) expect_error(resolver(dataset1 & var3, td)) + expect_error(resolver(dataset1 & var4, td)) - resolver(dataset2 & var1, td) - resolver(dataset2 & var2, td) - resolver(dataset2 & var3, td) + expect_error(resolver(dataset2 & var1, td)) + expect_no_error(resolver(dataset2 & var2, td)) + expect_error(resolver(dataset2 & var3, td)) + expect_error(resolver(dataset2 & var4, td)) - resolver(dataset3 & var1, td) - resolver(dataset3 & var2, td) - resolver(dataset3 & var3, td) + expect_no_error(resolver(dataset3 & var1, td)) + expect_no_error(resolver(dataset3 & var2, td)) + expect_error(resolver(dataset3 & var3, td)) + expect_error(resolver(dataset3 & var4, td)) }) diff --git a/tests/testthat/test-types.R b/tests/testthat/test-types.R new file mode 100644 index 00000000..28e74775 --- /dev/null +++ b/tests/testthat/test-types.R @@ -0,0 +1,39 @@ +first <- function(x){ + if (length(x) > 0) { + false <- rep(FALSE, length.out = length(x)) + false[1] <- TRUE + return(false) + } + return(FALSE) +} + +test_that("datasets", { + + expect_no_error(dataset0 <- datasets("df", "df")) + out <- list(names = "df", select = "df") + class(out) <- c("delayed", "datasets", "type", "list") + expect_equal(dataset0[["datasets"]], out) + expect_no_error(dataset1 <- datasets("df", first)) + expect_true(is.vector(dataset1$datasets$names)) + expect_no_error(dataset2 <- datasets(is.matrix, first)) + expect_true(is.vector(dataset2$datasets$names)) + expect_no_error(dataset3 <- datasets(is.data.frame, first)) +}) + +test_that("variables", { + expect_no_error(var0 <- variables("a", "a")) + expect_no_error(var1 <- variables("a", first)) + expect_no_error(var2 <- variables(is.factor, first)) + expect_no_error(var3 <- variables(is.factor, function(x){head(x, 1)})) + expect_no_error(var4 <- variables(is.matrix, function(x){head(x, 1)})) + +}) + +test_that("values", { + expect_no_error(val0 <- values("a", "a")) + expect_no_error(val1 <- values("a", first)) + expect_no_error(val2 <- values(is.factor, first)) + expect_no_error(val3 <- values(is.factor, function(x){head(x, 1)})) + expect_no_error(val4 <- values(is.matrix, function(x){head(x, 1)})) + +}) From 0d89dce2feb0ca2963eeb41a1bbabfa44f5ca300 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Thu, 6 Mar 2025 14:15:32 +0100 Subject: [PATCH 004/142] Add function for when a new selection is chosen --- NAMESPACE | 1 + R/delayed.R | 1 + R/resolver.R | 110 ++++++++++++++++++++++++----- R/types.R | 37 ++++++++-- man/update_spec.Rd | 21 ++++++ tests/testthat/test-resolver.R | 122 +++++++++++++++++++++++---------- 6 files changed, 232 insertions(+), 60 deletions(-) create mode 100644 man/update_spec.Rd diff --git a/NAMESPACE b/NAMESPACE index 2eaaa365..07bb8964 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -86,6 +86,7 @@ export(select_spec) export(select_spec.default) export(select_spec.delayed_data) export(split_by_sep) +export(update_spec) export(value_choices) export(values) export(variable_choices) diff --git a/R/delayed.R b/R/delayed.R index f67c7e2c..13858f4f 100644 --- a/R/delayed.R +++ b/R/delayed.R @@ -6,6 +6,7 @@ delay <- function(x) { #' @export #' @method is.delayed type is.delayed.type <- function(x) { + !all(is.character(x$names)) || !all(is.character(x$select)) } diff --git a/R/resolver.R b/R/resolver.R index ab63f4d7..8b4e5cb6 100644 --- a/R/resolver.R +++ b/R/resolver.R @@ -26,9 +26,9 @@ resolver <- function(spec, data, ...) { } stopifnot(is.transform(spec), has_dataset(spec)) specf <- spec - if (has_dataset(specf)) { + if (has_dataset(specf) && is.delayed(specf$datasets)) { specf <- resolver.datasets(specf, data) - } else { + } else if (!has_dataset(specf)) { specf$datasets <- NULL } @@ -63,16 +63,21 @@ functions_names <- function(unresolved, reference) { unique(unlist(c(unresolved[!is_fc], x), FALSE, FALSE)) } -functions_data <- function(unresolved, data) { +functions_data <- function(unresolved, data, names_data) { fc_unresolved <- unresolved[vapply(unresolved, is.function, logical(1L))] # This is for variables names <- names(data) + # browser(expr = is.matrix(data)) datasets <- names(data) + # Matrix doesn't have a names method + if (is.null(datasets)) { + datasets <- colnames(data) + } l <- lapply(fc_unresolved, function(f) { v <- vapply(datasets, function(d) { # Extract the data and apply the user supplied function - out <- f(data(data, d)) + out <- tryCatch(f(data(data, d)), error = function(x){FALSE}) if (!is.logical(out)) { stop("Provided functions should return a logical object.") } @@ -91,10 +96,13 @@ resolver.datasets <- function(spec, data) { if (!is(data, "qenv")) { stop("Please use qenv() or teal_data() objects.") } - + if (is.null(spec[["datasets"]])) { + return(spec) + } sdatasets <- spec$datasets data_names <- names(data) - + orig_names <- sdatasets$names + orig_select <- sdatasets$select if (is.delayed(sdatasets) && all(is.character(sdatasets$names))) { match <- intersect(data_names, sdatasets$names) missing <- setdiff(sdatasets$names, data_names) @@ -112,6 +120,7 @@ resolver.datasets <- function(spec, data) { sdatasets$select <- unique(new_select[!is.na(new_select)]) } } else if (is.delayed(sdatasets)) { + old_names <- sdatasets$names new_names <- c(functions_names(sdatasets$names, data_names), functions_data(sdatasets$names, data)) sdatasets$names <- unique(new_names[!is.na(new_names)]) @@ -127,7 +136,8 @@ resolver.datasets <- function(spec, data) { sdatasets$select <- unique(new_select[!is.na(new_select)]) } - + attr(sdatasets$names, "original") <- attr(orig_names, "original") + attr(sdatasets$select, "original") <- attr(orig_select, "original") spec$datasets <- resolved(sdatasets, "dataset") spec } @@ -140,12 +150,20 @@ resolver.variables <- function(spec, data) { if (is.delayed(spec$datasets)) { stop("Datasets not resolved yet") } + if (is.null(spec[["variables"]])) { + return(spec) + } datasets <- spec$datasets$select data_selected <- data(data, datasets) - names_data <- names(data_selected) + if (is.null(names(data_selected))) { + names_data <- colnames(data_selected) + } else { + names_data <- names(data_selected) + } svariables <- spec$variables - + orig_names <- svariables$names + orig_select <- svariables$select if (is.delayed(svariables) && all(is.character(svariables$names))) { match <- intersect(names_data, svariables$names) missing <- setdiff(svariables$names, names_data) @@ -173,8 +191,12 @@ resolver.variables <- function(spec, data) { svariables$select <- unique(new_select[!is.na(new_select)]) } } + + attr(svariables$names, "original") <- attr(orig_names, "original") + attr(svariables$select, "original") <- attr(orig_select, "original") spec$variables <- resolved(svariables, "variables") spec + } resolver.values <- function(spec, data) { @@ -182,23 +204,42 @@ resolver.values <- function(spec, data) { stop("Please use qenv() or teal_data() objects.") } - variables <- spec$variables$names + if (is.null(spec[["values"]])) { + return(spec) + } + svalues <- spec$values - spec$variables <- if (is.delayed(svalues) && all(is.character(svalues$names))) { + orig_names <- svalues$names + orig_select <- svalues$select + spec$values <- if (is.delayed(svalues) && all(is.character(svalues$names))) { match <- intersect(datasets, svalues$names) missing <- setdiff(svalues$names, datasets) if (length(missing)) { stop("Missing values ", paste(sQuote(missing), collapse = ", "), " were specified.") } svalues$names <- match - svalues$select <- functions_names(svalues$select, match) - svalues + if (length(match) == 1) { + svalues$select <- match + } else { + new_select <- c(functions_names(svalues$select, svalues$names), + functions_data(svalues$select, data_selected)) + svalues$select <- unique(new_select[!is.na(new_select)]) + } } else if (is.delayed(svalues)) { - svalues$names <- functions_names(svalues$names, datasets) - svalues$select <- functions_names(svalues$select, svalues$names) - svalues + new_names <- c(functions_names(svalues$names, names_data), + functions_data(svalues$names, data_selected)) + svalues$names <- unique(new_names[!is.na(new_names)]) + # browser() + if (length(svalues$names) == 1) { + svalues$select <- svalues$names + } else { + new_select <- c(functions_names(svalues$select, svalues$names), + functions_data(svalues$select, data_selected)) + svalues$select <- unique(new_select[!is.na(new_select)]) + } } - + attr(svalues$names, "original") <- attr(orig_names, "original") + attr(svalues$select, "original") <- attr(orig_select, "original") spec$values <- resolved(svalues, "values") spec } @@ -237,3 +278,38 @@ data.default <- function(x, variable) { data <- function(x, variable) { UseMethod("data") } + +#' Update a spec +#' +#' Once a selection is made update the specification +#' @param spec A specification +#' @param type Which type was updated? +#' @param value What is the new selection? +#' @return The specification with restored choices and selection if caused by the update. +#' @export +update_spec <- function(spec, type, value) { + w <- c("datasets", "variables", "values") + type <- match.arg(type, w) + restart_types <- w[seq_along(w) > which(type == w)] + if (value %in% spec[[type]]$names) { + original_select <- attr(spec[[type]]$select, "original") + spec[[type]][["select"]] <- value + attr(spec[[type]][["select"]], "original") <- original_select + } + + # Restart to the original specs + for (type in restart_types) { + + # If the spec doesn't exist then there is nothing else to update + if (is.null(spec[[type]]) || !length(spec[[type]])) { + spec[[type]] <- na_type() + return(spec) + } + fun <- match.fun(type) + restored_type <- fun(x = attr(spec[[type]]$names, "original"), + select = attr(spec[[type]]$select, "original")) + spec[[type]] <- na_type() + spec <- spec & restored_type + } + spec +} diff --git a/R/types.R b/R/types.R index a5fdc0ba..f9b956c9 100644 --- a/R/types.R +++ b/R/types.R @@ -26,8 +26,17 @@ na_type <- function() { out } +first <- function(x){ + if (length(x) > 0) { + false <- rep(FALSE, length.out = length(x)) + false[1] <- TRUE + return(false) + } + return(FALSE) +} + #' @export -datasets <- function(x, select = first_choice) { +datasets <- function(x, select = first) { stopifnot(is.character(x) || is.function(x) || (is.list(x) && all(vapply(x, is.function, logical(1L))))) stopifnot(is.character(select) || is.function(select) || (is.list(select) && all(vapply(select, is.function, logical(1L))))) if (is.function(x)) { @@ -38,6 +47,8 @@ datasets <- function(x, select = first_choice) { } type <- list(names = x, select = select) class(type) <- c("delayed", "datasets", "type", "list") + attr(type$names, "original") <- x + attr(type$select, "original") <- select o <- list(datasets = type, variables = na_type(), values = na_type()) class(o) <- c("delayed", "transform", "list") o @@ -45,7 +56,7 @@ datasets <- function(x, select = first_choice) { #' @export -variables <- function(x, select = first_choice) { +variables <- function(x, select = first) { stopifnot(is.character(x) || is.function(x) || (is.list(x) && all(vapply(x, is.function, logical(1L))))) stopifnot(is.character(select) || is.function(select) || (is.list(select) && all(vapply(select, is.function, logical(1L))))) if (is.function(x)) { @@ -56,13 +67,15 @@ variables <- function(x, select = first_choice) { } type <- list(names = x, select = select) class(type) <- c("delayed", "variables", "type", "list") + attr(type$names, "original") <- x + attr(type$select, "original") <- select o <- list(datasets = na_type(), variables = type, values = na_type()) class(o) <- c("delayed", "transform") o } #' @export -values <- function(x, select = first_choice) { +values <- function(x, select = first) { stopifnot(is.character(x) || is.function(x) || (is.list(x) && all(vapply(x, is.function, logical(1L))))) stopifnot(is.character(select) || is.function(select) || (is.list(select) && all(vapply(select, is.function, logical(1L))))) if (is.function(x)) { @@ -73,6 +86,8 @@ values <- function(x, select = first_choice) { } type <- list(names = x, select = select) class(type) <- c("delayed", "values", "type", "list") + attr(type$names, "original") <- x + attr(type$select, "original") <- select o <- list(datasets = na_type(), variables = na_type(), values = type) class(o) <- c("delayed", "transform") o @@ -82,6 +97,13 @@ values <- function(x, select = first_choice) { c.type <- function(...) { c1 <- class(..1) c2 <- class(..2) + + if (is.null(..1)) { + return(..2) + } else if (is.null(..2)) { + return(..1) + } + classes <- unique(c(c1, c2)) other_classes <- setdiff(classes, c("delayed", "type", "list")) @@ -102,11 +124,14 @@ c.type <- function(...) { names <- nam == "names" selects <- nam == "select" - out <- list(names = unlist(out[names], FALSE, FALSE), + new_l <- list(names = unlist(out[names], FALSE, FALSE), select = unlist(out[selects], FALSE, FALSE)) - l <- lapply(out, unique) + l <- lapply(new_l, unique) class(l) <- classes + + attr(l$names, "original") <- unique(unlist(lapply(out[names], attr, "original"), TRUE, FALSE)) + attr(l$select, "original") <- unique(unlist(lapply(out[selects], attr, "original"), TRUE, FALSE)) l } @@ -142,7 +167,7 @@ c.type <- function(...) { `[[.type<-` <- function(x, i, value) { cx <- class(x) if (!"type" %in% class(value)) { - stop("Modifying the specification with invalid objects") + stop("Modifying the specification with invalid objects.") } out <- NextMethod("[") class(out) <- cx diff --git a/man/update_spec.Rd b/man/update_spec.Rd new file mode 100644 index 00000000..ce82a3db --- /dev/null +++ b/man/update_spec.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/resolver.R +\name{update_spec} +\alias{update_spec} +\title{Update a spec} +\usage{ +update_spec(spec, type, value) +} +\arguments{ +\item{spec}{A specification} + +\item{type}{Which type was updated?} + +\item{value}{What is the new selection?} +} +\value{ +The specification with restored choices and selection if caused by the update. +} +\description{ +Once a selection is made update the specification +} diff --git a/tests/testthat/test-resolver.R b/tests/testthat/test-resolver.R index cba32daa..383d355c 100644 --- a/tests/testthat/test-resolver.R +++ b/tests/testthat/test-resolver.R @@ -1,58 +1,106 @@ f <- function(x){head(x, 1)} -first <- function(x){ - if (length(x) > 0) { - false <- rep(FALSE, length.out = length(x)) - false[1] <- TRUE - return(false) - } - return(FALSE) -} test_that("resolver datasets works", { - dataset1 <- datasets("df", f) - dataset2 <- datasets("df", first) - dataset3 <- datasets(is.matrix, first) - dataset4 <- datasets("df", mean) - dataset5 <- datasets(median, mean) + df_head <- datasets("df", f) + df_first <- datasets("df") + matrices <- datasets(is.matrix) + df_mean <- datasets("df", mean) + median_mean <- datasets(median, mean) td <- within(teal.data::teal_data(), { df <- data.frame(a = LETTERS[1:5], b = factor(letters[1:5]), c = factor(letters[1:5])) m <- cbind(b = 1:5, c = 10:14) m2 <- cbind(a = LETTERS[1:2], b = LETTERS[4:5]) }) - expect_no_error(resolver(dataset1, td)) - expect_no_error(resolver(dataset2, td)) - out <- resolver(dataset3, td) + expect_no_error(resolver(df_head, td)) + expect_no_error(resolver(df_first, td)) + out <- resolver(matrices, td) expect_length(out$datasets$select, 1L) # Because we use first - expect_no_error(resolver(dataset4, td)) - expect_error(resolver(dataset5, td)) + expect_no_error(resolver(df_mean, td)) + expect_error(resolver(median_mean, td)) }) test_that("resolver variables works", { - dataset1 <- datasets("df", first) - dataset2 <- datasets(is.matrix, first) - dataset3 <- datasets(is.data.frame, first) - var1 <- variables("a", first) - var2 <- variables(is.factor, first) - var3 <- variables(is.factor, function(x){head(x, 1)}) - var4 <- variables(is.matrix, function(x){head(x, 1)}) + df <- datasets("df") + matrices <- datasets(is.matrix) + data_frames <- datasets(is.data.frame) + var_a <- variables("a") + factors <- variables(is.factor) + factors_head <- variables(is.factor, function(x){head(x, 1)}) + var_matrices_head <- variables(is.matrix, function(x){head(x, 1)}) td <- within(teal.data::teal_data(), { df <- data.frame(a = LETTERS[1:5], b = factor(letters[1:5]), c = factor(letters[1:5])) m <- cbind(b = 1:5, c = 10:14) m2 <- cbind(a = LETTERS[1:2], b = LETTERS[4:5]) }) - expect_no_error(resolver(dataset1 & var1, td)) - resolver(dataset1 & var2, td) - expect_error(resolver(dataset1 & var3, td)) - expect_error(resolver(dataset1 & var4, td)) + expect_no_error(resolver(df & var_a, td)) + expect_no_error(resolver(df & factors, td)) + expect_error(resolver(df & factors_head, td)) + expect_error(resolver(df & var_matrices_head, td)) - expect_error(resolver(dataset2 & var1, td)) - expect_no_error(resolver(dataset2 & var2, td)) - expect_error(resolver(dataset2 & var3, td)) - expect_error(resolver(dataset2 & var4, td)) + expect_error(resolver(matrices & var_a, td)) + expect_error(resolver(matrices & factors, td)) + expect_error(resolver(matrices & factors_head, td)) + expect_error(resolver(matrices & var_matrices_head, td)) - expect_no_error(resolver(dataset3 & var1, td)) - expect_no_error(resolver(dataset3 & var2, td)) - expect_error(resolver(dataset3 & var3, td)) - expect_error(resolver(dataset3 & var4, td)) + expect_no_error(resolver(data_frames & var_a, td)) + expect_no_error(resolver(data_frames & factors, td)) + expect_error(resolver(data_frames & factors_head, td)) + expect_error(resolver(data_frames & var_matrices_head, td)) }) + +test_that("names and variables are reported", { + td <- within(teal.data::teal_data(), { + df <- data.frame(A = as.factor(letters[1:5]), + Ab = LETTERS[1:5], + Abc = c(LETTERS[1:4], letters[1])) + m <- matrix() + }) + df_upper_variables <- datasets("df") & variables(function(x){x==toupper(x)}) + out <- resolver(df_upper_variables, td) + # This should select both A because the name is all capital letters and Ab values is all upper case. + expect_length(out$variables$names, 2) + df_all_upper_variables <- datasets("df") & variables(function(x){all(x==toupper(x))}) + out <- resolver(df_all_upper_variables, td) + expect_length(out$variables$names, 2) +}) + + +test_that("update_spec resolves correctly", { + td <- within(teal.data::teal_data(), { + df <- data.frame(A = as.factor(letters[1:5]), + Ab = LETTERS[1:5]) + df_n <- data.frame(C = 1:5, + Ab = as.factor(letters[1:5])) + }) + data_frames_factors <- datasets(is.data.frame) & variables(is.factor) + expect_false(is.null(attr(data_frames_factors$datasets$names, "original"))) + expect_false(is.null(attr(data_frames_factors$datasets$select, "original"))) + expect_false(is.null(attr(data_frames_factors$variables$names, "original"))) + expect_false(is.null(attr(data_frames_factors$variables$select, "original"))) + + res <- resolver(data_frames_factors, td) + expect_false(is.null(attr(res$datasets$names, "original"))) + expect_false(is.null(attr(res$datasets$select, "original"))) + expect_false(is.null(attr(res$variables$names, "original"))) + expect_false(is.null(attr(res$variables$select, "original"))) + + res2 <- update_spec(res, "datasets", "df_n") + expect_false(is.null(attr(res2$datasets$names, "original"))) + expect_false(is.null(attr(res2$datasets$select, "original"))) + expect_false(is.null(attr(res2$variables$names, "original"))) + expect_false(is.null(attr(res2$variables$select, "original"))) + + expect_no_error(res3 <- resolver(res2, td)) + expect_false(is.null(attr(res3$datasets$names, "original"))) + expect_false(is.null(attr(res3$datasets$select, "original"))) + expect_equal(attr(res3$datasets$names, "original"), attr(data_frames_factors$datasets$names, "original")) + expect_equal(attr(res3$datasets$select, "original"), attr(data_frames_factors$datasets$select, "original")) + expect_equal(res3$datasets$select, "df_n", check.attributes = FALSE) + expect_equal(res3$variables$select, "Ab", check.attributes = FALSE) + expect_false(is.null(attr(res3$variables$names, "original"))) + expect_false(is.null(attr(res3$variables$select, "original"))) + expect_equal(attr(res3$variables$names, "original"), attr(data_frames_factors$variables$names, "original")) + expect_equal(attr(res3$variables$select, "original"), attr(data_frames_factors$variables$select, "original")) +}) + From 58182d2d56df2470a668efba17dfabf26deaebf5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Fri, 7 Mar 2025 11:28:37 +0100 Subject: [PATCH 005/142] Raising more errors and silencing some tests --- R/resolver.R | 58 +++++++++++++++++++++++------ tests/testthat/test-delayed.R | 5 ++- tests/testthat/test-ops_transform.R | 30 +++++++-------- tests/testthat/test-resolver.R | 13 ++++--- tests/testthat/test-types.R | 6 +-- 5 files changed, 75 insertions(+), 37 deletions(-) diff --git a/R/resolver.R b/R/resolver.R index 8b4e5cb6..99cb5f3a 100644 --- a/R/resolver.R +++ b/R/resolver.R @@ -68,7 +68,6 @@ functions_data <- function(unresolved, data, names_data) { # This is for variables names <- names(data) - # browser(expr = is.matrix(data)) datasets <- names(data) # Matrix doesn't have a names method if (is.null(datasets)) { @@ -117,13 +116,21 @@ resolver.datasets <- function(spec, data) { } else { new_select <- c(functions_names(sdatasets$select, sdatasets$names), functions_data(sdatasets$select, data[sdatasets$names])) - sdatasets$select <- unique(new_select[!is.na(new_select)]) + new_select <- unique(new_select[!is.na(new_select)]) + if (!length(new_select)) { + stop("No datasets meet the requirements to be selected") + } + sdatasets$select <- new_select } } else if (is.delayed(sdatasets)) { old_names <- sdatasets$names new_names <- c(functions_names(sdatasets$names, data_names), functions_data(sdatasets$names, data)) - sdatasets$names <- unique(new_names[!is.na(new_names)]) + new_names <- unique(new_names[!is.na(new_names)]) + if (!length(new_names)) { + stop("No datasets meet the requirements") + } + sdatasets$names <- new_names if (length(sdatasets$names) == 0) { stop("No selected datasets matching the conditions requested") @@ -134,7 +141,11 @@ resolver.datasets <- function(spec, data) { new_select <- c(functions_names(sdatasets$select, sdatasets$names), functions_data(sdatasets$select, data[sdatasets$names])) - sdatasets$select <- unique(new_select[!is.na(new_select)]) + new_select <- unique(new_select[!is.na(new_select)]) + if (!length(new_select)) { + stop("No datasets meet the requirements to be selected") + } + sdatasets$select <- new_select } attr(sdatasets$names, "original") <- attr(orig_names, "original") attr(sdatasets$select, "original") <- attr(orig_select, "original") @@ -176,19 +187,30 @@ resolver.variables <- function(spec, data) { } else { new_select <- c(functions_names(svariables$select, svariables$names), functions_data(svariables$select, data_selected)) - svariables$select <- unique(new_select[!is.na(new_select)]) + new_select <- unique(new_select[!is.na(new_select)]) + if (!length(new_select)) { + stop("No variables meet the requirements to be selected") + } + svariables$select <- new_select } } else if (is.delayed(svariables)) { new_names <- c(functions_names(svariables$names, names_data), functions_data(svariables$names, data_selected)) - svariables$names <- unique(new_names[!is.na(new_names)]) - # browser() + new_names <- unique(new_names[!is.na(new_names)]) + if (!length(new_names)) { + stop("No variables meet the requirements") + } + svariables$names <- new_names if (length(svariables$names) == 1) { svariables$select <- svariables$names } else { new_select <- c(functions_names(svariables$select, svariables$names), functions_data(svariables$select, data_selected)) - svariables$select <- unique(new_select[!is.na(new_select)]) + new_select <- unique(new_select[!is.na(new_select)]) + if (!length(new_select)) { + stop("No variables meet the requirements to be selected") + } + svariables$select <- new_select } } @@ -223,19 +245,31 @@ resolver.values <- function(spec, data) { } else { new_select <- c(functions_names(svalues$select, svalues$names), functions_data(svalues$select, data_selected)) - svalues$select <- unique(new_select[!is.na(new_select)]) + new_select <- unique(new_select[!is.na(new_select)]) + if (!length(new_select)) { + stop("No variables meet the requirements to be selected") + } + svalues$select <- new_select } } else if (is.delayed(svalues)) { new_names <- c(functions_names(svalues$names, names_data), functions_data(svalues$names, data_selected)) - svalues$names <- unique(new_names[!is.na(new_names)]) - # browser() + new_names <- unique(new_names[!is.na(new_names)]) + if (!length(new_names)) { + stop("No variables meet the requirements") + } + svalues$names <- new_names + if (length(svalues$names) == 1) { svalues$select <- svalues$names } else { new_select <- c(functions_names(svalues$select, svalues$names), functions_data(svalues$select, data_selected)) - svalues$select <- unique(new_select[!is.na(new_select)]) + new_select <- unique(new_select[!is.na(new_select)]) + if (!length(new_select)) { + stop("No variables meet the requirements to be selected") + } + svalues$select <- new_select } } attr(svalues$names, "original") <- attr(orig_names, "original") diff --git a/tests/testthat/test-delayed.R b/tests/testthat/test-delayed.R index 99bd1889..01a89170 100644 --- a/tests/testthat/test-delayed.R +++ b/tests/testthat/test-delayed.R @@ -11,8 +11,9 @@ test_that("is.delayed works", { v <- variables("b") da <- datasets("a", "a") expect_true(is.delayed(d)) - expect_true(is.delayed(da)) - expect_true(is.delayed(v)) + # expect_true(is.delayed(da)) + # expect_true(is.delayed(v)) expect_true(is.delayed(variables("b", "b"))) expect_true(is.delayed(d & v)) + expect_false(is.delayed(1)) }) diff --git a/tests/testthat/test-ops_transform.R b/tests/testthat/test-ops_transform.R index c8c3ff36..defeb9be 100644 --- a/tests/testthat/test-ops_transform.R +++ b/tests/testthat/test-ops_transform.R @@ -2,17 +2,17 @@ basic_ops <- function(fun) { FUN <- match.fun(fun) type1 <- FUN("ABC") types <- type1 & type1 - out <- list(names = "ABC", select = list(first_choice)) + out <- list(names = "ABC", select = list(first)) class(out) <- c("delayed", fun, "type", "list") - expect_equal(types[[fun]], out) + expect_equal(types[[fun]], out, check.attributes = FALSE) type2 <- FUN("ABC2") types <- type1 & type2 - out <- list(names = c("ABC", "ABC2"), select = list(first_choice)) + out <- list(names = c("ABC", "ABC2"), select = list(first)) class(out) <- c("delayed", fun, "type", "list") - expect_equal(types[[fun]], out) - expect_equal(types[[fun]]$names, c("ABC", "ABC2")) + expect_equal(types[[fun]], out, check.attributes = FALSE) + expect_equal(types[[fun]]$names, c("ABC", "ABC2"), check.attributes = FALSE) types2 <- types & type2 - expect_equal(types[[fun]]$names, c("ABC", "ABC2")) + expect_equal(types[[fun]]$names, c("ABC", "ABC2"), check.attributes = FALSE) expect_s3_class(types[[fun]], class(out)) type3 <- FUN("ABC2", select = all_choices) types <- type1 & type3 @@ -45,8 +45,8 @@ test_that("datsets & variables work", { vars <- dataset1 & var1 vars2 <- var1 & dataset1 expect_equal(vars, vars2) - expect_equal(vars$datasets$names, "ABC2") - expect_equal(vars$variables$names, "abc") + expect_equal(vars$datasets$names, "ABC2", check.attributes = FALSE) + expect_equal(vars$variables$names, "abc", check.attributes = FALSE) expect_error(vars & 1) }) @@ -56,8 +56,8 @@ test_that("datsets & values work", { vars <- dataset1 & val1 vars2 <- val1 & dataset1 expect_equal(vars, vars2) - expect_equal(vars$datasets$names, "ABC2") - expect_equal(vars$values$names, "abc") + expect_equal(vars$datasets$names, "ABC2", check.attributes = FALSE) + expect_equal(vars$values$names, "abc", check.attributes = FALSE) expect_error(vars & 1) }) @@ -67,8 +67,8 @@ test_that("variables & values work", { vars <- var1 & val1 vars2 <- val1 & var1 expect_equal(vars, vars2) - expect_equal(vars$variables$names, "ABC2") - expect_equal(vars$values$names, "abc") + expect_equal(vars$variables$names, "ABC2", check.attributes = FALSE) + expect_equal(vars$values$names, "abc", check.attributes = FALSE) expect_error(vars & 1) }) @@ -79,8 +79,8 @@ test_that("datasets & variables & values work", { vars <- dataset1 & var1 & val1 vars2 <- val1 & var1 & dataset1 expect_equal(vars, vars2) - expect_equal(vars$datasets$names, "ABC2") - expect_equal(vars$variables$names, "ABC2") - expect_equal(vars$values$names, "abc") + expect_equal(vars$datasets$names, "ABC2", check.attributes = FALSE) + expect_equal(vars$variables$names, "ABC2", check.attributes = FALSE) + expect_equal(vars$values$names, "abc", check.attributes = FALSE) expect_error(vars & 1) }) diff --git a/tests/testthat/test-resolver.R b/tests/testthat/test-resolver.R index 383d355c..1db50b1f 100644 --- a/tests/testthat/test-resolver.R +++ b/tests/testthat/test-resolver.R @@ -38,7 +38,8 @@ test_that("resolver variables works", { expect_error(resolver(df & factors_head, td)) expect_error(resolver(df & var_matrices_head, td)) - expect_error(resolver(matrices & var_a, td)) + + expect_error(resolver(matrices & var_a, td)) # datasets selection overpasses variable choices. expect_error(resolver(matrices & factors, td)) expect_error(resolver(matrices & factors_head, td)) expect_error(resolver(matrices & var_matrices_head, td)) @@ -58,11 +59,13 @@ test_that("names and variables are reported", { }) df_upper_variables <- datasets("df") & variables(function(x){x==toupper(x)}) out <- resolver(df_upper_variables, td) - # This should select both A because the name is all capital letters and Ab values is all upper case. - expect_length(out$variables$names, 2) + # This should select A and Ab: + # A because the name is all capital letters and + # Ab values is all upper case. + # expect_length(out$variables$names, 2) df_all_upper_variables <- datasets("df") & variables(function(x){all(x==toupper(x))}) - out <- resolver(df_all_upper_variables, td) - expect_length(out$variables$names, 2) + expect_no_error(out <- resolver(df_all_upper_variables, td)) + # expect_length(out$variables$names, 2) }) diff --git a/tests/testthat/test-types.R b/tests/testthat/test-types.R index 28e74775..f9702f2d 100644 --- a/tests/testthat/test-types.R +++ b/tests/testthat/test-types.R @@ -12,11 +12,11 @@ test_that("datasets", { expect_no_error(dataset0 <- datasets("df", "df")) out <- list(names = "df", select = "df") class(out) <- c("delayed", "datasets", "type", "list") - expect_equal(dataset0[["datasets"]], out) + expect_equal(dataset0[["datasets"]], out, check.attributes = FALSE) expect_no_error(dataset1 <- datasets("df", first)) - expect_true(is.vector(dataset1$datasets$names)) + # expect_true(is.vector(dataset1$datasets$names)) expect_no_error(dataset2 <- datasets(is.matrix, first)) - expect_true(is.vector(dataset2$datasets$names)) + # expect_true(is.vector(dataset2$datasets$names)) expect_no_error(dataset3 <- datasets(is.data.frame, first)) }) From c21591f41da743e43fd41f4e5bc0631f197c54bf Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Mon, 10 Mar 2025 17:30:01 +0100 Subject: [PATCH 006/142] Improve update_spec --- R/resolver.R | 35 ++++++++++++++++++++++++++--------- R/types.R | 4 ++-- man/update_spec.Rd | 22 +++++++++++++++++----- 3 files changed, 45 insertions(+), 16 deletions(-) diff --git a/R/resolver.R b/R/resolver.R index 99cb5f3a..de2cc614 100644 --- a/R/resolver.R +++ b/R/resolver.R @@ -313,24 +313,37 @@ data <- function(x, variable) { UseMethod("data") } -#' Update a spec +#' Update a specification #' -#' Once a selection is made update the specification -#' @param spec A specification -#' @param type Which type was updated? -#' @param value What is the new selection? +#' Once a selection is made update the specification for different valid selection. +#' @param spec A specification such as one created with datasets and variables. +#' @param type Which type was updated? One of datasets, variables, values. +#' @param value What is the new selection? One that is a valid value for the given type and specification. #' @return The specification with restored choices and selection if caused by the update. #' @export +#' @examples +#' td <- within(teal.data::teal_data(), { +#' df <- data.frame(A = as.factor(letters[1:5]), +#' Ab = LETTERS[1:5]) +#' df_n <- data.frame(C = 1:5, +#' Ab = as.factor(letters[1:5])) +#' }) +#' data_frames_factors <- datasets(is.data.frame) & variables(is.factor) +#' res <- resolver(data_frames_factors, td) +#' update_spec(res, "datasets", "df_n") +#' # update_spec(res, "datasets", "error") update_spec <- function(spec, type, value) { w <- c("datasets", "variables", "values") type <- match.arg(type, w) restart_types <- w[seq_along(w) > which(type == w)] - if (value %in% spec[[type]]$names) { + + if (is.delayed(spec[[type]])) { + stop(type, " has not been resolved yet.\n", "Please resolve the specification before trying to apply ") + } else if (all(value %in% spec[[type]]$names)) { original_select <- attr(spec[[type]]$select, "original") spec[[type]][["select"]] <- value attr(spec[[type]][["select"]], "original") <- original_select } - # Restart to the original specs for (type in restart_types) { @@ -340,8 +353,12 @@ update_spec <- function(spec, type, value) { return(spec) } fun <- match.fun(type) - restored_type <- fun(x = attr(spec[[type]]$names, "original"), - select = attr(spec[[type]]$select, "original")) + if (!length(spec[[type]]) && is.na(spec[[type]])) { + restored_type <- fun(x = na_type(), select = na_type()) + } else { + restored_type <- fun(x = attr(spec[[type]]$names, "original"), + select = attr(spec[[type]]$select, "original")) + } spec[[type]] <- na_type() spec <- spec & restored_type } diff --git a/R/types.R b/R/types.R index f9b956c9..bcd53830 100644 --- a/R/types.R +++ b/R/types.R @@ -21,8 +21,8 @@ has_value <- function(x) { } na_type <- function() { - out <- NA - class(out) <- "type" + out <- NA_character_ + class(out) <- c("type", class(out)) out } diff --git a/man/update_spec.Rd b/man/update_spec.Rd index ce82a3db..c820ee90 100644 --- a/man/update_spec.Rd +++ b/man/update_spec.Rd @@ -2,20 +2,32 @@ % Please edit documentation in R/resolver.R \name{update_spec} \alias{update_spec} -\title{Update a spec} +\title{Update a specification} \usage{ update_spec(spec, type, value) } \arguments{ -\item{spec}{A specification} +\item{spec}{A specification such as one created with datasets and variables.} -\item{type}{Which type was updated?} +\item{type}{Which type was updated? One of datasets, variables, values.} -\item{value}{What is the new selection?} +\item{value}{What is the new selection? One that is a valid value for the given type and specification.} } \value{ The specification with restored choices and selection if caused by the update. } \description{ -Once a selection is made update the specification +Once a selection is made update the specification for different valid selection. +} +\examples{ +td <- within(teal.data::teal_data(), { + df <- data.frame(A = as.factor(letters[1:5]), + Ab = LETTERS[1:5]) + df_n <- data.frame(C = 1:5, + Ab = as.factor(letters[1:5])) +}) +data_frames_factors <- datasets(is.data.frame) & variables(is.factor) +res <- resolver(data_frames_factors, td) +update_spec(res, "datasets", "df_n") +# update_spec(res, "datasets", "error") } From 8023b1c3c23f06323c56dbb48868093ed9f56075 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Mon, 10 Mar 2025 17:30:57 +0100 Subject: [PATCH 007/142] Simplify tests --- tests/testthat/test-resolver.R | 4 ++++ tests/testthat/test-types.R | 31 +++++++++++-------------------- 2 files changed, 15 insertions(+), 20 deletions(-) diff --git a/tests/testthat/test-resolver.R b/tests/testthat/test-resolver.R index 1db50b1f..c07d8a30 100644 --- a/tests/testthat/test-resolver.R +++ b/tests/testthat/test-resolver.R @@ -105,5 +105,9 @@ test_that("update_spec resolves correctly", { expect_false(is.null(attr(res3$variables$select, "original"))) expect_equal(attr(res3$variables$names, "original"), attr(data_frames_factors$variables$names, "original")) expect_equal(attr(res3$variables$select, "original"), attr(data_frames_factors$variables$select, "original")) + + expect_error(update_spec(res, "datasets", "error")) + expect_error(update_spec(data_frames_factors, "datasets", "error")) + expect_no_error(update_spec(datasets(x = c("df", "df2")), "datasets", "df2")) }) diff --git a/tests/testthat/test-types.R b/tests/testthat/test-types.R index f9702f2d..2984cb85 100644 --- a/tests/testthat/test-types.R +++ b/tests/testthat/test-types.R @@ -1,39 +1,30 @@ -first <- function(x){ - if (length(x) > 0) { - false <- rep(FALSE, length.out = length(x)) - false[1] <- TRUE - return(false) - } - return(FALSE) -} - test_that("datasets", { expect_no_error(dataset0 <- datasets("df", "df")) out <- list(names = "df", select = "df") class(out) <- c("delayed", "datasets", "type", "list") expect_equal(dataset0[["datasets"]], out, check.attributes = FALSE) - expect_no_error(dataset1 <- datasets("df", first)) - # expect_true(is.vector(dataset1$datasets$names)) - expect_no_error(dataset2 <- datasets(is.matrix, first)) - # expect_true(is.vector(dataset2$datasets$names)) - expect_no_error(dataset3 <- datasets(is.data.frame, first)) + expect_no_error(dataset1 <- datasets("df")) + expect_true(is(dataset1$datasets$names, "vector")) + expect_no_error(dataset2 <- datasets(is.matrix)) + expect_true(is(dataset2$datasets$names, "vector")) + expect_no_error(dataset3 <- datasets(is.data.frame)) }) test_that("variables", { expect_no_error(var0 <- variables("a", "a")) - expect_no_error(var1 <- variables("a", first)) - expect_no_error(var2 <- variables(is.factor, first)) + expect_no_error(var1 <- variables("a")) + expect_no_error(var2 <- variables(is.factor)) + # Allowed to specify whatever we like, it is not until resolution that this raises errors expect_no_error(var3 <- variables(is.factor, function(x){head(x, 1)})) expect_no_error(var4 <- variables(is.matrix, function(x){head(x, 1)})) - }) test_that("values", { expect_no_error(val0 <- values("a", "a")) - expect_no_error(val1 <- values("a", first)) - expect_no_error(val2 <- values(is.factor, first)) + expect_no_error(val1 <- values("a")) + expect_no_error(val2 <- values(is.factor)) + # Allowed to specify whatever we like, it is not until resolution that this raises errors expect_no_error(val3 <- values(is.factor, function(x){head(x, 1)})) expect_no_error(val4 <- values(is.matrix, function(x){head(x, 1)})) - }) From 37225be8fecb95d75c18fe20e515fc75f902bd7e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Mon, 10 Mar 2025 17:43:56 +0100 Subject: [PATCH 008/142] Add print method --- NAMESPACE | 1 + R/resolver.R | 6 +++--- R/types.R | 30 ++++++++++++++++++++++++++++++ 3 files changed, 34 insertions(+), 3 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 07bb8964..8f3d020d 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -33,6 +33,7 @@ S3method(print,delayed_select_spec) S3method(print,delayed_value_choices) S3method(print,delayed_variable_choices) S3method(print,filter_spec) +S3method(print,type) S3method(resolve,default) S3method(resolve,delayed_choices_selected) S3method(resolve,delayed_data_extract_spec) diff --git a/R/resolver.R b/R/resolver.R index de2cc614..9f2456f1 100644 --- a/R/resolver.R +++ b/R/resolver.R @@ -337,12 +337,12 @@ update_spec <- function(spec, type, value) { type <- match.arg(type, w) restart_types <- w[seq_along(w) > which(type == w)] - if (is.delayed(spec[[type]])) { - stop(type, " has not been resolved yet.\n", "Please resolve the specification before trying to apply ") - } else if (all(value %in% spec[[type]]$names)) { + if (all(value %in% spec[[type]]$names)) { original_select <- attr(spec[[type]]$select, "original") spec[[type]][["select"]] <- value attr(spec[[type]][["select"]], "original") <- original_select + } else if (is.list(spec[[type]]$names) && !any(vapply(spec[[type]]$names, is.function, logical(1L)))) { + stop("value not in possible choices.") } # Restart to the original specs for (type in restart_types) { diff --git a/R/types.R b/R/types.R index bcd53830..c5fb9d17 100644 --- a/R/types.R +++ b/R/types.R @@ -173,3 +173,33 @@ c.type <- function(...) { class(out) <- cx out } + +#' @export +print.type <- function(x, ...) { + is_na <- length(x) == 1L && is.na(x) + if (is_na) { + cat("Nothing possible") + return(x) + } + + nam_list <- is.list(x$names) + nam_functions <- sum(is.function(x$names)) + nam_values <- length(x$names) - nam_functions + if (nam_functions) { + cat(nam_functions, "functions to select possible choices.\n") + } + if (nam_values) { + cat(x$names[is.character(x$names)], "as possible choices.\n") + } + + sel_list <- is.list(x$select) + sel_functions <- sum(is.function(x$select)) + sel_values <- length(x$select) - sel_functions + if (sel_functions) { + cat(sel_functions, "functions to select.\n") + } + if (sel_values) { + cat(x$select[is.character(x$select)], "selected.\n") + } + return(x) +} From e1ec4204c1f25a17745e5c5d20da95f966aa367f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Mon, 10 Mar 2025 17:44:17 +0100 Subject: [PATCH 009/142] Uncomment some tests --- tests/testthat/test-delayed.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/testthat/test-delayed.R b/tests/testthat/test-delayed.R index 01a89170..3b8c3bfa 100644 --- a/tests/testthat/test-delayed.R +++ b/tests/testthat/test-delayed.R @@ -11,8 +11,8 @@ test_that("is.delayed works", { v <- variables("b") da <- datasets("a", "a") expect_true(is.delayed(d)) - # expect_true(is.delayed(da)) - # expect_true(is.delayed(v)) + expect_true(is.delayed(da)) + expect_true(is.delayed(v)) expect_true(is.delayed(variables("b", "b"))) expect_true(is.delayed(d & v)) expect_false(is.delayed(1)) From a8bb22633316d90dceae2ebe631b791286d4e1c7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Mon, 10 Mar 2025 17:52:11 +0100 Subject: [PATCH 010/142] Make print work --- R/types.R | 24 +++++++++++++++++------- 1 file changed, 17 insertions(+), 7 deletions(-) diff --git a/R/types.R b/R/types.R index c5fb9d17..64a920ba 100644 --- a/R/types.R +++ b/R/types.R @@ -183,23 +183,33 @@ print.type <- function(x, ...) { } nam_list <- is.list(x$names) - nam_functions <- sum(is.function(x$names)) + if (nam_list) { + nam_functions <- vapply(x$names, is.function, logical(1L)) + } else { + nam_functions <- FALSE + } + nam_values <- length(x$names) - nam_functions if (nam_functions) { - cat(nam_functions, "functions to select possible choices.\n") + cat(sum(nam_functions), "functions to select possible choices.\n") } if (nam_values) { - cat(x$names[is.character(x$names)], "as possible choices.\n") + cat(x$names[!nam_functions], "as possible choices.\n") } sel_list <- is.list(x$select) - sel_functions <- sum(is.function(x$select)) + if (sel_list) { + sel_functions <- vapply(x$select, is.function, logical(1L)) + } else { + sel_functions <- FALSE + } + sel_values <- length(x$select) - sel_functions - if (sel_functions) { - cat(sel_functions, "functions to select.\n") + if (any(sel_functions)) { + cat(sum(sel_functions), "functions to select.\n") } if (sel_values) { - cat(x$select[is.character(x$select)], "selected.\n") + cat(x$select[!sel_functions], "selected.\n") } return(x) } From f4bf89aca764c74290c828016406d57d9475ba83 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Wed, 12 Mar 2025 11:31:54 +0100 Subject: [PATCH 011/142] Move delayed to attributes --- R/delayed.R | 21 +++++++++++++-------- 1 file changed, 13 insertions(+), 8 deletions(-) diff --git a/R/delayed.R b/R/delayed.R index 13858f4f..419cb6ac 100644 --- a/R/delayed.R +++ b/R/delayed.R @@ -1,5 +1,8 @@ +# Only delay if the type or object really needs it and is not already delayed delay <- function(x) { - class(x) <- c("delayed", class(x)) + if (is.delayed(x)) { + attr(x, "delayed") <- TRUE + } x } @@ -7,10 +10,14 @@ delay <- function(x) { #' @method is.delayed type is.delayed.type <- function(x) { - !all(is.character(x$names)) || !all(is.character(x$select)) + na <- length(x) == 1L && is.na(x) + if (!na) { + return(!all(is.character(x$names)) || !all(is.character(x$select))) + } + FALSE } -#' @export is.delayed +#' @export #' @method is.delayed transform is.delayed.transform <- function(x) { is.delayed(x$datasets) || is.delayed(x$variables) || is.delayed(x$values) @@ -19,7 +26,7 @@ is.delayed.transform <- function(x) { #' @export #' @method is.delayed default is.delayed.default <- function(x) { - inherits(x, "delayed") + FALSE } #' @export @@ -33,13 +40,11 @@ resolved <- function(x, variable){ if (!s && !all(x$select %in% x$names)) { stop("Selected ", variable, " not available") } - - cl <- class(x) - class(x) <- setdiff(cl, "delayed") + attr(x, "delayed") <- NULL x } -get_datanames <- function(x) { +get_datasets <- function(x) { if (is.transform(x) && !is.delayed(x$datasets)) { x$datasets$names } else { From a1678fa120217caf1e7007f74ba24b993dab17cd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Wed, 12 Mar 2025 11:32:26 +0100 Subject: [PATCH 012/142] Add missing method! --- NAMESPACE | 1 + 1 file changed, 1 insertion(+) diff --git a/NAMESPACE b/NAMESPACE index 8f3d020d..138f6123 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -20,6 +20,7 @@ S3method(data_extract_srv,list) S3method(filter_spec_internal,default) S3method(filter_spec_internal,delayed_data) S3method(is.delayed,default) +S3method(is.delayed,transform) S3method(is.delayed,type) S3method(merge_expression_module,list) S3method(merge_expression_module,reactive) From 06c0eb995d7d30df811e907bdccd1290b22be9e4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Wed, 12 Mar 2025 11:41:25 +0100 Subject: [PATCH 013/142] Simplify type creation --- R/types.R | 82 ++++++++++++++++++++++++++----------------------------- 1 file changed, 38 insertions(+), 44 deletions(-) diff --git a/R/types.R b/R/types.R index 64a920ba..5f665967 100644 --- a/R/types.R +++ b/R/types.R @@ -1,7 +1,9 @@ transform <- function() { - o <- list(datasets = na_type(), variables = na_type(), values = na_type()) - class(o) <- c("delayed", "transform") - o + o <- list(datasets = na_type("datasets"), + variables = na_type("variables"), + values = na_type("values")) + class(o) <- c("transform", "list") + delay(o) } is.transform <- function(x) { @@ -20,9 +22,9 @@ has_value <- function(x) { !anyNA(x[["values"]]) } -na_type <- function() { +na_type <- function(type) { out <- NA_character_ - class(out) <- c("type", class(out)) + class(out) <- c(type, "type") out } @@ -35,64 +37,56 @@ first <- function(x){ return(FALSE) } -#' @export -datasets <- function(x, select = first) { - stopifnot(is.character(x) || is.function(x) || (is.list(x) && all(vapply(x, is.function, logical(1L))))) - stopifnot(is.character(select) || is.function(select) || (is.list(select) && all(vapply(select, is.function, logical(1L))))) +check_input <- function(input) { + is.character(input) || is.function(input) || + (is.list(input) && all(vapply(input, is.function, logical(1L)))) +} + +type_helper <- function(x, select, type) { + stopifnot("Invalid options" = check_input(x), + "Invalid selection" = check_input(type)) if (is.function(x)) { x <- list(x) } if (is.function(select)) { select <- list(select) } - type <- list(names = x, select = select) - class(type) <- c("delayed", "datasets", "type", "list") - attr(type$names, "original") <- x - attr(type$select, "original") <- select - o <- list(datasets = type, variables = na_type(), values = na_type()) - class(o) <- c("delayed", "transform", "list") + out <- list(names = x, select = select) + class(out) <- c(type, "type", "list") + attr(out$names, "original") <- x + attr(out$select, "original") <- select + delay(out) +} + +#' @export +datasets <- function(x, select = first) { + o <- transform() + o$datasets <- type_helper(x, select, type = "datasets") o } #' @export variables <- function(x, select = first) { - stopifnot(is.character(x) || is.function(x) || (is.list(x) && all(vapply(x, is.function, logical(1L))))) - stopifnot(is.character(select) || is.function(select) || (is.list(select) && all(vapply(select, is.function, logical(1L))))) - if (is.function(x)) { - x <- list(x) - } - if (is.function(select)) { - select <- list(select) - } - type <- list(names = x, select = select) - class(type) <- c("delayed", "variables", "type", "list") - attr(type$names, "original") <- x - attr(type$select, "original") <- select - o <- list(datasets = na_type(), variables = type, values = na_type()) - class(o) <- c("delayed", "transform") + o <- transform() + o$variables <- type_helper(x, select, type = "variables") o } #' @export values <- function(x, select = first) { - stopifnot(is.character(x) || is.function(x) || (is.list(x) && all(vapply(x, is.function, logical(1L))))) - stopifnot(is.character(select) || is.function(select) || (is.list(select) && all(vapply(select, is.function, logical(1L))))) - if (is.function(x)) { - x <- list(x) - } - if (is.function(select)) { - select <- list(select) - } - type <- list(names = x, select = select) - class(type) <- c("delayed", "values", "type", "list") - attr(type$names, "original") <- x - attr(type$select, "original") <- select - o <- list(datasets = na_type(), variables = na_type(), values = type) - class(o) <- c("delayed", "transform") + o <- transform() + o$values <- type_helper(x, select, type = "values") o } +#' @export +c.transform <- function(...) { + transf <- mapply(c, ...) + class(transf) <- c("transform", "list") + delay(transf) +} + #' @export c.type <- function(...) { c1 <- class(..1) @@ -191,7 +185,7 @@ print.type <- function(x, ...) { nam_values <- length(x$names) - nam_functions if (nam_functions) { - cat(sum(nam_functions), "functions to select possible choices.\n") + cat(sum(nam_functions), "functions for possible choices.\n") } if (nam_values) { cat(x$names[!nam_functions], "as possible choices.\n") From 208fb535f2b3e30fb663408f2d41d259ab9e50f9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Wed, 12 Mar 2025 11:41:53 +0100 Subject: [PATCH 014/142] Simplify resolver --- R/resolver.R | 31 ++++++++++++++++++------------- 1 file changed, 18 insertions(+), 13 deletions(-) diff --git a/R/resolver.R b/R/resolver.R index 9f2456f1..2ec05ccb 100644 --- a/R/resolver.R +++ b/R/resolver.R @@ -63,11 +63,10 @@ functions_names <- function(unresolved, reference) { unique(unlist(c(unresolved[!is_fc], x), FALSE, FALSE)) } -functions_data <- function(unresolved, data, names_data) { +functions_data <- function(unresolved, data) { fc_unresolved <- unresolved[vapply(unresolved, is.function, logical(1L))] # This is for variables - names <- names(data) datasets <- names(data) # Matrix doesn't have a names method if (is.null(datasets)) { @@ -80,11 +79,12 @@ functions_data <- function(unresolved, data, names_data) { if (!is.logical(out)) { stop("Provided functions should return a logical object.") } - if (length(out) > 1L) { - # Function resolution is unconventional... + if (length(out) != 1L && length(out) != length(data(data, d))) { + # Function resolution is unconventional, but this would produce too many warnings... + # warning("The output of the function must be of length 1 or the same length as the data.") return(FALSE) } - out + all(out) }, logical(1L)) datasets[v] }) @@ -338,10 +338,10 @@ update_spec <- function(spec, type, value) { restart_types <- w[seq_along(w) > which(type == w)] if (all(value %in% spec[[type]]$names)) { - original_select <- attr(spec[[type]]$select, "original") + original_select <- orig(spec[[type]]$select) spec[[type]][["select"]] <- value attr(spec[[type]][["select"]], "original") <- original_select - } else if (is.list(spec[[type]]$names) && !any(vapply(spec[[type]]$names, is.function, logical(1L)))) { + } else if (is.list(orig(spec[[type]]$names)) && !any(vapply(spec[[type]]$names, is.function, logical(1L)))) { stop("value not in possible choices.") } # Restart to the original specs @@ -349,18 +349,23 @@ update_spec <- function(spec, type, value) { # If the spec doesn't exist then there is nothing else to update if (is.null(spec[[type]]) || !length(spec[[type]])) { - spec[[type]] <- na_type() + spec[[type]] <- na_type(type) return(spec) } + fun <- match.fun(type) - if (!length(spec[[type]]) && is.na(spec[[type]])) { - restored_type <- fun(x = na_type(), select = na_type()) + if (length(spec[[type]]) == 1L && is.na(spec[[type]])) { + restored_type <- na_type(type) } else { - restored_type <- fun(x = attr(spec[[type]]$names, "original"), - select = attr(spec[[type]]$select, "original")) + restored_type <- fun(x = orig(spec[[type]]$names), + select = orig(spec[[type]]$select)) } - spec[[type]] <- na_type() + spec[[type]] <- na_type(type) spec <- spec & restored_type } spec } + +orig <- function(x) { + attr(x, "original") +} From cb94d6d34485d58473061bc75e0db2d6cf8b0090 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Wed, 12 Mar 2025 14:44:08 +0100 Subject: [PATCH 015/142] Delayed takes into consideration the selection too --- tests/testthat/test-delayed.R | 16 +++++----------- 1 file changed, 5 insertions(+), 11 deletions(-) diff --git a/tests/testthat/test-delayed.R b/tests/testthat/test-delayed.R index 3b8c3bfa..7a4eb07e 100644 --- a/tests/testthat/test-delayed.R +++ b/tests/testthat/test-delayed.R @@ -1,19 +1,13 @@ -test_that("delay works", { - out <- list(names = character(), select = character()) - dout <- delay(out) - expect_s3_class(dout, "delayed") - expect_true(is.delayed(dout)) - expect_equal(resolved(dout), out) -}) - test_that("is.delayed works", { d <- datasets("a") v <- variables("b") - da <- datasets("a", "a") expect_true(is.delayed(d)) - expect_true(is.delayed(da)) + expect_false(is.delayed(datasets("a", "a"))) expect_true(is.delayed(v)) - expect_true(is.delayed(variables("b", "b"))) + expect_false(is.delayed(variables("b", "b"))) expect_true(is.delayed(d & v)) expect_false(is.delayed(1)) + da <- datasets(is.data.frame) + expect_true(is.delayed(da)) + expect_true(is.delayed(da$datasets)) }) From 158eda90fb7b6108fbd3ddfa4357db7a6e0a6998 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Wed, 12 Mar 2025 14:44:37 +0100 Subject: [PATCH 016/142] Fix mistake and remove delayed class --- tests/testthat/test-ops_transform.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/testthat/test-ops_transform.R b/tests/testthat/test-ops_transform.R index defeb9be..dd80e642 100644 --- a/tests/testthat/test-ops_transform.R +++ b/tests/testthat/test-ops_transform.R @@ -3,7 +3,7 @@ basic_ops <- function(fun) { type1 <- FUN("ABC") types <- type1 & type1 out <- list(names = "ABC", select = list(first)) - class(out) <- c("delayed", fun, "type", "list") + class(out) <- c(fun, "type", "list") expect_equal(types[[fun]], out, check.attributes = FALSE) type2 <- FUN("ABC2") types <- type1 & type2 @@ -23,7 +23,7 @@ basic_ops <- function(fun) { expect_length(out[[fun]]$names, 2) expect_error(FUN("ABC") & 1) out <- type1 & type2b - expect_true(is(out[[fun]]$names, "vector")) + expect_true(is.list(out[[fun]]$names)) } test_that("datasets & work", { From d545331abe418e0948733beaba7dc97d1e171c4c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Wed, 12 Mar 2025 14:45:11 +0100 Subject: [PATCH 017/142] Resolve better by names --- tests/testthat/test-resolver.R | 20 +++++++++++++++----- 1 file changed, 15 insertions(+), 5 deletions(-) diff --git a/tests/testthat/test-resolver.R b/tests/testthat/test-resolver.R index c07d8a30..231a2e45 100644 --- a/tests/testthat/test-resolver.R +++ b/tests/testthat/test-resolver.R @@ -55,19 +55,29 @@ test_that("names and variables are reported", { df <- data.frame(A = as.factor(letters[1:5]), Ab = LETTERS[1:5], Abc = c(LETTERS[1:4], letters[1])) + df2 <- data.frame(A = 1:5, + B = 1:5) m <- matrix() }) - df_upper_variables <- datasets("df") & variables(function(x){x==toupper(x)}) + d_df <- datasets("df") + df_upper_variables <- d_df & variables(function(x){x==toupper(x)}) out <- resolver(df_upper_variables, td) # This should select A and Ab: # A because the name is all capital letters and # Ab values is all upper case. - # expect_length(out$variables$names, 2) - df_all_upper_variables <- datasets("df") & variables(function(x){all(x==toupper(x))}) + expect_length(out$variables$names, 2) + v_all_upper <- variables(function(x){all(x==toupper(x))}) + df_all_upper_variables <- d_df & v_all_upper expect_no_error(out <- resolver(df_all_upper_variables, td)) - # expect_length(out$variables$names, 2) -}) + expect_length(out$variables$names, 1) + expect_no_error(out <- resolver(datasets("df2") & v_all_upper, td)) + expect_length(out$variables$names, 2) + expect_no_error(out <- resolver(datasets(function(x){is.data.frame(x) && all(colnames(x) == toupper(colnames(x)))}), td)) + expect_length(out$datasets$names, 1) + expect_no_error(out <- resolver(datasets(is.data.frame) & datasets(function(x){colnames(x) == toupper(colnames(x))}), td)) + expect_length(out$datasets$names, 2) +}) test_that("update_spec resolves correctly", { td <- within(teal.data::teal_data(), { From 99cadc29296d87fa22cd2db91ab8cfd46bb48907 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Wed, 12 Mar 2025 15:27:46 +0100 Subject: [PATCH 018/142] Fix issues --- R/resolver.R | 73 ++++++++++++++++++++++++++++++---------------------- 1 file changed, 42 insertions(+), 31 deletions(-) diff --git a/R/resolver.R b/R/resolver.R index 2ec05ccb..b76fb4da 100644 --- a/R/resolver.R +++ b/R/resolver.R @@ -20,8 +20,8 @@ #' resolver(spec, td) #' spec <- dataset1 & variables("a", is.factor) #' resolver(spec, td) -resolver <- function(spec, data, ...) { - if (!is(data, "qenv")) { +resolver <- function(spec, data) { + if (!inherits(data, "qenv")) { stop("Please use qenv() or teal_data() objects.") } stopifnot(is.transform(spec), has_dataset(spec)) @@ -29,23 +29,23 @@ resolver <- function(spec, data, ...) { if (has_dataset(specf) && is.delayed(specf$datasets)) { specf <- resolver.datasets(specf, data) } else if (!has_dataset(specf)) { - specf$datasets <- NULL + specf$datasets <- na_type("datasets") } if (has_variable(specf) && !is.delayed(specf$datasets)) { specf <- resolver.variables(specf, data) } else { - specf$variables <- NULL + specf$variables <- na_type("variables") } if (has_value(specf) && !is.delayed(specf$datasets) && !is.delayed(specf$variables)) { specf <- resolver.values(specf, data) } else { - specf$values <- NULL + specf$values <- na_type("values") } - class(specf) <- setdiff(class(specf), "delayed") - specf + attr(specf, "delayed") <- NULL + delay(specf) } functions_names <- function(unresolved, reference) { @@ -92,7 +92,7 @@ functions_data <- function(unresolved, data) { } resolver.datasets <- function(spec, data) { - if (!is(data, "qenv")) { + if (!inherits(data, "qenv")) { stop("Please use qenv() or teal_data() objects.") } if (is.null(spec[["datasets"]])) { @@ -154,7 +154,7 @@ resolver.datasets <- function(spec, data) { } resolver.variables <- function(spec, data) { - if (!is(data, "qenv")) { + if (!inherits(data, "qenv")) { stop("Please use qenv() or teal_data() objects.") } @@ -222,7 +222,7 @@ resolver.variables <- function(spec, data) { } resolver.values <- function(spec, data) { - if (!is(data, "qenv")) { + if (!inherits(data, "qenv")) { stop("Please use qenv() or teal_data() objects.") } @@ -280,8 +280,10 @@ resolver.values <- function(spec, data) { #' @export data.MultiAssayExperiment <- function(x, variable) { - # length(variable) == 1L - cd <- colData(x) + if (!requireNamespace("MultiAssayExperiment", quietly = TRUE)) { + stop("Required to have MultiAssayExperiment's package.") + } + cd <- MultiAssayExperiment::colData(x) cd[[variable]] } @@ -316,7 +318,7 @@ data <- function(x, variable) { #' Update a specification #' #' Once a selection is made update the specification for different valid selection. -#' @param spec A specification such as one created with datasets and variables. +#' @param spec A resolved specification such as one created with datasets and variables. #' @param type Which type was updated? One of datasets, variables, values. #' @param value What is the new selection? One that is a valid value for the given type and specification. #' @return The specification with restored choices and selection if caused by the update. @@ -336,32 +338,41 @@ update_spec <- function(spec, type, value) { w <- c("datasets", "variables", "values") type <- match.arg(type, w) restart_types <- w[seq_along(w) > which(type == w)] - - if (all(value %in% spec[[type]]$names)) { + speci <- spec + if (!is.character(value)) { + stop("The updated value is not a character.", + "\nDo you attempt to set a new specification? Please open an issue") + } + valid_names <- spec[[type]]$names + if (is.delayed(spec[[type]])) { + stop(type, " should be resolved before updating.") + } + if (!is.list(valid_names) && all(value %in% valid_names)) { original_select <- orig(spec[[type]]$select) spec[[type]][["select"]] <- value attr(spec[[type]][["select"]], "original") <- original_select - } else if (is.list(orig(spec[[type]]$names)) && !any(vapply(spec[[type]]$names, is.function, logical(1L)))) { - stop("value not in possible choices.") + } else if (!is.list(valid_names) && !all(value %in% valid_names)) { + original_select <- orig(spec[[type]]$select) + valid_values <- intersect(value, valid_names) + if (!length(valid_values)) { + stop("No valid value provided.") + } + spec[[type]][["select"]] <- valid_values + attr(spec[[type]][["select"]], "original") <- original_select + } else { + stop("It seems the specification needs to be resolved first.") } - # Restart to the original specs - for (type in restart_types) { - # If the spec doesn't exist then there is nothing else to update - if (is.null(spec[[type]]) || !length(spec[[type]])) { - spec[[type]] <- na_type(type) - return(spec) - } + # Restore to the original specs + for (type in restart_types) { - fun <- match.fun(type) if (length(spec[[type]]) == 1L && is.na(spec[[type]])) { - restored_type <- na_type(type) - } else { - restored_type <- fun(x = orig(spec[[type]]$names), - select = orig(spec[[type]]$select)) + next } - spec[[type]] <- na_type(type) - spec <- spec & restored_type + fun <- match.fun(type) + restored_transform <- fun(x = orig(spec[[type]]$names), + select = orig(spec[[type]]$select)) + spec[[type]] <- restored_transform[[type]] } spec } From b26695a8cb72f89b246dec0124fc48793fe94bec Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Wed, 12 Mar 2025 15:28:25 +0100 Subject: [PATCH 019/142] Simplify c.type --- R/types.R | 113 ++++++++++++++++++------------------------------------ 1 file changed, 38 insertions(+), 75 deletions(-) diff --git a/R/types.R b/R/types.R index 5f665967..295c3c1b 100644 --- a/R/types.R +++ b/R/types.R @@ -39,7 +39,7 @@ first <- function(x){ check_input <- function(input) { is.character(input) || is.function(input) || - (is.list(input) && all(vapply(input, is.function, logical(1L)))) + (is.list(input) && all(vapply(input, function(x){is.function(x) || is.character(x)}, logical(1L)))) } type_helper <- function(x, select, type) { @@ -82,90 +82,46 @@ values <- function(x, select = first) { #' @export c.transform <- function(...) { - transf <- mapply(c, ...) + if (...length() > 2) { + stop("More than two specifications won't be considered. Use & to combine them", call. = FALSE) + } + transf <- mapply(c, ..., SIMPLIFY = FALSE) class(transf) <- c("transform", "list") delay(transf) } #' @export c.type <- function(...) { - c1 <- class(..1) - c2 <- class(..2) - if (is.null(..1)) { + if (length(..1) == 1L && is.na(..1)) { return(..2) - } else if (is.null(..2)) { + } else if (length(..2) == 1L && is.na(..2)) { return(..1) } - classes <- unique(c(c1, c2)) - other_classes <- setdiff(classes, c("delayed", "type", "list")) - - if ("delayed" %in% classes) { - classes <- c("delayed", other_classes, "type", "list") - } else { - classes <- c(other_classes, "type", "list") + objects <- list(...) + classes <- unlist(lapply(objects, class), FALSE,FALSE) + type <- setdiff(classes, c("type", "list")) + if (length(type) > 1L) { + stop("Combining different types", call. = FALSE) } - out <- NextMethod("c") - - if (all(is.na(out))) { - return(na_type()) - } else if (anyNA(out)) { - out <- out[!is.na(out)] - } - nam <- names(out) - names <- nam == "names" - selects <- nam == "select" - - new_l <- list(names = unlist(out[names], FALSE, FALSE), - select = unlist(out[selects], FALSE, FALSE)) - - l <- lapply(new_l, unique) - class(l) <- classes - - attr(l$names, "original") <- unique(unlist(lapply(out[names], attr, "original"), TRUE, FALSE)) - attr(l$select, "original") <- unique(unlist(lapply(out[selects], attr, "original"), TRUE, FALSE)) - l -} - -#' @export -`[.type` <- function(x, i, j, ..., exact = TRUE) { - cx <- class(x) - out <- NextMethod("[") - class(out) <- cx - out + names <- lapply(objects, "[[", i = "names") + select <- lapply(objects, "[[", i = "select") + names_orig <- lapply(names, orig) + select_orig <- lapply(select, orig) + type_f <- match.fun(type) + type_out <- type_f(x = simplify_c(names_orig), + select = simplify_c(select_orig)) + attr(type_out[[type]][["names"]], "original") <- NULL + attr(type_out[[type]][["names"]], "original") <- simplify_c(names_orig) + attr(type_out[[type]][["select"]], "original") <- NULL + attr(type_out[[type]][["select"]], "original") <- simplify_c(select_orig) + delay(type_out[[type]]) } -#' @export -`[.type<-` <- function(x, i, j, ..., value) { - cx <- class(x) - if (!"type" %in% class(value)) { - stop("Modifying the specification with invalid objects") - } - out <- NextMethod("[") - class(out) <- cx - out -} - -#' @export -`[[.type` <- function(x, i, ..., drop = TRUE) { - cx <- class(x) - out <- NextMethod("[[") - class(out) <- cx - out -} - - -#' @export -`[[.type<-` <- function(x, i, value) { - cx <- class(x) - if (!"type" %in% class(value)) { - stop("Modifying the specification with invalid objects.") - } - out <- NextMethod("[") - class(out) <- cx - out +simplify_c <- function(x) { + unique(unlist(x, FALSE, FALSE)) } #' @export @@ -183,12 +139,15 @@ print.type <- function(x, ...) { nam_functions <- FALSE } + msg_values <- character() nam_values <- length(x$names) - nam_functions - if (nam_functions) { - cat(sum(nam_functions), "functions for possible choices.\n") + if (any(nam_functions)) { + msg_values <- paste0(msg_values, sum(nam_functions), " functions for possible choices.", + collapse = "\n") } if (nam_values) { - cat(x$names[!nam_functions], "as possible choices.\n") + msg_values <- paste0(msg_values, x$names[!nam_functions], " as possible choices.", + collapse = "\n") } sel_list <- is.list(x$select) @@ -198,12 +157,16 @@ print.type <- function(x, ...) { sel_functions <- FALSE } + msg_sel <- character() sel_values <- length(x$select) - sel_functions if (any(sel_functions)) { - cat(sum(sel_functions), "functions to select.\n") + msg_sel <- paste0(msg_sel, sum(sel_functions), " functions to select.", + collapse = "\n") } if (sel_values) { - cat(x$select[!sel_functions], "selected.\n") + msg_sel <- paste0(msg_sel, x$select[!sel_functions], "selected.", + collapse = "\n") } + cat(msg_values, msg_sel) return(x) } From 6600d179d896a8d880d504db0bfc1dcc74f9d41d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Wed, 12 Mar 2025 15:29:25 +0100 Subject: [PATCH 020/142] Use Group Generic Functions --- NAMESPACE | 9 +++---- R/ops_transform.R | 66 ++++++++++++++++++---------------------------- man/resolver.Rd | 2 +- man/update_spec.Rd | 2 +- 4 files changed, 31 insertions(+), 48 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 138f6123..759061e4 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,11 +1,8 @@ # Generated by roxygen2: do not edit by hand -S3method("&",transform) -S3method("[","type<-") -S3method("[",type) -S3method("[[","type<-") -S3method("[[",type) -S3method("|",dataset) +S3method(Ops,transform) +S3method(Ops,type) +S3method(c,transform) S3method(c,type) S3method(data,MultiAssayExperiment) S3method(data,data.frame) diff --git a/R/ops_transform.R b/R/ops_transform.R index 5a97d3df..768b2e5f 100644 --- a/R/ops_transform.R +++ b/R/ops_transform.R @@ -1,47 +1,33 @@ #' @export -`&.transform` <- function(e1, e2) { - if (!is.transform(e1) || !is.transform(e2)) { - stop("Method not available") +Ops.transform <- function(e1, e2) { + if (missing(e2)) { + # out <- switch(.Generic, + # "!" = Negate, + stop("Method ", sQuote(.Generic), " not implemented for this class ", .Class, ".", call. = FALSE) + # return(out) } - o <- transform() - if (has_dataset(e1) || has_dataset(e2)) { - o$datasets <- c(e1$datasets, e2$datasets) - o$datasets <- o$datasets[!is.na(o$datasets)] - } - if (has_variable(e1) || has_variable(e2)) { - o$variables <- c(e1$variables, e2$variables) - o$variables <- o$variables[!is.na(o$variables)] - } - if (has_value(e1) || has_value(e2)) { - o$values <- c(e1$values, e2$values) - o$values <- o$values[!is.na(o$values)] - } - - class(o) <- c("delayed", "transform") - o + switch(.Generic, + "!=" = NextMethod(), + # "==" = NextMethod(), + # "|" = , + "&" = c(e1, e2), + stop("Method ", sQuote(.Generic), " not implemented for this class ", .Class, ".", call. = FALSE)) } #' @export -`|.dataset` <- function(e1, e2) { - if (!is.transform(e1) || !is.transform(e2)) { - stop("Method not available") +Ops.type <- function(e1, e2) { + if (missing(e2)) { + # out <- switch(.Generic, + # "!" = Negate, + stop("Method ", sQuote(.Generic), " not implemented for this class ", .Class, ".", call. = FALSE) + # return(out) } - s <- transform() - class(x) <- c("delayed", "transform") - x + out <- switch(.Generic, + "!=" = NextMethod(), + # "==" = NextMethod(), + # "|" = , + "&" = c(e1, e2), + stop("Method ", sQuote(.Generic), " not implemented for this class ", .Class, ".", call. = FALSE)) + class(out) <- class(e1) + out } - -# #' @export -# chooseOpsMethod.transform <- function(x, y, mx, my, cl, reverse) { -# # cat("\nx\n") -# # print(mx) -# # cat("\ny\n") -# # print(my) -# # cat("\ncl\n") -# # print(cl) -# # cat("\nreverse\n") -# # print(reverse) -# is.transform(x) -# } - -# ?Ops diff --git a/man/resolver.Rd b/man/resolver.Rd index 1063d0ef..3d39c39f 100644 --- a/man/resolver.Rd +++ b/man/resolver.Rd @@ -4,7 +4,7 @@ \alias{resolver} \title{Resolve the specification} \usage{ -resolver(spec, data, ...) +resolver(spec, data) } \arguments{ \item{spec}{A object extraction specification.} diff --git a/man/update_spec.Rd b/man/update_spec.Rd index c820ee90..a85cf2f9 100644 --- a/man/update_spec.Rd +++ b/man/update_spec.Rd @@ -7,7 +7,7 @@ update_spec(spec, type, value) } \arguments{ -\item{spec}{A specification such as one created with datasets and variables.} +\item{spec}{A resolved specification such as one created with datasets and variables.} \item{type}{Which type was updated? One of datasets, variables, values.} From df47b484e1c8abdbd647b5168b83120e4c9dbb32 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Wed, 12 Mar 2025 15:30:11 +0100 Subject: [PATCH 021/142] Improve tests --- tests/testthat/test-resolver.R | 3 ++- tests/testthat/test-types.R | 6 ++++++ 2 files changed, 8 insertions(+), 1 deletion(-) diff --git a/tests/testthat/test-resolver.R b/tests/testthat/test-resolver.R index 231a2e45..4210ca1b 100644 --- a/tests/testthat/test-resolver.R +++ b/tests/testthat/test-resolver.R @@ -118,6 +118,7 @@ test_that("update_spec resolves correctly", { expect_error(update_spec(res, "datasets", "error")) expect_error(update_spec(data_frames_factors, "datasets", "error")) - expect_no_error(update_spec(datasets(x = c("df", "df2")), "datasets", "df2")) + expect_error(update_spec(datasets(x = c("df", "df2")), "datasets", "df2")) + expect_no_error(update_spec(datasets(x = c("df", "df2"), "df"), "datasets", "df2")) }) diff --git a/tests/testthat/test-types.R b/tests/testthat/test-types.R index 2984cb85..2b1ae404 100644 --- a/tests/testthat/test-types.R +++ b/tests/testthat/test-types.R @@ -20,6 +20,12 @@ test_that("variables", { expect_no_error(var4 <- variables(is.matrix, function(x){head(x, 1)})) }) +test_that("raw combine of types", { + out <- c(datasets("df"), variables("df")) + expect_length(out, 3) + expect_error(c(datasets("df"), variables("df"), values("df"))) +}) + test_that("values", { expect_no_error(val0 <- values("a", "a")) expect_no_error(val1 <- values("a")) From e90025c1b48fc1e05a7a2b64cdf080e49d8b0459 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Wed, 12 Mar 2025 17:27:41 +0100 Subject: [PATCH 022/142] Make it work for simple cases of values --- R/resolver.R | 36 ++++++++++++++++++---------------- R/types.R | 2 +- tests/testthat/test-resolver.R | 17 ++++++++++++++++ 3 files changed, 37 insertions(+), 18 deletions(-) diff --git a/R/resolver.R b/R/resolver.R index b76fb4da..c6a4f118 100644 --- a/R/resolver.R +++ b/R/resolver.R @@ -95,7 +95,7 @@ resolver.datasets <- function(spec, data) { if (!inherits(data, "qenv")) { stop("Please use qenv() or teal_data() objects.") } - if (is.null(spec[["datasets"]])) { + if (is.null(spec[["datasets"]]) || all(is.na(spec[["datasets"]]))) { return(spec) } sdatasets <- spec$datasets @@ -147,8 +147,8 @@ resolver.datasets <- function(spec, data) { } sdatasets$select <- new_select } - attr(sdatasets$names, "original") <- attr(orig_names, "original") - attr(sdatasets$select, "original") <- attr(orig_select, "original") + attr(sdatasets$names, "original") <- orig(orig_names) + attr(sdatasets$select, "original") <- orig(orig_select) spec$datasets <- resolved(sdatasets, "dataset") spec } @@ -161,7 +161,7 @@ resolver.variables <- function(spec, data) { if (is.delayed(spec$datasets)) { stop("Datasets not resolved yet") } - if (is.null(spec[["variables"]])) { + if (is.null(spec[["variables"]]) || all(is.na(spec[["variables"]]))) { return(spec) } datasets <- spec$datasets$select @@ -214,8 +214,8 @@ resolver.variables <- function(spec, data) { } } - attr(svariables$names, "original") <- attr(orig_names, "original") - attr(svariables$select, "original") <- attr(orig_select, "original") + attr(svariables$names, "original") <- orig(orig_names) + attr(svariables$select, "original") <- orig(orig_select) spec$variables <- resolved(svariables, "variables") spec @@ -226,16 +226,17 @@ resolver.values <- function(spec, data) { stop("Please use qenv() or teal_data() objects.") } - if (is.null(spec[["values"]])) { + if (is.null(spec[["values"]]) || all(is.na(spec[["values"]]))) { return(spec) } - svalues <- spec$values + dataset <- data(data, spec$datasets$select) + variable <- data(dataset, spec$variables$select) orig_names <- svalues$names orig_select <- svalues$select spec$values <- if (is.delayed(svalues) && all(is.character(svalues$names))) { - match <- intersect(datasets, svalues$names) - missing <- setdiff(svalues$names, datasets) + match <- intersect(variable, svalues$names) + missing <- setdiff(svalues$names, variable) if (length(missing)) { stop("Missing values ", paste(sQuote(missing), collapse = ", "), " were specified.") } @@ -243,8 +244,9 @@ resolver.values <- function(spec, data) { if (length(match) == 1) { svalues$select <- match } else { + match <- intersect(variable, svalues$names) new_select <- c(functions_names(svalues$select, svalues$names), - functions_data(svalues$select, data_selected)) + functions_data(svalues$select, variable)) new_select <- unique(new_select[!is.na(new_select)]) if (!length(new_select)) { stop("No variables meet the requirements to be selected") @@ -252,8 +254,8 @@ resolver.values <- function(spec, data) { svalues$select <- new_select } } else if (is.delayed(svalues)) { - new_names <- c(functions_names(svalues$names, names_data), - functions_data(svalues$names, data_selected)) + new_names <- c(functions_names(svalues$names, variable), + functions_data(svalues$names, variable)) new_names <- unique(new_names[!is.na(new_names)]) if (!length(new_names)) { stop("No variables meet the requirements") @@ -263,8 +265,8 @@ resolver.values <- function(spec, data) { if (length(svalues$names) == 1) { svalues$select <- svalues$names } else { - new_select <- c(functions_names(svalues$select, svalues$names), - functions_data(svalues$select, data_selected)) + new_select <- c(functions_names(svalues$select, variable), + functions_data(svalues$select, variable)) new_select <- unique(new_select[!is.na(new_select)]) if (!length(new_select)) { stop("No variables meet the requirements to be selected") @@ -272,8 +274,8 @@ resolver.values <- function(spec, data) { svalues$select <- new_select } } - attr(svalues$names, "original") <- attr(orig_names, "original") - attr(svalues$select, "original") <- attr(orig_select, "original") + attr(svalues$names, "original") <- orig(orig_names) + attr(svalues$select, "original") <- orig(orig_select) spec$values <- resolved(svalues, "values") spec } diff --git a/R/types.R b/R/types.R index 295c3c1b..b4d84a07 100644 --- a/R/types.R +++ b/R/types.R @@ -164,7 +164,7 @@ print.type <- function(x, ...) { collapse = "\n") } if (sel_values) { - msg_sel <- paste0(msg_sel, x$select[!sel_functions], "selected.", + msg_sel <- paste0(msg_sel, x$select[!sel_functions], " selected.", collapse = "\n") } cat(msg_values, msg_sel) diff --git a/tests/testthat/test-resolver.R b/tests/testthat/test-resolver.R index 4210ca1b..67f8cf06 100644 --- a/tests/testthat/test-resolver.R +++ b/tests/testthat/test-resolver.R @@ -50,6 +50,23 @@ test_that("resolver variables works", { expect_error(resolver(data_frames & var_matrices_head, td)) }) +test_that("resolver values works", { + df <- datasets("df") + matrices <- datasets(is.matrix) + data_frames <- datasets(is.data.frame) + var_a <- variables("a") + factors <- variables(is.factor) + factors_head <- variables(is.factor, function(x){head(x, 1)}) + var_matrices_head <- variables(is.matrix, function(x){head(x, 1)}) + val_A <- values("A") + td <- within(teal.data::teal_data(), { + df <- data.frame(a = LETTERS[1:5], b = factor(letters[1:5]), c = factor(letters[1:5])) + m <- cbind(b = 1:5, c = 10:14) + m2 <- cbind(a = LETTERS[1:2], b = LETTERS[4:5]) + }) + expect_no_error(resolver(df & var_a & val_A, td)) +}) + test_that("names and variables are reported", { td <- within(teal.data::teal_data(), { df <- data.frame(A = as.factor(letters[1:5]), From a92f051854bfbc61e91b83b7c5dd07b09b15b6e2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Thu, 13 Mar 2025 13:59:59 +0100 Subject: [PATCH 023/142] Allow OR combinations --- R/ops_transform.R | 10 ++++++-- tests/testthat/test-ops_transform.R | 37 +++++++++++++++++++---------- 2 files changed, 33 insertions(+), 14 deletions(-) diff --git a/R/ops_transform.R b/R/ops_transform.R index 768b2e5f..6ff26a9b 100644 --- a/R/ops_transform.R +++ b/R/ops_transform.R @@ -8,8 +8,8 @@ Ops.transform <- function(e1, e2) { } switch(.Generic, "!=" = NextMethod(), - # "==" = NextMethod(), - # "|" = , + "==" = NextMethod(), + "|" = combine_transform(e1, e2), "&" = c(e1, e2), stop("Method ", sQuote(.Generic), " not implemented for this class ", .Class, ".", call. = FALSE)) } @@ -31,3 +31,9 @@ Ops.type <- function(e1, e2) { class(out) <- class(e1) out } + +combine_transform <- function(e1, e2) { + l <- list(e1, e2) + class(l) <- c("transform", "list") + l +} diff --git a/tests/testthat/test-ops_transform.R b/tests/testthat/test-ops_transform.R index dd80e642..de9918a8 100644 --- a/tests/testthat/test-ops_transform.R +++ b/tests/testthat/test-ops_transform.R @@ -39,48 +39,61 @@ test_that("values & work", { basic_ops("values") }) -test_that("datsets & variables work", { +test_that("&(datsets, variables) create a single transform", { dataset1 <- datasets("ABC2") var1 <- variables("abc") vars <- dataset1 & var1 vars2 <- var1 & dataset1 - expect_equal(vars, vars2) expect_equal(vars$datasets$names, "ABC2", check.attributes = FALSE) expect_equal(vars$variables$names, "abc", check.attributes = FALSE) - expect_error(vars & 1) +}) + +test_that("&(datsets, number) errors", { + expect_error(datasets("abc") & 1) }) test_that("datsets & values work", { dataset1 <- datasets("ABC2") val1 <- values("abc") vars <- dataset1 & val1 - vars2 <- val1 & dataset1 - expect_equal(vars, vars2) expect_equal(vars$datasets$names, "ABC2", check.attributes = FALSE) expect_equal(vars$values$names, "abc", check.attributes = FALSE) - expect_error(vars & 1) +}) + +test_that("&(datsets, number) errors", { + expect_error(variables("abc") & 1) }) test_that("variables & values work", { var1 <- variables("ABC2") val1 <- values("abc") vars <- var1 & val1 - vars2 <- val1 & var1 - expect_equal(vars, vars2) expect_equal(vars$variables$names, "ABC2", check.attributes = FALSE) expect_equal(vars$values$names, "abc", check.attributes = FALSE) - expect_error(vars & 1) }) -test_that("datasets & variables & values work", { +test_that("&(values, number) errors", { + expect_error(values("abc") & 1) +}) + +test_that("datasets & variables & values create a single specification", { dataset1 <- datasets("ABC2") var1 <- variables("ABC2") val1 <- values("abc") vars <- dataset1 & var1 & val1 vars2 <- val1 & var1 & dataset1 - expect_equal(vars, vars2) expect_equal(vars$datasets$names, "ABC2", check.attributes = FALSE) expect_equal(vars$variables$names, "ABC2", check.attributes = FALSE) expect_equal(vars$values$names, "abc", check.attributes = FALSE) - expect_error(vars & 1) +}) + +test_that("&(transform, number) errors", { + expect_error(datasets("ABC2") & variables("ABC2") & values("abc") & 1) +}) + + +test_that("| combines two transformers", { + spec <- datasets("ABC") | datasets("abc") + expect_length(spec, 2) + expect_error(spec[[1]]$datasets | spec[[1]]$datasets) }) From 41800f34fa9fe70607899513f77dcb8037f34b7c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Mon, 17 Mar 2025 16:58:07 +0100 Subject: [PATCH 024/142] Make it easier to work with types --- R/types.R | 30 ++++++++++++++++++++---------- 1 file changed, 20 insertions(+), 10 deletions(-) diff --git a/R/types.R b/R/types.R index b4d84a07..08e36b04 100644 --- a/R/types.R +++ b/R/types.R @@ -28,6 +28,17 @@ na_type <- function(type) { out } +#' @export +#' @method is.na type +is.na.type <- function(x) { + anyNA(unclass(x)) +} + +#' @export +anyNA.type <- function(x) { + anyNA(unclass(x)) +} + first <- function(x){ if (length(x) > 0) { false <- rep(FALSE, length.out = length(x)) @@ -93,9 +104,9 @@ c.transform <- function(...) { #' @export c.type <- function(...) { - if (length(..1) == 1L && is.na(..1)) { + if (is.na(..1)) { return(..2) - } else if (length(..2) == 1L && is.na(..2)) { + } else if (is.na(..2)) { return(..1) } @@ -126,8 +137,7 @@ simplify_c <- function(x) { #' @export print.type <- function(x, ...) { - is_na <- length(x) == 1L && is.na(x) - if (is_na) { + if (is.na(x)) { cat("Nothing possible") return(x) } @@ -140,14 +150,14 @@ print.type <- function(x, ...) { } msg_values <- character() - nam_values <- length(x$names) - nam_functions + nam_values <- length(x$names) - sum(nam_functions) if (any(nam_functions)) { msg_values <- paste0(msg_values, sum(nam_functions), " functions for possible choices.", collapse = "\n") } if (nam_values) { - msg_values <- paste0(msg_values, x$names[!nam_functions], " as possible choices.", - collapse = "\n") + msg_values <- paste0(msg_values, paste0(sQuote(x$names[!nam_functions]), collapse = ", "), + " as possible choices.", collapse = "\n") } sel_list <- is.list(x$select) @@ -158,14 +168,14 @@ print.type <- function(x, ...) { } msg_sel <- character() - sel_values <- length(x$select) - sel_functions + sel_values <- length(x$select) - sum(sel_functions) if (any(sel_functions)) { msg_sel <- paste0(msg_sel, sum(sel_functions), " functions to select.", collapse = "\n") } if (sel_values) { - msg_sel <- paste0(msg_sel, x$select[!sel_functions], " selected.", - collapse = "\n") + msg_sel <- paste0(msg_sel, paste0(sQuote(x$select[!sel_functions]), collapse = ", "), + " selected.", collapse = "\n") } cat(msg_values, msg_sel) return(x) From 3a39de288b098d2456b0e7ea1f5437778a734da1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Mon, 17 Mar 2025 16:59:33 +0100 Subject: [PATCH 025/142] Avoid conflicting names --- R/resolver.R | 24 ++++++++++++------------ 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/R/resolver.R b/R/resolver.R index c6a4f118..e7b3bdcd 100644 --- a/R/resolver.R +++ b/R/resolver.R @@ -75,11 +75,11 @@ functions_data <- function(unresolved, data) { l <- lapply(fc_unresolved, function(f) { v <- vapply(datasets, function(d) { # Extract the data and apply the user supplied function - out <- tryCatch(f(data(data, d)), error = function(x){FALSE}) + out <- tryCatch(f(extract(data, d)), error = function(x){FALSE}) if (!is.logical(out)) { stop("Provided functions should return a logical object.") } - if (length(out) != 1L && length(out) != length(data(data, d))) { + if (length(out) != 1L && length(out) != length(extract(data, d))) { # Function resolution is unconventional, but this would produce too many warnings... # warning("The output of the function must be of length 1 or the same length as the data.") return(FALSE) @@ -230,8 +230,8 @@ resolver.values <- function(spec, data) { return(spec) } svalues <- spec$values - dataset <- data(data, spec$datasets$select) - variable <- data(dataset, spec$variables$select) + dataset <- extract(data, spec$datasets$select) + variable <- extract(dataset, spec$variables$select) orig_names <- svalues$names orig_select <- svalues$select spec$values <- if (is.delayed(svalues) && all(is.character(svalues$names))) { @@ -281,7 +281,7 @@ resolver.values <- function(spec, data) { } #' @export -data.MultiAssayExperiment <- function(x, variable) { +extract.MultiAssayExperiment <- function(x, variable) { if (!requireNamespace("MultiAssayExperiment", quietly = TRUE)) { stop("Required to have MultiAssayExperiment's package.") } @@ -290,31 +290,31 @@ data.MultiAssayExperiment <- function(x, variable) { } #' @export -data.matrix <- function(x, variable) { +extract.matrix <- function(x, variable) { # length(variable) == 1L x[, variable, drop = TRUE] } #' @export -#' @method data data.frame -data.data.frame <- function(x, variable) { +#' @method extract data.frame +extract.data.frame <- function(x, variable) { # length(variable) == 1L x[, variable, drop = TRUE] } #' @export -data.qenv <- function(x, variable) { +extract.qenv <- function(x, variable) { x[[variable]] } #' @export -data.default <- function(x, variable) { +extract.default <- function(x, variable) { x[, variable, drop = TRUE] } #' @export -data <- function(x, variable) { - UseMethod("data") +extract <- function(x, variable) { + UseMethod("extract") } #' Update a specification From 6920d6e8200fedd70351b48c90aacc35770cce8e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Mon, 17 Mar 2025 17:00:14 +0100 Subject: [PATCH 026/142] Simplify according to new methods --- R/delayed.R | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/R/delayed.R b/R/delayed.R index 419cb6ac..61520bd9 100644 --- a/R/delayed.R +++ b/R/delayed.R @@ -10,8 +10,7 @@ delay <- function(x) { #' @method is.delayed type is.delayed.type <- function(x) { - na <- length(x) == 1L && is.na(x) - if (!na) { + if (!is.na(x)) { return(!all(is.character(x$names)) || !all(is.character(x$select))) } FALSE From d7287394c79721ed0ef79c6ae21217b89dfe0288 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Mon, 17 Mar 2025 17:04:26 +0100 Subject: [PATCH 027/142] Updating docs --- NAMESPACE | 14 +++++++----- R/resolver.R | 59 ++++++++++++++++++++++++++++++++++++++----------- man/resolver.Rd | 6 +++-- 3 files changed, 58 insertions(+), 21 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 759061e4..c7f6c89d 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -2,23 +2,25 @@ S3method(Ops,transform) S3method(Ops,type) +S3method(anyNA,type) S3method(c,transform) S3method(c,type) -S3method(data,MultiAssayExperiment) -S3method(data,data.frame) -S3method(data,default) -S3method(data,matrix) -S3method(data,qenv) S3method(data_extract_multiple_srv,FilteredData) S3method(data_extract_multiple_srv,list) S3method(data_extract_multiple_srv,reactive) S3method(data_extract_srv,FilteredData) S3method(data_extract_srv,list) +S3method(extract,MultiAssayExperiment) +S3method(extract,data.frame) +S3method(extract,default) +S3method(extract,matrix) +S3method(extract,qenv) S3method(filter_spec_internal,default) S3method(filter_spec_internal,delayed_data) S3method(is.delayed,default) S3method(is.delayed,transform) S3method(is.delayed,type) +S3method(is.na,type) S3method(merge_expression_module,list) S3method(merge_expression_module,reactive) S3method(merge_expression_srv,list) @@ -53,13 +55,13 @@ export(check_no_multiple_selection) export(choices_labeled) export(choices_selected) export(compose_and_enable_validators) -export(data) export(data_extract_multiple_srv) export(data_extract_spec) export(data_extract_srv) export(data_extract_ui) export(datanames_input) export(datasets) +export(extract) export(filter_spec) export(first_choice) export(first_choices) diff --git a/R/resolver.R b/R/resolver.R index e7b3bdcd..98593780 100644 --- a/R/resolver.R +++ b/R/resolver.R @@ -9,13 +9,15 @@ #' @export #' #' @examples -#' dataset1 <- datasets("df", function(x){head(x, 1)}) -#' dataset2 <- datasets(is.matrix, function(x){head(x, 1)}) +#' dataset1 <- datasets(is.data.frame) +#' dataset2 <- datasets(is.matrix) #' spec <- dataset1 & variables("a", "a") #' td <- within(teal.data::teal_data(), { #' df <- data.frame(a = as.factor(LETTERS[1:5]), b = letters[1:5]) +#' df2 <- data.frame(a = LETTERS[1:5], b = 1:5) #' m <- matrix() #' }) +#' resolver(spec | dataset2, td) #' resolver(dataset2, td) #' resolver(spec, td) #' spec <- dataset1 & variables("a", is.factor) @@ -24,7 +26,25 @@ resolver <- function(spec, data) { if (!inherits(data, "qenv")) { stop("Please use qenv() or teal_data() objects.") } - stopifnot(is.transform(spec), has_dataset(spec)) + stopifnot(is.transform(spec)) + + if (!is.delayed(spec)) { + return(spec) + } + + if (!is.null(names(spec))) { + rt <- resolver_transform(spec, data) + } else { + rt <- lapply(spec, resolver_transform, data = data) + if (length(rt) == 1) { + rt <- rt[[1]] + } + # FIXME: If there are several options invalidate whatever is below, until this is resolved. + } + rt +} + +resolver_transform <- function(spec, data) { specf <- spec if (has_dataset(specf) && is.delayed(specf$datasets)) { specf <- resolver.datasets(specf, data) @@ -165,7 +185,7 @@ resolver.variables <- function(spec, data) { return(spec) } datasets <- spec$datasets$select - data_selected <- data(data, datasets) + data_selected <- extract(data, datasets) if (is.null(names(data_selected))) { names_data <- colnames(data_selected) } else { @@ -337,18 +357,26 @@ extract <- function(x, variable) { #' update_spec(res, "datasets", "df_n") #' # update_spec(res, "datasets", "error") update_spec <- function(spec, type, value) { - w <- c("datasets", "variables", "values") - type <- match.arg(type, w) - restart_types <- w[seq_along(w) > which(type == w)] - speci <- spec if (!is.character(value)) { stop("The updated value is not a character.", "\nDo you attempt to set a new specification? Please open an issue") } - valid_names <- spec[[type]]$names - if (is.delayed(spec[[type]])) { - stop(type, " should be resolved before updating.") + + if (!is.null(names(spec))) { + updated_spec <- update_s_spec(spec, type, value) + } else { + update_multiple <- lapply(spec, update_s_spec, type, value) } + updated_spec +} + +update_s_spec <- function(spec, type, value) { + w <- c("datasets", "variables", "values") + type <- match.arg(type, w) + restart_types <- w[seq_along(w) > which(type == w)] + + valid_names <- spec[[type]]$names + if (!is.list(valid_names) && all(value %in% valid_names)) { original_select <- orig(spec[[type]]$select) spec[[type]][["select"]] <- value @@ -368,12 +396,12 @@ update_spec <- function(spec, type, value) { # Restore to the original specs for (type in restart_types) { - if (length(spec[[type]]) == 1L && is.na(spec[[type]])) { + if (is.na(spec[[type]])) { next } fun <- match.fun(type) restored_transform <- fun(x = orig(spec[[type]]$names), - select = orig(spec[[type]]$select)) + select = orig(spec[[type]]$select)) spec[[type]] <- restored_transform[[type]] } spec @@ -382,3 +410,8 @@ update_spec <- function(spec, type, value) { orig <- function(x) { attr(x, "original") } + +unorig <- function(x) { + attr(x, "original") <- NULL + x +} diff --git a/man/resolver.Rd b/man/resolver.Rd index 3d39c39f..dd7d1f1d 100644 --- a/man/resolver.Rd +++ b/man/resolver.Rd @@ -18,13 +18,15 @@ A transform but resolved Given the specification of some data to extract find if they are available or not. } \examples{ -dataset1 <- datasets("df", function(x){head(x, 1)}) -dataset2 <- datasets(is.matrix, function(x){head(x, 1)}) +dataset1 <- datasets(is.data.frame) +dataset2 <- datasets(is.matrix) spec <- dataset1 & variables("a", "a") td <- within(teal.data::teal_data(), { df <- data.frame(a = as.factor(LETTERS[1:5]), b = letters[1:5]) + df2 <- data.frame(a = LETTERS[1:5], b = 1:5) m <- matrix() }) +resolver(spec | dataset2, td) resolver(dataset2, td) resolver(spec, td) spec <- dataset1 & variables("a", is.factor) From 6a85027173afdc665f6cc7cf29bfdbf7e81c33ba Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Mon, 17 Mar 2025 17:18:16 +0100 Subject: [PATCH 028/142] Fix some checks --- R/types.R | 4 ++-- tests/testthat/test-resolver.R | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/R/types.R b/R/types.R index 08e36b04..03ff4b56 100644 --- a/R/types.R +++ b/R/types.R @@ -35,8 +35,8 @@ is.na.type <- function(x) { } #' @export -anyNA.type <- function(x) { - anyNA(unclass(x)) +anyNA.type <- function(x, recursive = FALSE) { + anyNA(unclass(x), recursive) } first <- function(x){ diff --git a/tests/testthat/test-resolver.R b/tests/testthat/test-resolver.R index 67f8cf06..e89a5340 100644 --- a/tests/testthat/test-resolver.R +++ b/tests/testthat/test-resolver.R @@ -135,7 +135,7 @@ test_that("update_spec resolves correctly", { expect_error(update_spec(res, "datasets", "error")) expect_error(update_spec(data_frames_factors, "datasets", "error")) - expect_error(update_spec(datasets(x = c("df", "df2")), "datasets", "df2")) + expect_no_error(update_spec(datasets(x = c("df", "df2")), "datasets", "df2")) expect_no_error(update_spec(datasets(x = c("df", "df2"), "df"), "datasets", "df2")) }) From 9993468317aeac524a33285fe5d789a3d8457125 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Tue, 18 Mar 2025 14:55:07 +0100 Subject: [PATCH 029/142] Simplify and reorganize delayed --- R/delayed.R | 31 ++++++++++++++++++------------- 1 file changed, 18 insertions(+), 13 deletions(-) diff --git a/R/delayed.R b/R/delayed.R index 61520bd9..86f47380 100644 --- a/R/delayed.R +++ b/R/delayed.R @@ -7,30 +7,35 @@ delay <- function(x) { } #' @export -#' @method is.delayed type -is.delayed.type <- function(x) { +is.delayed <- function(x) { + UseMethod("is.delayed") +} - if (!is.na(x)) { - return(!all(is.character(x$names)) || !all(is.character(x$select))) - } +#' @export +#' @method is.delayed default +is.delayed.default <- function(x) { FALSE } #' @export #' @method is.delayed transform is.delayed.transform <- function(x) { - is.delayed(x$datasets) || is.delayed(x$variables) || is.delayed(x$values) + if (!is.null(names(x))) { + any(vapply(x, is.delayed, logical(1L))) + } else { + delayed <- vapply(x, is.delayed, logical(1L)) + any(delayed) + } } #' @export -#' @method is.delayed default -is.delayed.default <- function(x) { - FALSE -} +#' @method is.delayed type +is.delayed.type <- function(x) { -#' @export -is.delayed <- function(x) { - UseMethod("is.delayed") + if (!is.na(x)) { + return(!all(is.character(x$names)) || !all(is.character(x$select))) + } + FALSE } resolved <- function(x, variable){ From 3624441d127faf5f368b0b754c9cb6ffcbf23340 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Wed, 19 Mar 2025 18:00:18 +0100 Subject: [PATCH 030/142] Basic operations work more flexible --- R/ops_transform.R | 96 ++++++++++++++++++++++++--- R/types.R | 161 ++++++++++++++++++++++++++++------------------ 2 files changed, 187 insertions(+), 70 deletions(-) diff --git a/R/ops_transform.R b/R/ops_transform.R index 6ff26a9b..b70d020e 100644 --- a/R/ops_transform.R +++ b/R/ops_transform.R @@ -9,8 +9,8 @@ Ops.transform <- function(e1, e2) { switch(.Generic, "!=" = NextMethod(), "==" = NextMethod(), - "|" = combine_transform(e1, e2), - "&" = c(e1, e2), + "|" = or_transform(e1, e2), + "&" = nd_transform(e1, e2), stop("Method ", sQuote(.Generic), " not implemented for this class ", .Class, ".", call. = FALSE)) } @@ -25,15 +25,93 @@ Ops.type <- function(e1, e2) { out <- switch(.Generic, "!=" = NextMethod(), # "==" = NextMethod(), - # "|" = , - "&" = c(e1, e2), + "|" = or_type(e1, e2), + "&" = nd_type(e1, e2), stop("Method ", sQuote(.Generic), " not implemented for this class ", .Class, ".", call. = FALSE)) - class(out) <- class(e1) out } -combine_transform <- function(e1, e2) { - l <- list(e1, e2) - class(l) <- c("transform", "list") - l +or_transform <- function(e1, e2) { + if (is.transform(e1) && is.type(e2) && !is.transform(e2)) { + opt2 <- e1 & e2 + out <- list(e1, opt2) + } else if (!is.transform(e1) && is.type(e1) && is.transform(e2)) { + opt2 <- e2 & e1 + out <- list(e2, opt2) + } else { + out <- list(e1, e2) + } + class(out) <- unique(c("transform", "list")) + out +} + +nd_transform <- function(e1, e2) { + if (is.transform(e1) && is.transform(e2)) { + types <- intersect(names(e1), names(e2)) + for (t in types) { + e1[[t]] <- unique(c(e1[[t]], e2[[t]])) + } + return(e1) + } + + if (is.type(e1) && is.transform(e2)) { + if (!is(e1) %in% names(e2)) { + e2[[is(e1)]] <- e1 + } else { + e2[[is(e1)]] <- c(e2[[is(e1)]], e1) + } + return(e2) + } else if (is.transform(e1) && is.type(e2)) { + if (!is(e2) %in% names(e1)) { + e1[[is(e2)]] <- e2 + } else { + e1[[is(e2)]] <- c(e1[[is(e2)]], e2) + } + out <- e1 + } else if (is.type(e1) && is.transform(e2)) { + out <- rev(c(e2, e1)) # To keep order in the list + } else { + stop("Method not implemented yet!") + } + out +} + +nd_type <- function(e1, e2) { + if (is.transform(e1) && !is.transform(e2)) { + out <- c(e1, list(e2)) + names(out)[length(out)] <- is(e2) + } else if (!is.transform(e1) && is.transform(e2)) { + out <- c(e2, list(e1)) + names(out)[length(out)] <- is(e1) + } else if (is.transform(e1) && is.transform(e2)){ + out <- c(e1, e2) + } else if (is.type(e1) && is.type(e2)) { + out <- list(e1, e2) + names(out) <- c(is(e1), is(e2)) + } else { + stop("Maybe we should decide how to apply a type to a list of transformers...") + } + class(out) <- c("transform", class(out)) + browser(expr = is(out) == "datasets" && length(table(names(out))) == 1L) + out +} + +or_type <- function(e1, e2) { + substitute <- is(e2) %in% names(e1) + if (substitute) { + out <- e1 + e1[[is(e2)]] <- e2 + return(add_type(out, e1)) + } + list(e1, e2) +} + + +# chooseOpsMethod.list <- function(x, y, mx, my, cl, reverse) TRUE +#' @export +chooseOpsMethod.transform <- function(x, y, mx, my, cl, reverse) { + # Apply one or other method + # !is.transform(x) + TRUE } +# chooseOpsMethod.type <- function(x, y, mx, my, cl, reverse) TRUE diff --git a/R/types.R b/R/types.R index 03ff4b56..fd7cb606 100644 --- a/R/types.R +++ b/R/types.R @@ -1,42 +1,26 @@ -transform <- function() { - o <- list(datasets = na_type("datasets"), - variables = na_type("variables"), - values = na_type("values")) - class(o) <- c("transform", "list") - delay(o) -} - is.transform <- function(x) { inherits(x, "transform") } -has_dataset <- function(x) { - !anyNA(x[["datasets"]]) -} - -has_variable <- function(x) { - !anyNA(x[["variables"]]) -} - -has_value <- function(x) { - !anyNA(x[["values"]]) -} - na_type <- function(type) { out <- NA_character_ class(out) <- c(type, "type") out } +is.type <- function(x) { + inherits(x, "type") +} + #' @export #' @method is.na type is.na.type <- function(x) { - anyNA(unclass(x)) + anyNA(unclass(x[c("names", "select")])) } #' @export anyNA.type <- function(x, recursive = FALSE) { - anyNA(unclass(x), recursive) + anyNA(unclass(x[c("names", "select")]), recursive) } first <- function(x){ @@ -71,64 +55,119 @@ type_helper <- function(x, select, type) { #' @export datasets <- function(x, select = first) { - o <- transform() - o$datasets <- type_helper(x, select, type = "datasets") - o + type_helper(x, select, type = "datasets") } #' @export variables <- function(x, select = first) { - o <- transform() - o$variables <- type_helper(x, select, type = "variables") - o + type_helper(x, select, type = "variables") } #' @export values <- function(x, select = first) { - o <- transform() - o$values <- type_helper(x, select, type = "values") - o -} + type_helper(x, select, type = "values") +} + +# #' @export +# c.type <- function(...) { +# +# if (is.na(..1)) { +# return(..2) +# } else if (is.na(..2)) { +# return(..1) +# } +# +# if (...length() > 2L) { +# stop("We can't combine this (yet)") +# } else if (all(class(..2) != class(..1))) { +# type_out <- ..1 +# type_out$child <- ..2 +# return(type_out) +# } +# out <- mapply(c, ..., SIMPLIFY = FALSE) +# out <- lapply(out, unique) +# class(out) <- c("transform", class(out)) +# delay(out) +# } #' @export c.transform <- function(...) { - if (...length() > 2) { - stop("More than two specifications won't be considered. Use & to combine them", call. = FALSE) + l <- list(...) + types <- lapply(l, names) + utypes <- unique(unlist(types, FALSE, FALSE)) + vector <- vector("list", length(utypes)) + names(vector) <- utypes + for (t in utypes) { + new_type <- vector("list", length = 2) + names(new_type) <- c("names", "select") + class(new_type) <- c("type", "list") + for (i in seq_along(l)) { + if (!t %in% names(l[[i]])) { + next + } + # Slower but less code duplication: + # new_type <- c(new_type, l[[i]][[t]]) + # then we need class(new_type) <- c(t, "type", "list") outside the loop + old_names <- new_type$names + old_select <- new_type$select + new_type$names <- c(old_names, l[[i]][[t]][["names"]]) + attr(new_type$names, "original") <- c(orig( + old_names), orig(l[[i]][[t]][["names"]])) + new_type$select <- c(old_select, l[[i]][[t]][["select"]]) + attr(new_type$select, "original") <- c(orig(old_select), orig(l[[i]][[t]][["select"]])) + } + orig_names <- unique(orig(new_type$names)) + new_type$names <- unique(new_type$names) + attr(new_type$names, "original") <- orig_names + + orig_select <- unique(orig(new_type$select)) + new_type$select <- unique(new_type$select) + attr(new_type$select, "original") <- orig_select + class(new_type) <- c(t, "type", "list") + vector[[t]] <- new_type } - transf <- mapply(c, ..., SIMPLIFY = FALSE) - class(transf) <- c("transform", "list") - delay(transf) + class(vector) <- c("transform", "list") + vector } #' @export c.type <- function(...) { - - if (is.na(..1)) { - return(..2) - } else if (is.na(..2)) { - return(..1) + l <- list(...) + types <- lapply(l, is) + utypes <- unique(unlist(types, FALSE, FALSE)) + vector <- vector("list", length(utypes)) + names(vector) <- utypes + for (t in utypes) { + new_type <- vector("list", length = 2) + names(new_type) <- c("names", "select") + for (i in seq_along(l)) { + if (!t %in% names(l[[i]])) { + next + } + old_names <- new_type$names + old_select <- new_type$select + new_type$names <- c(old_names, l[[i]][[t]][["names"]]) + attr(new_type$names, "original") <- c(orig( + old_names), orig(l[[i]][[t]][["names"]])) + new_type$select <- c(old_select, l[[i]][[t]][["select"]]) + attr(new_type$select, "original") <- c(orig(old_select), orig(l[[i]][[t]][["select"]])) + } + orig_names <- unique(orig(new_type$names)) + new_type$names <- unique(new_type$names) + attr(new_type$names, "original") <- orig_names + + orig_select <- unique(orig(new_type$select)) + new_type$select <- unique(new_type$select) + attr(new_type$select, "original") <- orig_select + class(new_type) <- c(t, "type", "list") + vector[[t]] <- new_type } - - objects <- list(...) - classes <- unlist(lapply(objects, class), FALSE,FALSE) - type <- setdiff(classes, c("type", "list")) - if (length(type) > 1L) { - stop("Combining different types", call. = FALSE) + if (length(vector) == 1) { + return(vector[[1]]) } - - names <- lapply(objects, "[[", i = "names") - select <- lapply(objects, "[[", i = "select") - names_orig <- lapply(names, orig) - select_orig <- lapply(select, orig) - type_f <- match.fun(type) - type_out <- type_f(x = simplify_c(names_orig), - select = simplify_c(select_orig)) - attr(type_out[[type]][["names"]], "original") <- NULL - attr(type_out[[type]][["names"]], "original") <- simplify_c(names_orig) - attr(type_out[[type]][["select"]], "original") <- NULL - attr(type_out[[type]][["select"]], "original") <- simplify_c(select_orig) - delay(type_out[[type]]) + class(vector) <- c("transform", "list") + vector } simplify_c <- function(x) { From 941b172a18c37cd03a4c2b3c43221931f3ede2c3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Tue, 25 Mar 2025 10:48:34 +0100 Subject: [PATCH 031/142] Simplify code --- R/delayed.R | 35 +++-------------------------------- 1 file changed, 3 insertions(+), 32 deletions(-) diff --git a/R/delayed.R b/R/delayed.R index 86f47380..d7416539 100644 --- a/R/delayed.R +++ b/R/delayed.R @@ -20,12 +20,7 @@ is.delayed.default <- function(x) { #' @export #' @method is.delayed transform is.delayed.transform <- function(x) { - if (!is.null(names(x))) { - any(vapply(x, is.delayed, logical(1L))) - } else { - delayed <- vapply(x, is.delayed, logical(1L)) - any(delayed) - } + any(vapply(x, is.delayed, logical(1L))) } #' @export @@ -38,36 +33,12 @@ is.delayed.type <- function(x) { FALSE } -resolved <- function(x, variable){ +resolved <- function(x, type = is(x)){ s <- all(is.character(x$names)) && all(is.character(x$select)) if (!s && !all(x$select %in% x$names)) { - stop("Selected ", variable, " not available") + stop("Selected ", type, " not resolved.") } attr(x, "delayed") <- NULL x } - -get_datasets <- function(x) { - if (is.transform(x) && !is.delayed(x$datasets)) { - x$datasets$names - } else { - NULL - } -} - -get_variables <- function(x) { - if (is.transform(x) && !is.delayed(x$datasets) && !is.delayed(x$variables)) { - x$variables$names - } else { - NULL - } -} - -get_values <- function(x) { - if (is.transform(x) && !is.delayed(x)) { - x$values$names - } else { - NULL - } -} From fe138e9e6b2d5080a6c2b6b29fc55538e5e5fa5e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Tue, 25 Mar 2025 10:50:40 +0100 Subject: [PATCH 032/142] Add more checks --- R/ops_transform.R | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/R/ops_transform.R b/R/ops_transform.R index b70d020e..5a4ae2f4 100644 --- a/R/ops_transform.R +++ b/R/ops_transform.R @@ -38,10 +38,13 @@ or_transform <- function(e1, e2) { } else if (!is.transform(e1) && is.type(e1) && is.transform(e2)) { opt2 <- e2 & e1 out <- list(e2, opt2) - } else { + } else if (is.transform(e1) && is.transform(e2)) { out <- list(e1, e2) + } else { + stop("Missing implementation method.") } - class(out) <- unique(c("transform", "list")) + # FIXME: Should we signal it is a transform or just a list of transform is enough? + # class(out) <- c("transform", "list") out } @@ -92,7 +95,6 @@ nd_type <- function(e1, e2) { stop("Maybe we should decide how to apply a type to a list of transformers...") } class(out) <- c("transform", class(out)) - browser(expr = is(out) == "datasets" && length(table(names(out))) == 1L) out } From cf2d634d02c102f78032ae057ec7ea456dcab646 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Tue, 25 Mar 2025 10:51:46 +0100 Subject: [PATCH 033/142] Resolve only what is possible. Select is resolved on the names of the variables selected not on the data itself. --- R/resolver.R | 487 ++++++++++++++++++++++----------------------------- 1 file changed, 206 insertions(+), 281 deletions(-) diff --git a/R/resolver.R b/R/resolver.R index 98593780..1e3fe15d 100644 --- a/R/resolver.R +++ b/R/resolver.R @@ -1,7 +1,7 @@ #' Resolve the specification #' #' Given the specification of some data to extract find if they are available or not. -#' +#' The specification for selecting a variable shouldn't depend on the data of said variable. #' @param spec A object extraction specification. #' @param data A `qenv()`, or `teal.data::teal_data()` object. #' @@ -26,52 +26,80 @@ resolver <- function(spec, data) { if (!inherits(data, "qenv")) { stop("Please use qenv() or teal_data() objects.") } - stopifnot(is.transform(spec)) - if (!is.delayed(spec)) { return(spec) } + # Adding some default specifications if they are missing + if ("values" %in% names(spec) && !"variables" %in% names(spec)) { + spec <- variables(first) & spec + } - if (!is.null(names(spec))) { - rt <- resolver_transform(spec, data) - } else { - rt <- lapply(spec, resolver_transform, data = data) - if (length(rt) == 1) { - rt <- rt[[1]] - } - # FIXME: If there are several options invalidate whatever is below, until this is resolved. + if ("variables" %in% names(spec) && !"datasets" %in% names(spec)) { + spec <- datasets(first) & spec } - rt + + stopifnot(is.transform(spec)) + det <- determine(spec, data, spec = spec) + det$type } -resolver_transform <- function(spec, data) { - specf <- spec - if (has_dataset(specf) && is.delayed(specf$datasets)) { - specf <- resolver.datasets(specf, data) - } else if (!has_dataset(specf)) { - specf$datasets <- na_type("datasets") +#' A method that should take a type and resolve it. +#' +#' Generic that makes the minimal check on spec. +#' Responsible of subsetting/extract the data received and check that the type matches +#' @param type The specification to resolve. +#' @param data The minimal data required. +#' @return A list with two elements, the type resolved and the data extracted. +#' @keywords internal +#' @export +determine <- function(type, data, ...) { + stopifnot(is.type(type) || is.transform(type)) + if (!is.delayed(type)) { + return(list(type = type, data = data)) } + UseMethod("determine") +} - if (has_variable(specf) && !is.delayed(specf$datasets)) { - specf <- resolver.variables(specf, data) +#' @export +determine.default <- function(type, data, ..., spec) { + if (!is.null(names(spec)) && is.delayed(spec)) { + rt <- determine(spec, data) } else { - specf$variables <- na_type("variables") + rt <- lapply(spec, resolver, data = data, spec = spec) + if (length(rt) == 1) { + return(rt[[1]]) + } } + rt +} - if (has_value(specf) && !is.delayed(specf$datasets) && !is.delayed(specf$variables)) { - specf <- resolver.values(specf, data) - } else { - specf$values <- na_type("values") +#' @export +determine.transform <- function(type, data, ..., spec) { + stopifnot(inherits(data, "qenv")) + # Recursion for other transforms in a list spec | spec + if (is.null(names(spec))) { + specs <- lapply(type, data, spec = spec) + return(specs) } - attr(specf, "delayed") <- NULL - delay(specf) + for (i in seq_along(type)) { + di <- determine(type[[i]], data, spec = spec) + # orverwrite so that next type in line receives the corresponding data and specification + if (is.null(di$type)) { + next + } + type[[i]] <- di$type + data <- di$data + } + list(type = type, data = data) # It is the transform object resolved. } functions_names <- function(unresolved, reference) { + stopifnot(is.character(reference)) # Allows for NA characters is_fc <- vapply(unresolved, is.function, logical(1L)) fc_unresolved <- unresolved[is_fc] x <- vector("character") + for (f in fc_unresolved) { y <- tryCatch(f(reference), error = function(x) f ) @@ -83,328 +111,225 @@ functions_names <- function(unresolved, reference) { unique(unlist(c(unresolved[!is_fc], x), FALSE, FALSE)) } -functions_data <- function(unresolved, data) { +functions_data <- function(unresolved, data, names) { + stopifnot(!is.null(data)) # Must be something but not NULL fc_unresolved <- unresolved[vapply(unresolved, is.function, logical(1L))] - - # This is for variables - datasets <- names(data) - # Matrix doesn't have a names method - if (is.null(datasets)) { - datasets <- colnames(data) - } l <- lapply(fc_unresolved, function(f) { - v <- vapply(datasets, function(d) { - # Extract the data and apply the user supplied function - out <- tryCatch(f(extract(data, d)), error = function(x){FALSE}) - if (!is.logical(out)) { - stop("Provided functions should return a logical object.") - } - if (length(out) != 1L && length(out) != length(extract(data, d))) { - # Function resolution is unconventional, but this would produce too many warnings... - # warning("The output of the function must be of length 1 or the same length as the data.") - return(FALSE) - } - all(out) - }, logical(1L)) - datasets[v] + all_data <- tryCatch(f(data), error = function(x){FALSE}) + if (any(all_data)) { + return(names[all_data]) + } else { + return(NULL) + } }) unique(unlist(l, FALSE, FALSE)) } -resolver.datasets <- function(spec, data) { - if (!inherits(data, "qenv")) { - stop("Please use qenv() or teal_data() objects.") - } - if (is.null(spec[["datasets"]]) || all(is.na(spec[["datasets"]]))) { - return(spec) - } - sdatasets <- spec$datasets - data_names <- names(data) - orig_names <- sdatasets$names - orig_select <- sdatasets$select - if (is.delayed(sdatasets) && all(is.character(sdatasets$names))) { - match <- intersect(data_names, sdatasets$names) - missing <- setdiff(sdatasets$names, data_names) +# Checks that for the given type and data names and data it can be resolved +# The workhorse of the resolver +determine_helper <- function(type, data_names, data) { + orig_names <- type$names + orig_select <- type$select + names_variables_obj <- if (is.null(names(data))) { colnames(data)} else {names(data)} + if (is.delayed(type) && all(is.character(type$names))) { + match <- intersect(data_names, type$names) + missing <- setdiff(type$names, data_names) if (length(missing)) { - stop("Missing datasets ", paste(sQuote(missing), collapse = ", "), " were specified.") + return(NULL) + # stop("Missing datasets ", paste(sQuote(missing), collapse = ", "), " were specified.") } - sdatasets$names <- match + type$names <- match if (length(match) == 0) { - stop("No selected datasets matching the conditions requested") + return(NULL) + # stop("No selected ", is(type), " matching the conditions requested") } else if (length(match) == 1) { - sdatasets$select <- match + type$select <- match } else { - new_select <- c(functions_names(sdatasets$select, sdatasets$names), - functions_data(sdatasets$select, data[sdatasets$names])) + new_select <- functions_names(type$select, type$names) new_select <- unique(new_select[!is.na(new_select)]) if (!length(new_select)) { - stop("No datasets meet the requirements to be selected") + return(NULL) + # stop("No ", is(type), " meet the requirements to be selected") } - sdatasets$select <- new_select + type$select <- new_select } - } else if (is.delayed(sdatasets)) { - old_names <- sdatasets$names - new_names <- c(functions_names(sdatasets$names, data_names), - functions_data(sdatasets$names, data)) + } else if (is.delayed(type)) { + old_names <- type$names + new_names <- c(functions_names(type$names, names_variables_obj), + functions_data(type$names, data, data_names)) new_names <- unique(new_names[!is.na(new_names)]) if (!length(new_names)) { - stop("No datasets meet the requirements") + return(NULL) + # stop("No ", is(type), " meet the requirements") } - sdatasets$names <- new_names + type$names <- new_names - if (length(sdatasets$names) == 0) { - stop("No selected datasets matching the conditions requested") - } else if (length(sdatasets$names) == 1) { - sdatasets$select <- sdatasets$names + if (length(type$names) == 0) { + return(NULL) + # stop("No selected ", is(type), " matching the conditions requested") + } else if (length(type$names) == 1) { + type$select <- type$names } - new_select <- c(functions_names(sdatasets$select, sdatasets$names), - functions_data(sdatasets$select, data[sdatasets$names])) + new_select <- functions_names(type$select, type$names) new_select <- unique(new_select[!is.na(new_select)]) if (!length(new_select)) { - stop("No datasets meet the requirements to be selected") + return(NULL) + stop("No ", is(type), " meet the requirements to be selected") } - sdatasets$select <- new_select + type$select <- new_select } - attr(sdatasets$names, "original") <- orig(orig_names) - attr(sdatasets$select, "original") <- orig(orig_select) - spec$datasets <- resolved(sdatasets, "dataset") - spec + attr(type$names, "original") <- orig(orig_names) + attr(type$select, "original") <- orig(orig_select) + resolved(type) } -resolver.variables <- function(spec, data) { +#' @export +determine.datasets <- function(type, data, ...) { if (!inherits(data, "qenv")) { stop("Please use qenv() or teal_data() objects.") } - if (is.delayed(spec$datasets)) { - stop("Datasets not resolved yet") - } - if (is.null(spec[["variables"]]) || all(is.na(spec[["variables"]]))) { - return(spec) - } - datasets <- spec$datasets$select - data_selected <- extract(data, datasets) - if (is.null(names(data_selected))) { - names_data <- colnames(data_selected) - } else { - names_data <- names(data_selected) - } - - svariables <- spec$variables - orig_names <- svariables$names - orig_select <- svariables$select - if (is.delayed(svariables) && all(is.character(svariables$names))) { - match <- intersect(names_data, svariables$names) - missing <- setdiff(svariables$names, names_data) - if (length(missing)) { - stop("Missing variables ", paste(sQuote(missing), collapse = ", "), " were specified.") - } - svariables$names <- match - if (length(match) == 1) { - svariables$select <- match - } else { - new_select <- c(functions_names(svariables$select, svariables$names), - functions_data(svariables$select, data_selected)) - new_select <- unique(new_select[!is.na(new_select)]) - if (!length(new_select)) { - stop("No variables meet the requirements to be selected") - } - svariables$select <- new_select - } - } else if (is.delayed(svariables)) { - new_names <- c(functions_names(svariables$names, names_data), - functions_data(svariables$names, data_selected)) - new_names <- unique(new_names[!is.na(new_names)]) - if (!length(new_names)) { - stop("No variables meet the requirements") - } - svariables$names <- new_names - if (length(svariables$names) == 1) { - svariables$select <- svariables$names - } else { - new_select <- c(functions_names(svariables$select, svariables$names), - functions_data(svariables$select, data_selected)) - new_select <- unique(new_select[!is.na(new_select)]) - if (!length(new_select)) { - stop("No variables meet the requirements to be selected") - } - svariables$select <- new_select + l <- vector("list", length(data)) + for (i in seq_along(data)){ + data_name_env <- names(data)[i] + out <- determine_helper(type, data_name_env, data[[data_name_env]]) + if (!is.null(out)) { + l[[i]] <- out } } - attr(svariables$names, "original") <- orig(orig_names) - attr(svariables$select, "original") <- orig(orig_select) - spec$variables <- resolved(svariables, "variables") - spec + # Merge together all the types + type <- do.call(c, l[lengths(l) > 1]) + # Not possible to know what is happening + if (!is.delayed(type) && length(type$select) > 1) { + list(type = type, data = data[type$select]) + } else if (!is.delayed(type) && length(type$select) == 1) { + list(type = type, data = data[[type$select]]) + } else { + list(type = type, data = NULL) + } } -resolver.values <- function(spec, data) { - if (!inherits(data, "qenv")) { - stop("Please use qenv() or teal_data() objects.") +#' @export +determine.variables <- function(type, data, ...) { + if (length(dim(data)) != 2L) { + stop("Can't resolve variables from this object of class ", class(data)) } - if (is.null(spec[["values"]]) || all(is.na(spec[["values"]]))) { - return(spec) + if (ncol(data) <= 0L) { + stop("Can't pull variable: No variable is available.") } - svalues <- spec$values - dataset <- extract(data, spec$datasets$select) - variable <- extract(dataset, spec$variables$select) - orig_names <- svalues$names - orig_select <- svalues$select - spec$values <- if (is.delayed(svalues) && all(is.character(svalues$names))) { - match <- intersect(variable, svalues$names) - missing <- setdiff(svalues$names, variable) - if (length(missing)) { - stop("Missing values ", paste(sQuote(missing), collapse = ", "), " were specified.") - } - svalues$names <- match - if (length(match) == 1) { - svalues$select <- match - } else { - match <- intersect(variable, svalues$names) - new_select <- c(functions_names(svalues$select, svalues$names), - functions_data(svalues$select, variable)) - new_select <- unique(new_select[!is.na(new_select)]) - if (!length(new_select)) { - stop("No variables meet the requirements to be selected") - } - svalues$select <- new_select - } - } else if (is.delayed(svalues)) { - new_names <- c(functions_names(svalues$names, variable), - functions_data(svalues$names, variable)) - new_names <- unique(new_names[!is.na(new_names)]) - if (!length(new_names)) { - stop("No variables meet the requirements") - } - svalues$names <- new_names - if (length(svalues$names) == 1) { - svalues$select <- svalues$names - } else { - new_select <- c(functions_names(svalues$select, variable), - functions_data(svalues$select, variable)) - new_select <- unique(new_select[!is.na(new_select)]) - if (!length(new_select)) { - stop("No variables meet the requirements to be selected") - } - svalues$select <- new_select + # Assumes the object has colnames method (true for major object classes: DataFrame, tibble, Matrix, array) + # FIXME: What happens if colnames is null: array(dim = c(4, 2)) |> colnames() + l <- vector("list", ncol(data)) + for (i in seq_len(ncol(data))){ + out <- determine_helper(type, colnames(data)[i], data[, i]) + if (!is.null(out)) { + l[[i]] <- out } } - attr(svalues$names, "original") <- orig(orig_names) - attr(svalues$select, "original") <- orig(orig_select) - spec$values <- resolved(svalues, "values") - spec + + # Merge together all the types + type <- do.call(c, l[lengths(l) > 1]) + + # Not possible to know what is happening + if (is.delayed(type)) { + return(list(type = type, data = NULL)) + } + # This works for matrices and data.frames of length 1 or multiple + # be aware of drop behavior on tibble vs data.frame + list(type = type, data = data[, type$select]) } #' @export -extract.MultiAssayExperiment <- function(x, variable) { +determine.mae_colData <- function(type, data, ...) { if (!requireNamespace("MultiAssayExperiment", quietly = TRUE)) { - stop("Required to have MultiAssayExperiment's package.") + stop("Requires 'MultiAssayExperiment' package.") } - cd <- MultiAssayExperiment::colData(x) - cd[[variable]] -} -#' @export -extract.matrix <- function(x, variable) { - # length(variable) == 1L - x[, variable, drop = TRUE] -} + new_data <- colData(data) + for (i in seq_along(new_data)){ + determine_helper(type, colnames(data)[i], new_data[, i]) + } + if (length(dim(new_data)) != 2L) { + stop("Can't resolve variables from this object of class ", class(new_data)) + } + if (ncol(new_data) <= 0L) { + stop("Can't pull variable: No variable is available.") + } + type <- determine_helper(type, colnames(data), data) -#' @export -#' @method extract data.frame -extract.data.frame <- function(x, variable) { - # length(variable) == 1L - x[, variable, drop = TRUE] -} + # Not possible to know what is happening + if (is.delayed(type)) { + return(list(type = type, data = NULL)) + } -#' @export -extract.qenv <- function(x, variable) { - x[[variable]] -} + if (length(type$select) > 1) { + list(type = type, data = data[type$select]) -#' @export -extract.default <- function(x, variable) { - x[, variable, drop = TRUE] + } else { + list(type = type, data = data[[type$select]]) + } } #' @export -extract <- function(x, variable) { - UseMethod("extract") +determine.mae_experiments <- function(type, data, ...) { + if (!requireNamespace("MultiAssayExperiment", quietly = TRUE)) { + stop("Requires 'MultiAssayExperiment' package.") + } + new_data <- experiments(data) + type <- determine_helper(type, names(new_data), new_data) + + # Not possible to know what is happening + if (is.delayed(type)) { + } + + if (!is.delayed(type) && length(type$select) > 1) { + list(type = type, data = new_data[type$select]) + + } else if (!is.delayed(type) && length(type$select) == 1) { + list(type = type, data = new_data[[type$select]]) + } else { + return(list(type = type, data = NULL)) + } } -#' Update a specification -#' -#' Once a selection is made update the specification for different valid selection. -#' @param spec A resolved specification such as one created with datasets and variables. -#' @param type Which type was updated? One of datasets, variables, values. -#' @param value What is the new selection? One that is a valid value for the given type and specification. -#' @return The specification with restored choices and selection if caused by the update. #' @export -#' @examples -#' td <- within(teal.data::teal_data(), { -#' df <- data.frame(A = as.factor(letters[1:5]), -#' Ab = LETTERS[1:5]) -#' df_n <- data.frame(C = 1:5, -#' Ab = as.factor(letters[1:5])) -#' }) -#' data_frames_factors <- datasets(is.data.frame) & variables(is.factor) -#' res <- resolver(data_frames_factors, td) -#' update_spec(res, "datasets", "df_n") -#' # update_spec(res, "datasets", "error") -update_spec <- function(spec, type, value) { - if (!is.character(value)) { - stop("The updated value is not a character.", - "\nDo you attempt to set a new specification? Please open an issue") +determine.mae_sampleMap <- function(type, data, ...) { + if (!requireNamespace("MultiAssayExperiment", quietly = TRUE)) { + stop("Requires 'MultiAssayExperiment' package.") } - if (!is.null(names(spec))) { - updated_spec <- update_s_spec(spec, type, value) - } else { - update_multiple <- lapply(spec, update_s_spec, type, value) + new_data <- sampleMap(data) + type <- determine_helper(type, names(new_data), new_data) + + # Not possible to know what is happening + if (is.delayed(type)) { + return(list(type = type, data = NULL)) } - updated_spec -} -update_s_spec <- function(spec, type, value) { - w <- c("datasets", "variables", "values") - type <- match.arg(type, w) - restart_types <- w[seq_along(w) > which(type == w)] - - valid_names <- spec[[type]]$names - - if (!is.list(valid_names) && all(value %in% valid_names)) { - original_select <- orig(spec[[type]]$select) - spec[[type]][["select"]] <- value - attr(spec[[type]][["select"]], "original") <- original_select - } else if (!is.list(valid_names) && !all(value %in% valid_names)) { - original_select <- orig(spec[[type]]$select) - valid_values <- intersect(value, valid_names) - if (!length(valid_values)) { - stop("No valid value provided.") - } - spec[[type]][["select"]] <- valid_values - attr(spec[[type]][["select"]], "original") <- original_select + if (length(type$select) > 1) { + list(type = type, data = data[type$select]) + } else { - stop("It seems the specification needs to be resolved first.") + list(type = type, data = data[[type$select]]) } +} - # Restore to the original specs - for (type in restart_types) { +#' @export +determine.values <- function(type, data, ...) { + type <- determine_helper(type, names(data), data) - if (is.na(spec[[type]])) { - next - } - fun <- match.fun(type) - restored_transform <- fun(x = orig(spec[[type]]$names), - select = orig(spec[[type]]$select)) - spec[[type]] <- restored_transform[[type]] + # Not possible to know what is happening + if (is.delayed(type)) { + return(list(type = type, data = NULL)) } - spec + + list(type = type, data = type$select) } orig <- function(x) { From 3385521aadf277ed374e0051c89413c0535ee88c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Tue, 25 Mar 2025 10:52:59 +0100 Subject: [PATCH 034/142] Combine safely multiple types --- R/types.R | 25 ++++++++++++++++++------- 1 file changed, 18 insertions(+), 7 deletions(-) diff --git a/R/types.R b/R/types.R index fd7cb606..85fdc0d4 100644 --- a/R/types.R +++ b/R/types.R @@ -95,6 +95,10 @@ values <- function(x, select = first) { c.transform <- function(...) { l <- list(...) types <- lapply(l, names) + typesc <- vapply(l, is.transform, logical(1L)) + if (!all(typesc)) { + stop("An object in position ", which(!typesc), " is not a specification.") + } utypes <- unique(unlist(types, FALSE, FALSE)) vector <- vector("list", length(utypes)) names(vector) <- utypes @@ -135,6 +139,10 @@ c.transform <- function(...) { c.type <- function(...) { l <- list(...) types <- lapply(l, is) + typesc <- vapply(l, is.type, logical(1L)) + if (!all(typesc)) { + stop("An object in position ", which(!typesc), " is not a type.") + } utypes <- unique(unlist(types, FALSE, FALSE)) vector <- vector("list", length(utypes)) names(vector) <- utypes @@ -142,24 +150,27 @@ c.type <- function(...) { new_type <- vector("list", length = 2) names(new_type) <- c("names", "select") for (i in seq_along(l)) { - if (!t %in% names(l[[i]])) { + names_l <- names(l[[i]]) + if (!is(l[[i]], t)) { next } old_names <- new_type$names old_select <- new_type$select - new_type$names <- c(old_names, l[[i]][[t]][["names"]]) + new_type$names <- c(old_names, l[[i]][["names"]]) attr(new_type$names, "original") <- c(orig( - old_names), orig(l[[i]][[t]][["names"]])) - new_type$select <- c(old_select, l[[i]][[t]][["select"]]) - attr(new_type$select, "original") <- c(orig(old_select), orig(l[[i]][[t]][["select"]])) + old_names), orig(l[[i]][["names"]])) + new_type$select <- unique(c(old_select, l[[i]][["select"]])) + attr(new_type$select, "original") <- c(orig(old_select), orig(l[[i]][["select"]])) } orig_names <- unique(orig(new_type$names)) + orig_select <- unique(orig(new_type$select)) new_type$names <- unique(new_type$names) attr(new_type$names, "original") <- orig_names - orig_select <- unique(orig(new_type$select)) - new_type$select <- unique(new_type$select) + # From the possible names apply the original function + new_type$select <- functions_names(orig(new_type$select), new_type$names) attr(new_type$select, "original") <- orig_select + class(new_type) <- c(t, "type", "list") vector[[t]] <- new_type } From 2c42af5a649d49384f45a97c49da7db77f6376c7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Tue, 25 Mar 2025 10:53:32 +0100 Subject: [PATCH 035/142] Add documentation for types --- R/types.R | 39 ++++++++++++++++++++++++++++++++++++ man/types.Rd | 56 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 95 insertions(+) create mode 100644 man/types.Rd diff --git a/R/types.R b/R/types.R index 85fdc0d4..30633870 100644 --- a/R/types.R +++ b/R/types.R @@ -53,17 +53,56 @@ type_helper <- function(x, select, type) { delay(out) } + +#' @rdname types +#' @name Types +#' @title Type specification +#' @description +#' Define how to select and extract data +#' @param x Character specifying the names or functions to select them. The functions will be applied on the data or the names. +#' @param select Character of `x` or functions to select on x (only on names or positional not on the data of the variable). +#' @returns An object of the same class as the function with two elements: names the content of x, and select. +#' @examples +#' datasets("A") +#' datasets("A") | datasets("B") +#' datasets(is.data.frame) +#' datasets("A") & variables(is.numeric) +NULL + + + +#' @describeIn types Specify datasets. #' @export datasets <- function(x, select = first) { type_helper(x, select, type = "datasets") } +#' @describeIn types Specify variables. #' @export variables <- function(x, select = first) { type_helper(x, select, type = "variables") } +#' @describeIn types Specify variables of MultiAssayExperiment col Data. +#' @export +mae_colData <- function(x, select = first) { + type_helper(x, select, type = "mae_colData") +} + +#' @describeIn types Specify variables of MultiAssayExperiment sampleMap. +#' @export +mae_sampleMap <- function(x, select = first) { + type_helper(x, select, type = "mae_sampleMap") +} + +#' @describeIn types Specify variables of MultiAssayExperiment experiments. +#' @export +mae_experiments <- function(x, select = first) { + type_helper(x, select, type = "mae_experiments") +} + +#' @describeIn types Specify values. #' @export values <- function(x, select = first) { type_helper(x, select, type = "values") diff --git a/man/types.Rd b/man/types.Rd new file mode 100644 index 00000000..731ae80f --- /dev/null +++ b/man/types.Rd @@ -0,0 +1,56 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/types.R +\name{Types} +\alias{Types} +\alias{datasets} +\alias{variables} +\alias{mae_colData} +\alias{mae_sampleMap} +\alias{mae_experiments} +\alias{values} +\title{Type specification} +\usage{ +datasets(x, select = first) + +variables(x, select = first) + +mae_colData(x, select = first) + +mae_sampleMap(x, select = first) + +mae_experiments(x, select = first) + +values(x, select = first) +} +\arguments{ +\item{x}{Character specifying the names or functions to select them. The functions will be applied on the data or the names.} + +\item{select}{Character of \code{x} or functions to select on x (only on names or positional not on the data of the variable).} +} +\value{ +An object of the same class as the function with two elements: names the content of x, and select. +} +\description{ +Define how to select and extract data +} +\section{Functions}{ +\itemize{ +\item \code{datasets()}: Specify datasets. + +\item \code{variables()}: Specify variables. + +\item \code{mae_colData()}: Specify variables of MultiAssayExperiment col Data. + +\item \code{mae_sampleMap()}: Specify variables of MultiAssayExperiment sampleMap. + +\item \code{mae_experiments()}: Specify variables of MultiAssayExperiment experiments. + +\item \code{values()}: Specify values. + +}} +\examples{ +datasets("A") +datasets("A") | datasets("B") +datasets(is.data.frame) +datasets("A") & variables(is.numeric) +} From 3cd91329135b668d8045dfef1224511573663156 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Tue, 25 Mar 2025 12:16:32 +0100 Subject: [PATCH 036/142] Better handling of types not resolved --- R/types.R | 6 +++++- man/update_spec.Rd | 2 +- 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/R/types.R b/R/types.R index 30633870..82697a33 100644 --- a/R/types.R +++ b/R/types.R @@ -207,7 +207,11 @@ c.type <- function(...) { attr(new_type$names, "original") <- orig_names # From the possible names apply the original function - new_type$select <- functions_names(orig(new_type$select), new_type$names) + if (any(vapply(l, is.delayed, logical(1L)))) { + new_type$select <- orig_select + } else { + new_type$select <- functions_names(orig(new_type$select), new_type$names) + } attr(new_type$select, "original") <- orig_select class(new_type) <- c(t, "type", "list") diff --git a/man/update_spec.Rd b/man/update_spec.Rd index a85cf2f9..3e10ddf8 100644 --- a/man/update_spec.Rd +++ b/man/update_spec.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/resolver.R +% Please edit documentation in R/update_spec.R \name{update_spec} \alias{update_spec} \title{Update a specification} From b780107f6dae8bc55d6de507514bc6d1fe7093a2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Tue, 25 Mar 2025 12:16:57 +0100 Subject: [PATCH 037/142] Better handling of resolver --- R/resolver.R | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/R/resolver.R b/R/resolver.R index 1e3fe15d..ebd5e9a2 100644 --- a/R/resolver.R +++ b/R/resolver.R @@ -95,7 +95,10 @@ determine.transform <- function(type, data, ..., spec) { } functions_names <- function(unresolved, reference) { - stopifnot(is.character(reference)) # Allows for NA characters + stopifnot(is.character(reference) || is.factor(reference) || is.null(reference)) # Allows for NA characters + if (is.null(reference)) { + return(NULL) + } is_fc <- vapply(unresolved, is.function, logical(1L)) fc_unresolved <- unresolved[is_fc] x <- vector("character") From 9cfb6f8f54f4591d8534d80af13844095976725b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Tue, 25 Mar 2025 12:17:59 +0100 Subject: [PATCH 038/142] Better handling of composing --- NAMESPACE | 19 +++++++++++++------ R/ops_transform.R | 3 +-- 2 files changed, 14 insertions(+), 8 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index c7f6c89d..e5e1254d 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -5,16 +5,20 @@ S3method(Ops,type) S3method(anyNA,type) S3method(c,transform) S3method(c,type) +S3method(chooseOpsMethod,transform) S3method(data_extract_multiple_srv,FilteredData) S3method(data_extract_multiple_srv,list) S3method(data_extract_multiple_srv,reactive) S3method(data_extract_srv,FilteredData) S3method(data_extract_srv,list) -S3method(extract,MultiAssayExperiment) -S3method(extract,data.frame) -S3method(extract,default) -S3method(extract,matrix) -S3method(extract,qenv) +S3method(determine,datasets) +S3method(determine,default) +S3method(determine,mae_colData) +S3method(determine,mae_experiments) +S3method(determine,mae_sampleMap) +S3method(determine,transform) +S3method(determine,values) +S3method(determine,variables) S3method(filter_spec_internal,default) S3method(filter_spec_internal,delayed_data) S3method(is.delayed,default) @@ -61,7 +65,7 @@ export(data_extract_srv) export(data_extract_ui) export(datanames_input) export(datasets) -export(extract) +export(determine) export(filter_spec) export(first_choice) export(first_choices) @@ -77,6 +81,9 @@ export(is_single_dataset) export(last_choice) export(last_choices) export(list_extract_spec) +export(mae_colData) +export(mae_experiments) +export(mae_sampleMap) export(merge_datasets) export(merge_expression_module) export(merge_expression_srv) diff --git a/R/ops_transform.R b/R/ops_transform.R index 5a4ae2f4..2c9c17d8 100644 --- a/R/ops_transform.R +++ b/R/ops_transform.R @@ -89,8 +89,7 @@ nd_type <- function(e1, e2) { } else if (is.transform(e1) && is.transform(e2)){ out <- c(e1, e2) } else if (is.type(e1) && is.type(e2)) { - out <- list(e1, e2) - names(out) <- c(is(e1), is(e2)) + out <- c(e1, e2) } else { stop("Maybe we should decide how to apply a type to a list of transformers...") } From bad225d0115a24dc366c88142fd98665587565fa Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Tue, 25 Mar 2025 12:18:50 +0100 Subject: [PATCH 039/142] Adding some other files --- man/determine.Rd | 21 +++++++++++++++++++++ man/resolver.Rd | 1 + tests/testthat/test-ops_transform.R | 3 ++- tests/testthat/test-resolver.R | 25 +++++++++++++++++++++++++ 4 files changed, 49 insertions(+), 1 deletion(-) create mode 100644 man/determine.Rd diff --git a/man/determine.Rd b/man/determine.Rd new file mode 100644 index 00000000..6d2b4fe9 --- /dev/null +++ b/man/determine.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/resolver.R +\name{determine} +\alias{determine} +\title{A method that should take a type and resolve it.} +\usage{ +determine(type, data, ...) +} +\arguments{ +\item{type}{The specification to resolve.} + +\item{data}{The minimal data required.} +} +\value{ +A list with two elements, the type resolved and the data extracted. +} +\description{ +Generic that makes the minimal check on spec. +Responsible of subsetting/extract the data received and check that the type matches +} +\keyword{internal} diff --git a/man/resolver.Rd b/man/resolver.Rd index dd7d1f1d..170a6c86 100644 --- a/man/resolver.Rd +++ b/man/resolver.Rd @@ -16,6 +16,7 @@ A transform but resolved } \description{ Given the specification of some data to extract find if they are available or not. +The specification for selecting a variable shouldn't depend on the data of said variable. } \examples{ dataset1 <- datasets(is.data.frame) diff --git a/tests/testthat/test-ops_transform.R b/tests/testthat/test-ops_transform.R index de9918a8..2a8fb0dc 100644 --- a/tests/testthat/test-ops_transform.R +++ b/tests/testthat/test-ops_transform.R @@ -89,11 +89,12 @@ test_that("datasets & variables & values create a single specification", { test_that("&(transform, number) errors", { expect_error(datasets("ABC2") & variables("ABC2") & values("abc") & 1) + expect_error(datasets("ABC2") & values("abc") & 1) }) test_that("| combines two transformers", { spec <- datasets("ABC") | datasets("abc") expect_length(spec, 2) - expect_error(spec[[1]]$datasets | spec[[1]]$datasets) + expect_true(is.null(names(spec))) }) diff --git a/tests/testthat/test-resolver.R b/tests/testthat/test-resolver.R index e89a5340..eb5e3b43 100644 --- a/tests/testthat/test-resolver.R +++ b/tests/testthat/test-resolver.R @@ -139,3 +139,28 @@ test_that("update_spec resolves correctly", { expect_no_error(update_spec(datasets(x = c("df", "df2"), "df"), "datasets", "df2")) }) + +test_that("OR resolver invalidates subsequent specifications", { + td <- within(teal_data(), { + df <- data.frame(A = 1:5, B = LETTERS[1:5]) + m <- cbind(A = 1:5, B = 5:10) + }) + var_a <- variables("A") + df_a <- datasets(is.data.frame) & var_a + matrix_a <- datasets(is.matrix) & var_a + df_or_m_var_a <- df_a | matrix_a + out <- resolver(df_or_m_var_a, td) +}) + +test_that("OR update_spec filters specifications", { + td <- within(teal_data(), { + df <- data.frame(A = 1:5, B = LETTERS[1:5]) + m <- cbind(A = 1:5, B = 5:10) + }) + var_a <- variables("A") + df_a <- datasets(is.data.frame) & var_a + matrix_a <- datasets(is.matrix) & var_a + df_or_m_var_a <- df_a | matrix_a + resolved <- resolver(df_or_m_var_a, td) + out <- update_spec(resolved, "datasets","df") +}) From c4c8e407283249b13ddd22ce2ab7c223545de589 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Tue, 25 Mar 2025 15:06:56 +0100 Subject: [PATCH 040/142] Add update_spec --- R/update_spec.R | 76 +++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 76 insertions(+) create mode 100644 R/update_spec.R diff --git a/R/update_spec.R b/R/update_spec.R new file mode 100644 index 00000000..2b6f4e28 --- /dev/null +++ b/R/update_spec.R @@ -0,0 +1,76 @@ +#' Update a specification +#' +#' Once a selection is made update the specification for different valid selection. +#' @param spec A resolved specification such as one created with datasets and variables. +#' @param type Which type was updated? One of datasets, variables, values. +#' @param value What is the new selection? One that is a valid value for the given type and specification. +#' @return The specification with restored choices and selection if caused by the update. +#' @export +#' @examples +#' td <- within(teal.data::teal_data(), { +#' df <- data.frame(A = as.factor(letters[1:5]), +#' Ab = LETTERS[1:5]) +#' df_n <- data.frame(C = 1:5, +#' Ab = as.factor(letters[1:5])) +#' }) +#' data_frames_factors <- datasets(is.data.frame) & variables(is.factor) +#' res <- resolver(data_frames_factors, td) +#' update_spec(res, "datasets", "df_n") +#' # update_spec(res, "datasets", "error") +update_spec <- function(spec, type, value) { + if (!is.character(value)) { + stop("The updated value is not a character.", + "\nDo you attempt to set a new specification? Please open an issue.") + } + + if (is.transform(spec) && is.null(names(spec))) { + updated_spec <- lapply(spec, update_s_spec, type, value) + class(updated_spec) <- class(spec) + updated_spec + } + if (is.transform(spec) && !is.null(names(spec))) { + updated_spec <- update_s_spec(spec, type, value) + } else if (is.type(spec)) { + updated_spec <- update_s_spec(spec, is(spec), value) + } else { + stop("Multiple or no specification is possible.") + } + updated_spec +} + +update_s_spec <- function(spec, type, value) { + spec_types <- names(spec) + type <- match.arg(type, spec_types) + restart_types <- spec_types[seq_along(spec_types) > which(type == spec_types)] + + valid_names <- spec[[type]]$names + + if (!is.list(valid_names) && all(value %in% valid_names)) { + original_select <- orig(spec[[type]]$select) + spec[[type]][["select"]] <- value + attr(spec[[type]][["select"]], "original") <- original_select + } else if (!is.list(valid_names) && !all(value %in% valid_names)) { + original_select <- orig(spec[[type]]$select) + valid_values <- intersect(value, valid_names) + if (!length(valid_values)) { + stop("No valid value provided.") + } + spec[[type]][["select"]] <- valid_values + attr(spec[[type]][["select"]], "original") <- original_select + } else { + stop("It seems the specification needs to be resolved first.") + } + + # Restore to the original specs + for (type_restart in restart_types) { + + if (is.na(spec[[type_restart]])) { + next + } + fun <- match.fun(type_restart) + restored_transform <- fun(x = orig(spec[[type_restart]]$names), + select = orig(spec[[type_restart]]$select)) + spec[[type_restart]] <- restored_transform + } + spec +} From 635ea9bc20bf30438e2d7319e178abafcc64a64f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Tue, 25 Mar 2025 17:11:11 +0100 Subject: [PATCH 041/142] Module for simple specifications --- R/module_input.R | 85 +++++++++++++++++++++++++++++++++++++++++++++++ R/ops_transform.R | 2 +- 2 files changed, 86 insertions(+), 1 deletion(-) create mode 100644 R/module_input.R diff --git a/R/module_input.R b/R/module_input.R new file mode 100644 index 00000000..45114f32 --- /dev/null +++ b/R/module_input.R @@ -0,0 +1,85 @@ + +helper_input <- function(id, + label, + multiple = FALSE) { + shiny::selectInput( + id, + label, + choices = NULL, + selected = NULL, + multiple = multiple) +} + +module_input_ui <- function(id, label, spec) { + ns <- NS(id) + input <- tagList( + a(label), + ) + l <- lapply(spec, function(x) { + helper_input(ns(is(x)), + paste("Select", is(x), collapse = " "), + multiple = is(x) != "datasets") + }) + input <- tagList(input, l) +} + +module_input_server <- function(id, spec, data) { + moduleServer(id, function(input, output, session) { + + react_updates <- reactive({ + if (!anyNA(spec) && is.delayed(spec)) { + spec <- teal.transform::resolver(spec, data()) + } + for (i in seq_along(input)) { + variable <- names(input)[i] + x <- input[[variable]] + spec_v <- spec[[variable]] + # a <- !is.null(x) && all(x %in% $names) + # browser(expr = !isFALSE(a) && !isTRUE(a)) + if (!is.null(x) && all(x %in% spec_v$names) && !x %in% spec_v$select) { + spec |> + update_spec(variable, input[[variable]]) |> + teal.transform::resolver(data()) + } + } + spec + }) + + observe({ + req(react_updates()) + spec <- react_updates() + for (i in seq_along(spec)) { + variable <- names(spec)[i] + + # Relies on order of arguments + if (is.delayed(spec[[variable]])) { + break + } + shiny::updateSelectInput( + session, + variable, + choices = unorig(spec[[variable]]$names), + selected = unorig(spec[[variable]]$select) + ) + # FIXME set on gray the input + # FIXME: Hide input field if any type on specification cannot be solved + } + }) + + + # Full selection #### + react_selection <- reactive({ + spec <- req(react_updates()) + req(!is.delayed(spec)) + selection <- vector("list", length(spec)) + names(selection) <- names(spec) + for (i in seq_along(spec)) { + variable <- names(spec)[i] + selection[[variable]] <- unorig(spec[[variable]]$select) + } + selection + }) + }) +} + + diff --git a/R/ops_transform.R b/R/ops_transform.R index 2c9c17d8..3f9df81c 100644 --- a/R/ops_transform.R +++ b/R/ops_transform.R @@ -93,7 +93,7 @@ nd_type <- function(e1, e2) { } else { stop("Maybe we should decide how to apply a type to a list of transformers...") } - class(out) <- c("transform", class(out)) + class(out) <- unique(c("transform", class(out))) out } From a30ec58094856cc429e47d1a254b3e33acf4958b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Wed, 26 Mar 2025 10:08:22 +0100 Subject: [PATCH 042/142] Update for multiple selections --- R/module_input.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/module_input.R b/R/module_input.R index 45114f32..4537c61e 100644 --- a/R/module_input.R +++ b/R/module_input.R @@ -36,8 +36,8 @@ module_input_server <- function(id, spec, data) { spec_v <- spec[[variable]] # a <- !is.null(x) && all(x %in% $names) # browser(expr = !isFALSE(a) && !isTRUE(a)) - if (!is.null(x) && all(x %in% spec_v$names) && !x %in% spec_v$select) { - spec |> + if (!is.null(x) && all(x %in% spec_v$names) && any(!x %in% spec_v$select)) { + spec <- spec |> update_spec(variable, input[[variable]]) |> teal.transform::resolver(data()) } From 3031edca5b5240f7e1226c730704e15eba67f5ee Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Wed, 26 Mar 2025 10:09:23 +0100 Subject: [PATCH 043/142] Make sure a list of transformators work --- NAMESPACE | 1 + R/delayed.R | 8 ++++++++ 2 files changed, 9 insertions(+) diff --git a/NAMESPACE b/NAMESPACE index e5e1254d..303a30a4 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -22,6 +22,7 @@ S3method(determine,variables) S3method(filter_spec_internal,default) S3method(filter_spec_internal,delayed_data) S3method(is.delayed,default) +S3method(is.delayed,list) S3method(is.delayed,transform) S3method(is.delayed,type) S3method(is.na,type) diff --git a/R/delayed.R b/R/delayed.R index d7416539..fb5f3ab9 100644 --- a/R/delayed.R +++ b/R/delayed.R @@ -14,9 +14,17 @@ is.delayed <- function(x) { #' @export #' @method is.delayed default is.delayed.default <- function(x) { + # FIXME: A warning? FALSE } +# Handling a list of transformers e1 | e2 +#' @export +#' @method is.delayed list +is.delayed.list <- function(x) { + any(vapply(x, is.delayed, logical(1L))) +} + #' @export #' @method is.delayed transform is.delayed.transform <- function(x) { From 81c3a9b84cf7b92ee7563a14a798aa5bb238e086 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Mon, 31 Mar 2025 16:33:04 +0200 Subject: [PATCH 044/142] Allow lists (should be of transforms) --- R/resolver.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/resolver.R b/R/resolver.R index ebd5e9a2..b390f4c3 100644 --- a/R/resolver.R +++ b/R/resolver.R @@ -38,7 +38,7 @@ resolver <- function(spec, data) { spec <- datasets(first) & spec } - stopifnot(is.transform(spec)) + stopifnot(is.list(spec) || is.transform(spec)) det <- determine(spec, data, spec = spec) det$type } @@ -53,7 +53,7 @@ resolver <- function(spec, data) { #' @keywords internal #' @export determine <- function(type, data, ...) { - stopifnot(is.type(type) || is.transform(type)) + stopifnot(is.type(type) || is.list(type) || is.transform(type)) if (!is.delayed(type)) { return(list(type = type, data = data)) } From d7a005bf2fb3bda96b247adf2a21b2e2a3f52b13 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Mon, 31 Mar 2025 16:33:58 +0200 Subject: [PATCH 045/142] Remove some comments --- R/module_input.R | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/R/module_input.R b/R/module_input.R index 4537c61e..e3225d00 100644 --- a/R/module_input.R +++ b/R/module_input.R @@ -34,8 +34,6 @@ module_input_server <- function(id, spec, data) { variable <- names(input)[i] x <- input[[variable]] spec_v <- spec[[variable]] - # a <- !is.null(x) && all(x %in% $names) - # browser(expr = !isFALSE(a) && !isTRUE(a)) if (!is.null(x) && all(x %in% spec_v$names) && any(!x %in% spec_v$select)) { spec <- spec |> update_spec(variable, input[[variable]]) |> @@ -61,7 +59,7 @@ module_input_server <- function(id, spec, data) { choices = unorig(spec[[variable]]$names), selected = unorig(spec[[variable]]$select) ) - # FIXME set on gray the input + # FIXME: set on gray the input # FIXME: Hide input field if any type on specification cannot be solved } }) From fa89e055f5f1354800850426759b99857ba0846f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Mon, 31 Mar 2025 16:34:37 +0200 Subject: [PATCH 046/142] Merging basic block --- R/merge_dataframes.R | 56 ++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 56 insertions(+) create mode 100644 R/merge_dataframes.R diff --git a/R/merge_dataframes.R b/R/merge_dataframes.R new file mode 100644 index 00000000..863aaeeb --- /dev/null +++ b/R/merge_dataframes.R @@ -0,0 +1,56 @@ + +# self_merge(df1, df2) almost equal to self_merge(df2, df1): Only changes on the column order. +self_merging <- function(e1, e2, ids, type) { + # Get the name of the variables to use as suffix. + # If we need the name at higher environments (ie: f(self_merging()) ) it could use rlang (probably) + name1 <- deparse(substitute(e1)) + name2 <- deparse(substitute(e2)) + suffix1 <- paste0(".", name1) + suffix2 <- paste0(".", name2) + ce1 <- colnames(e1) + ce2 <- colnames(e2) + type <- match.arg(type, c("inner", "left", "right", "full")) + + # Called by its side effects of adding the two variables the the current environment + switch(type, + inner = {all.x = FALSE; all.y = FALSE}, + full = {all.x = TRUE; all.y = TRUE}, + left = {all.x = TRUE; all.y = FALSE}, + right = {all.x = FALSE; all.y = TRUE}, + {all.x = FALSE; all.y = FALSE} + ) + + if (!is.null(names(ids))) { + name_ids <- names(ids) + } else { + name_ids <- ids + } + + if (!all(ids %in% name_ids) && !all(ids %in% ce2)) { + stop("Not all ids are in both objects") + } + # The default generic should find the right method, if not we : + # a) ask for the method to be implemented or + # b) implement it ourselves here to be used internally. + mm <- merge(e1, e2, + all.x = all.x, all.y = all.y, + by.x = name_ids, by.y = ids, + suffixes = c(suffix1, suffix2)) + g <- grep(paste0("\\.[", "(", name1, ")|(", name2, ")]"), + colnames(mm)) + if (length(g)) { + mix_columns <- setdiff(intersect(ce1, ce2), ids) + for (column in mix_columns) { + mc1 <- paste0(mix_columns, suffix1) + mc2 <- paste0(mix_columns, suffix2) + + # Rename column and delete one if they are the same + if (identical(mm[, mc1], mm[, mc2])) { + mm[, mc2] <- NULL + colnames(mm)[mc1 == colnames(mm)] <- column + } + } + } + mm + +} From 0142b780d16b5e90f1727c3b2a9ddfce3c7bbcec Mon Sep 17 00:00:00 2001 From: github-actions <41898282+github-actions[bot]@users.noreply.github.com> Date: Mon, 31 Mar 2025 14:56:11 +0000 Subject: [PATCH 047/142] [skip style] [skip vbump] Restyle files --- R/delayed.R | 5 +-- R/merge_dataframes.R | 40 +++++++++++++------ R/module_input.R | 14 +++---- R/ops_transform.R | 26 +++++++------ R/resolver.R | 30 +++++++------- R/types.R | 34 ++++++++++------ R/update_spec.R | 29 ++++++++------ tests/testthat/test-resolver.R | 71 +++++++++++++++++++++++----------- tests/testthat/test-types.R | 17 +++++--- 9 files changed, 168 insertions(+), 98 deletions(-) diff --git a/R/delayed.R b/R/delayed.R index fb5f3ab9..8569aa18 100644 --- a/R/delayed.R +++ b/R/delayed.R @@ -34,18 +34,17 @@ is.delayed.transform <- function(x) { #' @export #' @method is.delayed type is.delayed.type <- function(x) { - if (!is.na(x)) { return(!all(is.character(x$names)) || !all(is.character(x$select))) } FALSE } -resolved <- function(x, type = is(x)){ +resolved <- function(x, type = is(x)) { s <- all(is.character(x$names)) && all(is.character(x$select)) if (!s && !all(x$select %in% x$names)) { - stop("Selected ", type, " not resolved.") + stop("Selected ", type, " not resolved.") } attr(x, "delayed") <- NULL x diff --git a/R/merge_dataframes.R b/R/merge_dataframes.R index 863aaeeb..6b514ac9 100644 --- a/R/merge_dataframes.R +++ b/R/merge_dataframes.R @@ -1,4 +1,3 @@ - # self_merge(df1, df2) almost equal to self_merge(df2, df1): Only changes on the column order. self_merging <- function(e1, e2, ids, type) { # Get the name of the variables to use as suffix. @@ -13,11 +12,26 @@ self_merging <- function(e1, e2, ids, type) { # Called by its side effects of adding the two variables the the current environment switch(type, - inner = {all.x = FALSE; all.y = FALSE}, - full = {all.x = TRUE; all.y = TRUE}, - left = {all.x = TRUE; all.y = FALSE}, - right = {all.x = FALSE; all.y = TRUE}, - {all.x = FALSE; all.y = FALSE} + inner = { + all.x <- FALSE + all.y <- FALSE + }, + full = { + all.x <- TRUE + all.y <- TRUE + }, + left = { + all.x <- TRUE + all.y <- FALSE + }, + right = { + all.x <- FALSE + all.y <- TRUE + }, + { + all.x <- FALSE + all.y <- FALSE + } ) if (!is.null(names(ids))) { @@ -33,11 +47,14 @@ self_merging <- function(e1, e2, ids, type) { # a) ask for the method to be implemented or # b) implement it ourselves here to be used internally. mm <- merge(e1, e2, - all.x = all.x, all.y = all.y, - by.x = name_ids, by.y = ids, - suffixes = c(suffix1, suffix2)) - g <- grep(paste0("\\.[", "(", name1, ")|(", name2, ")]"), - colnames(mm)) + all.x = all.x, all.y = all.y, + by.x = name_ids, by.y = ids, + suffixes = c(suffix1, suffix2) + ) + g <- grep( + paste0("\\.[", "(", name1, ")|(", name2, ")]"), + colnames(mm) + ) if (length(g)) { mix_columns <- setdiff(intersect(ce1, ce2), ids) for (column in mix_columns) { @@ -52,5 +69,4 @@ self_merging <- function(e1, e2, ids, type) { } } mm - } diff --git a/R/module_input.R b/R/module_input.R index e3225d00..4d790422 100644 --- a/R/module_input.R +++ b/R/module_input.R @@ -1,4 +1,3 @@ - helper_input <- function(id, label, multiple = FALSE) { @@ -7,7 +6,8 @@ helper_input <- function(id, label, choices = NULL, selected = NULL, - multiple = multiple) + multiple = multiple + ) } module_input_ui <- function(id, label, spec) { @@ -17,15 +17,15 @@ module_input_ui <- function(id, label, spec) { ) l <- lapply(spec, function(x) { helper_input(ns(is(x)), - paste("Select", is(x), collapse = " "), - multiple = is(x) != "datasets") + paste("Select", is(x), collapse = " "), + multiple = is(x) != "datasets" + ) }) input <- tagList(input, l) } module_input_server <- function(id, spec, data) { moduleServer(id, function(input, output, session) { - react_updates <- reactive({ if (!anyNA(spec) && is.delayed(spec)) { spec <- teal.transform::resolver(spec, data()) @@ -34,7 +34,7 @@ module_input_server <- function(id, spec, data) { variable <- names(input)[i] x <- input[[variable]] spec_v <- spec[[variable]] - if (!is.null(x) && all(x %in% spec_v$names) && any(!x %in% spec_v$select)) { + if (!is.null(x) && all(x %in% spec_v$names) && any(!x %in% spec_v$select)) { spec <- spec |> update_spec(variable, input[[variable]]) |> teal.transform::resolver(data()) @@ -79,5 +79,3 @@ module_input_server <- function(id, spec, data) { }) }) } - - diff --git a/R/ops_transform.R b/R/ops_transform.R index 3f9df81c..4eb62408 100644 --- a/R/ops_transform.R +++ b/R/ops_transform.R @@ -2,16 +2,17 @@ Ops.transform <- function(e1, e2) { if (missing(e2)) { # out <- switch(.Generic, - # "!" = Negate, + # "!" = Negate, stop("Method ", sQuote(.Generic), " not implemented for this class ", .Class, ".", call. = FALSE) # return(out) } switch(.Generic, - "!=" = NextMethod(), - "==" = NextMethod(), - "|" = or_transform(e1, e2), - "&" = nd_transform(e1, e2), - stop("Method ", sQuote(.Generic), " not implemented for this class ", .Class, ".", call. = FALSE)) + "!=" = NextMethod(), + "==" = NextMethod(), + "|" = or_transform(e1, e2), + "&" = nd_transform(e1, e2), + stop("Method ", sQuote(.Generic), " not implemented for this class ", .Class, ".", call. = FALSE) + ) } #' @export @@ -23,11 +24,12 @@ Ops.type <- function(e1, e2) { # return(out) } out <- switch(.Generic, - "!=" = NextMethod(), - # "==" = NextMethod(), - "|" = or_type(e1, e2), - "&" = nd_type(e1, e2), - stop("Method ", sQuote(.Generic), " not implemented for this class ", .Class, ".", call. = FALSE)) + "!=" = NextMethod(), + # "==" = NextMethod(), + "|" = or_type(e1, e2), + "&" = nd_type(e1, e2), + stop("Method ", sQuote(.Generic), " not implemented for this class ", .Class, ".", call. = FALSE) + ) out } @@ -86,7 +88,7 @@ nd_type <- function(e1, e2) { } else if (!is.transform(e1) && is.transform(e2)) { out <- c(e2, list(e1)) names(out)[length(out)] <- is(e1) - } else if (is.transform(e1) && is.transform(e2)){ + } else if (is.transform(e1) && is.transform(e2)) { out <- c(e1, e2) } else if (is.type(e1) && is.type(e2)) { out <- c(e1, e2) diff --git a/R/resolver.R b/R/resolver.R index b390f4c3..95742e4d 100644 --- a/R/resolver.R +++ b/R/resolver.R @@ -104,8 +104,7 @@ functions_names <- function(unresolved, reference) { x <- vector("character") for (f in fc_unresolved) { - - y <- tryCatch(f(reference), error = function(x) f ) + y <- tryCatch(f(reference), error = function(x) f) if (!is.logical(y)) { stop("Provided functions should return a logical object.") } @@ -118,7 +117,9 @@ functions_data <- function(unresolved, data, names) { stopifnot(!is.null(data)) # Must be something but not NULL fc_unresolved <- unresolved[vapply(unresolved, is.function, logical(1L))] l <- lapply(fc_unresolved, function(f) { - all_data <- tryCatch(f(data), error = function(x){FALSE}) + all_data <- tryCatch(f(data), error = function(x) { + FALSE + }) if (any(all_data)) { return(names[all_data]) } else { @@ -133,7 +134,11 @@ functions_data <- function(unresolved, data, names) { determine_helper <- function(type, data_names, data) { orig_names <- type$names orig_select <- type$select - names_variables_obj <- if (is.null(names(data))) { colnames(data)} else {names(data)} + names_variables_obj <- if (is.null(names(data))) { + colnames(data) + } else { + names(data) + } if (is.delayed(type) && all(is.character(type$names))) { match <- intersect(data_names, type$names) missing <- setdiff(type$names, data_names) @@ -158,8 +163,10 @@ determine_helper <- function(type, data_names, data) { } } else if (is.delayed(type)) { old_names <- type$names - new_names <- c(functions_names(type$names, names_variables_obj), - functions_data(type$names, data, data_names)) + new_names <- c( + functions_names(type$names, names_variables_obj), + functions_data(type$names, data, data_names) + ) new_names <- unique(new_names[!is.na(new_names)]) if (!length(new_names)) { return(NULL) @@ -195,7 +202,7 @@ determine.datasets <- function(type, data, ...) { } l <- vector("list", length(data)) - for (i in seq_along(data)){ + for (i in seq_along(data)) { data_name_env <- names(data)[i] out <- determine_helper(type, data_name_env, data[[data_name_env]]) if (!is.null(out)) { @@ -229,7 +236,7 @@ determine.variables <- function(type, data, ...) { # Assumes the object has colnames method (true for major object classes: DataFrame, tibble, Matrix, array) # FIXME: What happens if colnames is null: array(dim = c(4, 2)) |> colnames() l <- vector("list", ncol(data)) - for (i in seq_len(ncol(data))){ + for (i in seq_len(ncol(data))) { out <- determine_helper(type, colnames(data)[i], data[, i]) if (!is.null(out)) { l[[i]] <- out @@ -255,7 +262,7 @@ determine.mae_colData <- function(type, data, ...) { } new_data <- colData(data) - for (i in seq_along(new_data)){ + for (i in seq_along(new_data)) { determine_helper(type, colnames(data)[i], new_data[, i]) } if (length(dim(new_data)) != 2L) { @@ -273,7 +280,6 @@ determine.mae_colData <- function(type, data, ...) { if (length(type$select) > 1) { list(type = type, data = data[type$select]) - } else { list(type = type, data = data[[type$select]]) } @@ -293,12 +299,11 @@ determine.mae_experiments <- function(type, data, ...) { if (!is.delayed(type) && length(type$select) > 1) { list(type = type, data = new_data[type$select]) - } else if (!is.delayed(type) && length(type$select) == 1) { list(type = type, data = new_data[[type$select]]) } else { return(list(type = type, data = NULL)) - } + } } #' @export @@ -317,7 +322,6 @@ determine.mae_sampleMap <- function(type, data, ...) { if (length(type$select) > 1) { list(type = type, data = data[type$select]) - } else { list(type = type, data = data[[type$select]]) } diff --git a/R/types.R b/R/types.R index 82697a33..6b8da509 100644 --- a/R/types.R +++ b/R/types.R @@ -23,7 +23,7 @@ anyNA.type <- function(x, recursive = FALSE) { anyNA(unclass(x[c("names", "select")]), recursive) } -first <- function(x){ +first <- function(x) { if (length(x) > 0) { false <- rep(FALSE, length.out = length(x)) false[1] <- TRUE @@ -34,12 +34,16 @@ first <- function(x){ check_input <- function(input) { is.character(input) || is.function(input) || - (is.list(input) && all(vapply(input, function(x){is.function(x) || is.character(x)}, logical(1L)))) + (is.list(input) && all(vapply(input, function(x) { + is.function(x) || is.character(x) + }, logical(1L)))) } type_helper <- function(x, select, type) { - stopifnot("Invalid options" = check_input(x), - "Invalid selection" = check_input(type)) + stopifnot( + "Invalid options" = check_input(x), + "Invalid selection" = check_input(type) + ) if (is.function(x)) { x <- list(x) } @@ -156,7 +160,8 @@ c.transform <- function(...) { old_select <- new_type$select new_type$names <- c(old_names, l[[i]][[t]][["names"]]) attr(new_type$names, "original") <- c(orig( - old_names), orig(l[[i]][[t]][["names"]])) + old_names + ), orig(l[[i]][[t]][["names"]])) new_type$select <- c(old_select, l[[i]][[t]][["select"]]) attr(new_type$select, "original") <- c(orig(old_select), orig(l[[i]][[t]][["select"]])) } @@ -197,7 +202,8 @@ c.type <- function(...) { old_select <- new_type$select new_type$names <- c(old_names, l[[i]][["names"]]) attr(new_type$names, "original") <- c(orig( - old_names), orig(l[[i]][["names"]])) + old_names + ), orig(l[[i]][["names"]])) new_type$select <- unique(c(old_select, l[[i]][["select"]])) attr(new_type$select, "original") <- c(orig(old_select), orig(l[[i]][["select"]])) } @@ -246,11 +252,14 @@ print.type <- function(x, ...) { nam_values <- length(x$names) - sum(nam_functions) if (any(nam_functions)) { msg_values <- paste0(msg_values, sum(nam_functions), " functions for possible choices.", - collapse = "\n") + collapse = "\n" + ) } if (nam_values) { msg_values <- paste0(msg_values, paste0(sQuote(x$names[!nam_functions]), collapse = ", "), - " as possible choices.", collapse = "\n") + " as possible choices.", + collapse = "\n" + ) } sel_list <- is.list(x$select) @@ -264,12 +273,15 @@ print.type <- function(x, ...) { sel_values <- length(x$select) - sum(sel_functions) if (any(sel_functions)) { msg_sel <- paste0(msg_sel, sum(sel_functions), " functions to select.", - collapse = "\n") + collapse = "\n" + ) } if (sel_values) { msg_sel <- paste0(msg_sel, paste0(sQuote(x$select[!sel_functions]), collapse = ", "), - " selected.", collapse = "\n") + " selected.", + collapse = "\n" + ) } - cat(msg_values, msg_sel) + cat(msg_values, msg_sel) return(x) } diff --git a/R/update_spec.R b/R/update_spec.R index 2b6f4e28..24083a8b 100644 --- a/R/update_spec.R +++ b/R/update_spec.R @@ -8,10 +8,14 @@ #' @export #' @examples #' td <- within(teal.data::teal_data(), { -#' df <- data.frame(A = as.factor(letters[1:5]), -#' Ab = LETTERS[1:5]) -#' df_n <- data.frame(C = 1:5, -#' Ab = as.factor(letters[1:5])) +#' df <- data.frame( +#' A = as.factor(letters[1:5]), +#' Ab = LETTERS[1:5] +#' ) +#' df_n <- data.frame( +#' C = 1:5, +#' Ab = as.factor(letters[1:5]) +#' ) #' }) #' data_frames_factors <- datasets(is.data.frame) & variables(is.factor) #' res <- resolver(data_frames_factors, td) @@ -19,8 +23,10 @@ #' # update_spec(res, "datasets", "error") update_spec <- function(spec, type, value) { if (!is.character(value)) { - stop("The updated value is not a character.", - "\nDo you attempt to set a new specification? Please open an issue.") + stop( + "The updated value is not a character.", + "\nDo you attempt to set a new specification? Please open an issue." + ) } if (is.transform(spec) && is.null(names(spec))) { @@ -30,10 +36,10 @@ update_spec <- function(spec, type, value) { } if (is.transform(spec) && !is.null(names(spec))) { updated_spec <- update_s_spec(spec, type, value) - } else if (is.type(spec)) { + } else if (is.type(spec)) { updated_spec <- update_s_spec(spec, is(spec), value) } else { - stop("Multiple or no specification is possible.") + stop("Multiple or no specification is possible.") } updated_spec } @@ -63,13 +69,14 @@ update_s_spec <- function(spec, type, value) { # Restore to the original specs for (type_restart in restart_types) { - if (is.na(spec[[type_restart]])) { next } fun <- match.fun(type_restart) - restored_transform <- fun(x = orig(spec[[type_restart]]$names), - select = orig(spec[[type_restart]]$select)) + restored_transform <- fun( + x = orig(spec[[type_restart]]$names), + select = orig(spec[[type_restart]]$select) + ) spec[[type_restart]] <- restored_transform } spec diff --git a/tests/testthat/test-resolver.R b/tests/testthat/test-resolver.R index eb5e3b43..b00b722d 100644 --- a/tests/testthat/test-resolver.R +++ b/tests/testthat/test-resolver.R @@ -1,4 +1,6 @@ -f <- function(x){head(x, 1)} +f <- function(x) { + head(x, 1) +} test_that("resolver datasets works", { df_head <- datasets("df", f) @@ -7,7 +9,7 @@ test_that("resolver datasets works", { df_mean <- datasets("df", mean) median_mean <- datasets(median, mean) td <- within(teal.data::teal_data(), { - df <- data.frame(a = LETTERS[1:5], b = factor(letters[1:5]), c = factor(letters[1:5])) + df <- data.frame(a = LETTERS[1:5], b = factor(letters[1:5]), c = factor(letters[1:5])) m <- cbind(b = 1:5, c = 10:14) m2 <- cbind(a = LETTERS[1:2], b = LETTERS[4:5]) }) @@ -25,10 +27,14 @@ test_that("resolver variables works", { data_frames <- datasets(is.data.frame) var_a <- variables("a") factors <- variables(is.factor) - factors_head <- variables(is.factor, function(x){head(x, 1)}) - var_matrices_head <- variables(is.matrix, function(x){head(x, 1)}) + factors_head <- variables(is.factor, function(x) { + head(x, 1) + }) + var_matrices_head <- variables(is.matrix, function(x) { + head(x, 1) + }) td <- within(teal.data::teal_data(), { - df <- data.frame(a = LETTERS[1:5], b = factor(letters[1:5]), c = factor(letters[1:5])) + df <- data.frame(a = LETTERS[1:5], b = factor(letters[1:5]), c = factor(letters[1:5])) m <- cbind(b = 1:5, c = 10:14) m2 <- cbind(a = LETTERS[1:2], b = LETTERS[4:5]) }) @@ -56,11 +62,15 @@ test_that("resolver values works", { data_frames <- datasets(is.data.frame) var_a <- variables("a") factors <- variables(is.factor) - factors_head <- variables(is.factor, function(x){head(x, 1)}) - var_matrices_head <- variables(is.matrix, function(x){head(x, 1)}) + factors_head <- variables(is.factor, function(x) { + head(x, 1) + }) + var_matrices_head <- variables(is.matrix, function(x) { + head(x, 1) + }) val_A <- values("A") td <- within(teal.data::teal_data(), { - df <- data.frame(a = LETTERS[1:5], b = factor(letters[1:5]), c = factor(letters[1:5])) + df <- data.frame(a = LETTERS[1:5], b = factor(letters[1:5]), c = factor(letters[1:5])) m <- cbind(b = 1:5, c = 10:14) m2 <- cbind(a = LETTERS[1:2], b = LETTERS[4:5]) }) @@ -69,39 +79,54 @@ test_that("resolver values works", { test_that("names and variables are reported", { td <- within(teal.data::teal_data(), { - df <- data.frame(A = as.factor(letters[1:5]), - Ab = LETTERS[1:5], - Abc = c(LETTERS[1:4], letters[1])) - df2 <- data.frame(A = 1:5, - B = 1:5) + df <- data.frame( + A = as.factor(letters[1:5]), + Ab = LETTERS[1:5], + Abc = c(LETTERS[1:4], letters[1]) + ) + df2 <- data.frame( + A = 1:5, + B = 1:5 + ) m <- matrix() }) d_df <- datasets("df") - df_upper_variables <- d_df & variables(function(x){x==toupper(x)}) + df_upper_variables <- d_df & variables(function(x) { + x == toupper(x) + }) out <- resolver(df_upper_variables, td) # This should select A and Ab: # A because the name is all capital letters and # Ab values is all upper case. expect_length(out$variables$names, 2) - v_all_upper <- variables(function(x){all(x==toupper(x))}) + v_all_upper <- variables(function(x) { + all(x == toupper(x)) + }) df_all_upper_variables <- d_df & v_all_upper expect_no_error(out <- resolver(df_all_upper_variables, td)) expect_length(out$variables$names, 1) expect_no_error(out <- resolver(datasets("df2") & v_all_upper, td)) expect_length(out$variables$names, 2) - expect_no_error(out <- resolver(datasets(function(x){is.data.frame(x) && all(colnames(x) == toupper(colnames(x)))}), td)) + expect_no_error(out <- resolver(datasets(function(x) { + is.data.frame(x) && all(colnames(x) == toupper(colnames(x))) + }), td)) expect_length(out$datasets$names, 1) - expect_no_error(out <- resolver(datasets(is.data.frame) & datasets(function(x){colnames(x) == toupper(colnames(x))}), td)) + expect_no_error(out <- resolver(datasets(is.data.frame) & datasets(function(x) { + colnames(x) == toupper(colnames(x)) + }), td)) expect_length(out$datasets$names, 2) - }) test_that("update_spec resolves correctly", { td <- within(teal.data::teal_data(), { - df <- data.frame(A = as.factor(letters[1:5]), - Ab = LETTERS[1:5]) - df_n <- data.frame(C = 1:5, - Ab = as.factor(letters[1:5])) + df <- data.frame( + A = as.factor(letters[1:5]), + Ab = LETTERS[1:5] + ) + df_n <- data.frame( + C = 1:5, + Ab = as.factor(letters[1:5]) + ) }) data_frames_factors <- datasets(is.data.frame) & variables(is.factor) expect_false(is.null(attr(data_frames_factors$datasets$names, "original"))) @@ -162,5 +187,5 @@ test_that("OR update_spec filters specifications", { matrix_a <- datasets(is.matrix) & var_a df_or_m_var_a <- df_a | matrix_a resolved <- resolver(df_or_m_var_a, td) - out <- update_spec(resolved, "datasets","df") + out <- update_spec(resolved, "datasets", "df") }) diff --git a/tests/testthat/test-types.R b/tests/testthat/test-types.R index 2b1ae404..7c3dbdc8 100644 --- a/tests/testthat/test-types.R +++ b/tests/testthat/test-types.R @@ -1,5 +1,4 @@ test_that("datasets", { - expect_no_error(dataset0 <- datasets("df", "df")) out <- list(names = "df", select = "df") class(out) <- c("delayed", "datasets", "type", "list") @@ -16,8 +15,12 @@ test_that("variables", { expect_no_error(var1 <- variables("a")) expect_no_error(var2 <- variables(is.factor)) # Allowed to specify whatever we like, it is not until resolution that this raises errors - expect_no_error(var3 <- variables(is.factor, function(x){head(x, 1)})) - expect_no_error(var4 <- variables(is.matrix, function(x){head(x, 1)})) + expect_no_error(var3 <- variables(is.factor, function(x) { + head(x, 1) + })) + expect_no_error(var4 <- variables(is.matrix, function(x) { + head(x, 1) + })) }) test_that("raw combine of types", { @@ -31,6 +34,10 @@ test_that("values", { expect_no_error(val1 <- values("a")) expect_no_error(val2 <- values(is.factor)) # Allowed to specify whatever we like, it is not until resolution that this raises errors - expect_no_error(val3 <- values(is.factor, function(x){head(x, 1)})) - expect_no_error(val4 <- values(is.matrix, function(x){head(x, 1)})) + expect_no_error(val3 <- values(is.factor, function(x) { + head(x, 1) + })) + expect_no_error(val4 <- values(is.matrix, function(x) { + head(x, 1) + })) }) From 521fd09460dc4eb57f21bd5b022cee59f311804a Mon Sep 17 00:00:00 2001 From: github-actions <41898282+github-actions[bot]@users.noreply.github.com> Date: Mon, 31 Mar 2025 14:59:26 +0000 Subject: [PATCH 048/142] [skip roxygen] [skip vbump] Roxygen Man Pages Auto Update --- man/update_spec.Rd | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/man/update_spec.Rd b/man/update_spec.Rd index 3e10ddf8..708e0909 100644 --- a/man/update_spec.Rd +++ b/man/update_spec.Rd @@ -21,10 +21,14 @@ Once a selection is made update the specification for different valid selection. } \examples{ td <- within(teal.data::teal_data(), { - df <- data.frame(A = as.factor(letters[1:5]), - Ab = LETTERS[1:5]) - df_n <- data.frame(C = 1:5, - Ab = as.factor(letters[1:5])) + df <- data.frame( + A = as.factor(letters[1:5]), + Ab = LETTERS[1:5] + ) + df_n <- data.frame( + C = 1:5, + Ab = as.factor(letters[1:5]) + ) }) data_frames_factors <- datasets(is.data.frame) & variables(is.factor) res <- resolver(data_frames_factors, td) From 54058d3eb678f2c782ba67f5dbf6f5bcc163c969 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Wed, 2 Apr 2025 16:19:40 +0200 Subject: [PATCH 049/142] Rename to make it easier to read --- R/resolver.R | 92 ++++++++++++++++++++++++++++++++-------------------- 1 file changed, 56 insertions(+), 36 deletions(-) diff --git a/R/resolver.R b/R/resolver.R index b390f4c3..24853766 100644 --- a/R/resolver.R +++ b/R/resolver.R @@ -3,7 +3,6 @@ #' Given the specification of some data to extract find if they are available or not. #' The specification for selecting a variable shouldn't depend on the data of said variable. #' @param spec A object extraction specification. -#' @param data A `qenv()`, or `teal.data::teal_data()` object. #' #' @returns A transform but resolved #' @export @@ -29,6 +28,7 @@ resolver <- function(spec, data) { if (!is.delayed(spec)) { return(spec) } + # Adding some default specifications if they are missing if ("values" %in% names(spec) && !"variables" %in% names(spec)) { spec <- variables(first) & spec @@ -54,8 +54,10 @@ resolver <- function(spec, data) { #' @export determine <- function(type, data, ...) { stopifnot(is.type(type) || is.list(type) || is.transform(type)) - if (!is.delayed(type)) { - return(list(type = type, data = data)) + if (!is.delayed(type) && length(type$select) > 1L) { + return(list(type = type, data = data[unorig(type$select)])) + } else if (!is.delayed(type) && length(type$select) == 1L) { + return(list(type = type, data = data[[unorig(type$select)]])) } UseMethod("determine") } @@ -65,7 +67,7 @@ determine.default <- function(type, data, ..., spec) { if (!is.null(names(spec)) && is.delayed(spec)) { rt <- determine(spec, data) } else { - rt <- lapply(spec, resolver, data = data, spec = spec) + rt <- lapply(spec, resolver, data = data) if (length(rt) == 1) { return(rt[[1]]) } @@ -82,55 +84,63 @@ determine.transform <- function(type, data, ..., spec) { return(specs) } + d <- data for (i in seq_along(type)) { - di <- determine(type[[i]], data, spec = spec) - # orverwrite so that next type in line receives the corresponding data and specification + di <- determine(type[[i]], d, spec = spec) + # overwrite so that next type in line receives the corresponding data and specification if (is.null(di$type)) { next } type[[i]] <- di$type - data <- di$data + d <- di$data } list(type = type, data = data) # It is the transform object resolved. } -functions_names <- function(unresolved, reference) { - stopifnot(is.character(reference) || is.factor(reference) || is.null(reference)) # Allows for NA characters - if (is.null(reference)) { +functions_names <- function(spec_criteria, names) { + stopifnot(is.character(names) || is.factor(names) || is.null(names)) # Allows for NA characters + if (is.null(names)) { return(NULL) } - is_fc <- vapply(unresolved, is.function, logical(1L)) - fc_unresolved <- unresolved[is_fc] - x <- vector("character") - - for (f in fc_unresolved) { + is_fc <- vapply(spec_criteria, is.function, logical(1L)) + functions <- spec_criteria[is_fc] + new_names <- vector("character") - y <- tryCatch(f(reference), error = function(x) f ) - if (!is.logical(y)) { + for (fun in functions) { + names_ok <- tryCatch(fun(names), error = function(new_names) FALSE ) + if (!is.logical(names_ok)) { stop("Provided functions should return a logical object.") } - x <- c(x, reference[y[!is.na(y)]]) + if (any(names_ok)) { + new_names <- c(new_names, names[names_ok]) + } } - unique(unlist(c(unresolved[!is_fc], x), FALSE, FALSE)) + old_names <- unique(unlist(spec_criteria[!is_fc], FALSE, FALSE)) + c(new_names, old_names) } -functions_data <- function(unresolved, data, names) { +# Extract data and evaluate if the function +functions_data <- function(spec_criteria, data, names_data) { stopifnot(!is.null(data)) # Must be something but not NULL - fc_unresolved <- unresolved[vapply(unresolved, is.function, logical(1L))] - l <- lapply(fc_unresolved, function(f) { - all_data <- tryCatch(f(data), error = function(x){FALSE}) - if (any(all_data)) { - return(names[all_data]) + is_fc <- vapply(spec_criteria, is.function, logical(1L)) + functions <- spec_criteria[is_fc] + + l <- lapply(functions, function(fun) { + data_ok <- tryCatch(fun(data), error = function(x){FALSE}) + if (any(data_ok)) { + return(names_data[data_ok]) } else { return(NULL) } }) - unique(unlist(l, FALSE, FALSE)) + new_names <- unique(unlist(l, FALSE, FALSE)) + c(new_names, spec_criteria[!is_fc]) } # Checks that for the given type and data names and data it can be resolved # The workhorse of the resolver determine_helper <- function(type, data_names, data) { + stopifnot(!is.null(type)) orig_names <- type$names orig_select <- type$select names_variables_obj <- if (is.null(names(data))) { colnames(data)} else {names(data)} @@ -160,7 +170,7 @@ determine_helper <- function(type, data_names, data) { old_names <- type$names new_names <- c(functions_names(type$names, names_variables_obj), functions_data(type$names, data, data_names)) - new_names <- unique(new_names[!is.na(new_names)]) + new_names <- unlist(unique(new_names[!is.na(new_names)]), use.names = FALSE) if (!length(new_names)) { return(NULL) # stop("No ", is(type), " meet the requirements") @@ -194,23 +204,33 @@ determine.datasets <- function(type, data, ...) { stop("Please use qenv() or teal_data() objects.") } - l <- vector("list", length(data)) - for (i in seq_along(data)){ + l <- vector("list", length(names(data))) + # Somehow in some cases (I didn't explore much this was TRUE) + for (i in seq_along(l)){ data_name_env <- names(data)[i] - out <- determine_helper(type, data_name_env, data[[data_name_env]]) + out <- determine_helper(type, data_name_env, extract(data, data_name_env)) if (!is.null(out)) { l[[i]] <- out } } # Merge together all the types - type <- do.call(c, l[lengths(l) > 1]) + type <- do.call(c, l[lengths(l) > 1L]) + # FIXME: This combine the different selections too. + # Instead it should apply once the select function and keep that instead. + # helper_something(type$select, type$names, data) # Not possible to know what is happening - - if (!is.delayed(type) && length(type$select) > 1) { - list(type = type, data = data[type$select]) - } else if (!is.delayed(type) && length(type$select) == 1) { - list(type = type, data = data[[type$select]]) + for (name in type$names){ + data_name_env <- names(data)[i] + out <- determine_helper(type, data_name_env, extract(data, data_name_env)) + if (!is.null(out)) { + l[[i]] <- out + } + } + if (!is.delayed(type) && length(type$select) > 1L) { + list(type = type, data = data[unorig(type$select)]) + } else if (!is.delayed(type) && length(type$select) == 1L) { + list(type = type, data = data[[unorig(type$select)]]) } else { list(type = type, data = NULL) } From 957e59d3a7706455e1a7426a496cd5bd73594067 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Wed, 2 Apr 2025 16:20:12 +0200 Subject: [PATCH 050/142] Minor tweaks --- R/types.R | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/R/types.R b/R/types.R index 82697a33..7f3d8884 100644 --- a/R/types.R +++ b/R/types.R @@ -25,7 +25,7 @@ anyNA.type <- function(x, recursive = FALSE) { first <- function(x){ if (length(x) > 0) { - false <- rep(FALSE, length.out = length(x)) + false <- rep_len(FALSE, length.out = length(x)) false[1] <- TRUE return(false) } @@ -207,11 +207,10 @@ c.type <- function(...) { attr(new_type$names, "original") <- orig_names # From the possible names apply the original function - if (any(vapply(l, is.delayed, logical(1L)))) { - new_type$select <- orig_select - } else { + if (is.delayed(new_type)) { new_type$select <- functions_names(orig(new_type$select), new_type$names) } + attr(new_type$select, "original") <- orig_select class(new_type) <- c(t, "type", "list") From b440e3fc9c5bada7d894b35452bdb89f1afd1639 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Wed, 2 Apr 2025 16:21:12 +0200 Subject: [PATCH 051/142] Merging for multiple data.frames --- R/merge_dataframes.R | 53 ++++++++++++++++++++++++++++++++++++++------ 1 file changed, 46 insertions(+), 7 deletions(-) diff --git a/R/merge_dataframes.R b/R/merge_dataframes.R index 863aaeeb..1499d118 100644 --- a/R/merge_dataframes.R +++ b/R/merge_dataframes.R @@ -1,3 +1,40 @@ +# Allows merging arbitrary number of data.frames by ids and type +merging <- function(..., ids, type) { + number_merges <- ...length() - 1L + stopifnot( + "Number of datasets is enough" = number_merges >= 1L, + "Number of arguments for ids matches data" = (length(ids) == number_merges && is.list(ids)) || length(ids) == 1L && is.character(ids), + "Number of arguments for type matches data" = length(type) == number_merges || length(type) == 1L) + list_df <- list(...) + + if (length(type) == 1L) { + type <- rep(type, number_merges) + } + if (length(ids) == 1L) { + ids <- rep(ids, number_merges) + } + + if (number_merges == 1L) { + return(self_merging(..1, ..2, ids = ids, type = type)) + } + + # l <- list("a", "b", "c", "d") + # number_merges <- length(l) - 1L + m <- list() + for (merge_i in seq_len(number_merges)) { + message(merge_i) + if (merge_i == 1L) { + out <- self_merging(list_df[[merge_i]], list_df[[merge_i + 1L]], + ids[[merge_i]], type = type[[merge_i]]) + } else { + out <- self_merging(out, list_df[[merge_i + 1L]], + ids[[merge_i]], type = type[[merge_i]]) + } + } + out +} + + # self_merge(df1, df2) almost equal to self_merge(df2, df1): Only changes on the column order. self_merging <- function(e1, e2, ids, type) { @@ -35,19 +72,21 @@ self_merging <- function(e1, e2, ids, type) { mm <- merge(e1, e2, all.x = all.x, all.y = all.y, by.x = name_ids, by.y = ids, - suffixes = c(suffix1, suffix2)) - g <- grep(paste0("\\.[", "(", name1, ")|(", name2, ")]"), - colnames(mm)) + suffixes = c(".e1", ".e2")) + g <- grep("\\.[(e1)(e2)]", colnames(mm)) if (length(g)) { mix_columns <- setdiff(intersect(ce1, ce2), ids) for (column in mix_columns) { - mc1 <- paste0(mix_columns, suffix1) - mc2 <- paste0(mix_columns, suffix2) - + mc1 <- paste0(column, ".e1") + mc2 <- paste0(column, ".e2") # Rename column and delete one if they are the same if (identical(mm[, mc1], mm[, mc2])) { mm[, mc2] <- NULL - colnames(mm)[mc1 == colnames(mm)] <- column + colnames(mm)[colnames(mm) %in% mc1] <- column + } else { + # Rename to keep the suffic of the data names + colnames(mm)[colnames(mm) %in% mc1] <- paste0(column, suffix1) + colnames(mm)[colnames(mm) %in% mc2] <- paste0(column, suffix2) } } } From 516c434b257219d028f4f977d3dbdb5d5bd4ec71 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Wed, 2 Apr 2025 16:21:36 +0200 Subject: [PATCH 052/142] Add back the extract methods --- NAMESPACE | 2 ++ 1 file changed, 2 insertions(+) diff --git a/NAMESPACE b/NAMESPACE index 303a30a4..cb2b8038 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -19,6 +19,7 @@ S3method(determine,mae_sampleMap) S3method(determine,transform) S3method(determine,values) S3method(determine,variables) +S3method(extract,default) S3method(filter_spec_internal,default) S3method(filter_spec_internal,delayed_data) S3method(is.delayed,default) @@ -67,6 +68,7 @@ export(data_extract_ui) export(datanames_input) export(datasets) export(determine) +export(extract) export(filter_spec) export(first_choice) export(first_choices) From e82f500dff6d6dbcf8a4c4166723b191d5803ba3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Wed, 2 Apr 2025 16:23:02 +0200 Subject: [PATCH 053/142] Add Method and the default (to be able to expand) TODO: Remove comments to activate some --- R/extract.R | 53 +++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 53 insertions(+) create mode 100644 R/extract.R diff --git a/R/extract.R b/R/extract.R new file mode 100644 index 00000000..617000ca --- /dev/null +++ b/R/extract.R @@ -0,0 +1,53 @@ +#' Internal method to extract data from different objects +#' +#' Required to resolve a specification into something usable (by comparing with the existing data). +#' Required by merging data based on a resolved specification. +#' @export +#' @noRd +#' @keywords internal +extract <- function(x, variable, ...) { + UseMethod("extract") +} + +# Cases handled by the default method +# @export +# extract.MultiAssayExperiment <- function(x, variable) { +# # if (!requireNamespace("MultiAssayExperiment", quietly = TRUE)) { +# # stop("Required to have MultiAssayExperiment's package.") +# # } +# x[, variable, drop = TRUE] +# } +# +# @export +# extract.DataFrame <- function(x, variable) { +# # if (!requireNamespace("S4Vectors", quietly = TRUE)) { +# # stop("Required to have S4Vectors's package.") +# # } +# x[, variable, drop = TRUE] +# } +# +# @export +# extract.matrix <- function(x, variable) { +# x[, variable, drop = TRUE] +# } + +#' @export +extract.default <- function(x, variable) { + if (length(dim(x)) == 2L) { + x[, variable, drop = TRUE] + } else { + x[[variable]] + } +} + +# @export +# @method extract data.frame +# extract.data.frame <- function(x, variable) { +# # length(variable) == 1L +# x[, variable, drop = TRUE] +# } + +# @export +# extract.qenv <- function(x, variable) { +# x[[variable]] +# } From d4d826ebde2ba865061f1d18a7dc3aef6bd44a4f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Fri, 4 Apr 2025 16:53:05 +0200 Subject: [PATCH 054/142] Extract multiple columns --- R/extract.R | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/R/extract.R b/R/extract.R index 617000ca..1624c01b 100644 --- a/R/extract.R +++ b/R/extract.R @@ -32,9 +32,9 @@ extract <- function(x, variable, ...) { # } #' @export -extract.default <- function(x, variable) { - if (length(dim(x)) == 2L) { - x[, variable, drop = TRUE] +extract.default <- function(x, variable, drop = TRUE) { + if (length(dim(x)) == 2L || length(variable) > 1L) { + x[, variable, drop = drop] } else { x[[variable]] } From 56fa80803f296e99b285c8c2aff42d6324e4edbb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Fri, 4 Apr 2025 16:54:19 +0200 Subject: [PATCH 055/142] Improve naming and fix some bugs --- R/resolver.R | 88 +++++++++++++++++++++++++++++++++------------------- 1 file changed, 56 insertions(+), 32 deletions(-) diff --git a/R/resolver.R b/R/resolver.R index 24853766..73243699 100644 --- a/R/resolver.R +++ b/R/resolver.R @@ -64,6 +64,7 @@ determine <- function(type, data, ...) { #' @export determine.default <- function(type, data, ..., spec) { + # Used when the type is of class list. if (!is.null(names(spec)) && is.delayed(spec)) { rt <- determine(spec, data) } else { @@ -107,7 +108,12 @@ functions_names <- function(spec_criteria, names) { new_names <- vector("character") for (fun in functions) { - names_ok <- tryCatch(fun(names), error = function(new_names) FALSE ) + names_ok <- tryCatch(fun(names), + error = function(x){FALSE}, + warning = function(x){ + if (isTRUE(x) || isFALSE(x)){ + x + } else {FALSE}} ) if (!is.logical(names_ok)) { stop("Provided functions should return a logical object.") } @@ -119,18 +125,26 @@ functions_names <- function(spec_criteria, names) { c(new_names, old_names) } -# Extract data and evaluate if the function -functions_data <- function(spec_criteria, data, names_data) { - stopifnot(!is.null(data)) # Must be something but not NULL +# Evaluate if the function applied to the data +# but we need to return the name of the data received +functions_data <- function(spec_criteria, names_data, data) { + stopifnot(!is.null(data), + length(names_data) == 1L) # Must be something but not NULL is_fc <- vapply(spec_criteria, is.function, logical(1L)) functions <- spec_criteria[is_fc] l <- lapply(functions, function(fun) { - data_ok <- tryCatch(fun(data), error = function(x){FALSE}) - if (any(data_ok)) { - return(names_data[data_ok]) - } else { - return(NULL) + data_ok <- tryCatch(fun(data), + error = function(x){FALSE}, + warning = function(x){ + if (isTRUE(x) || isFALSE(x)){ + x + } else {FALSE}}) + if (!is.logical(data_ok)) { + stop("Provided functions should return a logical object.") + } + if ((length(data_ok) == 1L && any(data_ok)) || all(data_ok)) { + return(names_data) } }) new_names <- unique(unlist(l, FALSE, FALSE)) @@ -143,19 +157,13 @@ determine_helper <- function(type, data_names, data) { stopifnot(!is.null(type)) orig_names <- type$names orig_select <- type$select - names_variables_obj <- if (is.null(names(data))) { colnames(data)} else {names(data)} if (is.delayed(type) && all(is.character(type$names))) { match <- intersect(data_names, type$names) - missing <- setdiff(type$names, data_names) - if (length(missing)) { - return(NULL) - # stop("Missing datasets ", paste(sQuote(missing), collapse = ", "), " were specified.") - } type$names <- match if (length(match) == 0) { return(NULL) # stop("No selected ", is(type), " matching the conditions requested") - } else if (length(match) == 1) { + } else if (length(match) == 1L) { type$select <- match } else { new_select <- functions_names(type$select, type$names) @@ -168,8 +176,8 @@ determine_helper <- function(type, data_names, data) { } } else if (is.delayed(type)) { old_names <- type$names - new_names <- c(functions_names(type$names, names_variables_obj), - functions_data(type$names, data, data_names)) + new_names <- c(functions_names(type$names, data_names), + functions_data(type$names, data_names, data)) new_names <- unlist(unique(new_names[!is.na(new_names)]), use.names = FALSE) if (!length(new_names)) { return(NULL) @@ -184,7 +192,8 @@ determine_helper <- function(type, data_names, data) { type$select <- type$names } - new_select <- functions_names(type$select, type$names) + new_select <- c(functions_names(type$select, type$names), + functions_data(type$select, type$names, data)) new_select <- unique(new_select[!is.na(new_select)]) if (!length(new_select)) { @@ -216,17 +225,9 @@ determine.datasets <- function(type, data, ...) { # Merge together all the types type <- do.call(c, l[lengths(l) > 1L]) - # FIXME: This combine the different selections too. - # Instead it should apply once the select function and keep that instead. - # helper_something(type$select, type$names, data) - # Not possible to know what is happening - for (name in type$names){ - data_name_env <- names(data)[i] - out <- determine_helper(type, data_name_env, extract(data, data_name_env)) - if (!is.null(out)) { - l[[i]] <- out - } - } + # Evaluate the selection based on all possible choices. + type <- eval_type_select(type, data) + if (!is.delayed(type) && length(type$select) > 1L) { list(type = type, data = data[unorig(type$select)]) } else if (!is.delayed(type) && length(type$select) == 1L) { @@ -258,6 +259,8 @@ determine.variables <- function(type, data, ...) { # Merge together all the types type <- do.call(c, l[lengths(l) > 1]) + # Check the selected values as they got appended. + type <- eval_type_select(type, data) # Not possible to know what is happening if (is.delayed(type)) { @@ -276,7 +279,7 @@ determine.mae_colData <- function(type, data, ...) { new_data <- colData(data) for (i in seq_along(new_data)){ - determine_helper(type, colnames(data)[i], new_data[, i]) + determine_helper(type, colnames(new_data)[i], new_data[, i]) } if (length(dim(new_data)) != 2L) { stop("Can't resolve variables from this object of class ", class(new_data)) @@ -284,7 +287,7 @@ determine.mae_colData <- function(type, data, ...) { if (ncol(new_data) <= 0L) { stop("Can't pull variable: No variable is available.") } - type <- determine_helper(type, colnames(data), data) + type <- determine_helper(type, colnames(new_data), new_data) # Not possible to know what is happening if (is.delayed(type)) { @@ -363,3 +366,24 @@ unorig <- function(x) { attr(x, "original") <- NULL x } + + +eval_type_select <- function(type, data) { + l <- vector("list", length(type$names)) + names(l) <- type$names + orig_select <- orig(type$select) + for (name in type$names){ + out <- functions_data(orig_select, name, extract(data, name)) + if (!is.null(out)) { + l[[name]] <- unlist(out) + } + } + + new_select <- c(functions_names(orig(type$select), type$names), + unlist(l, FALSE, FALSE)) + + new_select <- unique(new_select) + attr(new_select, "original") <- orig_select + type$select <- new_select + type +} From bcbf30443ec6f27cc86cee506bb5d12307a65c03 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Fri, 4 Apr 2025 16:55:12 +0200 Subject: [PATCH 056/142] Handle bare types --- R/update_spec.R | 22 +++++++++++++++++----- 1 file changed, 17 insertions(+), 5 deletions(-) diff --git a/R/update_spec.R b/R/update_spec.R index 2b6f4e28..c9a9b9e5 100644 --- a/R/update_spec.R +++ b/R/update_spec.R @@ -23,22 +23,34 @@ update_spec <- function(spec, type, value) { "\nDo you attempt to set a new specification? Please open an issue.") } - if (is.transform(spec) && is.null(names(spec))) { + if (!is.transform(spec) || !is.list(spec) && !is.type(spec)) { + stop("Unexpected object used as specification") + } + + if (is.null(names(spec))) { updated_spec <- lapply(spec, update_s_spec, type, value) class(updated_spec) <- class(spec) - updated_spec + return(updated_spec) } - if (is.transform(spec) && !is.null(names(spec))) { + if (!is.null(names(spec))) { updated_spec <- update_s_spec(spec, type, value) } else if (is.type(spec)) { updated_spec <- update_s_spec(spec, is(spec), value) - } else { - stop("Multiple or no specification is possible.") } updated_spec } update_s_spec <- function(spec, type, value) { + + if (is.type(spec)) { + l <- list(spec) + names(l) <- is(spec) + out <- update_s_spec(l, type, value) + return(out[[is(spec)]]) + } + + + spec_types <- names(spec) type <- match.arg(type, spec_types) restart_types <- spec_types[seq_along(spec_types) > which(type == spec_types)] From dabf7310ecefb018f58b31ae3de8ef31b73003ac Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Fri, 4 Apr 2025 16:55:41 +0200 Subject: [PATCH 057/142] Add some checks on the input --- R/module_input.R | 19 +++++++++++++------ 1 file changed, 13 insertions(+), 6 deletions(-) diff --git a/R/module_input.R b/R/module_input.R index e3225d00..a0c8656f 100644 --- a/R/module_input.R +++ b/R/module_input.R @@ -24,20 +24,27 @@ module_input_ui <- function(id, label, spec) { } module_input_server <- function(id, spec, data) { + stopifnot(is.transform(spec)) + stopifnot(is.reactive(data)) + stopifnot(is.character(id)) moduleServer(id, function(input, output, session) { - react_updates <- reactive({ + d <- data() if (!anyNA(spec) && is.delayed(spec)) { - spec <- teal.transform::resolver(spec, data()) + spec <- teal.transform::resolver(spec, d) } - for (i in seq_along(input)) { + for (i in seq_along(names(input))) { variable <- names(input)[i] x <- input[[variable]] spec_v <- spec[[variable]] - if (!is.null(x) && all(x %in% spec_v$names) && any(!x %in% spec_v$select)) { + # resolved <- !is.character(spec_v$names) && all(x %in% spec_v$names) && any(!x %in% spec_v$select) + + if (!is.null(x) && any(nzchar(x))) { spec <- spec |> - update_spec(variable, input[[variable]]) |> - teal.transform::resolver(data()) + update_spec(variable, x) |> + resolver(d) + } else { + spec <- resolver(spec, d) } } spec From 78a8e1f4654e86f54ccc699134dbd28447a03413 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Fri, 4 Apr 2025 17:25:14 +0200 Subject: [PATCH 058/142] Merging features --- R/merge_dataframes.R | 77 ++++++++++++++++++++++++++++++++++++-------- 1 file changed, 64 insertions(+), 13 deletions(-) diff --git a/R/merge_dataframes.R b/R/merge_dataframes.R index 1499d118..25de52f2 100644 --- a/R/merge_dataframes.R +++ b/R/merge_dataframes.R @@ -1,34 +1,85 @@ +merge_module_ui <- function(id) { + ns <- NS(id) + renderText(ns("a")) +} + +merge_module_srv <- function(id, data = data, input_list = input_list, ids, type) { + stopifnot(is.list(input_list)) + stopifnot(is.reactive(data)) + stopifnot(is.character(id)) + moduleServer(id, function(input, output, session) { + out <- reactive({ + input_data <- lapply(input_list, extract_input, data = data) + merging(input_data, ids, type) + }) + output$out <- out + }) +} + +extract_input <- function(input, data) { + for (i in input) { + # Extract data recursively: only works on lists and square objects (no MAE or similar) + # To work on new classes implement an extract.class method + # Assumes order of extraction on the input: qenv > datasets > variables + # IF datasetes > variables > qenv order + data <- extract(data, i, drop = FALSE) + } + data +} + # Allows merging arbitrary number of data.frames by ids and type + merging <- function(..., ids, type) { - number_merges <- ...length() - 1L + input_as_list <- is.list(..1) & ...length() == 1L + if (input_as_list) { + list_df <- ..1 + } else { + list_df <- list(...) + } + number_merges <- length(list_df) - 1L stopifnot( "Number of datasets is enough" = number_merges >= 1L, - "Number of arguments for ids matches data" = (length(ids) == number_merges && is.list(ids)) || length(ids) == 1L && is.character(ids), - "Number of arguments for type matches data" = length(type) == number_merges || length(type) == 1L) - list_df <- list(...) + "Number of arguments for type matches data" = length(type) == number_merges || length(type) == 1L + ) - if (length(type) == 1L) { + if (!missing(ids)) { + stopifnot("Number of arguments for ids matches data" = !(is.list(ids) && length(ids) == number_merges)) + } + if (length(type) != number_merges) { type <- rep(type, number_merges) } - if (length(ids) == 1L) { + if (!missing(ids) && length(ids) != number_merges) { ids <- rep(ids, number_merges) } - if (number_merges == 1L) { + if (number_merges == 1L && !input_as_list && !missing(ids)) { return(self_merging(..1, ..2, ids = ids, type = type)) + } else if (number_merges == 1L && !input_as_list && missing(ids)) { + return(self_merging(..1, ..2, type = type)) + } else if (number_merges == 1L && input_as_list && missing(ids)) { + return(self_merging(list_df[[1]], list_df[[2]], type = type)) + } else if (number_merges == 1L && input_as_list && !missing(ids)) { + return(self_merging(list_df[[1]], list_df[[2]], ids = ids, type = type)) } - # l <- list("a", "b", "c", "d") - # number_merges <- length(l) - 1L - m <- list() for (merge_i in seq_len(number_merges)) { message(merge_i) if (merge_i == 1L) { + if (missing(ids)) { + ids <- intersect(colnames(list_df[[merge_i]]), colnames(list_df[[merge_i + 1L]])) + } else { + ids <- ids[[merge_i]] + } out <- self_merging(list_df[[merge_i]], list_df[[merge_i + 1L]], - ids[[merge_i]], type = type[[merge_i]]) + ids, type = type[[merge_i]]) } else { + if (missing(ids)) { + ids <- intersect(colnames(out, colnames(list_df[[merge_i + 1L]]))) + } else { + ids <- ids[[merge_i]] + } out <- self_merging(out, list_df[[merge_i + 1L]], - ids[[merge_i]], type = type[[merge_i]]) + ids, type = type[[merge_i]]) } } out @@ -37,7 +88,7 @@ merging <- function(..., ids, type) { # self_merge(df1, df2) almost equal to self_merge(df2, df1): Only changes on the column order. -self_merging <- function(e1, e2, ids, type) { +self_merging <- function(e1, e2, ids = intersect(colnames(e1), colnames(e2)), type) { # Get the name of the variables to use as suffix. # If we need the name at higher environments (ie: f(self_merging()) ) it could use rlang (probably) name1 <- deparse(substitute(e1)) From ee357b072b2ece56e78d15c5bc63bb96e531d328 Mon Sep 17 00:00:00 2001 From: github-actions <41898282+github-actions[bot]@users.noreply.github.com> Date: Fri, 4 Apr 2025 15:44:56 +0000 Subject: [PATCH 059/142] [skip style] [skip vbump] Restyle files --- R/merge_dataframes.R | 17 +++++++----- R/module_input.R | 2 +- R/resolver.R | 62 +++++++++++++++++++++++++++++--------------- R/update_spec.R | 1 - 4 files changed, 53 insertions(+), 29 deletions(-) diff --git a/R/merge_dataframes.R b/R/merge_dataframes.R index 514cbfd8..b0d175f5 100644 --- a/R/merge_dataframes.R +++ b/R/merge_dataframes.R @@ -39,7 +39,7 @@ merging <- function(..., ids, type) { number_merges <- length(list_df) - 1L stopifnot( "Number of datasets is enough" = number_merges >= 1L, - "Number of arguments for type matches data" = length(type) == number_merges || length(type) == 1L + "Number of arguments for type matches data" = length(type) == number_merges || length(type) == 1L ) if (!missing(ids)) { @@ -71,7 +71,9 @@ merging <- function(..., ids, type) { ids <- ids[[merge_i]] } out <- self_merging(list_df[[merge_i]], list_df[[merge_i + 1L]], - ids, type = type[[merge_i]]) + ids, + type = type[[merge_i]] + ) } else { if (missing(ids)) { ids <- intersect(colnames(out, colnames(list_df[[merge_i + 1L]]))) @@ -79,7 +81,9 @@ merging <- function(..., ids, type) { ids <- ids[[merge_i]] } out <- self_merging(out, list_df[[merge_i + 1L]], - ids, type = type[[merge_i]]) + ids, + type = type[[merge_i]] + ) } } out @@ -135,9 +139,10 @@ self_merging <- function(e1, e2, ids = intersect(colnames(e1), colnames(e2)), ty # a) ask for the method to be implemented or # b) implement it ourselves here to be used internally. mm <- merge(e1, e2, - all.x = all.x, all.y = all.y, - by.x = name_ids, by.y = ids, - suffixes = c(".e1", ".e2")) + all.x = all.x, all.y = all.y, + by.x = name_ids, by.y = ids, + suffixes = c(".e1", ".e2") + ) g <- grep("\\.[(e1)(e2)]", colnames(mm)) if (length(g)) { mix_columns <- setdiff(intersect(ce1, ce2), ids) diff --git a/R/module_input.R b/R/module_input.R index 85c5f8ee..f632d891 100644 --- a/R/module_input.R +++ b/R/module_input.R @@ -40,7 +40,7 @@ module_input_server <- function(id, spec, data) { spec_v <- spec[[variable]] # resolved <- !is.character(spec_v$names) && all(x %in% spec_v$names) && any(!x %in% spec_v$select) - if (!is.null(x) && any(nzchar(x))) { + if (!is.null(x) && any(nzchar(x))) { spec <- spec |> update_spec(variable, x) |> resolver(d) diff --git a/R/resolver.R b/R/resolver.R index 64b19763..77f096a4 100644 --- a/R/resolver.R +++ b/R/resolver.R @@ -109,11 +109,17 @@ functions_names <- function(spec_criteria, names) { for (fun in functions) { names_ok <- tryCatch(fun(names), - error = function(x){FALSE}, - warning = function(x){ - if (isTRUE(x) || isFALSE(x)){ - x - } else {FALSE}} ) + error = function(x) { + FALSE + }, + warning = function(x) { + if (isTRUE(x) || isFALSE(x)) { + x + } else { + FALSE + } + } + ) if (!is.logical(names_ok)) { stop("Provided functions should return a logical object.") } @@ -128,18 +134,26 @@ functions_names <- function(spec_criteria, names) { # Evaluate if the function applied to the data # but we need to return the name of the data received functions_data <- function(spec_criteria, names_data, data) { - stopifnot(!is.null(data), - length(names_data) == 1L) # Must be something but not NULL + stopifnot( + !is.null(data), + length(names_data) == 1L + ) # Must be something but not NULL is_fc <- vapply(spec_criteria, is.function, logical(1L)) functions <- spec_criteria[is_fc] l <- lapply(functions, function(fun) { data_ok <- tryCatch(fun(data), - error = function(x){FALSE}, - warning = function(x){ - if (isTRUE(x) || isFALSE(x)){ - x - } else {FALSE}}) + error = function(x) { + FALSE + }, + warning = function(x) { + if (isTRUE(x) || isFALSE(x)) { + x + } else { + FALSE + } + } + ) if (!is.logical(data_ok)) { stop("Provided functions should return a logical object.") } @@ -179,9 +193,11 @@ determine_helper <- function(type, data_names, data) { old_names <- type$names new_names <- c( functions_names(type$names, data_names), - functions_data(type$names, data_names, data)) + functions_data(type$names, data_names, data) + ) new_names <- unlist(unique(new_names[!is.na(new_names)]), - use.names = FALSE) + use.names = FALSE + ) if (!length(new_names)) { return(NULL) # stop("No ", is(type), " meet the requirements") @@ -195,8 +211,10 @@ determine_helper <- function(type, data_names, data) { type$select <- type$names } - new_select <- c(functions_names(type$select, type$names), - functions_data(type$select, type$names, data)) + new_select <- c( + functions_names(type$select, type$names), + functions_data(type$select, type$names, data) + ) new_select <- unique(new_select[!is.na(new_select)]) if (!length(new_select)) { @@ -218,7 +236,7 @@ determine.datasets <- function(type, data, ...) { l <- vector("list", length(names(data))) # Somehow in some cases (I didn't explore much this was TRUE) - for (i in seq_along(l)){ + for (i in seq_along(l)) { data_name_env <- names(data)[i] out <- determine_helper(type, data_name_env, extract(data, data_name_env)) if (!is.null(out)) { @@ -281,7 +299,7 @@ determine.mae_colData <- function(type, data, ...) { } new_data <- colData(data) - for (i in seq_along(new_data)){ + for (i in seq_along(new_data)) { type <- determine_helper(type, colnames(new_data)[i], new_data[, i]) } if (length(dim(new_data)) != 2L) { @@ -372,15 +390,17 @@ eval_type_select <- function(type, data) { l <- vector("list", length(type$names)) names(l) <- type$names orig_select <- orig(type$select) - for (name in type$names){ + for (name in type$names) { out <- functions_data(orig_select, name, extract(data, name)) if (!is.null(out)) { l[[name]] <- unlist(out) } } - new_select <- c(functions_names(orig(type$select), type$names), - unlist(l, FALSE, FALSE)) + new_select <- c( + functions_names(orig(type$select), type$names), + unlist(l, FALSE, FALSE) + ) new_select <- unique(new_select) attr(new_select, "original") <- orig_select diff --git a/R/update_spec.R b/R/update_spec.R index 89616843..7c280db5 100644 --- a/R/update_spec.R +++ b/R/update_spec.R @@ -47,7 +47,6 @@ update_spec <- function(spec, type, value) { } update_s_spec <- function(spec, type, value) { - if (is.type(spec)) { l <- list(spec) names(l) <- is(spec) From b266116874678f1b4537bdd0086564fed3c8fa0a Mon Sep 17 00:00:00 2001 From: github-actions <41898282+github-actions[bot]@users.noreply.github.com> Date: Fri, 4 Apr 2025 15:49:07 +0000 Subject: [PATCH 060/142] [skip roxygen] [skip vbump] Roxygen Man Pages Auto Update --- man/resolver.Rd | 2 -- 1 file changed, 2 deletions(-) diff --git a/man/resolver.Rd b/man/resolver.Rd index 170a6c86..14e2f520 100644 --- a/man/resolver.Rd +++ b/man/resolver.Rd @@ -8,8 +8,6 @@ resolver(spec, data) } \arguments{ \item{spec}{A object extraction specification.} - -\item{data}{A \code{qenv()}, or \code{teal.data::teal_data()} object.} } \value{ A transform but resolved From 8a2fcb6ff0ba55f2ad502b941d3d384e81226f6b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Mon, 7 Apr 2025 11:28:32 +0200 Subject: [PATCH 061/142] Instead of a list make us of ... --- R/merge_dataframes.R | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/R/merge_dataframes.R b/R/merge_dataframes.R index 514cbfd8..c5b2f32f 100644 --- a/R/merge_dataframes.R +++ b/R/merge_dataframes.R @@ -3,16 +3,17 @@ merge_module_ui <- function(id) { renderText(ns("a")) } -merge_module_srv <- function(id, data = data, input_list = input_list, ids, type) { - stopifnot(is.list(input_list)) - stopifnot(is.reactive(data)) +merge_module_srv <- function(id, ..., data, ids, type) { + # stopifnot(is.reactive(data)) stopifnot(is.character(id)) moduleServer(id, function(input, output, session) { out <- reactive({ + input_list = list(...) input_data <- lapply(input_list, extract_input, data = data) - merging(input_data, ids, type) + merging(input_data, ids = ids, type = type) }) output$out <- out + out }) } From b03e0d910edc8db32420e2fb16f625969857ab6f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Mon, 7 Apr 2025 17:11:23 +0200 Subject: [PATCH 062/142] Solve most issues --- NAMESPACE | 1 + R/extract.R | 2 +- R/ops_transform.R | 6 +++++- R/resolver.R | 16 +++++++++++++--- R/types.R | 4 ++++ R/update_spec.R | 5 +++-- man/resolver.Rd | 2 +- tests/testthat/test-delayed.R | 1 - tests/testthat/test-ops_transform.R | 16 ++++++++-------- tests/testthat/test-resolver.R | 20 +++++++++++--------- tests/testthat/test-types.R | 10 +++++----- 11 files changed, 52 insertions(+), 31 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index cb2b8038..6f5acd46 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -105,3 +105,4 @@ export(variables) import(shiny) importFrom(dplyr,"%>%") importFrom(lifecycle,badge) +importFrom(methods,is) diff --git a/R/extract.R b/R/extract.R index 1624c01b..a49795f9 100644 --- a/R/extract.R +++ b/R/extract.R @@ -32,7 +32,7 @@ extract <- function(x, variable, ...) { # } #' @export -extract.default <- function(x, variable, drop = TRUE) { +extract.default <- function(x, variable, ..., drop = TRUE) { if (length(dim(x)) == 2L || length(variable) > 1L) { x[, variable, drop = drop] } else { diff --git a/R/ops_transform.R b/R/ops_transform.R index 4eb62408..540f2ee9 100644 --- a/R/ops_transform.R +++ b/R/ops_transform.R @@ -92,6 +92,10 @@ nd_type <- function(e1, e2) { out <- c(e1, e2) } else if (is.type(e1) && is.type(e2)) { out <- c(e1, e2) + } else if (or.transform(e1) && is.type(e2) ){ + out <- lapply(e1, nd_type, e2 = e2) + } else if (or.transform(e2) && is.type(e1) ){ + out <- lapply(e2, nd_type, e2 = e1) } else { stop("Maybe we should decide how to apply a type to a list of transformers...") } @@ -104,7 +108,7 @@ or_type <- function(e1, e2) { if (substitute) { out <- e1 e1[[is(e2)]] <- e2 - return(add_type(out, e1)) + return(nd_type(out, e1)) } list(e1, e2) } diff --git a/R/resolver.R b/R/resolver.R index 64b19763..53065a24 100644 --- a/R/resolver.R +++ b/R/resolver.R @@ -3,6 +3,7 @@ #' Given the specification of some data to extract find if they are available or not. #' The specification for selecting a variable shouldn't depend on the data of said variable. #' @param spec A object extraction specification. +#' @param data The qenv where the specification is evaluated. #' #' @returns A transform but resolved #' @export @@ -74,6 +75,7 @@ determine.default <- function(type, data, ..., spec) { } } rt + } #' @export @@ -109,7 +111,7 @@ functions_names <- function(spec_criteria, names) { for (fun in functions) { names_ok <- tryCatch(fun(names), - error = function(x){FALSE}, + error = function(x){x}, warning = function(x){ if (isTRUE(x) || isFALSE(x)){ x @@ -135,7 +137,7 @@ functions_data <- function(spec_criteria, names_data, data) { l <- lapply(functions, function(fun) { data_ok <- tryCatch(fun(data), - error = function(x){FALSE}, + error = function(x){x}, warning = function(x){ if (isTRUE(x) || isFALSE(x)){ x @@ -143,7 +145,7 @@ functions_data <- function(spec_criteria, names_data, data) { if (!is.logical(data_ok)) { stop("Provided functions should return a logical object.") } - if ((length(data_ok) == 1L && any(data_ok)) || all(data_ok)) { + if ((length(data_ok) == 1L && (any(data_ok)) || all(data_ok))) { return(names_data) } }) @@ -231,6 +233,10 @@ determine.datasets <- function(type, data, ...) { # Evaluate the selection based on all possible choices. type <- eval_type_select(type, data) + if (is.null(type$names)) { + stop("No datasets meet the specification.", call. = FALSE) + } + if (!is.delayed(type) && length(type$select) > 1L) { list(type = type, data = data[unorig(type$select)]) } else if (!is.delayed(type) && length(type$select) == 1L) { @@ -265,6 +271,10 @@ determine.variables <- function(type, data, ...) { # Check the selected values as they got appended. type <- eval_type_select(type, data) + if (is.null(type$names)) { + stop("No variables meet the specification.", call. = FALSE) + } + # Not possible to know what is happening if (is.delayed(type)) { return(list(type = type, data = NULL)) diff --git a/R/types.R b/R/types.R index 045c74a9..65855e5a 100644 --- a/R/types.R +++ b/R/types.R @@ -2,6 +2,10 @@ is.transform <- function(x) { inherits(x, "transform") } +or.transform <- function(x) { + is.list(x) && all(vapply(x, function(x){is.transform(x) || is.type(x)}, logical(1L))) +} + na_type <- function(type) { out <- NA_character_ class(out) <- c(type, "type") diff --git a/R/update_spec.R b/R/update_spec.R index 89616843..04cb5f9d 100644 --- a/R/update_spec.R +++ b/R/update_spec.R @@ -29,12 +29,12 @@ update_spec <- function(spec, type, value) { ) } - if (!is.transform(spec) || !is.list(spec) && !is.type(spec)) { + if (!((is.type(spec) || is.transform(spec)) || or.transform(spec))) { stop("Unexpected object used as specification") } if (is.null(names(spec))) { - updated_spec <- lapply(spec, update_s_spec, type, value) + updated_spec <- lapply(spec, update_s_spec, type = type, value = value) class(updated_spec) <- class(spec) return(updated_spec) } @@ -46,6 +46,7 @@ update_spec <- function(spec, type, value) { updated_spec } +#' @importFrom methods is update_s_spec <- function(spec, type, value) { if (is.type(spec)) { diff --git a/man/resolver.Rd b/man/resolver.Rd index 170a6c86..9a05f1c9 100644 --- a/man/resolver.Rd +++ b/man/resolver.Rd @@ -9,7 +9,7 @@ resolver(spec, data) \arguments{ \item{spec}{A object extraction specification.} -\item{data}{A \code{qenv()}, or \code{teal.data::teal_data()} object.} +\item{data}{The qenv where the specification is evaluated.} } \value{ A transform but resolved diff --git a/tests/testthat/test-delayed.R b/tests/testthat/test-delayed.R index 7a4eb07e..a6efe359 100644 --- a/tests/testthat/test-delayed.R +++ b/tests/testthat/test-delayed.R @@ -9,5 +9,4 @@ test_that("is.delayed works", { expect_false(is.delayed(1)) da <- datasets(is.data.frame) expect_true(is.delayed(da)) - expect_true(is.delayed(da$datasets)) }) diff --git a/tests/testthat/test-ops_transform.R b/tests/testthat/test-ops_transform.R index 2a8fb0dc..e712ee25 100644 --- a/tests/testthat/test-ops_transform.R +++ b/tests/testthat/test-ops_transform.R @@ -4,26 +4,26 @@ basic_ops <- function(fun) { types <- type1 & type1 out <- list(names = "ABC", select = list(first)) class(out) <- c(fun, "type", "list") - expect_equal(types[[fun]], out, check.attributes = FALSE) + expect_equal(types, out, check.attributes = FALSE) type2 <- FUN("ABC2") types <- type1 & type2 out <- list(names = c("ABC", "ABC2"), select = list(first)) class(out) <- c("delayed", fun, "type", "list") - expect_equal(types[[fun]], out, check.attributes = FALSE) - expect_equal(types[[fun]]$names, c("ABC", "ABC2"), check.attributes = FALSE) + expect_equal(types, out, check.attributes = FALSE) + expect_equal(types$names, c("ABC", "ABC2"), check.attributes = FALSE) types2 <- types & type2 - expect_equal(types[[fun]]$names, c("ABC", "ABC2"), check.attributes = FALSE) - expect_s3_class(types[[fun]], class(out)) + expect_equal(types$names, c("ABC", "ABC2"), check.attributes = FALSE) + expect_s3_class(types, class(out)) type3 <- FUN("ABC2", select = all_choices) types <- type1 & type3 - expect_length(types[[fun]]$select, 2) + expect_length(types$select, 2) type2b <- FUN(first_choice) type2c <- FUN(last_choice) out <- type2b & type2c - expect_length(out[[fun]]$names, 2) + expect_length(out$names, 2) expect_error(FUN("ABC") & 1) out <- type1 & type2b - expect_true(is.list(out[[fun]]$names)) + expect_true(is.list(out$names)) } test_that("datasets & work", { diff --git a/tests/testthat/test-resolver.R b/tests/testthat/test-resolver.R index b00b722d..a8e4cd64 100644 --- a/tests/testthat/test-resolver.R +++ b/tests/testthat/test-resolver.R @@ -3,7 +3,7 @@ f <- function(x) { } test_that("resolver datasets works", { - df_head <- datasets("df", f) + df_head <- datasets("df") df_first <- datasets("df") matrices <- datasets(is.matrix) df_mean <- datasets("df", mean) @@ -16,7 +16,7 @@ test_that("resolver datasets works", { expect_no_error(resolver(df_head, td)) expect_no_error(resolver(df_first, td)) out <- resolver(matrices, td) - expect_length(out$datasets$select, 1L) # Because we use first + expect_length(out$select, 1L) # Because we use first expect_no_error(resolver(df_mean, td)) expect_error(resolver(median_mean, td)) }) @@ -104,17 +104,17 @@ test_that("names and variables are reported", { }) df_all_upper_variables <- d_df & v_all_upper expect_no_error(out <- resolver(df_all_upper_variables, td)) - expect_length(out$variables$names, 1) + expect_length(out$variables$names, 2L) expect_no_error(out <- resolver(datasets("df2") & v_all_upper, td)) - expect_length(out$variables$names, 2) + expect_length(out$variables$names, 2L) expect_no_error(out <- resolver(datasets(function(x) { is.data.frame(x) && all(colnames(x) == toupper(colnames(x))) }), td)) - expect_length(out$datasets$names, 1) + expect_length(out$names, 1L) expect_no_error(out <- resolver(datasets(is.data.frame) & datasets(function(x) { colnames(x) == toupper(colnames(x)) }), td)) - expect_length(out$datasets$names, 2) + expect_length(out$names, 2L) }) test_that("update_spec resolves correctly", { @@ -166,7 +166,7 @@ test_that("update_spec resolves correctly", { test_that("OR resolver invalidates subsequent specifications", { - td <- within(teal_data(), { + td <- within(teal.data::teal_data(), { df <- data.frame(A = 1:5, B = LETTERS[1:5]) m <- cbind(A = 1:5, B = 5:10) }) @@ -175,10 +175,11 @@ test_that("OR resolver invalidates subsequent specifications", { matrix_a <- datasets(is.matrix) & var_a df_or_m_var_a <- df_a | matrix_a out <- resolver(df_or_m_var_a, td) + expect_false(is.null(out)) }) test_that("OR update_spec filters specifications", { - td <- within(teal_data(), { + td <- within(teal.data::teal_data(), { df <- data.frame(A = 1:5, B = LETTERS[1:5]) m <- cbind(A = 1:5, B = 5:10) }) @@ -187,5 +188,6 @@ test_that("OR update_spec filters specifications", { matrix_a <- datasets(is.matrix) & var_a df_or_m_var_a <- df_a | matrix_a resolved <- resolver(df_or_m_var_a, td) - out <- update_spec(resolved, "datasets", "df") + # The second option is not possible to have it as df + expect_error(update_spec(resolved, "datasets", "df")) }) diff --git a/tests/testthat/test-types.R b/tests/testthat/test-types.R index 7c3dbdc8..3a64cee2 100644 --- a/tests/testthat/test-types.R +++ b/tests/testthat/test-types.R @@ -2,11 +2,11 @@ test_that("datasets", { expect_no_error(dataset0 <- datasets("df", "df")) out <- list(names = "df", select = "df") class(out) <- c("delayed", "datasets", "type", "list") - expect_equal(dataset0[["datasets"]], out, check.attributes = FALSE) + expect_equal(dataset0, out, check.attributes = FALSE) expect_no_error(dataset1 <- datasets("df")) - expect_true(is(dataset1$datasets$names, "vector")) + expect_true(is(dataset1$names, "vector")) expect_no_error(dataset2 <- datasets(is.matrix)) - expect_true(is(dataset2$datasets$names, "vector")) + expect_true(is(dataset2$names, "vector")) expect_no_error(dataset3 <- datasets(is.data.frame)) }) @@ -25,8 +25,8 @@ test_that("variables", { test_that("raw combine of types", { out <- c(datasets("df"), variables("df")) - expect_length(out, 3) - expect_error(c(datasets("df"), variables("df"), values("df"))) + expect_length(out, 2L) + expect_no_error(c(datasets("df"), variables("df"), values("df"))) }) test_that("values", { From a19ed318ae48be9ec75e8a058e005958f06d960c Mon Sep 17 00:00:00 2001 From: github-actions <41898282+github-actions[bot]@users.noreply.github.com> Date: Mon, 7 Apr 2025 15:15:34 +0000 Subject: [PATCH 063/142] [skip style] [skip vbump] Restyle files --- R/merge_dataframes.R | 2 +- R/ops_transform.R | 4 ++-- R/resolver.R | 33 ++++++++++++++++++++++----------- R/types.R | 4 +++- 4 files changed, 28 insertions(+), 15 deletions(-) diff --git a/R/merge_dataframes.R b/R/merge_dataframes.R index 56e29d61..4eeb87b8 100644 --- a/R/merge_dataframes.R +++ b/R/merge_dataframes.R @@ -8,7 +8,7 @@ merge_module_srv <- function(id, ..., data, ids, type) { stopifnot(is.character(id)) moduleServer(id, function(input, output, session) { out <- reactive({ - input_list = list(...) + input_list <- list(...) input_data <- lapply(input_list, extract_input, data = data) merging(input_data, ids = ids, type = type) }) diff --git a/R/ops_transform.R b/R/ops_transform.R index 540f2ee9..58ca87bb 100644 --- a/R/ops_transform.R +++ b/R/ops_transform.R @@ -92,9 +92,9 @@ nd_type <- function(e1, e2) { out <- c(e1, e2) } else if (is.type(e1) && is.type(e2)) { out <- c(e1, e2) - } else if (or.transform(e1) && is.type(e2) ){ + } else if (or.transform(e1) && is.type(e2)) { out <- lapply(e1, nd_type, e2 = e2) - } else if (or.transform(e2) && is.type(e1) ){ + } else if (or.transform(e2) && is.type(e1)) { out <- lapply(e2, nd_type, e2 = e1) } else { stop("Maybe we should decide how to apply a type to a list of transformers...") diff --git a/R/resolver.R b/R/resolver.R index 79063795..5b4eb38e 100644 --- a/R/resolver.R +++ b/R/resolver.R @@ -75,7 +75,6 @@ determine.default <- function(type, data, ..., spec) { } } rt - } #' @export @@ -111,11 +110,17 @@ functions_names <- function(spec_criteria, names) { for (fun in functions) { names_ok <- tryCatch(fun(names), - error = function(x){x}, - warning = function(x){ - if (isTRUE(x) || isFALSE(x)){ - x - } else {FALSE}} ) + error = function(x) { + x + }, + warning = function(x) { + if (isTRUE(x) || isFALSE(x)) { + x + } else { + FALSE + } + } + ) if (!is.logical(names_ok)) { stop("Provided functions should return a logical object.") } @@ -139,11 +144,17 @@ functions_data <- function(spec_criteria, names_data, data) { l <- lapply(functions, function(fun) { data_ok <- tryCatch(fun(data), - error = function(x){x}, - warning = function(x){ - if (isTRUE(x) || isFALSE(x)){ - x - } else {FALSE}}) + error = function(x) { + x + }, + warning = function(x) { + if (isTRUE(x) || isFALSE(x)) { + x + } else { + FALSE + } + } + ) if (!is.logical(data_ok)) { stop("Provided functions should return a logical object.") } diff --git a/R/types.R b/R/types.R index 65855e5a..1cc058ea 100644 --- a/R/types.R +++ b/R/types.R @@ -3,7 +3,9 @@ is.transform <- function(x) { } or.transform <- function(x) { - is.list(x) && all(vapply(x, function(x){is.transform(x) || is.type(x)}, logical(1L))) + is.list(x) && all(vapply(x, function(x) { + is.transform(x) || is.type(x) + }, logical(1L))) } na_type <- function(type) { From f146b4fb4df18b23eedaa0b1693bca11a9629a2b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Tue, 8 Apr 2025 17:09:46 +0200 Subject: [PATCH 064/142] Fix some error/warnings --- R/delayed.R | 9 +++++++++ R/extract.R | 7 +++++-- R/module_input.R | 2 +- R/resolver.R | 17 ++++++++--------- man/extract.Rd | 22 ++++++++++++++++++++++ man/is.delayed.Rd | 22 ++++++++++++++++++++++ man/update_spec.Rd | 2 +- tests/testthat/test-resolver.R | 19 ++++++++++++++++--- 8 files changed, 84 insertions(+), 16 deletions(-) create mode 100644 man/extract.Rd create mode 100644 man/is.delayed.Rd diff --git a/R/delayed.R b/R/delayed.R index 8569aa18..f94cd585 100644 --- a/R/delayed.R +++ b/R/delayed.R @@ -6,6 +6,15 @@ delay <- function(x) { x } +#' Is the specification resolved? +#' +#' Check that the specification is resolved against a given data source. +#' @param x Object to be evaluated. +#' @returns A single logical value. +#' @examples +#' is.delayed(1) +#' is.delayed(variables("df", "df")) +#' is.delayed(variables("df")) # Unknown selection #' @export is.delayed <- function(x) { UseMethod("is.delayed") diff --git a/R/extract.R b/R/extract.R index a49795f9..d315ffe4 100644 --- a/R/extract.R +++ b/R/extract.R @@ -2,9 +2,12 @@ #' #' Required to resolve a specification into something usable (by comparing with the existing data). #' Required by merging data based on a resolved specification. +#' @param x Object from which a subset/element is required. +#' @param variable Name of the element to be extracted. +#' @param ... Other arguments passed to the specific method. #' @export -#' @noRd -#' @keywords internal +#' @examples +#' extract(iris, "Sepal.Length") extract <- function(x, variable, ...) { UseMethod("extract") } diff --git a/R/module_input.R b/R/module_input.R index f632d891..2cfad2ed 100644 --- a/R/module_input.R +++ b/R/module_input.R @@ -32,7 +32,7 @@ module_input_server <- function(id, spec, data) { react_updates <- reactive({ d <- data() if (!anyNA(spec) && is.delayed(spec)) { - spec <- teal.transform::resolver(spec, d) + spec <- resolver(spec, d) } for (i in seq_along(names(input))) { variable <- names(input)[i] diff --git a/R/resolver.R b/R/resolver.R index 79063795..e542893c 100644 --- a/R/resolver.R +++ b/R/resolver.R @@ -41,7 +41,11 @@ resolver <- function(spec, data) { stopifnot(is.list(spec) || is.transform(spec)) det <- determine(spec, data, spec = spec) - det$type + if (is.null(names(det))) { + return(lapply(det, `[[`, 1)) + } else { + det$type + } } #' A method that should take a type and resolve it. @@ -66,10 +70,10 @@ determine <- function(type, data, ...) { #' @export determine.default <- function(type, data, ..., spec) { # Used when the type is of class list. - if (!is.null(names(spec)) && is.delayed(spec)) { - rt <- determine(spec, data) + if (!is.null(names(type)) && is.delayed(type)) { + rt <- determine(type, data) } else { - rt <- lapply(spec, resolver, data = data) + rt <- lapply(type, determine, data = data, spec = spec) if (length(rt) == 1) { return(rt[[1]]) } @@ -81,11 +85,6 @@ determine.default <- function(type, data, ..., spec) { #' @export determine.transform <- function(type, data, ..., spec) { stopifnot(inherits(data, "qenv")) - # Recursion for other transforms in a list spec | spec - if (is.null(names(spec))) { - specs <- lapply(type, data, spec = spec) - return(specs) - } d <- data for (i in seq_along(type)) { diff --git a/man/extract.Rd b/man/extract.Rd new file mode 100644 index 00000000..9c2ab252 --- /dev/null +++ b/man/extract.Rd @@ -0,0 +1,22 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/extract.R +\name{extract} +\alias{extract} +\title{Internal method to extract data from different objects} +\usage{ +extract(x, variable, ...) +} +\arguments{ +\item{x}{Object from which a subset/element is required.} + +\item{variable}{Name of the element to be extracted.} + +\item{...}{Other arguments passed to the specific method.} +} +\description{ +Required to resolve a specification into something usable (by comparing with the existing data). +Required by merging data based on a resolved specification. +} +\examples{ +extract(iris, "Sepal.Length") +} diff --git a/man/is.delayed.Rd b/man/is.delayed.Rd new file mode 100644 index 00000000..49f4290a --- /dev/null +++ b/man/is.delayed.Rd @@ -0,0 +1,22 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/delayed.R +\name{is.delayed} +\alias{is.delayed} +\title{Is the specification resolved?} +\usage{ +is.delayed(x) +} +\arguments{ +\item{x}{Object to be evaluated.} +} +\value{ +A single logical value. +} +\description{ +Check that the specification is resolved against a given data source. +} +\examples{ +is.delayed(1) +is.delayed(variables("df", "df")) +is.delayed(variables("df")) # Unknown selection +} diff --git a/man/update_spec.Rd b/man/update_spec.Rd index 708e0909..a1db5f32 100644 --- a/man/update_spec.Rd +++ b/man/update_spec.Rd @@ -17,7 +17,7 @@ update_spec(spec, type, value) The specification with restored choices and selection if caused by the update. } \description{ -Once a selection is made update the specification for different valid selection. +Update the specification for different selection. } \examples{ td <- within(teal.data::teal_data(), { diff --git a/tests/testthat/test-resolver.R b/tests/testthat/test-resolver.R index a8e4cd64..d0c68701 100644 --- a/tests/testthat/test-resolver.R +++ b/tests/testthat/test-resolver.R @@ -160,12 +160,12 @@ test_that("update_spec resolves correctly", { expect_error(update_spec(res, "datasets", "error")) expect_error(update_spec(data_frames_factors, "datasets", "error")) - expect_no_error(update_spec(datasets(x = c("df", "df2")), "datasets", "df2")) + expect_error(update_spec(datasets(x = c("df", "df2")), "datasets", "df2")) expect_no_error(update_spec(datasets(x = c("df", "df2"), "df"), "datasets", "df2")) }) -test_that("OR resolver invalidates subsequent specifications", { +test_that("OR specifications resolves correctly", { td <- within(teal.data::teal_data(), { df <- data.frame(A = 1:5, B = LETTERS[1:5]) m <- cbind(A = 1:5, B = 5:10) @@ -175,7 +175,20 @@ test_that("OR resolver invalidates subsequent specifications", { matrix_a <- datasets(is.matrix) & var_a df_or_m_var_a <- df_a | matrix_a out <- resolver(df_or_m_var_a, td) - expect_false(is.null(out)) + expect_true(all(vapply(out, is.transform, logical(1L)))) +}) + +test_that("OR specifications fail correctly", { + td <- within(teal.data::teal_data(), { + df <- data.frame(A = 1:5, B = LETTERS[1:5]) + m <- cbind(A = 1:5, B = 5:10) + }) + var_a <- variables("A") + df_a <- datasets(is.data.frame) & var_a + matrix_a <- datasets(is.matrix) & var_a + df_or_m_var_a <- df_a | matrix_a + out <- resolver(df_or_m_var_a, td) + expect_error(update_spec(out, "variables", "B")) }) test_that("OR update_spec filters specifications", { From 58fcf91a02db57ea862f164648471ae51b389c01 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Tue, 8 Apr 2025 17:23:13 +0200 Subject: [PATCH 065/142] Apply styler --- R/merge_dataframes.R | 2 +- R/ops_transform.R | 4 ++-- R/resolver.R | 33 ++++++++++++++++++++++----------- R/types.R | 4 +++- 4 files changed, 28 insertions(+), 15 deletions(-) diff --git a/R/merge_dataframes.R b/R/merge_dataframes.R index 56e29d61..4eeb87b8 100644 --- a/R/merge_dataframes.R +++ b/R/merge_dataframes.R @@ -8,7 +8,7 @@ merge_module_srv <- function(id, ..., data, ids, type) { stopifnot(is.character(id)) moduleServer(id, function(input, output, session) { out <- reactive({ - input_list = list(...) + input_list <- list(...) input_data <- lapply(input_list, extract_input, data = data) merging(input_data, ids = ids, type = type) }) diff --git a/R/ops_transform.R b/R/ops_transform.R index 540f2ee9..58ca87bb 100644 --- a/R/ops_transform.R +++ b/R/ops_transform.R @@ -92,9 +92,9 @@ nd_type <- function(e1, e2) { out <- c(e1, e2) } else if (is.type(e1) && is.type(e2)) { out <- c(e1, e2) - } else if (or.transform(e1) && is.type(e2) ){ + } else if (or.transform(e1) && is.type(e2)) { out <- lapply(e1, nd_type, e2 = e2) - } else if (or.transform(e2) && is.type(e1) ){ + } else if (or.transform(e2) && is.type(e1)) { out <- lapply(e2, nd_type, e2 = e1) } else { stop("Maybe we should decide how to apply a type to a list of transformers...") diff --git a/R/resolver.R b/R/resolver.R index e542893c..9cbc7fd2 100644 --- a/R/resolver.R +++ b/R/resolver.R @@ -79,7 +79,6 @@ determine.default <- function(type, data, ..., spec) { } } rt - } #' @export @@ -110,11 +109,17 @@ functions_names <- function(spec_criteria, names) { for (fun in functions) { names_ok <- tryCatch(fun(names), - error = function(x){x}, - warning = function(x){ - if (isTRUE(x) || isFALSE(x)){ - x - } else {FALSE}} ) + error = function(x) { + x + }, + warning = function(x) { + if (isTRUE(x) || isFALSE(x)) { + x + } else { + FALSE + } + } + ) if (!is.logical(names_ok)) { stop("Provided functions should return a logical object.") } @@ -138,11 +143,17 @@ functions_data <- function(spec_criteria, names_data, data) { l <- lapply(functions, function(fun) { data_ok <- tryCatch(fun(data), - error = function(x){x}, - warning = function(x){ - if (isTRUE(x) || isFALSE(x)){ - x - } else {FALSE}}) + error = function(x) { + x + }, + warning = function(x) { + if (isTRUE(x) || isFALSE(x)) { + x + } else { + FALSE + } + } + ) if (!is.logical(data_ok)) { stop("Provided functions should return a logical object.") } diff --git a/R/types.R b/R/types.R index 65855e5a..1cc058ea 100644 --- a/R/types.R +++ b/R/types.R @@ -3,7 +3,9 @@ is.transform <- function(x) { } or.transform <- function(x) { - is.list(x) && all(vapply(x, function(x){is.transform(x) || is.type(x)}, logical(1L))) + is.list(x) && all(vapply(x, function(x) { + is.transform(x) || is.type(x) + }, logical(1L))) } na_type <- function(type) { From 6aedd0afb5b542f63dfec25f0496071c712be1fc Mon Sep 17 00:00:00 2001 From: github-actions <41898282+github-actions[bot]@users.noreply.github.com> Date: Tue, 8 Apr 2025 15:26:59 +0000 Subject: [PATCH 066/142] [skip roxygen] [skip vbump] Roxygen Man Pages Auto Update --- man/update_spec.Rd | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/man/update_spec.Rd b/man/update_spec.Rd index a1db5f32..708e0909 100644 --- a/man/update_spec.Rd +++ b/man/update_spec.Rd @@ -17,7 +17,7 @@ update_spec(spec, type, value) The specification with restored choices and selection if caused by the update. } \description{ -Update the specification for different selection. +Once a selection is made update the specification for different valid selection. } \examples{ td <- within(teal.data::teal_data(), { From 4807d7d21b8ba666bdd43176d1c6c93ad4f97d42 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Wed, 9 Apr 2025 09:26:34 +0200 Subject: [PATCH 067/142] Add additional checks and case handling --- R/update_spec.R | 13 ++++++++++--- 1 file changed, 10 insertions(+), 3 deletions(-) diff --git a/R/update_spec.R b/R/update_spec.R index 44621634..05ae0248 100644 --- a/R/update_spec.R +++ b/R/update_spec.R @@ -1,6 +1,6 @@ #' Update a specification #' -#' Once a selection is made update the specification for different valid selection. +#' Update the specification for different selection. #' @param spec A resolved specification such as one created with datasets and variables. #' @param type Which type was updated? One of datasets, variables, values. #' @param value What is the new selection? One that is a valid value for the given type and specification. @@ -55,7 +55,9 @@ update_s_spec <- function(spec, type, value) { return(out[[is(spec)]]) } - + if (is.delayed(spec)) { + stop("Specification is not resolved (`!is.delayed(spec)`) can't update selections.") + } spec_types <- names(spec) type <- match.arg(type, spec_types) @@ -69,11 +71,16 @@ update_s_spec <- function(spec, type, value) { attr(spec[[type]][["select"]], "original") <- original_select } else if (!is.list(valid_names) && !all(value %in% valid_names)) { original_select <- orig(spec[[type]]$select) + valid_values <- intersect(value, valid_names) if (!length(valid_values)) { stop("No valid value provided.") } - spec[[type]][["select"]] <- valid_values + if (!length(valid_values)) { + spec[[type]][["select"]] <- original_select + } else { + spec[[type]][["select"]] <- valid_values + } attr(spec[[type]][["select"]], "original") <- original_select } else { stop("It seems the specification needs to be resolved first.") From 711f92d5c671cebc85fb0b5cc05d3fab28e1a03c Mon Sep 17 00:00:00 2001 From: github-actions <41898282+github-actions[bot]@users.noreply.github.com> Date: Wed, 9 Apr 2025 07:30:30 +0000 Subject: [PATCH 068/142] [skip roxygen] [skip vbump] Roxygen Man Pages Auto Update --- man/update_spec.Rd | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/man/update_spec.Rd b/man/update_spec.Rd index 708e0909..a1db5f32 100644 --- a/man/update_spec.Rd +++ b/man/update_spec.Rd @@ -17,7 +17,7 @@ update_spec(spec, type, value) The specification with restored choices and selection if caused by the update. } \description{ -Once a selection is made update the specification for different valid selection. +Update the specification for different selection. } \examples{ td <- within(teal.data::teal_data(), { From 06c4b07ec99a101bfa638474eb5ff489d70705a4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Wed, 9 Apr 2025 09:49:31 +0200 Subject: [PATCH 069/142] Comment code related to MAE --- NAMESPACE | 3 - R/resolver.R | 142 ++++++++++++++++++++++----------------------- man/update_spec.Rd | 2 +- 3 files changed, 72 insertions(+), 75 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 6f5acd46..80442543 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -13,9 +13,6 @@ S3method(data_extract_srv,FilteredData) S3method(data_extract_srv,list) S3method(determine,datasets) S3method(determine,default) -S3method(determine,mae_colData) -S3method(determine,mae_experiments) -S3method(determine,mae_sampleMap) S3method(determine,transform) S3method(determine,values) S3method(determine,variables) diff --git a/R/resolver.R b/R/resolver.R index 9cbc7fd2..7e620298 100644 --- a/R/resolver.R +++ b/R/resolver.R @@ -300,77 +300,77 @@ determine.variables <- function(type, data, ...) { list(type = type, data = data[, type$select]) } -#' @export -determine.mae_colData <- function(type, data, ...) { - if (!requireNamespace("MultiAssayExperiment", quietly = TRUE)) { - stop("Requires 'MultiAssayExperiment' package.") - } - - new_data <- colData(data) - for (i in seq_along(new_data)) { - type <- determine_helper(type, colnames(new_data)[i], new_data[, i]) - } - if (length(dim(new_data)) != 2L) { - stop("Can't resolve variables from this object of class ", class(new_data)) - } - if (ncol(new_data) <= 0L) { - stop("Can't pull variable: No variable is available.") - } - type <- determine_helper(type, colnames(new_data), new_data) - - # Not possible to know what is happening - if (is.delayed(type)) { - return(list(type = type, data = NULL)) - } - - if (length(type$select) > 1) { - list(type = type, data = data[type$select]) - } else { - list(type = type, data = data[[type$select]]) - } -} - -#' @export -determine.mae_experiments <- function(type, data, ...) { - if (!requireNamespace("MultiAssayExperiment", quietly = TRUE)) { - stop("Requires 'MultiAssayExperiment' package.") - } - new_data <- experiments(data) - type <- determine_helper(type, names(new_data), new_data) - - # Not possible to know what is happening - if (is.delayed(type)) { - } - - if (!is.delayed(type) && length(type$select) > 1) { - list(type = type, data = new_data[type$select]) - } else if (!is.delayed(type) && length(type$select) == 1) { - list(type = type, data = new_data[[type$select]]) - } else { - return(list(type = type, data = NULL)) - } -} - -#' @export -determine.mae_sampleMap <- function(type, data, ...) { - if (!requireNamespace("MultiAssayExperiment", quietly = TRUE)) { - stop("Requires 'MultiAssayExperiment' package.") - } - - new_data <- sampleMap(data) - type <- determine_helper(type, names(new_data), new_data) - - # Not possible to know what is happening - if (is.delayed(type)) { - return(list(type = type, data = NULL)) - } - - if (length(type$select) > 1) { - list(type = type, data = data[type$select]) - } else { - list(type = type, data = data[[type$select]]) - } -} +# @export +# determine.mae_colData <- function(type, data, ...) { +# if (!requireNamespace("MultiAssayExperiment", quietly = TRUE)) { +# stop("Requires 'MultiAssayExperiment' package.") +# } +# +# new_data <- colData(data) +# for (i in seq_along(new_data)) { +# type <- determine_helper(type, colnames(new_data)[i], new_data[, i]) +# } +# if (length(dim(new_data)) != 2L) { +# stop("Can't resolve variables from this object of class ", class(new_data)) +# } +# if (ncol(new_data) <= 0L) { +# stop("Can't pull variable: No variable is available.") +# } +# type <- determine_helper(type, colnames(new_data), new_data) +# +# # Not possible to know what is happening +# if (is.delayed(type)) { +# return(list(type = type, data = NULL)) +# } +# +# if (length(type$select) > 1) { +# list(type = type, data = data[type$select]) +# } else { +# list(type = type, data = data[[type$select]]) +# } +# } + +# @export +# determine.mae_experiments <- function(type, data, ...) { +# if (!requireNamespace("MultiAssayExperiment", quietly = TRUE)) { +# stop("Requires 'MultiAssayExperiment' package.") +# } +# new_data <- experiments(data) +# type <- determine_helper(type, names(new_data), new_data) +# +# # Not possible to know what is happening +# if (is.delayed(type)) { +# } +# +# if (!is.delayed(type) && length(type$select) > 1) { +# list(type = type, data = new_data[type$select]) +# } else if (!is.delayed(type) && length(type$select) == 1) { +# list(type = type, data = new_data[[type$select]]) +# } else { +# return(list(type = type, data = NULL)) +# } +# } + +# @export +# determine.mae_sampleMap <- function(type, data, ...) { +# if (!requireNamespace("MultiAssayExperiment", quietly = TRUE)) { +# stop("Requires 'MultiAssayExperiment' package.") +# } +# +# new_data <- sampleMap(data) +# type <- determine_helper(type, names(new_data), new_data) +# +# # Not possible to know what is happening +# if (is.delayed(type)) { +# return(list(type = type, data = NULL)) +# } +# +# if (length(type$select) > 1) { +# list(type = type, data = data[type$select]) +# } else { +# list(type = type, data = data[[type$select]]) +# } +# } #' @export determine.values <- function(type, data, ...) { diff --git a/man/update_spec.Rd b/man/update_spec.Rd index 708e0909..a1db5f32 100644 --- a/man/update_spec.Rd +++ b/man/update_spec.Rd @@ -17,7 +17,7 @@ update_spec(spec, type, value) The specification with restored choices and selection if caused by the update. } \description{ -Once a selection is made update the specification for different valid selection. +Update the specification for different selection. } \examples{ td <- within(teal.data::teal_data(), { From 0d032cd9065b92b7014573b5c1ff450b75bd7b71 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Wed, 9 Apr 2025 18:01:05 +0200 Subject: [PATCH 070/142] Minor improvements --- R/module_input.R | 7 +++++++ R/types.R | 5 +++++ R/update_spec.R | 2 +- 3 files changed, 13 insertions(+), 1 deletion(-) diff --git a/R/module_input.R b/R/module_input.R index 2cfad2ed..d532de7e 100644 --- a/R/module_input.R +++ b/R/module_input.R @@ -10,11 +10,17 @@ helper_input <- function(id, ) } +#' @export module_input_ui <- function(id, label, spec) { ns <- NS(id) input <- tagList( a(label), ) + + if (valid_transform(spec)) { + stop("Unexpected object used as specification.") + } + l <- lapply(spec, function(x) { helper_input(ns(is(x)), paste("Select", is(x), collapse = " "), @@ -24,6 +30,7 @@ module_input_ui <- function(id, label, spec) { input <- tagList(input, l) } +#' @export module_input_server <- function(id, spec, data) { stopifnot(is.transform(spec)) stopifnot(is.reactive(data)) diff --git a/R/types.R b/R/types.R index 1cc058ea..bce53884 100644 --- a/R/types.R +++ b/R/types.R @@ -2,6 +2,11 @@ is.transform <- function(x) { inherits(x, "transform") } + +valid_transform <- function(x) { + !((is.type(x) || is.transform(x)) || or.transform(x)) +} + or.transform <- function(x) { is.list(x) && all(vapply(x, function(x) { is.transform(x) || is.type(x) diff --git a/R/update_spec.R b/R/update_spec.R index 05ae0248..00e6efa8 100644 --- a/R/update_spec.R +++ b/R/update_spec.R @@ -29,7 +29,7 @@ update_spec <- function(spec, type, value) { ) } - if (!((is.type(spec) || is.transform(spec)) || or.transform(spec))) { + if (valid_transform(spec)) { stop("Unexpected object used as specification") } From c7f267566449a51026fee4432fcfe8ba54b262f4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Wed, 9 Apr 2025 18:01:37 +0200 Subject: [PATCH 071/142] Merge from a list of inputs --- R/merge_dataframes.R | 72 +++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 71 insertions(+), 1 deletion(-) diff --git a/R/merge_dataframes.R b/R/merge_dataframes.R index 4eeb87b8..1fb28f1c 100644 --- a/R/merge_dataframes.R +++ b/R/merge_dataframes.R @@ -3,12 +3,82 @@ merge_module_ui <- function(id) { renderText(ns("a")) } +consolidate_extraction <- function(...) { + if (...length() > 1) { + input_resolved <- as.list(...) + } else { + input_resolved <- ..1 + } + + datasets <- lapply(input_resolved, function(x){x$datasets}) + # Assume the data is a data.frame so no other specifications types are present. + variables <- lapply(input_resolved, function(x){x$variables}) + lapply(unique(datasets), + function(dataset, x, y) { + list("datasets" = dataset, "variables" = y[x == dataset]) + }, x = datasets, y = variables) +} + +add_ids <- function(input, data) { + + jk <- join_keys(data) + if (!length(jk)) { + return(input) + } + + datasets <- names(input) + l <- lapply(datasets, function(x, join_keys, i) { + c(i[[x]], unique(unlist(jk[[x]]))) + }, join_keys = jk, i = input) + + names(l) <- datasets +} + + +extract_ids <- function(input, data) { + jk <- join_keys(data) + # No join_keys => input + if (!length(jk)) { + input <- unlist(input) + tab <- table(input) + out <- names(tab)[tab > 1] + + if (length(out)) { + ei <- extract_input(input, data) + tab0 <- unlist(lapply(ei, colnames)) + tab <- table(tab0) + out <- names(tab)[tab > 1] + } + return(out) + } + + l <- lapply(datasets, function(x, join_keys) { + unique(unlist(jk[[x]])) + }, join_keys = jk) + out <- unique(unlist(l)) +} + merge_module_srv <- function(id, ..., data, ids, type) { # stopifnot(is.reactive(data)) stopifnot(is.character(id)) moduleServer(id, function(input, output, session) { out <- reactive({ - input_list <- list(...) + if (...length() == 1L && is.list(..1)) { + input_list <- ..1 + } else { + input_list <- list(...) + } + + input_list <- consolidate_extraction(input_list) + + # No merge is needed + if (length(input_list) == 1L) { + out <- extract_input(input_list, data) + output$out <- out + return(out) + } + # Add ids to merge by them if known + input_list <- add_ids(input_list, data) input_data <- lapply(input_list, extract_input, data = data) merging(input_data, ids = ids, type = type) }) From b733b34843477169e39cd318c9aa40a59a6c4fd7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Thu, 10 Apr 2025 14:46:57 +0200 Subject: [PATCH 072/142] Make it possible to consolidate input and extraction --- R/merge_dataframes.R | 28 +++++++++++++++------------- 1 file changed, 15 insertions(+), 13 deletions(-) diff --git a/R/merge_dataframes.R b/R/merge_dataframes.R index 1fb28f1c..42c49a9c 100644 --- a/R/merge_dataframes.R +++ b/R/merge_dataframes.R @@ -1,3 +1,4 @@ + merge_module_ui <- function(id) { ns <- NS(id) renderText(ns("a")) @@ -5,7 +6,7 @@ merge_module_ui <- function(id) { consolidate_extraction <- function(...) { if (...length() > 1) { - input_resolved <- as.list(...) + input_resolved <- list(...) } else { input_resolved <- ..1 } @@ -15,7 +16,7 @@ consolidate_extraction <- function(...) { variables <- lapply(input_resolved, function(x){x$variables}) lapply(unique(datasets), function(dataset, x, y) { - list("datasets" = dataset, "variables" = y[x == dataset]) + list("datasets" = dataset, "variables" = unique(unlist(y[x == dataset]))) }, x = datasets, y = variables) } @@ -26,12 +27,14 @@ add_ids <- function(input, data) { return(input) } - datasets <- names(input) - l <- lapply(datasets, function(x, join_keys, i) { - c(i[[x]], unique(unlist(jk[[x]]))) - }, join_keys = jk, i = input) - - names(l) <- datasets + datasets <- lapply(input, function(x){x$datasets}) + for (i in seq_along(input)) { + x <- input[[i]] + # Avoid adding as id something already present. + ids <- setdiff(unique(unlist(jk[[x$datasets]])), x$variables) + input[[i]][["variables"]] <- c(x$variables, ids) + } + input } @@ -44,10 +47,7 @@ extract_ids <- function(input, data) { out <- names(tab)[tab > 1] if (length(out)) { - ei <- extract_input(input, data) - tab0 <- unlist(lapply(ei, colnames)) - tab <- table(tab0) - out <- names(tab)[tab > 1] + return(NULL) } return(out) } @@ -80,7 +80,9 @@ merge_module_srv <- function(id, ..., data, ids, type) { # Add ids to merge by them if known input_list <- add_ids(input_list, data) input_data <- lapply(input_list, extract_input, data = data) - merging(input_data, ids = ids, type = type) + # TODO: return an expression + # Evaluation should be addressed by eval_code(qenv, code = output) + merging(input_data, ids = extract_ids(input_list, data), type = type) }) output$out <- out out From 1134bbd4949da759f303932b87d197994c6dff2e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Thu, 10 Apr 2025 17:29:28 +0200 Subject: [PATCH 073/142] Increase version --- DESCRIPTION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index 0150a808..72882ca9 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: teal.transform Title: Functions for Extracting and Merging Data in the 'teal' Framework -Version: 0.6.0.9000 +Version: 0.6.0.9001 Date: 2025-02-12 Authors@R: c( person("Dawid", "Kaledkowski", , "dawid.kaledkowski@roche.com", role = c("aut", "cre")), From cc26a2553689c11d0ec993e2e21a1406ced14f14 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Thu, 24 Apr 2025 09:48:23 +0200 Subject: [PATCH 074/142] Merge data.frames within qenv --- NAMESPACE | 2 + R/extract.R | 32 ++++++ R/merge_dataframes.R | 233 +++++++++++++------------------------------ 3 files changed, 105 insertions(+), 162 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 80442543..bc4c5a81 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -87,6 +87,8 @@ export(mae_sampleMap) export(merge_datasets) export(merge_expression_module) export(merge_expression_srv) +export(module_input_server) +export(module_input_ui) export(no_selected_as_NULL) export(resolve_delayed) export(resolver) diff --git a/R/extract.R b/R/extract.R index d315ffe4..03012585 100644 --- a/R/extract.R +++ b/R/extract.R @@ -54,3 +54,35 @@ extract.default <- function(x, variable, ..., drop = TRUE) { # extract.qenv <- function(x, variable) { # x[[variable]] # } + +# Get code to be evaluated & displayed by modules +extract_srv <- function(id, input) { + stopifnot(is.null(input$datasets)) + stopifnot(is.null(input$variables)) + moduleServer( + id, + function(input, output, session) { + + obj <- extract(data(), input$datasets) + method <- paste0("extract.", class(obj)) + method <- dynGet(method, ifnotfound = "extract.default", inherits = TRUE) + if (identical(method, "extract.default")) { + b <- get("extract.default") + } else { + b <- get(method) + } + # Extract definition + extract_f_def <- call("<-", x = as.name("extract"), value = b) + q <- eval_code(data(), code = extract_f_def) + + # Extraction happening: + # FIXME assumes only to variables used + output <- call("<-", x = as.name(input$datasets), value = + substitute( + extract(obj, variables), + list(obj = as.name(input$datasets), + variables = input$variables))) + q <- eval_code(q, code = output) + }) +} + diff --git a/R/merge_dataframes.R b/R/merge_dataframes.R index 42c49a9c..7b2f7ba1 100644 --- a/R/merge_dataframes.R +++ b/R/merge_dataframes.R @@ -1,9 +1,5 @@ - -merge_module_ui <- function(id) { - ns <- NS(id) - renderText(ns("a")) -} - +# Simplify multiple datasets & variables into the bare minimum necessary. +# This simplifies the number of extractions and merging required consolidate_extraction <- function(...) { if (...length() > 1) { input_resolved <- list(...) @@ -11,42 +7,45 @@ consolidate_extraction <- function(...) { input_resolved <- ..1 } - datasets <- lapply(input_resolved, function(x){x$datasets}) # Assume the data is a data.frame so no other specifications types are present. - variables <- lapply(input_resolved, function(x){x$variables}) + datasets <- lapply(input_resolved, `$`, name = datasets) + variables <- lapply(input_resolved, `$`, name = variables) lapply(unique(datasets), function(dataset, x, y) { - list("datasets" = dataset, "variables" = unique(unlist(y[x == dataset]))) + list("datasets" = dataset, + "variables" = unique(unlist(y[x == dataset]))) }, x = datasets, y = variables) } +# Function to add ids of data.frames to the output of modules to enable merging them. add_ids <- function(input, data) { jk <- join_keys(data) + # If no join keys they should be on the input if (!length(jk)) { return(input) } - datasets <- lapply(input, function(x){x$datasets}) + datasets <- lapply(input, `$`, name = datasets) for (i in seq_along(input)) { x <- input[[i]] - # Avoid adding as id something already present. + # Avoid adding as id something already present: No duplicating input. ids <- setdiff(unique(unlist(jk[[x$datasets]])), x$variables) input[[i]][["variables"]] <- c(x$variables, ids) } input } - +# Find common ids to enable merging. extract_ids <- function(input, data) { - jk <- join_keys(data) + jk <- teal.data::join_keys(data) # No join_keys => input if (!length(jk)) { input <- unlist(input) tab <- table(input) out <- names(tab)[tab > 1] - if (length(out)) { + if (!length(out)) { return(NULL) } return(out) @@ -58,180 +57,90 @@ extract_ids <- function(input, data) { out <- unique(unlist(l)) } -merge_module_srv <- function(id, ..., data, ids, type) { - # stopifnot(is.reactive(data)) - stopifnot(is.character(id)) - moduleServer(id, function(input, output, session) { - out <- reactive({ - if (...length() == 1L && is.list(..1)) { - input_list <- ..1 - } else { - input_list <- list(...) - } - - input_list <- consolidate_extraction(input_list) - - # No merge is needed - if (length(input_list) == 1L) { - out <- extract_input(input_list, data) - output$out <- out - return(out) - } - # Add ids to merge by them if known - input_list <- add_ids(input_list, data) - input_data <- lapply(input_list, extract_input, data = data) - # TODO: return an expression - # Evaluation should be addressed by eval_code(qenv, code = output) - merging(input_data, ids = extract_ids(input_list, data), type = type) - }) - output$out <- out - out - }) -} +merge_call_pair <- function(selections, by, data, + merge_function = "dplyr::full_join", + anl_name = "ANL") { + stopifnot(length(selections) == 2L) + datasets <- sapply(selections, function(x){x$datasets}) + by <- extract_ids(input = selections, data) + + if (grepl("::", merge_function, fixed = TRUE)) { + m <- strsplit(merge_function, split = "::", fixed = TRUE)[[1]] + data <- eval_code(data, call("library", m[1])) + merge_function <- m[2] + } -extract_input <- function(input, data) { - for (i in input) { - # Extract data recursively: only works on lists and square objects (no MAE or similar) - # To work on new classes implement an extract.class method - # Assumes order of extraction on the input: qenv > datasets > variables - # IF datasetes > variables > qenv order - data <- extract(data, i, drop = FALSE) + if (!missing(by) && length(by)) { + call_m <- call(merge_function, + x = as.name(datasets[1]), + y = as.name(datasets[2]), + by = by) + } else { + call_m <- call(merge_function, + x = as.name(datasets[1]), + y = as.name(datasets[2])) } - data + call_m } -# Allows merging arbitrary number of data.frames by ids and type +merge_call_multiple <- function(input, ids, merge_function, data, + anl_name = "ANL") { -merging <- function(..., ids, type) { - input_as_list <- is.list(..1) & ...length() == 1L - if (input_as_list) { - list_df <- ..1 - } else { - list_df <- list(...) - } - number_merges <- length(list_df) - 1L + datasets <- sapply(input, function(x){x$datasets}) + stopifnot(is.character(datasets) && length(datasets) >= 1L) + number_merges <- length(datasets) - 1L stopifnot( "Number of datasets is enough" = number_merges >= 1L, - "Number of arguments for type matches data" = length(type) == number_merges || length(type) == 1L + "Number of arguments for type matches data" = length(merge_function) == number_merges || length(merge_function) == 1L ) - if (!missing(ids)) { stopifnot("Number of arguments for ids matches data" = !(is.list(ids) && length(ids) == number_merges)) } - if (length(type) != number_merges) { - type <- rep(type, number_merges) + if (length(merge_function) != number_merges) { + merge_function <- rep(merge_function, number_merges) } if (!missing(ids) && length(ids) != number_merges) { ids <- rep(ids, number_merges) } - if (number_merges == 1L && !input_as_list && !missing(ids)) { - return(self_merging(..1, ..2, ids = ids, type = type)) - } else if (number_merges == 1L && !input_as_list && missing(ids)) { - return(self_merging(..1, ..2, type = type)) - } else if (number_merges == 1L && input_as_list && missing(ids)) { - return(self_merging(list_df[[1]], list_df[[2]], type = type)) - } else if (number_merges == 1L && input_as_list && !missing(ids)) { - return(self_merging(list_df[[1]], list_df[[2]], ids = ids, type = type)) + if (number_merges == 1L && missing(ids)) { + previous <- merge_call_pair(input, merge_function = merge_function, data = data) + final_call <- call("<-", x = as.name(anl_name), value = previous) + return(eval_code(data, final_call)) + } else if (number_merges == 1L && !missing(ids)) { + previous <- merge_call_pair(input, by = ids, merge_function = merge_function, data = data) + final_call <- call("<-", x = as.name(anl_name), value = previous) + return(eval_code(data, final_call)) } + + for (merge_i in seq_len(number_merges)) { - message(merge_i) if (merge_i == 1L) { - if (missing(ids)) { - ids <- intersect(colnames(list_df[[merge_i]]), colnames(list_df[[merge_i + 1L]])) - } else { + datasets_i <- seq_len(2) + if (!missing(ids)) { ids <- ids[[merge_i]] + previous <- merge_call_pair(input[datasets_i], + ids, + merge_function[merge_i], data = data) + } else { + previous <- merge_call_pair(input[datasets_i], + merge_function[merge_i], data = data) } - out <- self_merging(list_df[[merge_i]], list_df[[merge_i + 1L]], - ids, - type = type[[merge_i]] - ) } else { - if (missing(ids)) { - ids <- intersect(colnames(out, colnames(list_df[[merge_i + 1L]]))) + datasets_ids <- merge_i:(merge_i + 1L) + if (!missing(ids)) { + current <- merge_call_pair(input[datasets_ids], + type = merge_function[merge_i], data = data) } else { ids <- ids[[merge_i]] - } - out <- self_merging(out, list_df[[merge_i + 1L]], - ids, - type = type[[merge_i]] - ) - } - } - out -} - - -# self_merge(df1, df2) almost equal to self_merge(df2, df1): Only changes on the column order. -self_merging <- function(e1, e2, ids = intersect(colnames(e1), colnames(e2)), type) { - # Get the name of the variables to use as suffix. - # If we need the name at higher environments (ie: f(self_merging()) ) it could use rlang (probably) - name1 <- deparse(substitute(e1)) - name2 <- deparse(substitute(e2)) - suffix1 <- paste0(".", name1) - suffix2 <- paste0(".", name2) - ce1 <- colnames(e1) - ce2 <- colnames(e2) - type <- match.arg(type, c("inner", "left", "right", "full")) - - # Called by its side effects of adding the two variables the the current environment - switch(type, - inner = { - all.x <- FALSE - all.y <- FALSE - }, - full = { - all.x <- TRUE - all.y <- TRUE - }, - left = { - all.x <- TRUE - all.y <- FALSE - }, - right = { - all.x <- FALSE - all.y <- TRUE - }, - { - all.x <- FALSE - all.y <- FALSE - } - ) - - if (!is.null(names(ids))) { - name_ids <- names(ids) - } else { - name_ids <- ids - } - - if (!all(ids %in% name_ids) && !all(ids %in% ce2)) { - stop("Not all ids are in both objects") - } - # The default generic should find the right method, if not we : - # a) ask for the method to be implemented or - # b) implement it ourselves here to be used internally. - mm <- merge(e1, e2, - all.x = all.x, all.y = all.y, - by.x = name_ids, by.y = ids, - suffixes = c(".e1", ".e2") - ) - g <- grep("\\.[(e1)(e2)]", colnames(mm)) - if (length(g)) { - mix_columns <- setdiff(intersect(ce1, ce2), ids) - for (column in mix_columns) { - mc1 <- paste0(column, ".e1") - mc2 <- paste0(column, ".e2") - # Rename column and delete one if they are the same - if (identical(mm[, mc1], mm[, mc2])) { - mm[, mc2] <- NULL - colnames(mm)[colnames(mm) %in% mc1] <- column - } else { - # Rename to keep the suffic of the data names - colnames(mm)[colnames(mm) %in% mc1] <- paste0(column, suffix1) - colnames(mm)[colnames(mm) %in% mc2] <- paste0(column, suffix2) + current <- merge_call_pair(input[datasets_ids], + ids, + type = merge_function[merge_i], data = data) } } + previous <- call("%>%", as.name(previous), as.name(current)) } - mm + final_call <- call("<-", x = as.name(anl_name), value = previous) + eval_code(data, final_call) } From 1c2ddadc7e65483934d9c60b8b6b410b34c0e660 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Thu, 24 Apr 2025 09:49:42 +0200 Subject: [PATCH 075/142] WIP: add ! operator --- R/ops_transform.R | 15 ++++++++++---- R/resolver.R | 32 +++++++++++++++++++++++------ R/types.R | 52 ++++++++++++++++++++++++++++++++--------------- 3 files changed, 73 insertions(+), 26 deletions(-) diff --git a/R/ops_transform.R b/R/ops_transform.R index 58ca87bb..8ff9da0b 100644 --- a/R/ops_transform.R +++ b/R/ops_transform.R @@ -18,10 +18,11 @@ Ops.transform <- function(e1, e2) { #' @export Ops.type <- function(e1, e2) { if (missing(e2)) { - # out <- switch(.Generic, - # "!" = Negate, - stop("Method ", sQuote(.Generic), " not implemented for this class ", .Class, ".", call. = FALSE) - # return(out) + out <- switch(.Generic, + "!" = negate_type(e1), + stop("Method ", sQuote(.Generic), + " not implemented for this class ", .Class, ".", call. = FALSE)) + return(out) } out <- switch(.Generic, "!=" = NextMethod(), @@ -114,6 +115,12 @@ or_type <- function(e1, e2) { } +negate_type <- function(e1, e2) { + out <- list(except = e1$names) + class(out) <- class(e1) + out +} + # chooseOpsMethod.list <- function(x, y, mx, my, cl, reverse) TRUE #' @export chooseOpsMethod.transform <- function(x, y, mx, my, cl, reverse) { diff --git a/R/resolver.R b/R/resolver.R index 7e620298..058a48a7 100644 --- a/R/resolver.R +++ b/R/resolver.R @@ -171,15 +171,25 @@ determine_helper <- function(type, data_names, data) { stopifnot(!is.null(type)) orig_names <- type$names orig_select <- type$select + orig_exc <- type$except if (is.delayed(type) && all(is.character(type$names))) { - match <- intersect(data_names, type$names) - type$names <- match - if (length(match) == 0) { + new_names <- intersect(data_names, type$names) + + if (!is.null(type$except)) { + excludes <- c(functions_names(type$except, data_names), + functions_data(type$except, data_names, data)) + type$except <- excludes + original(type$except, "original") <- orig(orig_exc) + new_names <- setdiff(new_names, excludes) + } + + type$names <- new_names + if (length(new_names) == 0) { return(NULL) # stop("No selected ", is(type), " matching the conditions requested") - } else if (length(match) == 1L) { - type$select <- match + } else if (length(new_names) == 1L) { + type$select <- new_names } else { new_select <- functions_names(type$select, type$names) new_select <- unique(new_select[!is.na(new_select)]) @@ -190,7 +200,6 @@ determine_helper <- function(type, data_names, data) { type$select <- new_select } } else if (is.delayed(type)) { - old_names <- type$names new_names <- c( functions_names(type$names, data_names), functions_data(type$names, data_names, data) @@ -198,6 +207,17 @@ determine_helper <- function(type, data_names, data) { new_names <- unlist(unique(new_names[!is.na(new_names)]), use.names = FALSE ) + + if (!is.null(type$except)) { + excludes <- c(functions_names(type$except, data_names), + functions_data(type$except, data_names, data)) + + type$except <- excludes + original(type$except, "original") <- orig(orig_exc) + + new_names <- setdiff(new_names, excludes) + } + if (!length(new_names)) { return(NULL) # stop("No ", is(type), " meet the requirements") diff --git a/R/types.R b/R/types.R index bce53884..f58e8a45 100644 --- a/R/types.R +++ b/R/types.R @@ -202,10 +202,9 @@ c.type <- function(...) { vector <- vector("list", length(utypes)) names(vector) <- utypes for (t in utypes) { - new_type <- vector("list", length = 2) - names(new_type) <- c("names", "select") + new_type <- vector("list", length = 3) + names(new_type) <- c("names", "select", "except") for (i in seq_along(l)) { - names_l <- names(l[[i]]) if (!is(l[[i]], t)) { next } @@ -217,6 +216,10 @@ c.type <- function(...) { ), orig(l[[i]][["names"]])) new_type$select <- unique(c(old_select, l[[i]][["select"]])) attr(new_type$select, "original") <- c(orig(old_select), orig(l[[i]][["select"]])) + + new_type$except <- c(new_type$except, l[[i]][["except"]]) + attr(new_type$except, "original") <- c(orig(l[[i]][["except"]]), orig(new_type$except)) + } orig_names <- unique(orig(new_type$names)) orig_select <- unique(orig(new_type$select)) @@ -251,12 +254,7 @@ print.type <- function(x, ...) { return(x) } - nam_list <- is.list(x$names) - if (nam_list) { - nam_functions <- vapply(x$names, is.function, logical(1L)) - } else { - nam_functions <- FALSE - } + nam_functions <- count_functions(x$names) msg_values <- character() nam_values <- length(x$names) - sum(nam_functions) @@ -272,12 +270,7 @@ print.type <- function(x, ...) { ) } - sel_list <- is.list(x$select) - if (sel_list) { - sel_functions <- vapply(x$select, is.function, logical(1L)) - } else { - sel_functions <- FALSE - } + sel_functions <- count_functions(x$select) msg_sel <- character() sel_values <- length(x$select) - sum(sel_functions) @@ -292,6 +285,33 @@ print.type <- function(x, ...) { collapse = "\n" ) } - cat(msg_values, msg_sel) + if (!is.null(x[["except"]])) { + exc_functions <- count_functions(x$except) + msg_exc <- character() + sel_values <- length(x$except) - sum(exc_functions) + if (any(exc_functions)) { + msg_exc <- paste0(msg_exc, sum(exc_functions), " functions to exclude.", + collapse = "\n" + ) + } + if (sel_values) { + msg_exc <- paste0(msg_exc, paste0(sQuote(x$except[!exc_functions]), collapse = ", "), + " excluded.", + collapse = "\n" + ) + } + } else { + msg_exc <- character() + } + + cat(msg_values, msg_sel, msg_exc) return(x) } + +count_functions <- function(x) { + if (is.list(x)) { + vapply(x, is.function, logical(1L)) + } else { + FALSE + } +} From d27750fc3e4cf437aec34ab8f4391639b60a4507 Mon Sep 17 00:00:00 2001 From: github-actions <41898282+github-actions[bot]@users.noreply.github.com> Date: Thu, 24 Apr 2025 08:52:43 +0000 Subject: [PATCH 076/142] [skip style] [skip vbump] Restyle files --- R/extract.R | 20 ++++++++++------- R/merge_dataframes.R | 52 ++++++++++++++++++++++++++++---------------- R/ops_transform.R | 9 +++++--- R/resolver.R | 12 ++++++---- R/types.R | 7 +++--- 5 files changed, 62 insertions(+), 38 deletions(-) diff --git a/R/extract.R b/R/extract.R index 03012585..1ee7ecc1 100644 --- a/R/extract.R +++ b/R/extract.R @@ -62,7 +62,6 @@ extract_srv <- function(id, input) { moduleServer( id, function(input, output, session) { - obj <- extract(data(), input$datasets) method <- paste0("extract.", class(obj)) method <- dynGet(method, ifnotfound = "extract.default", inherits = TRUE) @@ -77,12 +76,17 @@ extract_srv <- function(id, input) { # Extraction happening: # FIXME assumes only to variables used - output <- call("<-", x = as.name(input$datasets), value = - substitute( - extract(obj, variables), - list(obj = as.name(input$datasets), - variables = input$variables))) + output <- call("<-", + x = as.name(input$datasets), value = + substitute( + extract(obj, variables), + list( + obj = as.name(input$datasets), + variables = input$variables + ) + ) + ) q <- eval_code(q, code = output) - }) + } + ) } - diff --git a/R/merge_dataframes.R b/R/merge_dataframes.R index 7b2f7ba1..6be7d9a2 100644 --- a/R/merge_dataframes.R +++ b/R/merge_dataframes.R @@ -11,15 +11,18 @@ consolidate_extraction <- function(...) { datasets <- lapply(input_resolved, `$`, name = datasets) variables <- lapply(input_resolved, `$`, name = variables) lapply(unique(datasets), - function(dataset, x, y) { - list("datasets" = dataset, - "variables" = unique(unlist(y[x == dataset]))) - }, x = datasets, y = variables) + function(dataset, x, y) { + list( + "datasets" = dataset, + "variables" = unique(unlist(y[x == dataset])) + ) + }, + x = datasets, y = variables + ) } # Function to add ids of data.frames to the output of modules to enable merging them. add_ids <- function(input, data) { - jk <- join_keys(data) # If no join keys they should be on the input if (!length(jk)) { @@ -61,7 +64,9 @@ merge_call_pair <- function(selections, by, data, merge_function = "dplyr::full_join", anl_name = "ANL") { stopifnot(length(selections) == 2L) - datasets <- sapply(selections, function(x){x$datasets}) + datasets <- sapply(selections, function(x) { + x$datasets + }) by <- extract_ids(input = selections, data) if (grepl("::", merge_function, fixed = TRUE)) { @@ -72,21 +77,24 @@ merge_call_pair <- function(selections, by, data, if (!missing(by) && length(by)) { call_m <- call(merge_function, - x = as.name(datasets[1]), - y = as.name(datasets[2]), - by = by) + x = as.name(datasets[1]), + y = as.name(datasets[2]), + by = by + ) } else { call_m <- call(merge_function, - x = as.name(datasets[1]), - y = as.name(datasets[2])) + x = as.name(datasets[1]), + y = as.name(datasets[2]) + ) } call_m } merge_call_multiple <- function(input, ids, merge_function, data, anl_name = "ANL") { - - datasets <- sapply(input, function(x){x$datasets}) + datasets <- sapply(input, function(x) { + x$datasets + }) stopifnot(is.character(datasets) && length(datasets) >= 1L) number_merges <- length(datasets) - 1L stopifnot( @@ -121,22 +129,28 @@ merge_call_multiple <- function(input, ids, merge_function, data, if (!missing(ids)) { ids <- ids[[merge_i]] previous <- merge_call_pair(input[datasets_i], - ids, - merge_function[merge_i], data = data) + ids, + merge_function[merge_i], + data = data + ) } else { previous <- merge_call_pair(input[datasets_i], - merge_function[merge_i], data = data) + merge_function[merge_i], + data = data + ) } } else { datasets_ids <- merge_i:(merge_i + 1L) if (!missing(ids)) { current <- merge_call_pair(input[datasets_ids], - type = merge_function[merge_i], data = data) + type = merge_function[merge_i], data = data + ) } else { ids <- ids[[merge_i]] current <- merge_call_pair(input[datasets_ids], - ids, - type = merge_function[merge_i], data = data) + ids, + type = merge_function[merge_i], data = data + ) } } previous <- call("%>%", as.name(previous), as.name(current)) diff --git a/R/ops_transform.R b/R/ops_transform.R index 8ff9da0b..67d6dad0 100644 --- a/R/ops_transform.R +++ b/R/ops_transform.R @@ -19,9 +19,12 @@ Ops.transform <- function(e1, e2) { Ops.type <- function(e1, e2) { if (missing(e2)) { out <- switch(.Generic, - "!" = negate_type(e1), - stop("Method ", sQuote(.Generic), - " not implemented for this class ", .Class, ".", call. = FALSE)) + "!" = negate_type(e1), + stop("Method ", sQuote(.Generic), + " not implemented for this class ", .Class, ".", + call. = FALSE + ) + ) return(out) } out <- switch(.Generic, diff --git a/R/resolver.R b/R/resolver.R index 058a48a7..4d664836 100644 --- a/R/resolver.R +++ b/R/resolver.R @@ -177,8 +177,10 @@ determine_helper <- function(type, data_names, data) { new_names <- intersect(data_names, type$names) if (!is.null(type$except)) { - excludes <- c(functions_names(type$except, data_names), - functions_data(type$except, data_names, data)) + excludes <- c( + functions_names(type$except, data_names), + functions_data(type$except, data_names, data) + ) type$except <- excludes original(type$except, "original") <- orig(orig_exc) new_names <- setdiff(new_names, excludes) @@ -209,8 +211,10 @@ determine_helper <- function(type, data_names, data) { ) if (!is.null(type$except)) { - excludes <- c(functions_names(type$except, data_names), - functions_data(type$except, data_names, data)) + excludes <- c( + functions_names(type$except, data_names), + functions_data(type$except, data_names, data) + ) type$except <- excludes original(type$except, "original") <- orig(orig_exc) diff --git a/R/types.R b/R/types.R index f58e8a45..0cec0468 100644 --- a/R/types.R +++ b/R/types.R @@ -219,7 +219,6 @@ c.type <- function(...) { new_type$except <- c(new_type$except, l[[i]][["except"]]) attr(new_type$except, "original") <- c(orig(l[[i]][["except"]]), orig(new_type$except)) - } orig_names <- unique(orig(new_type$names)) orig_select <- unique(orig(new_type$select)) @@ -291,13 +290,13 @@ print.type <- function(x, ...) { sel_values <- length(x$except) - sum(exc_functions) if (any(exc_functions)) { msg_exc <- paste0(msg_exc, sum(exc_functions), " functions to exclude.", - collapse = "\n" + collapse = "\n" ) } if (sel_values) { msg_exc <- paste0(msg_exc, paste0(sQuote(x$except[!exc_functions]), collapse = ", "), - " excluded.", - collapse = "\n" + " excluded.", + collapse = "\n" ) } } else { From 810ce49a0aa815d709d7abc3eae0c0012572c502 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Thu, 24 Apr 2025 12:36:40 +0200 Subject: [PATCH 077/142] Address some checks warnings --- DESCRIPTION | 1 + R/extract.R | 8 ++++---- R/merge_dataframes.R | 14 +++++++------- R/resolver.R | 4 ++-- 4 files changed, 14 insertions(+), 13 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 2908ce62..6608015d 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -31,6 +31,7 @@ Imports: shinyjs, shinyvalidate (>= 0.1.3), stats, + teal.code (>= 0.6.0), teal.data (>= 0.7.0), teal.logger (>= 0.3.1), teal.widgets (>= 0.4.3), diff --git a/R/extract.R b/R/extract.R index 1ee7ecc1..162620f8 100644 --- a/R/extract.R +++ b/R/extract.R @@ -56,13 +56,13 @@ extract.default <- function(x, variable, ..., drop = TRUE) { # } # Get code to be evaluated & displayed by modules -extract_srv <- function(id, input) { +extract_srv <- function(id, input, data) { stopifnot(is.null(input$datasets)) stopifnot(is.null(input$variables)) moduleServer( id, function(input, output, session) { - obj <- extract(data(), input$datasets) + obj <- extract(data, input$datasets) method <- paste0("extract.", class(obj)) method <- dynGet(method, ifnotfound = "extract.default", inherits = TRUE) if (identical(method, "extract.default")) { @@ -72,7 +72,7 @@ extract_srv <- function(id, input) { } # Extract definition extract_f_def <- call("<-", x = as.name("extract"), value = b) - q <- eval_code(data(), code = extract_f_def) + q <- teal.code::eval_code(data, code = extract_f_def) # Extraction happening: # FIXME assumes only to variables used @@ -86,7 +86,7 @@ extract_srv <- function(id, input) { ) ) ) - q <- eval_code(q, code = output) + q <- teal.code::eval_code(q, code = output) } ) } diff --git a/R/merge_dataframes.R b/R/merge_dataframes.R index 6be7d9a2..3ba12c80 100644 --- a/R/merge_dataframes.R +++ b/R/merge_dataframes.R @@ -23,7 +23,7 @@ consolidate_extraction <- function(...) { # Function to add ids of data.frames to the output of modules to enable merging them. add_ids <- function(input, data) { - jk <- join_keys(data) + jk <- teal.data::join_keys(data) # If no join keys they should be on the input if (!length(jk)) { return(input) @@ -71,7 +71,7 @@ merge_call_pair <- function(selections, by, data, if (grepl("::", merge_function, fixed = TRUE)) { m <- strsplit(merge_function, split = "::", fixed = TRUE)[[1]] - data <- eval_code(data, call("library", m[1])) + data <- teal.code::eval_code(data, call("library", m[1])) merge_function <- m[2] } @@ -114,11 +114,11 @@ merge_call_multiple <- function(input, ids, merge_function, data, if (number_merges == 1L && missing(ids)) { previous <- merge_call_pair(input, merge_function = merge_function, data = data) final_call <- call("<-", x = as.name(anl_name), value = previous) - return(eval_code(data, final_call)) + return(teal.code::eval_code(data, final_call)) } else if (number_merges == 1L && !missing(ids)) { previous <- merge_call_pair(input, by = ids, merge_function = merge_function, data = data) final_call <- call("<-", x = as.name(anl_name), value = previous) - return(eval_code(data, final_call)) + return(teal.code::eval_code(data, final_call)) } @@ -143,18 +143,18 @@ merge_call_multiple <- function(input, ids, merge_function, data, datasets_ids <- merge_i:(merge_i + 1L) if (!missing(ids)) { current <- merge_call_pair(input[datasets_ids], - type = merge_function[merge_i], data = data + merge_function = merge_function[merge_i], data = data ) } else { ids <- ids[[merge_i]] current <- merge_call_pair(input[datasets_ids], ids, - type = merge_function[merge_i], data = data + merge_function = merge_function[merge_i], data = data ) } } previous <- call("%>%", as.name(previous), as.name(current)) } final_call <- call("<-", x = as.name(anl_name), value = previous) - eval_code(data, final_call) + teal.code::eval_code(data, final_call) } diff --git a/R/resolver.R b/R/resolver.R index 4d664836..a85ea2e3 100644 --- a/R/resolver.R +++ b/R/resolver.R @@ -182,7 +182,7 @@ determine_helper <- function(type, data_names, data) { functions_data(type$except, data_names, data) ) type$except <- excludes - original(type$except, "original") <- orig(orig_exc) + attr(type$except, "original") <- orig(orig_exc) new_names <- setdiff(new_names, excludes) } @@ -217,7 +217,7 @@ determine_helper <- function(type, data_names, data) { ) type$except <- excludes - original(type$except, "original") <- orig(orig_exc) + attr(type$except, "original") <- orig(orig_exc) new_names <- setdiff(new_names, excludes) } From 8cea67418829ca3082966d8852efcad8cc857e1f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Thu, 24 Apr 2025 12:37:04 +0200 Subject: [PATCH 078/142] WIP: Add tests for ! operator --- tests/testthat/test-ops_transform.R | 1 + tests/testthat/test-resolver.R | 10 ++++++++++ 2 files changed, 11 insertions(+) diff --git a/tests/testthat/test-ops_transform.R b/tests/testthat/test-ops_transform.R index e712ee25..a015b709 100644 --- a/tests/testthat/test-ops_transform.R +++ b/tests/testthat/test-ops_transform.R @@ -24,6 +24,7 @@ basic_ops <- function(fun) { expect_error(FUN("ABC") & 1) out <- type1 & type2b expect_true(is.list(out$names)) + expect_no_error(type1 & !type2) } test_that("datasets & work", { diff --git a/tests/testthat/test-resolver.R b/tests/testthat/test-resolver.R index d0c68701..8b265eef 100644 --- a/tests/testthat/test-resolver.R +++ b/tests/testthat/test-resolver.R @@ -77,6 +77,16 @@ test_that("resolver values works", { expect_no_error(resolver(df & var_a & val_A, td)) }) +test_that("resolver works with excluded types", { + td <- within(teal.data::teal_data(), { + df <- data.frame(a = LETTERS[1:5], + b = factor(letters[1:5]), + c = factor(letters[1:5])) + }) + spec <- datasets("df") & variables(c("a", "b")) & !variables("b") + expect_no_error(resolver(spec, td)) +}) + test_that("names and variables are reported", { td <- within(teal.data::teal_data(), { df <- data.frame( From cf4c5b2fd7449dbba1e792d30311f9023a9f3dde Mon Sep 17 00:00:00 2001 From: github-actions <41898282+github-actions[bot]@users.noreply.github.com> Date: Thu, 24 Apr 2025 10:39:19 +0000 Subject: [PATCH 079/142] [skip style] [skip vbump] Restyle files --- tests/testthat/test-resolver.R | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/tests/testthat/test-resolver.R b/tests/testthat/test-resolver.R index 8b265eef..d061e442 100644 --- a/tests/testthat/test-resolver.R +++ b/tests/testthat/test-resolver.R @@ -79,9 +79,11 @@ test_that("resolver values works", { test_that("resolver works with excluded types", { td <- within(teal.data::teal_data(), { - df <- data.frame(a = LETTERS[1:5], - b = factor(letters[1:5]), - c = factor(letters[1:5])) + df <- data.frame( + a = LETTERS[1:5], + b = factor(letters[1:5]), + c = factor(letters[1:5]) + ) }) spec <- datasets("df") & variables(c("a", "b")) & !variables("b") expect_no_error(resolver(spec, td)) From 4a3c2c877a5eb0d30fcb9579fddd914add760435 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= <185338939+llrs-roche@users.noreply.github.com> Date: Fri, 25 Apr 2025 12:08:32 +0200 Subject: [PATCH 080/142] Use unique datasets before merging MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Co-authored-by: Dawid Kałędkowski Signed-off-by: Lluís Revilla <185338939+llrs-roche@users.noreply.github.com> --- R/merge_dataframes.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/merge_dataframes.R b/R/merge_dataframes.R index 3ba12c80..f5a3126a 100644 --- a/R/merge_dataframes.R +++ b/R/merge_dataframes.R @@ -92,9 +92,9 @@ merge_call_pair <- function(selections, by, data, merge_call_multiple <- function(input, ids, merge_function, data, anl_name = "ANL") { - datasets <- sapply(input, function(x) { + datasets <- unique(sapply(input, function(x) { x$datasets - }) + })) stopifnot(is.character(datasets) && length(datasets) >= 1L) number_merges <- length(datasets) - 1L stopifnot( From 59c6aff692fe04202f6ca4d652378595e156b2a0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Fri, 25 Apr 2025 14:47:26 +0200 Subject: [PATCH 081/142] Use consolidate_extraction to make sure merging is needed --- R/merge_dataframes.R | 15 ++++++++++----- 1 file changed, 10 insertions(+), 5 deletions(-) diff --git a/R/merge_dataframes.R b/R/merge_dataframes.R index f5a3126a..46c5f4f9 100644 --- a/R/merge_dataframes.R +++ b/R/merge_dataframes.R @@ -8,8 +8,8 @@ consolidate_extraction <- function(...) { } # Assume the data is a data.frame so no other specifications types are present. - datasets <- lapply(input_resolved, `$`, name = datasets) - variables <- lapply(input_resolved, `$`, name = variables) + datasets <- lapply(input_resolved, function(x){x$datasets}) + variables <- lapply(input_resolved, function(x){x$variables}) lapply(unique(datasets), function(dataset, x, y) { list( @@ -29,7 +29,7 @@ add_ids <- function(input, data) { return(input) } - datasets <- lapply(input, `$`, name = datasets) + datasets <- lapply(input, function(x){x$datasets}) for (i in seq_along(input)) { x <- input[[i]] # Avoid adding as id something already present: No duplicating input. @@ -63,10 +63,13 @@ extract_ids <- function(input, data) { merge_call_pair <- function(selections, by, data, merge_function = "dplyr::full_join", anl_name = "ANL") { + + selections <- consolidate_extraction(selections) stopifnot(length(selections) == 2L) - datasets <- sapply(selections, function(x) { + datasets <- unique(sapply(selections, function(x) { x$datasets - }) + })) + stopifnot(length(datasets) >= 2) by <- extract_ids(input = selections, data) if (grepl("::", merge_function, fixed = TRUE)) { @@ -92,6 +95,8 @@ merge_call_pair <- function(selections, by, data, merge_call_multiple <- function(input, ids, merge_function, data, anl_name = "ANL") { + + input <- consolidate_extraction(input) datasets <- unique(sapply(input, function(x) { x$datasets })) From 11932a81797fafb65b8f61cf3fdddd884622d029 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Fri, 25 Apr 2025 17:40:48 +0200 Subject: [PATCH 082/142] Verify it works without problems with just c() --- tests/testthat/test-types.R | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/tests/testthat/test-types.R b/tests/testthat/test-types.R index 3a64cee2..c454419c 100644 --- a/tests/testthat/test-types.R +++ b/tests/testthat/test-types.R @@ -29,6 +29,13 @@ test_that("raw combine of types", { expect_no_error(c(datasets("df"), variables("df"), values("df"))) }) +test_that("combine types", { + expect_no_error(c( + datasets(is.data.frame, select = "df1"), + variables(is.numeric) + )) +}) + test_that("values", { expect_no_error(val0 <- values("a", "a")) expect_no_error(val1 <- values("a")) From 7b306fc7cb3bfde7ad5399652a0c71be8f1e0366 Mon Sep 17 00:00:00 2001 From: github-actions <41898282+github-actions[bot]@users.noreply.github.com> Date: Fri, 25 Apr 2025 15:43:27 +0000 Subject: [PATCH 083/142] [skip style] [skip vbump] Restyle files --- R/merge_dataframes.R | 14 +++++++++----- 1 file changed, 9 insertions(+), 5 deletions(-) diff --git a/R/merge_dataframes.R b/R/merge_dataframes.R index 46c5f4f9..a0b72bfc 100644 --- a/R/merge_dataframes.R +++ b/R/merge_dataframes.R @@ -8,8 +8,12 @@ consolidate_extraction <- function(...) { } # Assume the data is a data.frame so no other specifications types are present. - datasets <- lapply(input_resolved, function(x){x$datasets}) - variables <- lapply(input_resolved, function(x){x$variables}) + datasets <- lapply(input_resolved, function(x) { + x$datasets + }) + variables <- lapply(input_resolved, function(x) { + x$variables + }) lapply(unique(datasets), function(dataset, x, y) { list( @@ -29,7 +33,9 @@ add_ids <- function(input, data) { return(input) } - datasets <- lapply(input, function(x){x$datasets}) + datasets <- lapply(input, function(x) { + x$datasets + }) for (i in seq_along(input)) { x <- input[[i]] # Avoid adding as id something already present: No duplicating input. @@ -63,7 +69,6 @@ extract_ids <- function(input, data) { merge_call_pair <- function(selections, by, data, merge_function = "dplyr::full_join", anl_name = "ANL") { - selections <- consolidate_extraction(selections) stopifnot(length(selections) == 2L) datasets <- unique(sapply(selections, function(x) { @@ -95,7 +100,6 @@ merge_call_pair <- function(selections, by, data, merge_call_multiple <- function(input, ids, merge_function, data, anl_name = "ANL") { - input <- consolidate_extraction(input) datasets <- unique(sapply(input, function(x) { x$datasets From bec03ff98269c8f0c31d6be66e0826b7a3eb9ee6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Mon, 28 Apr 2025 12:28:59 +0200 Subject: [PATCH 084/142] Remove operators (and exclude) --- NAMESPACE | 3 - R/ops_transform.R | 134 ---------------------------- R/types.R | 15 +--- tests/testthat/test-delayed.R | 2 +- tests/testthat/test-ops_transform.R | 101 --------------------- tests/testthat/test-resolver.R | 63 +++++++------ tests/testthat/test-types.R | 6 +- 7 files changed, 39 insertions(+), 285 deletions(-) delete mode 100644 R/ops_transform.R delete mode 100644 tests/testthat/test-ops_transform.R diff --git a/NAMESPACE b/NAMESPACE index bc4c5a81..85bd463e 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,11 +1,8 @@ # Generated by roxygen2: do not edit by hand -S3method(Ops,transform) -S3method(Ops,type) S3method(anyNA,type) S3method(c,transform) S3method(c,type) -S3method(chooseOpsMethod,transform) S3method(data_extract_multiple_srv,FilteredData) S3method(data_extract_multiple_srv,list) S3method(data_extract_multiple_srv,reactive) diff --git a/R/ops_transform.R b/R/ops_transform.R deleted file mode 100644 index 67d6dad0..00000000 --- a/R/ops_transform.R +++ /dev/null @@ -1,134 +0,0 @@ -#' @export -Ops.transform <- function(e1, e2) { - if (missing(e2)) { - # out <- switch(.Generic, - # "!" = Negate, - stop("Method ", sQuote(.Generic), " not implemented for this class ", .Class, ".", call. = FALSE) - # return(out) - } - switch(.Generic, - "!=" = NextMethod(), - "==" = NextMethod(), - "|" = or_transform(e1, e2), - "&" = nd_transform(e1, e2), - stop("Method ", sQuote(.Generic), " not implemented for this class ", .Class, ".", call. = FALSE) - ) -} - -#' @export -Ops.type <- function(e1, e2) { - if (missing(e2)) { - out <- switch(.Generic, - "!" = negate_type(e1), - stop("Method ", sQuote(.Generic), - " not implemented for this class ", .Class, ".", - call. = FALSE - ) - ) - return(out) - } - out <- switch(.Generic, - "!=" = NextMethod(), - # "==" = NextMethod(), - "|" = or_type(e1, e2), - "&" = nd_type(e1, e2), - stop("Method ", sQuote(.Generic), " not implemented for this class ", .Class, ".", call. = FALSE) - ) - out -} - -or_transform <- function(e1, e2) { - if (is.transform(e1) && is.type(e2) && !is.transform(e2)) { - opt2 <- e1 & e2 - out <- list(e1, opt2) - } else if (!is.transform(e1) && is.type(e1) && is.transform(e2)) { - opt2 <- e2 & e1 - out <- list(e2, opt2) - } else if (is.transform(e1) && is.transform(e2)) { - out <- list(e1, e2) - } else { - stop("Missing implementation method.") - } - # FIXME: Should we signal it is a transform or just a list of transform is enough? - # class(out) <- c("transform", "list") - out -} - -nd_transform <- function(e1, e2) { - if (is.transform(e1) && is.transform(e2)) { - types <- intersect(names(e1), names(e2)) - for (t in types) { - e1[[t]] <- unique(c(e1[[t]], e2[[t]])) - } - return(e1) - } - - if (is.type(e1) && is.transform(e2)) { - if (!is(e1) %in% names(e2)) { - e2[[is(e1)]] <- e1 - } else { - e2[[is(e1)]] <- c(e2[[is(e1)]], e1) - } - return(e2) - } else if (is.transform(e1) && is.type(e2)) { - if (!is(e2) %in% names(e1)) { - e1[[is(e2)]] <- e2 - } else { - e1[[is(e2)]] <- c(e1[[is(e2)]], e2) - } - out <- e1 - } else if (is.type(e1) && is.transform(e2)) { - out <- rev(c(e2, e1)) # To keep order in the list - } else { - stop("Method not implemented yet!") - } - out -} - -nd_type <- function(e1, e2) { - if (is.transform(e1) && !is.transform(e2)) { - out <- c(e1, list(e2)) - names(out)[length(out)] <- is(e2) - } else if (!is.transform(e1) && is.transform(e2)) { - out <- c(e2, list(e1)) - names(out)[length(out)] <- is(e1) - } else if (is.transform(e1) && is.transform(e2)) { - out <- c(e1, e2) - } else if (is.type(e1) && is.type(e2)) { - out <- c(e1, e2) - } else if (or.transform(e1) && is.type(e2)) { - out <- lapply(e1, nd_type, e2 = e2) - } else if (or.transform(e2) && is.type(e1)) { - out <- lapply(e2, nd_type, e2 = e1) - } else { - stop("Maybe we should decide how to apply a type to a list of transformers...") - } - class(out) <- unique(c("transform", class(out))) - out -} - -or_type <- function(e1, e2) { - substitute <- is(e2) %in% names(e1) - if (substitute) { - out <- e1 - e1[[is(e2)]] <- e2 - return(nd_type(out, e1)) - } - list(e1, e2) -} - - -negate_type <- function(e1, e2) { - out <- list(except = e1$names) - class(out) <- class(e1) - out -} - -# chooseOpsMethod.list <- function(x, y, mx, my, cl, reverse) TRUE -#' @export -chooseOpsMethod.transform <- function(x, y, mx, my, cl, reverse) { - # Apply one or other method - # !is.transform(x) - TRUE -} -# chooseOpsMethod.type <- function(x, y, mx, my, cl, reverse) TRUE diff --git a/R/types.R b/R/types.R index 0cec0468..6186fa41 100644 --- a/R/types.R +++ b/R/types.R @@ -7,12 +7,6 @@ valid_transform <- function(x) { !((is.type(x) || is.transform(x)) || or.transform(x)) } -or.transform <- function(x) { - is.list(x) && all(vapply(x, function(x) { - is.transform(x) || is.type(x) - }, logical(1L))) -} - na_type <- function(type) { out <- NA_character_ class(out) <- c(type, "type") @@ -175,6 +169,7 @@ c.transform <- function(...) { ), orig(l[[i]][[t]][["names"]])) new_type$select <- c(old_select, l[[i]][[t]][["select"]]) attr(new_type$select, "original") <- c(orig(old_select), orig(l[[i]][[t]][["select"]])) + attr(new_type, "delayed") <- any(attr(new_type, "delayed"), attr(l[[i]], "delayed")) } orig_names <- unique(orig(new_type$names)) new_type$names <- unique(new_type$names) @@ -202,8 +197,8 @@ c.type <- function(...) { vector <- vector("list", length(utypes)) names(vector) <- utypes for (t in utypes) { - new_type <- vector("list", length = 3) - names(new_type) <- c("names", "select", "except") + new_type <- vector("list", length = 2) + names(new_type) <- c("names", "select") for (i in seq_along(l)) { if (!is(l[[i]], t)) { next @@ -216,9 +211,6 @@ c.type <- function(...) { ), orig(l[[i]][["names"]])) new_type$select <- unique(c(old_select, l[[i]][["select"]])) attr(new_type$select, "original") <- c(orig(old_select), orig(l[[i]][["select"]])) - - new_type$except <- c(new_type$except, l[[i]][["except"]]) - attr(new_type$except, "original") <- c(orig(l[[i]][["except"]]), orig(new_type$except)) } orig_names <- unique(orig(new_type$names)) orig_select <- unique(orig(new_type$select)) @@ -233,6 +225,7 @@ c.type <- function(...) { attr(new_type$select, "original") <- orig_select class(new_type) <- c(t, "type", "list") + attr(new_type, "delayed") <- is.delayed(new_type) vector[[t]] <- new_type } if (length(vector) == 1) { diff --git a/tests/testthat/test-delayed.R b/tests/testthat/test-delayed.R index a6efe359..7b9a9beb 100644 --- a/tests/testthat/test-delayed.R +++ b/tests/testthat/test-delayed.R @@ -5,7 +5,7 @@ test_that("is.delayed works", { expect_false(is.delayed(datasets("a", "a"))) expect_true(is.delayed(v)) expect_false(is.delayed(variables("b", "b"))) - expect_true(is.delayed(d & v)) + expect_true(is.delayed(c(d, v))) expect_false(is.delayed(1)) da <- datasets(is.data.frame) expect_true(is.delayed(da)) diff --git a/tests/testthat/test-ops_transform.R b/tests/testthat/test-ops_transform.R deleted file mode 100644 index a015b709..00000000 --- a/tests/testthat/test-ops_transform.R +++ /dev/null @@ -1,101 +0,0 @@ -basic_ops <- function(fun) { - FUN <- match.fun(fun) - type1 <- FUN("ABC") - types <- type1 & type1 - out <- list(names = "ABC", select = list(first)) - class(out) <- c(fun, "type", "list") - expect_equal(types, out, check.attributes = FALSE) - type2 <- FUN("ABC2") - types <- type1 & type2 - out <- list(names = c("ABC", "ABC2"), select = list(first)) - class(out) <- c("delayed", fun, "type", "list") - expect_equal(types, out, check.attributes = FALSE) - expect_equal(types$names, c("ABC", "ABC2"), check.attributes = FALSE) - types2 <- types & type2 - expect_equal(types$names, c("ABC", "ABC2"), check.attributes = FALSE) - expect_s3_class(types, class(out)) - type3 <- FUN("ABC2", select = all_choices) - types <- type1 & type3 - expect_length(types$select, 2) - type2b <- FUN(first_choice) - type2c <- FUN(last_choice) - out <- type2b & type2c - expect_length(out$names, 2) - expect_error(FUN("ABC") & 1) - out <- type1 & type2b - expect_true(is.list(out$names)) - expect_no_error(type1 & !type2) -} - -test_that("datasets & work", { - basic_ops("datasets") -}) - - -test_that("variables & work", { - basic_ops("variables") -}) - -test_that("values & work", { - basic_ops("values") -}) - -test_that("&(datsets, variables) create a single transform", { - dataset1 <- datasets("ABC2") - var1 <- variables("abc") - vars <- dataset1 & var1 - vars2 <- var1 & dataset1 - expect_equal(vars$datasets$names, "ABC2", check.attributes = FALSE) - expect_equal(vars$variables$names, "abc", check.attributes = FALSE) -}) - -test_that("&(datsets, number) errors", { - expect_error(datasets("abc") & 1) -}) - -test_that("datsets & values work", { - dataset1 <- datasets("ABC2") - val1 <- values("abc") - vars <- dataset1 & val1 - expect_equal(vars$datasets$names, "ABC2", check.attributes = FALSE) - expect_equal(vars$values$names, "abc", check.attributes = FALSE) -}) - -test_that("&(datsets, number) errors", { - expect_error(variables("abc") & 1) -}) - -test_that("variables & values work", { - var1 <- variables("ABC2") - val1 <- values("abc") - vars <- var1 & val1 - expect_equal(vars$variables$names, "ABC2", check.attributes = FALSE) - expect_equal(vars$values$names, "abc", check.attributes = FALSE) -}) - -test_that("&(values, number) errors", { - expect_error(values("abc") & 1) -}) - -test_that("datasets & variables & values create a single specification", { - dataset1 <- datasets("ABC2") - var1 <- variables("ABC2") - val1 <- values("abc") - vars <- dataset1 & var1 & val1 - vars2 <- val1 & var1 & dataset1 - expect_equal(vars$datasets$names, "ABC2", check.attributes = FALSE) - expect_equal(vars$variables$names, "ABC2", check.attributes = FALSE) - expect_equal(vars$values$names, "abc", check.attributes = FALSE) -}) - -test_that("&(transform, number) errors", { - expect_error(datasets("ABC2") & variables("ABC2") & values("abc") & 1) - expect_error(datasets("ABC2") & values("abc") & 1) -}) - - -test_that("| combines two transformers", { - spec <- datasets("ABC") | datasets("abc") - expect_length(spec, 2) - expect_true(is.null(names(spec))) -}) diff --git a/tests/testthat/test-resolver.R b/tests/testthat/test-resolver.R index d061e442..7cf7c6a4 100644 --- a/tests/testthat/test-resolver.R +++ b/tests/testthat/test-resolver.R @@ -39,21 +39,21 @@ test_that("resolver variables works", { m2 <- cbind(a = LETTERS[1:2], b = LETTERS[4:5]) }) - expect_no_error(resolver(df & var_a, td)) - expect_no_error(resolver(df & factors, td)) - expect_error(resolver(df & factors_head, td)) - expect_error(resolver(df & var_matrices_head, td)) + expect_no_error(resolver(c(df, var_a), td)) + expect_no_error(resolver(c(df, factors), td)) + expect_error(resolver(c(df, factors_head), td)) + expect_error(resolver(c(df, var_matrices_head), td)) - expect_error(resolver(matrices & var_a, td)) # datasets selection overpasses variable choices. - expect_error(resolver(matrices & factors, td)) - expect_error(resolver(matrices & factors_head, td)) - expect_error(resolver(matrices & var_matrices_head, td)) + expect_error(resolver(c(matrices, var_a), td)) # datasets selection overpasses variable choices. + expect_error(resolver(c(matrices, factors), td)) + expect_error(resolver(c(matrices, factors_head), td)) + expect_error(resolver(c(matrices, var_matrices_head), td)) - expect_no_error(resolver(data_frames & var_a, td)) - expect_no_error(resolver(data_frames & factors, td)) - expect_error(resolver(data_frames & factors_head, td)) - expect_error(resolver(data_frames & var_matrices_head, td)) + expect_no_error(resolver(c(data_frames, var_a), td)) + expect_no_error(resolver(c(data_frames, factors), td)) + expect_error(resolver(c(data_frames, factors_head), td)) + expect_error(resolver(c(data_frames, var_matrices_head), td)) }) test_that("resolver values works", { @@ -74,7 +74,7 @@ test_that("resolver values works", { m <- cbind(b = 1:5, c = 10:14) m2 <- cbind(a = LETTERS[1:2], b = LETTERS[4:5]) }) - expect_no_error(resolver(df & var_a & val_A, td)) + expect_no_error(resolver(c(df, var_a, val_A), td)) }) test_that("resolver works with excluded types", { @@ -85,8 +85,8 @@ test_that("resolver works with excluded types", { c = factor(letters[1:5]) ) }) - spec <- datasets("df") & variables(c("a", "b")) & !variables("b") - expect_no_error(resolver(spec, td)) + # spec <- c(datasets("df"), variables(c("a", "b")), !variables("b")) + # expect_no_error(resolver(spec, td)) }) test_that("names and variables are reported", { @@ -103,9 +103,9 @@ test_that("names and variables are reported", { m <- matrix() }) d_df <- datasets("df") - df_upper_variables <- d_df & variables(function(x) { + df_upper_variables <- c(d_df, variables(function(x) { x == toupper(x) - }) + })) out <- resolver(df_upper_variables, td) # This should select A and Ab: # A because the name is all capital letters and @@ -114,17 +114,17 @@ test_that("names and variables are reported", { v_all_upper <- variables(function(x) { all(x == toupper(x)) }) - df_all_upper_variables <- d_df & v_all_upper + df_all_upper_variables <- c(d_df, v_all_upper) expect_no_error(out <- resolver(df_all_upper_variables, td)) expect_length(out$variables$names, 2L) - expect_no_error(out <- resolver(datasets("df2") & v_all_upper, td)) + expect_no_error(out <- resolver(c(datasets("df2"), v_all_upper), td)) expect_length(out$variables$names, 2L) expect_no_error(out <- resolver(datasets(function(x) { is.data.frame(x) && all(colnames(x) == toupper(colnames(x))) }), td)) expect_length(out$names, 1L) - expect_no_error(out <- resolver(datasets(is.data.frame) & datasets(function(x) { - colnames(x) == toupper(colnames(x)) + expect_no_error(out <- resolver(datasets(function(x) { + is.data.frame(x) || any(colnames(x) == toupper(colnames(x))) }), td)) expect_length(out$names, 2L) }) @@ -140,7 +140,7 @@ test_that("update_spec resolves correctly", { Ab = as.factor(letters[1:5]) ) }) - data_frames_factors <- datasets(is.data.frame) & variables(is.factor) + data_frames_factors <- c(datasets(is.data.frame), variables(is.factor)) expect_false(is.null(attr(data_frames_factors$datasets$names, "original"))) expect_false(is.null(attr(data_frames_factors$datasets$select, "original"))) expect_false(is.null(attr(data_frames_factors$variables$names, "original"))) @@ -176,16 +176,15 @@ test_that("update_spec resolves correctly", { expect_no_error(update_spec(datasets(x = c("df", "df2"), "df"), "datasets", "df2")) }) - test_that("OR specifications resolves correctly", { td <- within(teal.data::teal_data(), { df <- data.frame(A = 1:5, B = LETTERS[1:5]) m <- cbind(A = 1:5, B = 5:10) }) var_a <- variables("A") - df_a <- datasets(is.data.frame) & var_a - matrix_a <- datasets(is.matrix) & var_a - df_or_m_var_a <- df_a | matrix_a + df_a <- c(datasets(is.data.frame), var_a) + matrix_a <- c(datasets(is.matrix), var_a) + df_or_m_var_a <- list(df_a, matrix_a) out <- resolver(df_or_m_var_a, td) expect_true(all(vapply(out, is.transform, logical(1L)))) }) @@ -196,9 +195,9 @@ test_that("OR specifications fail correctly", { m <- cbind(A = 1:5, B = 5:10) }) var_a <- variables("A") - df_a <- datasets(is.data.frame) & var_a - matrix_a <- datasets(is.matrix) & var_a - df_or_m_var_a <- df_a | matrix_a + df_a <- c(datasets(is.data.frame), var_a) + matrix_a <- c(datasets(is.matrix), var_a) + df_or_m_var_a <- list(df_a, matrix_a) out <- resolver(df_or_m_var_a, td) expect_error(update_spec(out, "variables", "B")) }) @@ -209,9 +208,9 @@ test_that("OR update_spec filters specifications", { m <- cbind(A = 1:5, B = 5:10) }) var_a <- variables("A") - df_a <- datasets(is.data.frame) & var_a - matrix_a <- datasets(is.matrix) & var_a - df_or_m_var_a <- df_a | matrix_a + df_a <- c(datasets(is.data.frame), var_a) + matrix_a <- c(datasets(is.matrix), var_a) + df_or_m_var_a <- list(df_a, matrix_a) resolved <- resolver(df_or_m_var_a, td) # The second option is not possible to have it as df expect_error(update_spec(resolved, "datasets", "df")) diff --git a/tests/testthat/test-types.R b/tests/testthat/test-types.R index c454419c..39795174 100644 --- a/tests/testthat/test-types.R +++ b/tests/testthat/test-types.R @@ -24,9 +24,9 @@ test_that("variables", { }) test_that("raw combine of types", { - out <- c(datasets("df"), variables("df")) - expect_length(out, 2L) - expect_no_error(c(datasets("df"), variables("df"), values("df"))) + expect_equal(c(datasets("df")), datasets("df")) + expect_length(c(datasets("df"), variables("df")), 2L) + expect_length(c(datasets("df"), variables("df"), values("df")), 3L) }) test_that("combine types", { From 3c32eab8e584b91d4ce199e8a9c84a1a72d867ec Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Tue, 29 Apr 2025 08:09:44 +0200 Subject: [PATCH 085/142] Simplify --- R/merge_dataframes.R | 8 ++------ 1 file changed, 2 insertions(+), 6 deletions(-) diff --git a/R/merge_dataframes.R b/R/merge_dataframes.R index 46c5f4f9..6a3a15a0 100644 --- a/R/merge_dataframes.R +++ b/R/merge_dataframes.R @@ -66,9 +66,7 @@ merge_call_pair <- function(selections, by, data, selections <- consolidate_extraction(selections) stopifnot(length(selections) == 2L) - datasets <- unique(sapply(selections, function(x) { - x$datasets - })) + datasets <- unique(unlist(lapply(selections, `[[`, datasets), FALSE, FALSE)) stopifnot(length(datasets) >= 2) by <- extract_ids(input = selections, data) @@ -97,9 +95,7 @@ merge_call_multiple <- function(input, ids, merge_function, data, anl_name = "ANL") { input <- consolidate_extraction(input) - datasets <- unique(sapply(input, function(x) { - x$datasets - })) + datasets <- unique(unlist(lapply(input, `[[`, "datasets"), FALSE, FALSE)) stopifnot(is.character(datasets) && length(datasets) >= 1L) number_merges <- length(datasets) - 1L stopifnot( From 386232d9f06ba742bbb855bba4813eff1d53713d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Tue, 29 Apr 2025 10:10:00 +0200 Subject: [PATCH 086/142] Add tidyselect::eval_select --- R/selector.R | 10 ++++++++++ 1 file changed, 10 insertions(+) create mode 100644 R/selector.R diff --git a/R/selector.R b/R/selector.R new file mode 100644 index 00000000..8c70318a --- /dev/null +++ b/R/selector.R @@ -0,0 +1,10 @@ +selector <- function(data, ...) { + if (is.environment(data)) { + data <- as.list(data) + } + if (is.null(names(data))) { + stop("Can't extract the data.") + } + pos <- tidyselect::eval_select(rlang::expr(c(...)), data) + pos +} From 64c42e2888ffbf028e3caced674118b4b77aa186 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Wed, 30 Apr 2025 17:30:45 +0200 Subject: [PATCH 087/142] Add support for expressions in types --- R/selector.R | 5 +++- R/types.R | 66 +++++++--------------------------------------------- 2 files changed, 13 insertions(+), 58 deletions(-) diff --git a/R/selector.R b/R/selector.R index 8c70318a..55be6ed5 100644 --- a/R/selector.R +++ b/R/selector.R @@ -1,10 +1,13 @@ selector <- function(data, ...) { if (is.environment(data)) { data <- as.list(data) + } else if (length(dim(data)) == 2L) { + data <- as.data.frame(data) } + if (is.null(names(data))) { stop("Can't extract the data.") } - pos <- tidyselect::eval_select(rlang::expr(c(...)), data) + pos <- tidyselect::eval_select(expr = ..., data) pos } diff --git a/R/types.R b/R/types.R index 6186fa41..4267d334 100644 --- a/R/types.R +++ b/R/types.R @@ -45,16 +45,6 @@ check_input <- function(input) { } type_helper <- function(x, select, type) { - stopifnot( - "Invalid options" = check_input(x), - "Invalid selection" = check_input(type) - ) - if (is.function(x)) { - x <- list(x) - } - if (is.function(select)) { - select <- list(select) - } out <- list(names = x, select = select) class(out) <- c(type, "type", "list") attr(out$names, "original") <- x @@ -62,7 +52,6 @@ type_helper <- function(x, select, type) { delay(out) } - #' @rdname types #' @name Types #' @title Type specification @@ -78,67 +67,30 @@ type_helper <- function(x, select, type) { #' datasets("A") & variables(is.numeric) NULL - - #' @describeIn types Specify datasets. #' @export -datasets <- function(x, select = first) { - type_helper(x, select, type = "datasets") +datasets <- function(x, select = everything()) { + type_helper(x = rlang::enquo(x), select = rlang::enquo(select), type = "datasets") } - #' @describeIn types Specify variables. #' @export -variables <- function(x, select = first) { - type_helper(x, select, type = "variables") +variables <- function(x, select = everything()) { + type_helper(x = rlang::enquo(x), select = rlang::enquo(select), type = "variables") } -#' @describeIn types Specify variables of MultiAssayExperiment col Data. +#' @describeIn types Specify colData of SummarizedExperiment and derived classes. #' @export -mae_colData <- function(x, select = first) { - type_helper(x, select, type = "mae_colData") -} - -#' @describeIn types Specify variables of MultiAssayExperiment sampleMap. -#' @export -mae_sampleMap <- function(x, select = first) { - type_helper(x, select, type = "mae_sampleMap") -} - -#' @describeIn types Specify variables of MultiAssayExperiment experiments. -#' @export -mae_experiments <- function(x, select = first) { - type_helper(x, select, type = "mae_experiments") +colData <- function(x, select = everything()) { + type_helper(x = rlang::enquo(x), select = rlang::enquo(select), type = "colData") } #' @describeIn types Specify values. #' @export -values <- function(x, select = first) { - type_helper(x, select, type = "values") +values <- function(x, select = everything()) { + type_helper(x = rlang::enquo(x), select = rlang::enquo(select), type = "values") } -# #' @export -# c.type <- function(...) { -# -# if (is.na(..1)) { -# return(..2) -# } else if (is.na(..2)) { -# return(..1) -# } -# -# if (...length() > 2L) { -# stop("We can't combine this (yet)") -# } else if (all(class(..2) != class(..1))) { -# type_out <- ..1 -# type_out$child <- ..2 -# return(type_out) -# } -# out <- mapply(c, ..., SIMPLIFY = FALSE) -# out <- lapply(out, unique) -# class(out) <- c("transform", class(out)) -# delay(out) -# } - #' @export c.transform <- function(...) { l <- list(...) From 2a00dd22fd2df2a0207b8f6d204d6530d7f514dc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Wed, 30 Apr 2025 17:31:59 +0200 Subject: [PATCH 088/142] Use the tidyselect approach (remove operators) --- R/resolver.R | 114 ++++++++++++++++++++++++--------------------------- 1 file changed, 54 insertions(+), 60 deletions(-) diff --git a/R/resolver.R b/R/resolver.R index a85ea2e3..112c26fa 100644 --- a/R/resolver.R +++ b/R/resolver.R @@ -32,11 +32,11 @@ resolver <- function(spec, data) { # Adding some default specifications if they are missing if ("values" %in% names(spec) && !"variables" %in% names(spec)) { - spec <- variables(first) & spec + spec <- c(variables(first), spec) } if ("variables" %in% names(spec) && !"datasets" %in% names(spec)) { - spec <- datasets(first) & spec + spec <- c(datasets(first), spec) } stopifnot(is.list(spec) || is.transform(spec)) @@ -71,20 +71,20 @@ determine <- function(type, data, ...) { determine.default <- function(type, data, ..., spec) { # Used when the type is of class list. if (!is.null(names(type)) && is.delayed(type)) { - rt <- determine(type, data) - } else { - rt <- lapply(type, determine, data = data, spec = spec) - if (length(rt) == 1) { - return(rt[[1]]) - } + return(determine(type, data)) } - rt + d <- data + for (i in seq_along(type)) { + di <- determine(type[[i]], d, spec = spec) + type[[i]] <- di$type + d <- di$data + } + list(type = type, data = data) } #' @export determine.transform <- function(type, data, ..., spec) { stopifnot(inherits(data, "qenv")) - d <- data for (i in seq_along(type)) { di <- determine(type[[i]], d, spec = spec) @@ -242,8 +242,8 @@ determine_helper <- function(type, data_names, data) { new_select <- unique(new_select[!is.na(new_select)]) if (!length(new_select)) { - return(NULL) stop("No ", is(type), " meet the requirements to be selected") + return(NULL) } type$select <- new_select } @@ -254,32 +254,23 @@ determine_helper <- function(type, data_names, data) { #' @export determine.datasets <- function(type, data, ...) { - if (!inherits(data, "qenv")) { + if (is.null(data)) { + return(list(type = type, data = NULL)) + } else if (!inherits(data, "qenv")) { stop("Please use qenv() or teal_data() objects.") } - l <- vector("list", length(names(data))) - # Somehow in some cases (I didn't explore much this was TRUE) - for (i in seq_along(l)) { - data_name_env <- names(data)[i] - out <- determine_helper(type, data_name_env, extract(data, data_name_env)) - if (!is.null(out)) { - l[[i]] <- out - } - } - - # Merge together all the types - type <- do.call(c, l[lengths(l) > 1L]) - # Evaluate the selection based on all possible choices. - type <- eval_type_select(type, data) + # Assumes the object has colnames method (true for major object classes: DataFrame, tibble, Matrix, array) + # FIXME: What happens if colnames is null: array(dim = c(4, 2)) |> colnames() + type <- eval_type_names(type, data) - if (is.null(type$names)) { - stop("No datasets meet the specification.", call. = FALSE) + if (is.null(type$names) || !length(type$names)) { + stop("No ", class(type), " meet the specification.", call. = FALSE) } - if (!is.delayed(type) && length(type$select) > 1L) { - list(type = type, data = data[unorig(type$select)]) - } else if (!is.delayed(type) && length(type$select) == 1L) { + type <- eval_type_select(type, data[unorig(type$names)]) + + if (!is.delayed(type) && length(type$select) == 1L) { list(type = type, data = data[[unorig(type$select)]]) } else { list(type = type, data = NULL) @@ -288,8 +279,12 @@ determine.datasets <- function(type, data, ...) { #' @export determine.variables <- function(type, data, ...) { - if (length(dim(data)) != 2L) { - stop("Can't resolve variables from this object of class ", class(data)) + + if (is.null(data)) { + return(list(type = type, data = NULL)) + } else if (length(dim(data)) != 2L) { + stop("Can't resolve variables from this object of class ", + toString(sQuote(class(data)))) } if (ncol(data) <= 0L) { @@ -298,23 +293,14 @@ determine.variables <- function(type, data, ...) { # Assumes the object has colnames method (true for major object classes: DataFrame, tibble, Matrix, array) # FIXME: What happens if colnames is null: array(dim = c(4, 2)) |> colnames() - l <- vector("list", ncol(data)) - for (i in seq_len(ncol(data))) { - out <- determine_helper(type, colnames(data)[i], data[, i]) - if (!is.null(out)) { - l[[i]] <- out - } + type <- eval_type_names(type, data) + + if (is.null(type$names) || !length(type$names)) { + stop("No ", class(type), " meet the specification.", call. = FALSE) } - # Merge together all the types - type <- do.call(c, l[lengths(l) > 1]) - # Check the selected values as they got appended. type <- eval_type_select(type, data) - if (is.null(type$names)) { - stop("No variables meet the specification.", call. = FALSE) - } - # Not possible to know what is happening if (is.delayed(type)) { return(list(type = type, data = NULL)) @@ -417,25 +403,33 @@ unorig <- function(x) { x } - eval_type_select <- function(type, data) { - l <- vector("list", length(type$names)) - names(l) <- type$names + stopifnot(is.character(type$names)) + orig_select <- orig(type$select) - for (name in type$names) { - out <- functions_data(orig_select, name, extract(data, name)) - if (!is.null(out)) { - l[[name]] <- unlist(out) - } - } - new_select <- c( - functions_names(orig(type$select), type$names), - unlist(l, FALSE, FALSE) - ) + names <- seq_along(type$names) + names(names) <- type$names + select_data <- selector(data, type$select) - new_select <- unique(new_select) + # Keep only those that were already selected + new_select <- intersect(unique(names(c(select_data))), unorig(type$names)) attr(new_select, "original") <- orig_select + type$select <- new_select + + type +} + + +eval_type_names <- function(type, data) { + orig_names <- orig(type$names) + new_names <- selector(data, type$names) + + new_names <- unique(names(new_names)) + attr(new_names, "original") <- orig_names + + type$names <- new_names + type } From a78ecce88864befbf42d1844e71ffc5c8aabb520 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Wed, 30 Apr 2025 17:34:54 +0200 Subject: [PATCH 089/142] Remove extra MAE methods --- NAMESPACE | 2 -- 1 file changed, 2 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 85bd463e..9e66c7b1 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -79,8 +79,6 @@ export(last_choice) export(last_choices) export(list_extract_spec) export(mae_colData) -export(mae_experiments) -export(mae_sampleMap) export(merge_datasets) export(merge_expression_module) export(merge_expression_srv) From 6fa687ec2084dea0eeef4967d6c4b5a4b68660cf Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Tue, 6 May 2025 10:10:20 +0200 Subject: [PATCH 090/142] Fix issues --- .pre-commit-config.yaml | 2 +- DESCRIPTION | 1 + R/module_input.R | 4 +- R/resolver.R | 191 +++++++++------------------------ R/types.R | 55 ++++++---- R/update_spec.R | 10 +- inst/WORDLIST | 10 +- man/resolver.Rd | 10 +- man/types.Rd | 26 ++--- man/update_spec.Rd | 2 +- tests/testthat/test-delayed.R | 4 +- tests/testthat/test-resolver.R | 96 ++++++----------- tests/testthat/test-types.R | 29 +++-- 13 files changed, 164 insertions(+), 276 deletions(-) diff --git a/.pre-commit-config.yaml b/.pre-commit-config.yaml index 24e1e2c1..5949c0ee 100644 --- a/.pre-commit-config.yaml +++ b/.pre-commit-config.yaml @@ -6,7 +6,7 @@ default_language_version: python: python3 repos: - repo: https://github.com/lorenzwalthert/precommit - rev: v0.4.3.9007 + rev: v0.4.3.9009 hooks: - id: style-files name: Style code with `styler` diff --git a/DESCRIPTION b/DESCRIPTION index 6608015d..89ae48f1 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -22,6 +22,7 @@ Depends: R (>= 3.6) Imports: checkmate (>= 2.1.0), + cli (>= 3.6.4), dplyr (>= 1.1.0), lifecycle (>= 0.2.0), logger (>= 0.2.0), diff --git a/R/module_input.R b/R/module_input.R index d532de7e..a6931856 100644 --- a/R/module_input.R +++ b/R/module_input.R @@ -48,9 +48,7 @@ module_input_server <- function(id, spec, data) { # resolved <- !is.character(spec_v$names) && all(x %in% spec_v$names) && any(!x %in% spec_v$select) if (!is.null(x) && any(nzchar(x))) { - spec <- spec |> - update_spec(variable, x) |> - resolver(d) + spec <- resolver(update_spec(spec, variable, x), d) } else { spec <- resolver(spec, d) } diff --git a/R/resolver.R b/R/resolver.R index 112c26fa..2cd80544 100644 --- a/R/resolver.R +++ b/R/resolver.R @@ -9,18 +9,18 @@ #' @export #' #' @examples -#' dataset1 <- datasets(is.data.frame) -#' dataset2 <- datasets(is.matrix) -#' spec <- dataset1 & variables("a", "a") +#' dataset1 <- datasets(where(is.data.frame)) +#' dataset2 <- datasets(where(is.matrix)) +#' spec <- c(dataset1, variables("a", "a")) #' td <- within(teal.data::teal_data(), { #' df <- data.frame(a = as.factor(LETTERS[1:5]), b = letters[1:5]) #' df2 <- data.frame(a = LETTERS[1:5], b = 1:5) #' m <- matrix() #' }) -#' resolver(spec | dataset2, td) +#' resolver(list(spec, dataset2), td) #' resolver(dataset2, td) #' resolver(spec, td) -#' spec <- dataset1 & variables("a", is.factor) +#' spec <- c(dataset1, variables("a", where(is.character))) #' resolver(spec, td) resolver <- function(spec, data) { if (!inherits(data, "qenv")) { @@ -98,94 +98,16 @@ determine.transform <- function(type, data, ..., spec) { list(type = type, data = data) # It is the transform object resolved. } -functions_names <- function(spec_criteria, names) { - stopifnot(is.character(names) || is.factor(names) || is.null(names)) # Allows for NA characters - if (is.null(names)) { - return(NULL) - } - is_fc <- vapply(spec_criteria, is.function, logical(1L)) - functions <- spec_criteria[is_fc] - new_names <- vector("character") - - for (fun in functions) { - names_ok <- tryCatch(fun(names), - error = function(x) { - x - }, - warning = function(x) { - if (isTRUE(x) || isFALSE(x)) { - x - } else { - FALSE - } - } - ) - if (!is.logical(names_ok)) { - stop("Provided functions should return a logical object.") - } - if (any(names_ok)) { - new_names <- c(new_names, names[names_ok]) - } - } - old_names <- unique(unlist(spec_criteria[!is_fc], FALSE, FALSE)) - c(new_names, old_names) -} - -# Evaluate if the function applied to the data -# but we need to return the name of the data received -functions_data <- function(spec_criteria, names_data, data) { - stopifnot( - !is.null(data), - length(names_data) == 1L - ) # Must be something but not NULL - is_fc <- vapply(spec_criteria, is.function, logical(1L)) - functions <- spec_criteria[is_fc] - - l <- lapply(functions, function(fun) { - data_ok <- tryCatch(fun(data), - error = function(x) { - x - }, - warning = function(x) { - if (isTRUE(x) || isFALSE(x)) { - x - } else { - FALSE - } - } - ) - if (!is.logical(data_ok)) { - stop("Provided functions should return a logical object.") - } - if ((length(data_ok) == 1L && (any(data_ok)) || all(data_ok))) { - return(names_data) - } - }) - new_names <- unique(unlist(l, FALSE, FALSE)) - c(new_names, spec_criteria[!is_fc]) -} - # Checks that for the given type and data names and data it can be resolved # The workhorse of the resolver determine_helper <- function(type, data_names, data) { stopifnot(!is.null(type)) orig_names <- type$names orig_select <- type$select - orig_exc <- type$except if (is.delayed(type) && all(is.character(type$names))) { new_names <- intersect(data_names, type$names) - if (!is.null(type$except)) { - excludes <- c( - functions_names(type$except, data_names), - functions_data(type$except, data_names, data) - ) - type$except <- excludes - attr(type$except, "original") <- orig(orig_exc) - new_names <- setdiff(new_names, excludes) - } - type$names <- new_names if (length(new_names) == 0) { return(NULL) @@ -193,8 +115,7 @@ determine_helper <- function(type, data_names, data) { } else if (length(new_names) == 1L) { type$select <- new_names } else { - new_select <- functions_names(type$select, type$names) - new_select <- unique(new_select[!is.na(new_select)]) + new_select <- selector(data, type$names) if (!length(new_select)) { return(NULL) # stop("No ", is(type), " meet the requirements to be selected") @@ -202,51 +123,25 @@ determine_helper <- function(type, data_names, data) { type$select <- new_select } } else if (is.delayed(type)) { - new_names <- c( - functions_names(type$names, data_names), - functions_data(type$names, data_names, data) - ) - new_names <- unlist(unique(new_names[!is.na(new_names)]), - use.names = FALSE - ) - - if (!is.null(type$except)) { - excludes <- c( - functions_names(type$except, data_names), - functions_data(type$except, data_names, data) - ) - - type$except <- excludes - attr(type$except, "original") <- orig(orig_exc) - - new_names <- setdiff(new_names, excludes) - } - - if (!length(new_names)) { - return(NULL) - # stop("No ", is(type), " meet the requirements") - } - type$names <- new_names + new_names <- selector(data, type$select) + } - if (length(type$names) == 0) { - return(NULL) - # stop("No selected ", is(type), " matching the conditions requested") - } else if (length(type$names) == 1) { - type$select <- type$names - } - new_select <- c( - functions_names(type$select, type$names), - functions_data(type$select, type$names, data) - ) + if (!length(new_names)) { + return(NULL) + # stop("No ", is(type), " meet the requirements") + } + type$names <- new_names - new_select <- unique(new_select[!is.na(new_select)]) - if (!length(new_select)) { - stop("No ", is(type), " meet the requirements to be selected") - return(NULL) - } - type$select <- new_select + if (length(type$names) == 0) { + return(NULL) + # stop("No selected ", is(type), " matching the conditions requested") + } else if (length(type$names) == 1) { + type$select <- type$names } + + new_select <- selector(data, type$select) + type$select <- new_select attr(type$names, "original") <- orig(orig_names) attr(type$select, "original") <- orig(orig_select) resolved(type) @@ -261,11 +156,11 @@ determine.datasets <- function(type, data, ...) { } # Assumes the object has colnames method (true for major object classes: DataFrame, tibble, Matrix, array) - # FIXME: What happens if colnames is null: array(dim = c(4, 2)) |> colnames() + # FIXME: What happens if colnames is null: colnames(array(dim = c(4, 2))) type <- eval_type_names(type, data) if (is.null(type$names) || !length(type$names)) { - stop("No ", class(type), " meet the specification.", call. = FALSE) + stop("No ", toString(is(type)), " meet the specification.", call. = FALSE) } type <- eval_type_select(type, data[unorig(type$names)]) @@ -273,30 +168,29 @@ determine.datasets <- function(type, data, ...) { if (!is.delayed(type) && length(type$select) == 1L) { list(type = type, data = data[[unorig(type$select)]]) } else { - list(type = type, data = NULL) + list(type = type, data = data[unorig(type$select)]) } } #' @export determine.variables <- function(type, data, ...) { - if (is.null(data)) { return(list(type = type, data = NULL)) } else if (length(dim(data)) != 2L) { - stop("Can't resolve variables from this object of class ", - toString(sQuote(class(data)))) + stop( + "Can't resolve variables from this object of class ", + toString(sQuote(class(data))) + ) } if (ncol(data) <= 0L) { stop("Can't pull variable: No variable is available.") } - # Assumes the object has colnames method (true for major object classes: DataFrame, tibble, Matrix, array) - # FIXME: What happens if colnames is null: array(dim = c(4, 2)) |> colnames() type <- eval_type_names(type, data) if (is.null(type$names) || !length(type$names)) { - stop("No ", class(type), " meet the specification.", call. = FALSE) + stop("No ", toString(is(type)), " meet the specification.", call. = FALSE) } type <- eval_type_select(type, data) @@ -384,14 +278,25 @@ determine.variables <- function(type, data, ...) { #' @export determine.values <- function(type, data, ...) { - type <- determine_helper(type, names(data), data) + if (!is.numeric(data)) { + d <- data + names(d) <- data + } else { + d <- data + } + sel <- selector(d, type$names) + type$names <- data[sel] + + + sel2 <- selector(d[sel], type$select) + type$select <- data[sel][sel2] # Not possible to know what is happening if (is.delayed(type)) { return(list(type = type, data = NULL)) } - list(type = type, data = type$select) + list(type = type, data = data[sel]) } orig <- function(x) { @@ -407,6 +312,9 @@ eval_type_select <- function(type, data) { stopifnot(is.character(type$names)) orig_select <- orig(type$select) + if (length(orig_select) == 1L) { + orig_select <- orig_select[[1L]] + } names <- seq_along(type$names) names(names) <- type$names @@ -414,6 +322,9 @@ eval_type_select <- function(type, data) { # Keep only those that were already selected new_select <- intersect(unique(names(c(select_data))), unorig(type$names)) + if (is.null(new_select)) { + stop("No ", is(type), " selection is possible.") + } attr(new_select, "original") <- orig_select type$select <- new_select @@ -424,9 +335,13 @@ eval_type_select <- function(type, data) { eval_type_names <- function(type, data) { orig_names <- orig(type$names) + if (length(orig_names) == 1L) { + orig_names <- orig_names[[1L]] + } + new_names <- selector(data, type$names) - new_names <- unique(names(new_names)) + new_names <- unique(names(new_names)) attr(new_names, "original") <- orig_names type$names <- new_names diff --git a/R/types.R b/R/types.R index 4267d334..51c3884c 100644 --- a/R/types.R +++ b/R/types.R @@ -4,7 +4,7 @@ is.transform <- function(x) { valid_transform <- function(x) { - !((is.type(x) || is.transform(x)) || or.transform(x)) + !((is.type(x) || is.transform(x))) } na_type <- function(type) { @@ -37,13 +37,24 @@ first <- function(x) { return(FALSE) } -check_input <- function(input) { - is.character(input) || is.function(input) || - (is.list(input) && all(vapply(input, function(x) { - is.function(x) || is.character(x) - }, logical(1L)))) +first_var <- function(offset = 0L, vars = NULL) { + if (!rlang::is_integerish(offset, n = 1)) { + not <- class(offset) + cli::cli_abort("{.arg offset} must be a single integer, not {not}.") + } + vars <- vars %||% tidyselect::peek_vars(fn = "first_var") + n <- length(vars) + if (offset > n) { + cli::cli_abort("{.arg offset} ({offset}) must be smaller than the number of columns ({n}).") + } else if (n == 0) { + cli::cli_abort("Can't select last column when input is empty.") + } else { + 1L + } } +last_var <- tidyselect::last_col + type_helper <- function(x, select, type) { out <- list(names = x, select = select) class(out) <- c(type, "type", "list") @@ -62,32 +73,32 @@ type_helper <- function(x, select, type) { #' @returns An object of the same class as the function with two elements: names the content of x, and select. #' @examples #' datasets("A") -#' datasets("A") | datasets("B") -#' datasets(is.data.frame) -#' datasets("A") & variables(is.numeric) +#' c(datasets("A"), datasets("B")) +#' datasets(where(is.data.frame)) +#' c(datasets("A"), variables(where(is.numeric))) NULL #' @describeIn types Specify datasets. #' @export -datasets <- function(x, select = everything()) { +datasets <- function(x, select = 1) { type_helper(x = rlang::enquo(x), select = rlang::enquo(select), type = "datasets") } #' @describeIn types Specify variables. #' @export -variables <- function(x, select = everything()) { +variables <- function(x, select = 1) { type_helper(x = rlang::enquo(x), select = rlang::enquo(select), type = "variables") } -#' @describeIn types Specify colData of SummarizedExperiment and derived classes. +#' @describeIn types Specify colData. #' @export -colData <- function(x, select = everything()) { +mae_colData <- function(x, select = 1) { type_helper(x = rlang::enquo(x), select = rlang::enquo(select), type = "colData") } #' @describeIn types Specify values. #' @export -values <- function(x, select = everything()) { +values <- function(x, select = 1) { type_helper(x = rlang::enquo(x), select = rlang::enquo(select), type = "values") } @@ -166,14 +177,16 @@ c.type <- function(...) { } orig_names <- unique(orig(new_type$names)) orig_select <- unique(orig(new_type$select)) + new_type$names <- unique(new_type$names) + if (length(new_type$names) == 1) { + new_type$names <- new_type$names[[1]] + } attr(new_type$names, "original") <- orig_names - # From the possible names apply the original function - if (is.delayed(new_type)) { - new_type$select <- functions_names(orig(new_type$select), new_type$names) + if (length(new_type$select) == 1) { + new_type$select <- new_type$select[[1]] } - attr(new_type$select, "original") <- orig_select class(new_type) <- c(t, "type", "list") @@ -208,7 +221,7 @@ print.type <- function(x, ...) { ) } if (nam_values) { - msg_values <- paste0(msg_values, paste0(sQuote(x$names[!nam_functions]), collapse = ", "), + msg_values <- paste0(msg_values, paste0(rlang::as_label(x$names[!nam_functions]), collapse = ", "), " as possible choices.", collapse = "\n" ) @@ -224,7 +237,7 @@ print.type <- function(x, ...) { ) } if (sel_values) { - msg_sel <- paste0(msg_sel, paste0(sQuote(x$select[!sel_functions]), collapse = ", "), + msg_sel <- paste0(msg_sel, paste0(rlang::as_label(x$select[!sel_functions]), collapse = ", "), " selected.", collapse = "\n" ) @@ -239,7 +252,7 @@ print.type <- function(x, ...) { ) } if (sel_values) { - msg_exc <- paste0(msg_exc, paste0(sQuote(x$except[!exc_functions]), collapse = ", "), + msg_exc <- paste0(msg_exc, paste0(rlang::as_label(x$except[!exc_functions]), collapse = ", "), " excluded.", collapse = "\n" ) diff --git a/R/update_spec.R b/R/update_spec.R index 00e6efa8..4d637839 100644 --- a/R/update_spec.R +++ b/R/update_spec.R @@ -17,7 +17,7 @@ #' Ab = as.factor(letters[1:5]) #' ) #' }) -#' data_frames_factors <- datasets(is.data.frame) & variables(is.factor) +#' data_frames_factors <- c(datasets(where(is.data.frame)), variables(where(is.factor))) #' res <- resolver(data_frames_factors, td) #' update_spec(res, "datasets", "df_n") #' # update_spec(res, "datasets", "error") @@ -91,10 +91,10 @@ update_s_spec <- function(spec, type, value) { if (is.na(spec[[type_restart]])) { next } - fun <- match.fun(type_restart) - restored_transform <- fun( - x = orig(spec[[type_restart]]$names), - select = orig(spec[[type_restart]]$select) + restored_transform <- type_helper( + type = type_restart, + x = orig(spec[[type_restart]]$names)[[1]], + select = orig(spec[[type_restart]]$select)[[1]] ) spec[[type_restart]] <- restored_transform } diff --git a/inst/WORDLIST b/inst/WORDLIST index 69f70fc7..f6b2e6ca 100644 --- a/inst/WORDLIST +++ b/inst/WORDLIST @@ -1,10 +1,12 @@ CDISC -Forkers -Hoffmann -Shinylive -UI cloneable +colData +Forkers funder +Hoffmann preselected +qenv repo reproducibility +Shinylive +UI diff --git a/man/resolver.Rd b/man/resolver.Rd index 9a05f1c9..628952c4 100644 --- a/man/resolver.Rd +++ b/man/resolver.Rd @@ -19,17 +19,17 @@ Given the specification of some data to extract find if they are available or no The specification for selecting a variable shouldn't depend on the data of said variable. } \examples{ -dataset1 <- datasets(is.data.frame) -dataset2 <- datasets(is.matrix) -spec <- dataset1 & variables("a", "a") +dataset1 <- datasets(where(is.data.frame)) +dataset2 <- datasets(where(is.matrix)) +spec <- c(dataset1, variables("a", "a")) td <- within(teal.data::teal_data(), { df <- data.frame(a = as.factor(LETTERS[1:5]), b = letters[1:5]) df2 <- data.frame(a = LETTERS[1:5], b = 1:5) m <- matrix() }) -resolver(spec | dataset2, td) +resolver(list(spec, dataset2), td) resolver(dataset2, td) resolver(spec, td) -spec <- dataset1 & variables("a", is.factor) +spec <- c(dataset1, variables("a", where(is.character))) resolver(spec, td) } diff --git a/man/types.Rd b/man/types.Rd index 731ae80f..0295bf5d 100644 --- a/man/types.Rd +++ b/man/types.Rd @@ -5,22 +5,16 @@ \alias{datasets} \alias{variables} \alias{mae_colData} -\alias{mae_sampleMap} -\alias{mae_experiments} \alias{values} \title{Type specification} \usage{ -datasets(x, select = first) +datasets(x, select = 1) -variables(x, select = first) +variables(x, select = 1) -mae_colData(x, select = first) +mae_colData(x, select = 1) -mae_sampleMap(x, select = first) - -mae_experiments(x, select = first) - -values(x, select = first) +values(x, select = 1) } \arguments{ \item{x}{Character specifying the names or functions to select them. The functions will be applied on the data or the names.} @@ -39,18 +33,14 @@ Define how to select and extract data \item \code{variables()}: Specify variables. -\item \code{mae_colData()}: Specify variables of MultiAssayExperiment col Data. - -\item \code{mae_sampleMap()}: Specify variables of MultiAssayExperiment sampleMap. - -\item \code{mae_experiments()}: Specify variables of MultiAssayExperiment experiments. +\item \code{mae_colData()}: Specify colData. \item \code{values()}: Specify values. }} \examples{ datasets("A") -datasets("A") | datasets("B") -datasets(is.data.frame) -datasets("A") & variables(is.numeric) +c(datasets("A"), datasets("B")) +datasets(where(is.data.frame)) +c(datasets("A"), variables(where(is.numeric))) } diff --git a/man/update_spec.Rd b/man/update_spec.Rd index a1db5f32..eb750cb4 100644 --- a/man/update_spec.Rd +++ b/man/update_spec.Rd @@ -30,7 +30,7 @@ td <- within(teal.data::teal_data(), { Ab = as.factor(letters[1:5]) ) }) -data_frames_factors <- datasets(is.data.frame) & variables(is.factor) +data_frames_factors <- c(datasets(where(is.data.frame)), variables(where(is.factor))) res <- resolver(data_frames_factors, td) update_spec(res, "datasets", "df_n") # update_spec(res, "datasets", "error") diff --git a/tests/testthat/test-delayed.R b/tests/testthat/test-delayed.R index 7b9a9beb..17c2ab8f 100644 --- a/tests/testthat/test-delayed.R +++ b/tests/testthat/test-delayed.R @@ -2,9 +2,9 @@ test_that("is.delayed works", { d <- datasets("a") v <- variables("b") expect_true(is.delayed(d)) - expect_false(is.delayed(datasets("a", "a"))) + expect_true(is.delayed(datasets("a", "a"))) expect_true(is.delayed(v)) - expect_false(is.delayed(variables("b", "b"))) + expect_true(is.delayed(variables("b", "b"))) expect_true(is.delayed(c(d, v))) expect_false(is.delayed(1)) da <- datasets(is.data.frame) diff --git a/tests/testthat/test-resolver.R b/tests/testthat/test-resolver.R index 7cf7c6a4..e43b0370 100644 --- a/tests/testthat/test-resolver.R +++ b/tests/testthat/test-resolver.R @@ -5,9 +5,9 @@ f <- function(x) { test_that("resolver datasets works", { df_head <- datasets("df") df_first <- datasets("df") - matrices <- datasets(is.matrix) - df_mean <- datasets("df", mean) - median_mean <- datasets(median, mean) + matrices <- datasets(where(is.matrix)) + df_mean <- datasets("df", where(mean)) + median_mean <- datasets(where(median), where(mean)) td <- within(teal.data::teal_data(), { df <- data.frame(a = LETTERS[1:5], b = factor(letters[1:5]), c = factor(letters[1:5])) m <- cbind(b = 1:5, c = 10:14) @@ -16,23 +16,23 @@ test_that("resolver datasets works", { expect_no_error(resolver(df_head, td)) expect_no_error(resolver(df_first, td)) out <- resolver(matrices, td) - expect_length(out$select, 1L) # Because we use first - expect_no_error(resolver(df_mean, td)) + expect_length(out$select, 2L) # Because we use everything + expect_error(expect_warning(resolver(df_mean, td))) expect_error(resolver(median_mean, td)) }) test_that("resolver variables works", { df <- datasets("df") - matrices <- datasets(is.matrix) - data_frames <- datasets(is.data.frame) + matrices <- datasets(where(is.matrix)) + data_frames <- datasets(where(is.data.frame)) var_a <- variables("a") - factors <- variables(is.factor) - factors_head <- variables(is.factor, function(x) { + factors <- variables(where(is.factor)) + factors_head <- variables(where(is.factor), where(function(x) { head(x, 1) - }) - var_matrices_head <- variables(is.matrix, function(x) { + })) + var_matrices_head <- variables(where(is.matrix), where(function(x) { head(x, 1) - }) + })) td <- within(teal.data::teal_data(), { df <- data.frame(a = LETTERS[1:5], b = factor(letters[1:5]), c = factor(letters[1:5])) m <- cbind(b = 1:5, c = 10:14) @@ -58,16 +58,16 @@ test_that("resolver variables works", { test_that("resolver values works", { df <- datasets("df") - matrices <- datasets(is.matrix) - data_frames <- datasets(is.data.frame) + matrices <- datasets(where(is.matrix)) + data_frames <- datasets(where(is.data.frame)) var_a <- variables("a") factors <- variables(is.factor) - factors_head <- variables(is.factor, function(x) { + factors_head <- variables(where(is.factor), where(function(x) { head(x, 1) - }) - var_matrices_head <- variables(is.matrix, function(x) { + })) + var_matrices_head <- variables(where(is.matrix), where(function(x) { head(x, 1) - }) + })) val_A <- values("A") td <- within(teal.data::teal_data(), { df <- data.frame(a = LETTERS[1:5], b = factor(letters[1:5]), c = factor(letters[1:5])) @@ -103,29 +103,30 @@ test_that("names and variables are reported", { m <- matrix() }) d_df <- datasets("df") - df_upper_variables <- c(d_df, variables(function(x) { + upper_variables <- variables(where(function(x) { x == toupper(x) })) - out <- resolver(df_upper_variables, td) + df_upper_variables <- c(d_df, upper_variables) + expect_error(resolver(df_upper_variables, td)) # This should select A and Ab: # A because the name is all capital letters and # Ab values is all upper case. - expect_length(out$variables$names, 2) - v_all_upper <- variables(function(x) { + # expect_length(out$variables$names, 2) + v_all_upper <- variables(where(function(x) { all(x == toupper(x)) - }) + })) df_all_upper_variables <- c(d_df, v_all_upper) expect_no_error(out <- resolver(df_all_upper_variables, td)) - expect_length(out$variables$names, 2L) + expect_length(out$variables$names, 1L) expect_no_error(out <- resolver(c(datasets("df2"), v_all_upper), td)) expect_length(out$variables$names, 2L) expect_no_error(out <- resolver(datasets(function(x) { is.data.frame(x) && all(colnames(x) == toupper(colnames(x))) }), td)) expect_length(out$names, 1L) - expect_no_error(out <- resolver(datasets(function(x) { + expect_no_error(out <- resolver(datasets(where(function(x) { is.data.frame(x) || any(colnames(x) == toupper(colnames(x))) - }), td)) + })), td)) expect_length(out$names, 2L) }) @@ -140,40 +141,13 @@ test_that("update_spec resolves correctly", { Ab = as.factor(letters[1:5]) ) }) - data_frames_factors <- c(datasets(is.data.frame), variables(is.factor)) + data_frames_factors <- c(datasets(where(is.data.frame)), variables(where(is.factor))) expect_false(is.null(attr(data_frames_factors$datasets$names, "original"))) expect_false(is.null(attr(data_frames_factors$datasets$select, "original"))) expect_false(is.null(attr(data_frames_factors$variables$names, "original"))) expect_false(is.null(attr(data_frames_factors$variables$select, "original"))) - res <- resolver(data_frames_factors, td) - expect_false(is.null(attr(res$datasets$names, "original"))) - expect_false(is.null(attr(res$datasets$select, "original"))) - expect_false(is.null(attr(res$variables$names, "original"))) - expect_false(is.null(attr(res$variables$select, "original"))) - - res2 <- update_spec(res, "datasets", "df_n") - expect_false(is.null(attr(res2$datasets$names, "original"))) - expect_false(is.null(attr(res2$datasets$select, "original"))) - expect_false(is.null(attr(res2$variables$names, "original"))) - expect_false(is.null(attr(res2$variables$select, "original"))) - - expect_no_error(res3 <- resolver(res2, td)) - expect_false(is.null(attr(res3$datasets$names, "original"))) - expect_false(is.null(attr(res3$datasets$select, "original"))) - expect_equal(attr(res3$datasets$names, "original"), attr(data_frames_factors$datasets$names, "original")) - expect_equal(attr(res3$datasets$select, "original"), attr(data_frames_factors$datasets$select, "original")) - expect_equal(res3$datasets$select, "df_n", check.attributes = FALSE) - expect_equal(res3$variables$select, "Ab", check.attributes = FALSE) - expect_false(is.null(attr(res3$variables$names, "original"))) - expect_false(is.null(attr(res3$variables$select, "original"))) - expect_equal(attr(res3$variables$names, "original"), attr(data_frames_factors$variables$names, "original")) - expect_equal(attr(res3$variables$select, "original"), attr(data_frames_factors$variables$select, "original")) - - expect_error(update_spec(res, "datasets", "error")) - expect_error(update_spec(data_frames_factors, "datasets", "error")) - expect_error(update_spec(datasets(x = c("df", "df2")), "datasets", "df2")) - expect_no_error(update_spec(datasets(x = c("df", "df2"), "df"), "datasets", "df2")) + expect_error(resolver(data_frames_factors, td)) }) test_that("OR specifications resolves correctly", { @@ -182,8 +156,8 @@ test_that("OR specifications resolves correctly", { m <- cbind(A = 1:5, B = 5:10) }) var_a <- variables("A") - df_a <- c(datasets(is.data.frame), var_a) - matrix_a <- c(datasets(is.matrix), var_a) + df_a <- c(datasets(where(is.data.frame)), var_a) + matrix_a <- c(datasets(where(is.matrix)), var_a) df_or_m_var_a <- list(df_a, matrix_a) out <- resolver(df_or_m_var_a, td) expect_true(all(vapply(out, is.transform, logical(1L)))) @@ -195,8 +169,8 @@ test_that("OR specifications fail correctly", { m <- cbind(A = 1:5, B = 5:10) }) var_a <- variables("A") - df_a <- c(datasets(is.data.frame), var_a) - matrix_a <- c(datasets(is.matrix), var_a) + df_a <- c(datasets(where(is.data.frame)), var_a) + matrix_a <- c(datasets(where(is.matrix)), var_a) df_or_m_var_a <- list(df_a, matrix_a) out <- resolver(df_or_m_var_a, td) expect_error(update_spec(out, "variables", "B")) @@ -208,8 +182,8 @@ test_that("OR update_spec filters specifications", { m <- cbind(A = 1:5, B = 5:10) }) var_a <- variables("A") - df_a <- c(datasets(is.data.frame), var_a) - matrix_a <- c(datasets(is.matrix), var_a) + df_a <- c(datasets(where(is.data.frame)), var_a) + matrix_a <- c(datasets(where(is.matrix)), var_a) df_or_m_var_a <- list(df_a, matrix_a) resolved <- resolver(df_or_m_var_a, td) # The second option is not possible to have it as df diff --git a/tests/testthat/test-types.R b/tests/testthat/test-types.R index 39795174..2f99472c 100644 --- a/tests/testthat/test-types.R +++ b/tests/testthat/test-types.R @@ -1,26 +1,21 @@ test_that("datasets", { expect_no_error(dataset0 <- datasets("df", "df")) - out <- list(names = "df", select = "df") - class(out) <- c("delayed", "datasets", "type", "list") - expect_equal(dataset0, out, check.attributes = FALSE) expect_no_error(dataset1 <- datasets("df")) - expect_true(is(dataset1$names, "vector")) - expect_no_error(dataset2 <- datasets(is.matrix)) - expect_true(is(dataset2$names, "vector")) - expect_no_error(dataset3 <- datasets(is.data.frame)) + expect_no_error(dataset2 <- datasets(where(is.matrix))) + expect_no_error(dataset3 <- datasets(where(is.data.frame))) }) test_that("variables", { expect_no_error(var0 <- variables("a", "a")) expect_no_error(var1 <- variables("a")) - expect_no_error(var2 <- variables(is.factor)) + expect_no_error(var2 <- variables(where(is.factor))) # Allowed to specify whatever we like, it is not until resolution that this raises errors - expect_no_error(var3 <- variables(is.factor, function(x) { + expect_no_error(var3 <- variables(where(is.factor), where(function(x) { head(x, 1) - })) - expect_no_error(var4 <- variables(is.matrix, function(x) { + }))) + expect_no_error(var4 <- variables(where(is.matrix), where(function(x) { head(x, 1) - })) + }))) }) test_that("raw combine of types", { @@ -31,20 +26,20 @@ test_that("raw combine of types", { test_that("combine types", { expect_no_error(c( - datasets(is.data.frame, select = "df1"), - variables(is.numeric) + datasets(where(is.data.frame), select = "df1"), + variables(where(is.numeric)) )) }) test_that("values", { expect_no_error(val0 <- values("a", "a")) expect_no_error(val1 <- values("a")) - expect_no_error(val2 <- values(is.factor)) + expect_no_error(val2 <- values(where(is.factor))) # Allowed to specify whatever we like, it is not until resolution that this raises errors - expect_no_error(val3 <- values(is.factor, function(x) { + expect_no_error(val3 <- values(where(is.factor), function(x) { head(x, 1) })) - expect_no_error(val4 <- values(is.matrix, function(x) { + expect_no_error(val4 <- values(where(is.matrix), function(x) { head(x, 1) })) }) From 18df6fc6dec90d2552dc75ccde20087d5862a03c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Tue, 6 May 2025 10:27:03 +0200 Subject: [PATCH 091/142] Fix remaining tests --- tests/testthat/test-resolver.R | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/tests/testthat/test-resolver.R b/tests/testthat/test-resolver.R index e43b0370..f218d9a9 100644 --- a/tests/testthat/test-resolver.R +++ b/tests/testthat/test-resolver.R @@ -16,7 +16,7 @@ test_that("resolver datasets works", { expect_no_error(resolver(df_head, td)) expect_no_error(resolver(df_first, td)) out <- resolver(matrices, td) - expect_length(out$select, 2L) # Because we use everything + expect_length(out$select, 1L) # Because we use 1 expect_error(expect_warning(resolver(df_mean, td))) expect_error(resolver(median_mean, td)) }) @@ -45,7 +45,7 @@ test_that("resolver variables works", { expect_error(resolver(c(df, var_matrices_head), td)) - expect_error(resolver(c(matrices, var_a), td)) # datasets selection overpasses variable choices. + expect_no_error(resolver(c(matrices, var_a), td)) expect_error(resolver(c(matrices, factors), td)) expect_error(resolver(c(matrices, factors_head), td)) expect_error(resolver(c(matrices, var_matrices_head), td)) @@ -147,7 +147,7 @@ test_that("update_spec resolves correctly", { expect_false(is.null(attr(data_frames_factors$variables$names, "original"))) expect_false(is.null(attr(data_frames_factors$variables$select, "original"))) - expect_error(resolver(data_frames_factors, td)) + expect_no_error(resolver(data_frames_factors, td)) }) test_that("OR specifications resolves correctly", { From 5cadc4325bfe487df3dc92e4156f0fef4ed5e6c9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Tue, 6 May 2025 10:45:57 +0200 Subject: [PATCH 092/142] Fix bugs --- R/merge_dataframes.R | 16 ++++++++++------ R/update_spec.R | 4 ++-- 2 files changed, 12 insertions(+), 8 deletions(-) diff --git a/R/merge_dataframes.R b/R/merge_dataframes.R index 6a3a15a0..9e3b97f1 100644 --- a/R/merge_dataframes.R +++ b/R/merge_dataframes.R @@ -8,8 +8,12 @@ consolidate_extraction <- function(...) { } # Assume the data is a data.frame so no other specifications types are present. - datasets <- lapply(input_resolved, function(x){x$datasets}) - variables <- lapply(input_resolved, function(x){x$variables}) + datasets <- lapply(input_resolved, function(x) { + x$datasets + }) + variables <- lapply(input_resolved, function(x) { + x$variables + }) lapply(unique(datasets), function(dataset, x, y) { list( @@ -29,7 +33,9 @@ add_ids <- function(input, data) { return(input) } - datasets <- lapply(input, function(x){x$datasets}) + datasets <- lapply(input, function(x) { + x$datasets + }) for (i in seq_along(input)) { x <- input[[i]] # Avoid adding as id something already present: No duplicating input. @@ -63,10 +69,9 @@ extract_ids <- function(input, data) { merge_call_pair <- function(selections, by, data, merge_function = "dplyr::full_join", anl_name = "ANL") { - selections <- consolidate_extraction(selections) stopifnot(length(selections) == 2L) - datasets <- unique(unlist(lapply(selections, `[[`, datasets), FALSE, FALSE)) + datasets <- unique(unlist(lapply(selections, `[[`, "datasets"), FALSE, FALSE)) stopifnot(length(datasets) >= 2) by <- extract_ids(input = selections, data) @@ -93,7 +98,6 @@ merge_call_pair <- function(selections, by, data, merge_call_multiple <- function(input, ids, merge_function, data, anl_name = "ANL") { - input <- consolidate_extraction(input) datasets <- unique(unlist(lapply(input, `[[`, "datasets"), FALSE, FALSE)) stopifnot(is.character(datasets) && length(datasets) >= 1L) diff --git a/R/update_spec.R b/R/update_spec.R index 4d637839..b02e26e2 100644 --- a/R/update_spec.R +++ b/R/update_spec.R @@ -93,8 +93,8 @@ update_s_spec <- function(spec, type, value) { } restored_transform <- type_helper( type = type_restart, - x = orig(spec[[type_restart]]$names)[[1]], - select = orig(spec[[type_restart]]$select)[[1]] + x = orig(spec[[type_restart]]$names), + select = orig(spec[[type_restart]]$select) ) spec[[type_restart]] <- restored_transform } From 50576d654a0460a4c4c29caaf1382eaaf08322d7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Tue, 6 May 2025 14:18:49 +0200 Subject: [PATCH 093/142] Add method for colData and avoid Infinite recursion --- NAMESPACE | 1 + R/resolver.R | 135 ++++++++++++++++++++++++++++++--------------------- 2 files changed, 80 insertions(+), 56 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 9e66c7b1..5d596b3e 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -8,6 +8,7 @@ S3method(data_extract_multiple_srv,list) S3method(data_extract_multiple_srv,reactive) S3method(data_extract_srv,FilteredData) S3method(data_extract_srv,list) +S3method(determine,colData) S3method(determine,datasets) S3method(determine,default) S3method(determine,transform) diff --git a/R/resolver.R b/R/resolver.R index 2cd80544..765d883b 100644 --- a/R/resolver.R +++ b/R/resolver.R @@ -69,17 +69,40 @@ determine <- function(type, data, ...) { #' @export determine.default <- function(type, data, ..., spec) { - # Used when the type is of class list. - if (!is.null(names(type)) && is.delayed(type)) { - return(determine(type, data)) + type <- eval_type_names(type, data) + + if (is.null(type$names) || !length(type$names)) { + stop("No ", toString(is(type)), " meet the specification.", call. = FALSE) } - d <- data - for (i in seq_along(type)) { - di <- determine(type[[i]], d, spec = spec) - type[[i]] <- di$type - d <- di$data + + type <- eval_type_select(type, data[unorig(type$names)]) + + if (!is.delayed(type) && length(type$select) == 1L) { + list(type = type, data = data[[unorig(type$select)]]) + } else { + list(type = type, data = data[unorig(type$select)]) + } +} + +#' @export +determine.colData <- function(type, data, ..., spec) { + if (!requireNamespace("SummarizedExperiment", quietly = TRUE)) { + stop("Requires SummarizedExperiment package from Bioconductor.") + } + data <- as.data.frame(colData(data)) + type <- eval_type_names(type, data) + + if (is.null(type$names) || !length(type$names)) { + stop("No ", toString(is(type)), " meet the specification.", call. = FALSE) + } + + type <- eval_type_select(type, data[unorig(type$names)]) + + if (!is.delayed(type) && length(type$select) == 1L) { + list(type = type, data = data[[unorig(type$select)]]) + } else { + list(type = type, data = data[unorig(type$select)]) } - list(type = type, data = data) } #' @export @@ -100,52 +123,52 @@ determine.transform <- function(type, data, ..., spec) { # Checks that for the given type and data names and data it can be resolved # The workhorse of the resolver -determine_helper <- function(type, data_names, data) { - stopifnot(!is.null(type)) - orig_names <- type$names - orig_select <- type$select - - if (is.delayed(type) && all(is.character(type$names))) { - new_names <- intersect(data_names, type$names) - - type$names <- new_names - if (length(new_names) == 0) { - return(NULL) - # stop("No selected ", is(type), " matching the conditions requested") - } else if (length(new_names) == 1L) { - type$select <- new_names - } else { - new_select <- selector(data, type$names) - if (!length(new_select)) { - return(NULL) - # stop("No ", is(type), " meet the requirements to be selected") - } - type$select <- new_select - } - } else if (is.delayed(type)) { - new_names <- selector(data, type$select) - } - - - if (!length(new_names)) { - return(NULL) - # stop("No ", is(type), " meet the requirements") - } - type$names <- new_names - - if (length(type$names) == 0) { - return(NULL) - # stop("No selected ", is(type), " matching the conditions requested") - } else if (length(type$names) == 1) { - type$select <- type$names - } - - new_select <- selector(data, type$select) - type$select <- new_select - attr(type$names, "original") <- orig(orig_names) - attr(type$select, "original") <- orig(orig_select) - resolved(type) -} +# determine_helper <- function(type, data_names, data) { +# stopifnot(!is.null(type)) +# orig_names <- type$names +# orig_select <- type$select +# +# if (is.delayed(type) && all(is.character(type$names))) { +# new_names <- intersect(data_names, type$names) +# +# type$names <- new_names +# if (length(new_names) == 0) { +# return(NULL) +# # stop("No selected ", is(type), " matching the conditions requested") +# } else if (length(new_names) == 1L) { +# type$select <- new_names +# } else { +# new_select <- selector(data, type$names) +# if (!length(new_select)) { +# return(NULL) +# # stop("No ", is(type), " meet the requirements to be selected") +# } +# type$select <- new_select +# } +# } else if (is.delayed(type)) { +# new_names <- selector(data, type$select) +# } +# +# +# if (!length(new_names)) { +# return(NULL) +# # stop("No ", is(type), " meet the requirements") +# } +# type$names <- new_names +# +# if (length(type$names) == 0) { +# return(NULL) +# # stop("No selected ", is(type), " matching the conditions requested") +# } else if (length(type$names) == 1) { +# type$select <- type$names +# } +# +# new_select <- selector(data, type$select) +# type$select <- new_select +# attr(type$names, "original") <- orig(orig_names) +# attr(type$select, "original") <- orig(orig_select) +# resolved(type) +# } #' @export determine.datasets <- function(type, data, ...) { @@ -201,7 +224,7 @@ determine.variables <- function(type, data, ...) { } # This works for matrices and data.frames of length 1 or multiple # be aware of drop behavior on tibble vs data.frame - list(type = type, data = data[, type$select]) + list(type = type, data = data[, type$select, drop = FALSE]) } # @export From a031ad931c65f7f5f8401d23ed72abc17b20f75c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Thu, 8 May 2025 11:13:50 +0200 Subject: [PATCH 094/142] If selection is empty it stops --- R/resolver.R | 9 +++++++-- tests/testthat/test-resolver.R | 9 ++++----- 2 files changed, 11 insertions(+), 7 deletions(-) diff --git a/R/resolver.R b/R/resolver.R index 765d883b..4a8d4aad 100644 --- a/R/resolver.R +++ b/R/resolver.R @@ -69,6 +69,11 @@ determine <- function(type, data, ...) { #' @export determine.default <- function(type, data, ..., spec) { + if (is.list(type) && is.null(names(type))) { + l <- lapply(type, determine, data = data, spec = spec) + return(l) + } + type <- eval_type_names(type, data) if (is.null(type$names) || !length(type$names)) { @@ -345,8 +350,8 @@ eval_type_select <- function(type, data) { # Keep only those that were already selected new_select <- intersect(unique(names(c(select_data))), unorig(type$names)) - if (is.null(new_select)) { - stop("No ", is(type), " selection is possible.") + if (is.null(new_select) || !length(new_select)) { + stop("No ", is(type), " selection is possible.", call. = FALSE) } attr(new_select, "original") <- orig_select diff --git a/tests/testthat/test-resolver.R b/tests/testthat/test-resolver.R index f218d9a9..a9a59825 100644 --- a/tests/testthat/test-resolver.R +++ b/tests/testthat/test-resolver.R @@ -40,7 +40,7 @@ test_that("resolver variables works", { }) expect_no_error(resolver(c(df, var_a), td)) - expect_no_error(resolver(c(df, factors), td)) + expect_error(resolver(c(df, factors), td)) expect_error(resolver(c(df, factors_head), td)) expect_error(resolver(c(df, var_matrices_head), td)) @@ -51,7 +51,7 @@ test_that("resolver variables works", { expect_error(resolver(c(matrices, var_matrices_head), td)) expect_no_error(resolver(c(data_frames, var_a), td)) - expect_no_error(resolver(c(data_frames, factors), td)) + expect_error(resolver(c(data_frames, factors), td)) expect_error(resolver(c(data_frames, factors_head), td)) expect_error(resolver(c(data_frames, var_matrices_head), td)) }) @@ -116,8 +116,7 @@ test_that("names and variables are reported", { all(x == toupper(x)) })) df_all_upper_variables <- c(d_df, v_all_upper) - expect_no_error(out <- resolver(df_all_upper_variables, td)) - expect_length(out$variables$names, 1L) + expect_error(out <- resolver(df_all_upper_variables, td)) expect_no_error(out <- resolver(c(datasets("df2"), v_all_upper), td)) expect_length(out$variables$names, 2L) expect_no_error(out <- resolver(datasets(function(x) { @@ -147,7 +146,7 @@ test_that("update_spec resolves correctly", { expect_false(is.null(attr(data_frames_factors$variables$names, "original"))) expect_false(is.null(attr(data_frames_factors$variables$select, "original"))) - expect_no_error(resolver(data_frames_factors, td)) + expect_error(resolver(data_frames_factors, td)) }) test_that("OR specifications resolves correctly", { From 153524443cbaaa966da47c2ef039d157e29d69b3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Fri, 9 May 2025 09:28:44 +0200 Subject: [PATCH 095/142] Rename x argument to names and transform class to specification --- NAMESPACE | 2 +- R/delayed.R | 30 +++++++++++++++--------------- R/resolver.R | 2 +- R/types.R | 40 ++++++++++++++++++++-------------------- R/update_spec.R | 6 +++--- man/is.delayed.Rd | 4 ++-- man/resolver.Rd | 2 +- man/types.Rd | 10 +++++----- 8 files changed, 48 insertions(+), 48 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 5d596b3e..0b3b27ac 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,7 +1,7 @@ # Generated by roxygen2: do not edit by hand S3method(anyNA,type) -S3method(c,transform) +S3method(c,specification) S3method(c,type) S3method(data_extract_multiple_srv,FilteredData) S3method(data_extract_multiple_srv,list) diff --git a/R/delayed.R b/R/delayed.R index f94cd585..62e8772d 100644 --- a/R/delayed.R +++ b/R/delayed.R @@ -9,20 +9,20 @@ delay <- function(x) { #' Is the specification resolved? #' #' Check that the specification is resolved against a given data source. -#' @param x Object to be evaluated. +#' @param specification Object to be evaluated. #' @returns A single logical value. #' @examples #' is.delayed(1) #' is.delayed(variables("df", "df")) #' is.delayed(variables("df")) # Unknown selection #' @export -is.delayed <- function(x) { +is.delayed <- function(specification) { UseMethod("is.delayed") } #' @export #' @method is.delayed default -is.delayed.default <- function(x) { +is.delayed.default <- function(specification) { # FIXME: A warning? FALSE } @@ -30,31 +30,31 @@ is.delayed.default <- function(x) { # Handling a list of transformers e1 | e2 #' @export #' @method is.delayed list -is.delayed.list <- function(x) { - any(vapply(x, is.delayed, logical(1L))) +is.delayed.list <- function(specification) { + any(vapply(specification, is.delayed, logical(1L))) } #' @export #' @method is.delayed transform -is.delayed.transform <- function(x) { - any(vapply(x, is.delayed, logical(1L))) +is.delayed.transform <- function(specification) { + any(vapply(specification, is.delayed, logical(1L))) } #' @export #' @method is.delayed type -is.delayed.type <- function(x) { - if (!is.na(x)) { - return(!all(is.character(x$names)) || !all(is.character(x$select))) +is.delayed.type <- function(specification) { + if (!is.na(specification)) { + return(!all(is.character(specification$names)) || !all(is.character(specification$select))) } FALSE } -resolved <- function(x, type = is(x)) { - s <- all(is.character(x$names)) && all(is.character(x$select)) +resolved <- function(specification, type = is(specification)) { + s <- all(is.character(specification$names)) && all(is.character(specification$select)) - if (!s && !all(x$select %in% x$names)) { + if (!s && !all(specification$select %in% specification$names)) { stop("Selected ", type, " not resolved.") } - attr(x, "delayed") <- NULL - x + attr(specification, "delayed") <- NULL + specification } diff --git a/R/resolver.R b/R/resolver.R index 4a8d4aad..a1226b4a 100644 --- a/R/resolver.R +++ b/R/resolver.R @@ -5,7 +5,7 @@ #' @param spec A object extraction specification. #' @param data The qenv where the specification is evaluated. #' -#' @returns A transform but resolved +#' @returns A specification but resolved: the names and selection is the name of the objects (if possible). #' @export #' #' @examples diff --git a/R/types.R b/R/types.R index 51c3884c..c55dfbb2 100644 --- a/R/types.R +++ b/R/types.R @@ -1,10 +1,10 @@ -is.transform <- function(x) { - inherits(x, "transform") +is.specification <- function(x) { + inherits(x, "specification") } -valid_transform <- function(x) { - !((is.type(x) || is.transform(x))) +valid_specification <- function(x) { + !((is.type(x) || is.specification(x))) } na_type <- function(type) { @@ -55,10 +55,10 @@ first_var <- function(offset = 0L, vars = NULL) { last_var <- tidyselect::last_col -type_helper <- function(x, select, type) { - out <- list(names = x, select = select) +type_helper <- function(names, select, type) { + out <- list(names = names, select = select) class(out) <- c(type, "type", "list") - attr(out$names, "original") <- x + attr(out$names, "original") <- names attr(out$select, "original") <- select delay(out) } @@ -68,7 +68,7 @@ type_helper <- function(x, select, type) { #' @title Type specification #' @description #' Define how to select and extract data -#' @param x Character specifying the names or functions to select them. The functions will be applied on the data or the names. +#' @param names Character specifying the names or functions to select them. The functions will be applied on the data or the names. #' @param select Character of `x` or functions to select on x (only on names or positional not on the data of the variable). #' @returns An object of the same class as the function with two elements: names the content of x, and select. #' @examples @@ -80,33 +80,33 @@ NULL #' @describeIn types Specify datasets. #' @export -datasets <- function(x, select = 1) { - type_helper(x = rlang::enquo(x), select = rlang::enquo(select), type = "datasets") +datasets <- function(names, select = 1) { + type_helper(names = rlang::enquo(names), select = rlang::enquo(select), type = "datasets") } #' @describeIn types Specify variables. #' @export -variables <- function(x, select = 1) { - type_helper(x = rlang::enquo(x), select = rlang::enquo(select), type = "variables") +variables <- function(names, select = 1) { + type_helper(names = rlang::enquo(names), select = rlang::enquo(select), type = "variables") } #' @describeIn types Specify colData. #' @export -mae_colData <- function(x, select = 1) { - type_helper(x = rlang::enquo(x), select = rlang::enquo(select), type = "colData") +mae_colData <- function(names, select = 1) { + type_helper(names = rlang::enquo(names), select = rlang::enquo(select), type = "colData") } #' @describeIn types Specify values. #' @export -values <- function(x, select = 1) { - type_helper(x = rlang::enquo(x), select = rlang::enquo(select), type = "values") +values <- function(names, select = 1) { + type_helper(names = rlang::enquo(names), select = rlang::enquo(select), type = "values") } #' @export -c.transform <- function(...) { +c.specification <- function(...) { l <- list(...) types <- lapply(l, names) - typesc <- vapply(l, is.transform, logical(1L)) + typesc <- vapply(l, is.specification, logical(1L)) if (!all(typesc)) { stop("An object in position ", which(!typesc), " is not a specification.") } @@ -144,7 +144,7 @@ c.transform <- function(...) { class(new_type) <- c(t, "type", "list") vector[[t]] <- new_type } - class(vector) <- c("transform", "list") + class(vector) <- c("specification", "list") vector } @@ -196,7 +196,7 @@ c.type <- function(...) { if (length(vector) == 1) { return(vector[[1]]) } - class(vector) <- c("transform", "list") + class(vector) <- c("specification", "list") vector } diff --git a/R/update_spec.R b/R/update_spec.R index b02e26e2..b74d4674 100644 --- a/R/update_spec.R +++ b/R/update_spec.R @@ -29,7 +29,7 @@ update_spec <- function(spec, type, value) { ) } - if (valid_transform(spec)) { + if (valid_specification(spec)) { stop("Unexpected object used as specification") } @@ -91,12 +91,12 @@ update_s_spec <- function(spec, type, value) { if (is.na(spec[[type_restart]])) { next } - restored_transform <- type_helper( + restored_specification <- type_helper( type = type_restart, x = orig(spec[[type_restart]]$names), select = orig(spec[[type_restart]]$select) ) - spec[[type_restart]] <- restored_transform + spec[[type_restart]] <- restored_specification } spec } diff --git a/man/is.delayed.Rd b/man/is.delayed.Rd index 49f4290a..7a83ec6a 100644 --- a/man/is.delayed.Rd +++ b/man/is.delayed.Rd @@ -4,10 +4,10 @@ \alias{is.delayed} \title{Is the specification resolved?} \usage{ -is.delayed(x) +is.delayed(specification) } \arguments{ -\item{x}{Object to be evaluated.} +\item{specification}{Object to be evaluated.} } \value{ A single logical value. diff --git a/man/resolver.Rd b/man/resolver.Rd index 628952c4..108f2f18 100644 --- a/man/resolver.Rd +++ b/man/resolver.Rd @@ -12,7 +12,7 @@ resolver(spec, data) \item{data}{The qenv where the specification is evaluated.} } \value{ -A transform but resolved +A specification but resolved: the names and selection is the name of the objects (if possible). } \description{ Given the specification of some data to extract find if they are available or not. diff --git a/man/types.Rd b/man/types.Rd index 0295bf5d..10409985 100644 --- a/man/types.Rd +++ b/man/types.Rd @@ -8,16 +8,16 @@ \alias{values} \title{Type specification} \usage{ -datasets(x, select = 1) +datasets(names, select = 1) -variables(x, select = 1) +variables(names, select = 1) -mae_colData(x, select = 1) +mae_colData(names, select = 1) -values(x, select = 1) +values(names, select = 1) } \arguments{ -\item{x}{Character specifying the names or functions to select them. The functions will be applied on the data or the names.} +\item{names}{Character specifying the names or functions to select them. The functions will be applied on the data or the names.} \item{select}{Character of \code{x} or functions to select on x (only on names or positional not on the data of the variable).} } From 1385c1f5dd95cb635d98a24b44fc2204b99235f1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Fri, 9 May 2025 10:12:04 +0200 Subject: [PATCH 096/142] Revert testing to allow empty selection --- NAMESPACE | 2 +- R/module_input.R | 2 +- R/resolver.R | 14 +++----------- tests/testthat/test-resolver.R | 10 +++++----- 4 files changed, 10 insertions(+), 18 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 0b3b27ac..a6695192 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -11,7 +11,7 @@ S3method(data_extract_srv,list) S3method(determine,colData) S3method(determine,datasets) S3method(determine,default) -S3method(determine,transform) +S3method(determine,specification) S3method(determine,values) S3method(determine,variables) S3method(extract,default) diff --git a/R/module_input.R b/R/module_input.R index a6931856..d60794e2 100644 --- a/R/module_input.R +++ b/R/module_input.R @@ -32,7 +32,7 @@ module_input_ui <- function(id, label, spec) { #' @export module_input_server <- function(id, spec, data) { - stopifnot(is.transform(spec)) + stopifnot(is.specification(spec)) stopifnot(is.reactive(data)) stopifnot(is.character(id)) moduleServer(id, function(input, output, session) { diff --git a/R/resolver.R b/R/resolver.R index a1226b4a..69ebcf2c 100644 --- a/R/resolver.R +++ b/R/resolver.R @@ -39,7 +39,7 @@ resolver <- function(spec, data) { spec <- c(datasets(first), spec) } - stopifnot(is.list(spec) || is.transform(spec)) + stopifnot(is.list(spec) || is.specification(spec)) det <- determine(spec, data, spec = spec) if (is.null(names(det))) { return(lapply(det, `[[`, 1)) @@ -58,7 +58,7 @@ resolver <- function(spec, data) { #' @keywords internal #' @export determine <- function(type, data, ...) { - stopifnot(is.type(type) || is.list(type) || is.transform(type)) + stopifnot(is.type(type) || is.list(type) || is.specification(type)) if (!is.delayed(type) && length(type$select) > 1L) { return(list(type = type, data = data[unorig(type$select)])) } else if (!is.delayed(type) && length(type$select) == 1L) { @@ -75,11 +75,6 @@ determine.default <- function(type, data, ..., spec) { } type <- eval_type_names(type, data) - - if (is.null(type$names) || !length(type$names)) { - stop("No ", toString(is(type)), " meet the specification.", call. = FALSE) - } - type <- eval_type_select(type, data[unorig(type$names)]) if (!is.delayed(type) && length(type$select) == 1L) { @@ -111,7 +106,7 @@ determine.colData <- function(type, data, ..., spec) { } #' @export -determine.transform <- function(type, data, ..., spec) { +determine.specification <- function(type, data, ..., spec) { stopifnot(inherits(data, "qenv")) d <- data for (i in seq_along(type)) { @@ -350,9 +345,6 @@ eval_type_select <- function(type, data) { # Keep only those that were already selected new_select <- intersect(unique(names(c(select_data))), unorig(type$names)) - if (is.null(new_select) || !length(new_select)) { - stop("No ", is(type), " selection is possible.", call. = FALSE) - } attr(new_select, "original") <- orig_select type$select <- new_select diff --git a/tests/testthat/test-resolver.R b/tests/testthat/test-resolver.R index a9a59825..48c33130 100644 --- a/tests/testthat/test-resolver.R +++ b/tests/testthat/test-resolver.R @@ -40,7 +40,7 @@ test_that("resolver variables works", { }) expect_no_error(resolver(c(df, var_a), td)) - expect_error(resolver(c(df, factors), td)) + expect_no_error(resolver(c(df, factors), td)) expect_error(resolver(c(df, factors_head), td)) expect_error(resolver(c(df, var_matrices_head), td)) @@ -51,7 +51,7 @@ test_that("resolver variables works", { expect_error(resolver(c(matrices, var_matrices_head), td)) expect_no_error(resolver(c(data_frames, var_a), td)) - expect_error(resolver(c(data_frames, factors), td)) + expect_no_error(resolver(c(data_frames, factors), td)) expect_error(resolver(c(data_frames, factors_head), td)) expect_error(resolver(c(data_frames, var_matrices_head), td)) }) @@ -116,7 +116,7 @@ test_that("names and variables are reported", { all(x == toupper(x)) })) df_all_upper_variables <- c(d_df, v_all_upper) - expect_error(out <- resolver(df_all_upper_variables, td)) + expect_no_error(out <- resolver(df_all_upper_variables, td)) expect_no_error(out <- resolver(c(datasets("df2"), v_all_upper), td)) expect_length(out$variables$names, 2L) expect_no_error(out <- resolver(datasets(function(x) { @@ -146,7 +146,7 @@ test_that("update_spec resolves correctly", { expect_false(is.null(attr(data_frames_factors$variables$names, "original"))) expect_false(is.null(attr(data_frames_factors$variables$select, "original"))) - expect_error(resolver(data_frames_factors, td)) + expect_no_error(resolver(data_frames_factors, td)) }) test_that("OR specifications resolves correctly", { @@ -159,7 +159,7 @@ test_that("OR specifications resolves correctly", { matrix_a <- c(datasets(where(is.matrix)), var_a) df_or_m_var_a <- list(df_a, matrix_a) out <- resolver(df_or_m_var_a, td) - expect_true(all(vapply(out, is.transform, logical(1L)))) + expect_true(all(vapply(out, is.specification, logical(1L)))) }) test_that("OR specifications fail correctly", { From 85787b840f6c34d07d198299ff230bdd0ca8fa68 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Fri, 9 May 2025 12:22:58 +0200 Subject: [PATCH 097/142] Fix problems with renamings --- NAMESPACE | 3 ++- R/delayed.R | 4 ++-- R/module_input.R | 2 +- R/update_spec.R | 2 +- 4 files changed, 6 insertions(+), 5 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index a6695192..10c63de6 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -15,11 +15,12 @@ S3method(determine,specification) S3method(determine,values) S3method(determine,variables) S3method(extract,default) +S3method(extract,teal_data) S3method(filter_spec_internal,default) S3method(filter_spec_internal,delayed_data) S3method(is.delayed,default) S3method(is.delayed,list) -S3method(is.delayed,transform) +S3method(is.delayed,specification) S3method(is.delayed,type) S3method(is.na,type) S3method(merge_expression_module,list) diff --git a/R/delayed.R b/R/delayed.R index 62e8772d..595838f7 100644 --- a/R/delayed.R +++ b/R/delayed.R @@ -35,8 +35,8 @@ is.delayed.list <- function(specification) { } #' @export -#' @method is.delayed transform -is.delayed.transform <- function(specification) { +#' @method is.delayed specification +is.delayed.specification <- function(specification) { any(vapply(specification, is.delayed, logical(1L))) } diff --git a/R/module_input.R b/R/module_input.R index d60794e2..00104c59 100644 --- a/R/module_input.R +++ b/R/module_input.R @@ -17,7 +17,7 @@ module_input_ui <- function(id, label, spec) { a(label), ) - if (valid_transform(spec)) { + if (valid_specification(spec)) { stop("Unexpected object used as specification.") } diff --git a/R/update_spec.R b/R/update_spec.R index b74d4674..a65c53f8 100644 --- a/R/update_spec.R +++ b/R/update_spec.R @@ -93,7 +93,7 @@ update_s_spec <- function(spec, type, value) { } restored_specification <- type_helper( type = type_restart, - x = orig(spec[[type_restart]]$names), + names = orig(spec[[type_restart]]$names), select = orig(spec[[type_restart]]$select) ) spec[[type_restart]] <- restored_specification From 3fafc92bf5acb99223e8b2d9816adc8f4c7f24ac Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Fri, 9 May 2025 12:24:26 +0200 Subject: [PATCH 098/142] Extract before tidyselect on names --- R/extract.R | 32 +++++++++------------------- R/resolver.R | 39 ++++++++++++++++------------------ tests/testthat/test-resolver.R | 12 ----------- 3 files changed, 28 insertions(+), 55 deletions(-) diff --git a/R/extract.R b/R/extract.R index 162620f8..6279ec6f 100644 --- a/R/extract.R +++ b/R/extract.R @@ -12,30 +12,9 @@ extract <- function(x, variable, ...) { UseMethod("extract") } -# Cases handled by the default method -# @export -# extract.MultiAssayExperiment <- function(x, variable) { -# # if (!requireNamespace("MultiAssayExperiment", quietly = TRUE)) { -# # stop("Required to have MultiAssayExperiment's package.") -# # } -# x[, variable, drop = TRUE] -# } -# -# @export -# extract.DataFrame <- function(x, variable) { -# # if (!requireNamespace("S4Vectors", quietly = TRUE)) { -# # stop("Required to have S4Vectors's package.") -# # } -# x[, variable, drop = TRUE] -# } -# -# @export -# extract.matrix <- function(x, variable) { -# x[, variable, drop = TRUE] -# } #' @export -extract.default <- function(x, variable, ..., drop = TRUE) { +extract.default <- function(x, variable, ..., drop = FALSE) { if (length(dim(x)) == 2L || length(variable) > 1L) { x[, variable, drop = drop] } else { @@ -43,6 +22,15 @@ extract.default <- function(x, variable, ..., drop = TRUE) { } } +#' @export +extract.teal_data <- function(x, variable, ...) { + if (length(variable) > 1L) { + x[variable] + } else { + x[[variable]] + } +} + # @export # @method extract data.frame # extract.data.frame <- function(x, variable) { diff --git a/R/resolver.R b/R/resolver.R index 69ebcf2c..ee8e091a 100644 --- a/R/resolver.R +++ b/R/resolver.R @@ -331,8 +331,25 @@ unorig <- function(x) { x } +eval_type_names <- function(type, data) { + orig_names <- orig(type$names) + if (length(orig_names) == 1L) { + orig_names <- orig_names[[1L]] + } + + new_names <- selector(data, type$names) + + new_names <- unique(names(new_names)) + attr(new_names, "original") <- orig_names + + type$names <- new_names + + type +} + eval_type_select <- function(type, data) { stopifnot(is.character(type$names)) + data <- extract(data, type$names) orig_select <- orig(type$select) if (length(orig_select) == 1L) { @@ -341,30 +358,10 @@ eval_type_select <- function(type, data) { names <- seq_along(type$names) names(names) <- type$names - select_data <- selector(data, type$select) + new_select <- names(selector(data, type$select)) - # Keep only those that were already selected - new_select <- intersect(unique(names(c(select_data))), unorig(type$names)) attr(new_select, "original") <- orig_select - type$select <- new_select type } - - -eval_type_names <- function(type, data) { - orig_names <- orig(type$names) - if (length(orig_names) == 1L) { - orig_names <- orig_names[[1L]] - } - - new_names <- selector(data, type$names) - - new_names <- unique(names(new_names)) - attr(new_names, "original") <- orig_names - - type$names <- new_names - - type -} diff --git a/tests/testthat/test-resolver.R b/tests/testthat/test-resolver.R index 48c33130..126a6121 100644 --- a/tests/testthat/test-resolver.R +++ b/tests/testthat/test-resolver.R @@ -77,18 +77,6 @@ test_that("resolver values works", { expect_no_error(resolver(c(df, var_a, val_A), td)) }) -test_that("resolver works with excluded types", { - td <- within(teal.data::teal_data(), { - df <- data.frame( - a = LETTERS[1:5], - b = factor(letters[1:5]), - c = factor(letters[1:5]) - ) - }) - # spec <- c(datasets("df"), variables(c("a", "b")), !variables("b")) - # expect_no_error(resolver(spec, td)) -}) - test_that("names and variables are reported", { td <- within(teal.data::teal_data(), { df <- data.frame( From 5ccfe34c9ee7849eefa62bd798f50670e1713bbd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Fri, 9 May 2025 13:20:49 +0200 Subject: [PATCH 099/142] Reuse extraction --- R/resolver.R | 24 +++++++++++------------- 1 file changed, 11 insertions(+), 13 deletions(-) diff --git a/R/resolver.R b/R/resolver.R index ee8e091a..3faa3a30 100644 --- a/R/resolver.R +++ b/R/resolver.R @@ -59,10 +59,8 @@ resolver <- function(spec, data) { #' @export determine <- function(type, data, ...) { stopifnot(is.type(type) || is.list(type) || is.specification(type)) - if (!is.delayed(type) && length(type$select) > 1L) { - return(list(type = type, data = data[unorig(type$select)])) - } else if (!is.delayed(type) && length(type$select) == 1L) { - return(list(type = type, data = data[[unorig(type$select)]])) + if (!is.delayed(type)) { + return(list(type = type, data = extract(data, unorig(type$select)))) } UseMethod("determine") } @@ -186,13 +184,9 @@ determine.datasets <- function(type, data, ...) { stop("No ", toString(is(type)), " meet the specification.", call. = FALSE) } - type <- eval_type_select(type, data[unorig(type$names)]) + type <- eval_type_select(type, data) - if (!is.delayed(type) && length(type$select) == 1L) { - list(type = type, data = data[[unorig(type$select)]]) - } else { - list(type = type, data = data[unorig(type$select)]) - } + list(type = type, data = extract(data, unorig(type$select))) } #' @export @@ -224,7 +218,7 @@ determine.variables <- function(type, data, ...) { } # This works for matrices and data.frames of length 1 or multiple # be aware of drop behavior on tibble vs data.frame - list(type = type, data = data[, type$select, drop = FALSE]) + list(type = type, data = extract(data, unorig(type$select))) } # @export @@ -349,8 +343,12 @@ eval_type_names <- function(type, data) { eval_type_select <- function(type, data) { stopifnot(is.character(type$names)) - data <- extract(data, type$names) - + if (!is(data, "qenv")) { + data <- extract(data, type$names) + } else { + # Do not extract; selection would be from the data extracted not from the names. + data <- data[type$names] + } orig_select <- orig(type$select) if (length(orig_select) == 1L) { orig_select <- orig_select[[1L]] From 10509da325a39eca8ee0481480f5d13c2225270b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Fri, 9 May 2025 13:22:35 +0200 Subject: [PATCH 100/142] Match expectations based on names --- R/selector.R | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/R/selector.R b/R/selector.R index 55be6ed5..069f8628 100644 --- a/R/selector.R +++ b/R/selector.R @@ -1,6 +1,7 @@ selector <- function(data, ...) { if (is.environment(data)) { - data <- as.list(data) + # To keep the "order" of the names in the extraction: avoids suprises + data <- as.list(data)[names(data)] } else if (length(dim(data)) == 2L) { data <- as.data.frame(data) } From 5b8b51d4fc58b61fc46523ac63c920228b363eff Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Fri, 9 May 2025 13:45:42 +0200 Subject: [PATCH 101/142] Clean up of unused functions and arguments --- R/resolver.R | 10 +++++----- R/types.R | 27 --------------------------- 2 files changed, 5 insertions(+), 32 deletions(-) diff --git a/R/resolver.R b/R/resolver.R index 3faa3a30..d82b29e5 100644 --- a/R/resolver.R +++ b/R/resolver.R @@ -40,7 +40,7 @@ resolver <- function(spec, data) { } stopifnot(is.list(spec) || is.specification(spec)) - det <- determine(spec, data, spec = spec) + det <- determine(spec, data) if (is.null(names(det))) { return(lapply(det, `[[`, 1)) } else { @@ -66,7 +66,7 @@ determine <- function(type, data, ...) { } #' @export -determine.default <- function(type, data, ..., spec) { +determine.default <- function(type, data, ...) { if (is.list(type) && is.null(names(type))) { l <- lapply(type, determine, data = data, spec = spec) return(l) @@ -83,7 +83,7 @@ determine.default <- function(type, data, ..., spec) { } #' @export -determine.colData <- function(type, data, ..., spec) { +determine.colData <- function(type, data, ...) { if (!requireNamespace("SummarizedExperiment", quietly = TRUE)) { stop("Requires SummarizedExperiment package from Bioconductor.") } @@ -104,11 +104,11 @@ determine.colData <- function(type, data, ..., spec) { } #' @export -determine.specification <- function(type, data, ..., spec) { +determine.specification <- function(type, data, ...) { stopifnot(inherits(data, "qenv")) d <- data for (i in seq_along(type)) { - di <- determine(type[[i]], d, spec = spec) + di <- determine(type[[i]], d) # overwrite so that next type in line receives the corresponding data and specification if (is.null(di$type)) { next diff --git a/R/types.R b/R/types.R index c55dfbb2..349ce0a7 100644 --- a/R/types.R +++ b/R/types.R @@ -28,33 +28,6 @@ anyNA.type <- function(x, recursive = FALSE) { anyNA(unclass(x[c("names", "select")]), recursive) } -first <- function(x) { - if (length(x) > 0) { - false <- rep_len(FALSE, length.out = length(x)) - false[1] <- TRUE - return(false) - } - return(FALSE) -} - -first_var <- function(offset = 0L, vars = NULL) { - if (!rlang::is_integerish(offset, n = 1)) { - not <- class(offset) - cli::cli_abort("{.arg offset} must be a single integer, not {not}.") - } - vars <- vars %||% tidyselect::peek_vars(fn = "first_var") - n <- length(vars) - if (offset > n) { - cli::cli_abort("{.arg offset} ({offset}) must be smaller than the number of columns ({n}).") - } else if (n == 0) { - cli::cli_abort("Can't select last column when input is empty.") - } else { - 1L - } -} - -last_var <- tidyselect::last_col - type_helper <- function(names, select, type) { out <- list(names = names, select = select) class(out) <- c(type, "type", "list") From 29c65009c060909ece7192255c238eeddd26d9cf Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Fri, 9 May 2025 13:50:13 +0200 Subject: [PATCH 102/142] Restore test --- tests/testthat/test-resolver.R | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/tests/testthat/test-resolver.R b/tests/testthat/test-resolver.R index 126a6121..02f6c907 100644 --- a/tests/testthat/test-resolver.R +++ b/tests/testthat/test-resolver.R @@ -44,8 +44,7 @@ test_that("resolver variables works", { expect_error(resolver(c(df, factors_head), td)) expect_error(resolver(c(df, var_matrices_head), td)) - - expect_no_error(resolver(c(matrices, var_a), td)) + expect_error(resolver(c(matrices, var_a), td)) expect_error(resolver(c(matrices, factors), td)) expect_error(resolver(c(matrices, factors_head), td)) expect_error(resolver(c(matrices, var_matrices_head), td)) From 3ba1bf567511ed2e565ee07d576ad0f53d40f896 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Fri, 9 May 2025 19:59:23 +0200 Subject: [PATCH 103/142] Renaming --- NAMESPACE | 1 + R/delayed.R | 6 +- R/module_input.R | 6 +- R/resolver.R | 221 ++++++++------------------------- R/types.R | 139 +++++++++------------ man/types.Rd | 13 +- tests/testthat/test-resolver.R | 31 +++-- 7 files changed, 147 insertions(+), 270 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 10c63de6..c84bac54 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -11,6 +11,7 @@ S3method(data_extract_srv,list) S3method(determine,colData) S3method(determine,datasets) S3method(determine,default) +S3method(determine,list) S3method(determine,specification) S3method(determine,values) S3method(determine,variables) diff --git a/R/delayed.R b/R/delayed.R index 595838f7..cb9c70eb 100644 --- a/R/delayed.R +++ b/R/delayed.R @@ -44,15 +44,15 @@ is.delayed.specification <- function(specification) { #' @method is.delayed type is.delayed.type <- function(specification) { if (!is.na(specification)) { - return(!all(is.character(specification$names)) || !all(is.character(specification$select))) + return(!all(is.character(specification$choices)) || !all(is.character(specification$selected))) } FALSE } resolved <- function(specification, type = is(specification)) { - s <- all(is.character(specification$names)) && all(is.character(specification$select)) + s <- all(is.character(specification$choices)) && all(is.character(specification$selected)) - if (!s && !all(specification$select %in% specification$names)) { + if (!s && !all(specification$selected %in% specification$choices)) { stop("Selected ", type, " not resolved.") } attr(specification, "delayed") <- NULL diff --git a/R/module_input.R b/R/module_input.R index 00104c59..0fd75dcb 100644 --- a/R/module_input.R +++ b/R/module_input.R @@ -69,8 +69,8 @@ module_input_server <- function(id, spec, data) { shiny::updateSelectInput( session, variable, - choices = unorig(spec[[variable]]$names), - selected = unorig(spec[[variable]]$select) + choices = unorig(spec[[variable]]$choices), + selected = unorig(spec[[variable]]$selected) ) # FIXME: set on gray the input # FIXME: Hide input field if any type on specification cannot be solved @@ -86,7 +86,7 @@ module_input_server <- function(id, spec, data) { names(selection) <- names(spec) for (i in seq_along(spec)) { variable <- names(spec)[i] - selection[[variable]] <- unorig(spec[[variable]]$select) + selection[[variable]] <- unorig(spec[[variable]]$selected) } selection }) diff --git a/R/resolver.R b/R/resolver.R index d82b29e5..f5e66cfd 100644 --- a/R/resolver.R +++ b/R/resolver.R @@ -30,16 +30,13 @@ resolver <- function(spec, data) { return(spec) } - # Adding some default specifications if they are missing - if ("values" %in% names(spec) && !"variables" %in% names(spec)) { - spec <- c(variables(first), spec) - } - - if ("variables" %in% names(spec) && !"datasets" %in% names(spec)) { - spec <- c(datasets(first), spec) + stopifnot(is.list(spec) || is.specification(spec)) + if (is.type(spec)) { + spec <- list(spec) + names(spec) <- is(spec[[1]]) + class(spec) <- c("specification", class(spec)) } - stopifnot(is.list(spec) || is.specification(spec)) det <- determine(spec, data) if (is.null(names(det))) { return(lapply(det, `[[`, 1)) @@ -60,26 +57,27 @@ resolver <- function(spec, data) { determine <- function(type, data, ...) { stopifnot(is.type(type) || is.list(type) || is.specification(type)) if (!is.delayed(type)) { - return(list(type = type, data = extract(data, unorig(type$select)))) + return(list(type = type, data = extract(data, unorig(type$selected)))) } UseMethod("determine") } #' @export determine.default <- function(type, data, ...) { + stop("There is not a specific method to pick choices.") +} + +#' @export +determine.list <- function(type, data, ...) { if (is.list(type) && is.null(names(type))) { l <- lapply(type, determine, data = data, spec = spec) return(l) } type <- eval_type_names(type, data) - type <- eval_type_select(type, data[unorig(type$names)]) + type <- eval_type_select(type, data) - if (!is.delayed(type) && length(type$select) == 1L) { - list(type = type, data = data[[unorig(type$select)]]) - } else { - list(type = type, data = data[unorig(type$select)]) - } + list(type = type, data = extract(data, unorig(type$selected))) } #' @export @@ -90,22 +88,28 @@ determine.colData <- function(type, data, ...) { data <- as.data.frame(colData(data)) type <- eval_type_names(type, data) - if (is.null(type$names) || !length(type$names)) { + if (is.null(type$choices) || !length(type$choices)) { stop("No ", toString(is(type)), " meet the specification.", call. = FALSE) } - type <- eval_type_select(type, data[unorig(type$names)]) + type <- eval_type_select(type, data) - if (!is.delayed(type) && length(type$select) == 1L) { - list(type = type, data = data[[unorig(type$select)]]) - } else { - list(type = type, data = data[unorig(type$select)]) - } + list(type = type, data = extract(data, unorig(type$selected))) } #' @export determine.specification <- function(type, data, ...) { stopifnot(inherits(data, "qenv")) + + # Adding some default specifications if they are missing + if ("values" %in% names(type) && !"variables" %in% names(type)) { + type <- append(type, list(variables = variables()), length(type) - 1) + } + + if ("variables" %in% names(type) && !"datasets" %in% names(type)) { + type <- append(type, list(variables = datasets()), length(type) - 1) + } + d <- data for (i in seq_along(type)) { di <- determine(type[[i]], d) @@ -119,55 +123,6 @@ determine.specification <- function(type, data, ...) { list(type = type, data = data) # It is the transform object resolved. } -# Checks that for the given type and data names and data it can be resolved -# The workhorse of the resolver -# determine_helper <- function(type, data_names, data) { -# stopifnot(!is.null(type)) -# orig_names <- type$names -# orig_select <- type$select -# -# if (is.delayed(type) && all(is.character(type$names))) { -# new_names <- intersect(data_names, type$names) -# -# type$names <- new_names -# if (length(new_names) == 0) { -# return(NULL) -# # stop("No selected ", is(type), " matching the conditions requested") -# } else if (length(new_names) == 1L) { -# type$select <- new_names -# } else { -# new_select <- selector(data, type$names) -# if (!length(new_select)) { -# return(NULL) -# # stop("No ", is(type), " meet the requirements to be selected") -# } -# type$select <- new_select -# } -# } else if (is.delayed(type)) { -# new_names <- selector(data, type$select) -# } -# -# -# if (!length(new_names)) { -# return(NULL) -# # stop("No ", is(type), " meet the requirements") -# } -# type$names <- new_names -# -# if (length(type$names) == 0) { -# return(NULL) -# # stop("No selected ", is(type), " matching the conditions requested") -# } else if (length(type$names) == 1) { -# type$select <- type$names -# } -# -# new_select <- selector(data, type$select) -# type$select <- new_select -# attr(type$names, "original") <- orig(orig_names) -# attr(type$select, "original") <- orig(orig_select) -# resolved(type) -# } - #' @export determine.datasets <- function(type, data, ...) { if (is.null(data)) { @@ -180,13 +135,13 @@ determine.datasets <- function(type, data, ...) { # FIXME: What happens if colnames is null: colnames(array(dim = c(4, 2))) type <- eval_type_names(type, data) - if (is.null(type$names) || !length(type$names)) { + if (is.null(type$choices) || !length(type$choices)) { stop("No ", toString(is(type)), " meet the specification.", call. = FALSE) } type <- eval_type_select(type, data) - list(type = type, data = extract(data, unorig(type$select))) + list(type = type, data = extract(data, unorig(type$selected))) } #' @export @@ -206,7 +161,7 @@ determine.variables <- function(type, data, ...) { type <- eval_type_names(type, data) - if (is.null(type$names) || !length(type$names)) { + if (is.null(type$choices) || !length(type$choices)) { stop("No ", toString(is(type)), " meet the specification.", call. = FALSE) } @@ -218,81 +173,9 @@ determine.variables <- function(type, data, ...) { } # This works for matrices and data.frames of length 1 or multiple # be aware of drop behavior on tibble vs data.frame - list(type = type, data = extract(data, unorig(type$select))) + list(type = type, data = extract(data, unorig(type$selected))) } -# @export -# determine.mae_colData <- function(type, data, ...) { -# if (!requireNamespace("MultiAssayExperiment", quietly = TRUE)) { -# stop("Requires 'MultiAssayExperiment' package.") -# } -# -# new_data <- colData(data) -# for (i in seq_along(new_data)) { -# type <- determine_helper(type, colnames(new_data)[i], new_data[, i]) -# } -# if (length(dim(new_data)) != 2L) { -# stop("Can't resolve variables from this object of class ", class(new_data)) -# } -# if (ncol(new_data) <= 0L) { -# stop("Can't pull variable: No variable is available.") -# } -# type <- determine_helper(type, colnames(new_data), new_data) -# -# # Not possible to know what is happening -# if (is.delayed(type)) { -# return(list(type = type, data = NULL)) -# } -# -# if (length(type$select) > 1) { -# list(type = type, data = data[type$select]) -# } else { -# list(type = type, data = data[[type$select]]) -# } -# } - -# @export -# determine.mae_experiments <- function(type, data, ...) { -# if (!requireNamespace("MultiAssayExperiment", quietly = TRUE)) { -# stop("Requires 'MultiAssayExperiment' package.") -# } -# new_data <- experiments(data) -# type <- determine_helper(type, names(new_data), new_data) -# -# # Not possible to know what is happening -# if (is.delayed(type)) { -# } -# -# if (!is.delayed(type) && length(type$select) > 1) { -# list(type = type, data = new_data[type$select]) -# } else if (!is.delayed(type) && length(type$select) == 1) { -# list(type = type, data = new_data[[type$select]]) -# } else { -# return(list(type = type, data = NULL)) -# } -# } - -# @export -# determine.mae_sampleMap <- function(type, data, ...) { -# if (!requireNamespace("MultiAssayExperiment", quietly = TRUE)) { -# stop("Requires 'MultiAssayExperiment' package.") -# } -# -# new_data <- sampleMap(data) -# type <- determine_helper(type, names(new_data), new_data) -# -# # Not possible to know what is happening -# if (is.delayed(type)) { -# return(list(type = type, data = NULL)) -# } -# -# if (length(type$select) > 1) { -# list(type = type, data = data[type$select]) -# } else { -# list(type = type, data = data[[type$select]]) -# } -# } - #' @export determine.values <- function(type, data, ...) { if (!is.numeric(data)) { @@ -301,12 +184,12 @@ determine.values <- function(type, data, ...) { } else { d <- data } - sel <- selector(d, type$names) - type$names <- data[sel] + sel <- selector(d, type$choices) + type$choices <- data[sel] - sel2 <- selector(d[sel], type$select) - type$select <- data[sel][sel2] + sel2 <- selector(d[sel], type$selected) + type$selected <- data[sel][sel2] # Not possible to know what is happening if (is.delayed(type)) { @@ -326,40 +209,40 @@ unorig <- function(x) { } eval_type_names <- function(type, data) { - orig_names <- orig(type$names) - if (length(orig_names) == 1L) { - orig_names <- orig_names[[1L]] + orig_choices <- orig(type$choices) + if (length(orig_choices) == 1L) { + orig_choices <- orig_choices[[1L]] } - new_names <- selector(data, type$names) + new_choices <- selector(data, type$choices) - new_names <- unique(names(new_names)) - attr(new_names, "original") <- orig_names + new_choices <- unique(names(new_choices)) + attr(new_choices, "original") <- orig_choices - type$names <- new_names + type$choices <- new_choices type } eval_type_select <- function(type, data) { - stopifnot(is.character(type$names)) + stopifnot(is.character(type$choices)) if (!is(data, "qenv")) { - data <- extract(data, type$names) + data <- extract(data, type$choices) } else { # Do not extract; selection would be from the data extracted not from the names. - data <- data[type$names] + data <- data[type$choices] } - orig_select <- orig(type$select) - if (length(orig_select) == 1L) { - orig_select <- orig_select[[1L]] + orig_selected <- orig(type$selected) + if (length(orig_selected) == 1L) { + orig_selected <- orig_selected[[1L]] } - names <- seq_along(type$names) - names(names) <- type$names - new_select <- names(selector(data, type$select)) + choices <- seq_along(type$choices) + names(choices) <- type$choices + new_selected <- names(selector(data, type$selected)) - attr(new_select, "original") <- orig_select - type$select <- new_select + attr(new_selected, "original") <- orig_selected + type$selected <- new_selected type } diff --git a/R/types.R b/R/types.R index 349ce0a7..ba434533 100644 --- a/R/types.R +++ b/R/types.R @@ -20,19 +20,19 @@ is.type <- function(x) { #' @export #' @method is.na type is.na.type <- function(x) { - anyNA(unclass(x[c("names", "select")])) + anyNA(unclass(x[c("names", "selected")])) } #' @export anyNA.type <- function(x, recursive = FALSE) { - anyNA(unclass(x[c("names", "select")]), recursive) + anyNA(unclass(x[c("choices", "selected")]), recursive) } -type_helper <- function(names, select, type) { - out <- list(names = names, select = select) +type_helper <- function(choices, selected, type) { + out <- list(choices = choices, selected = selected) class(out) <- c(type, "type", "list") - attr(out$names, "original") <- names - attr(out$select, "original") <- select + attr(out$choices, "original") <- choices + attr(out$selected, "original") <- selected delay(out) } @@ -41,10 +41,11 @@ type_helper <- function(names, select, type) { #' @title Type specification #' @description #' Define how to select and extract data -#' @param names Character specifying the names or functions to select them. The functions will be applied on the data or the names. -#' @param select Character of `x` or functions to select on x (only on names or positional not on the data of the variable). +#' @param choices <[`tidy-select`][dplyr_tidy_select]> One unquoted expression to be used to pick the choices. +#' @param selected <[`tidy-select`][dplyr_tidy_select]> One unquoted expression to be used to pick from choices to be selected. #' @returns An object of the same class as the function with two elements: names the content of x, and select. #' @examples +#' datasets() #' datasets("A") #' c(datasets("A"), datasets("B")) #' datasets(where(is.data.frame)) @@ -53,26 +54,26 @@ NULL #' @describeIn types Specify datasets. #' @export -datasets <- function(names, select = 1) { - type_helper(names = rlang::enquo(names), select = rlang::enquo(select), type = "datasets") +datasets <- function(choices = everything(), select = 1) { + type_helper(rlang::enquo(choices), rlang::enquo(select), "datasets") } #' @describeIn types Specify variables. #' @export -variables <- function(names, select = 1) { - type_helper(names = rlang::enquo(names), select = rlang::enquo(select), type = "variables") +variables <- function(choices = everything(), select = 1) { + type_helper(rlang::enquo(choices), rlang::enquo(select), "variables") } #' @describeIn types Specify colData. #' @export -mae_colData <- function(names, select = 1) { - type_helper(names = rlang::enquo(names), select = rlang::enquo(select), type = "colData") +mae_colData <- function(choices = everything(), select = 1) { + type_helper(rlang::enquo(choices), rlang::enquo(select), "colData") } #' @describeIn types Specify values. #' @export -values <- function(names, select = 1) { - type_helper(names = rlang::enquo(names), select = rlang::enquo(select), type = "values") +values <- function(choices = everything(), select = 1) { + type_helper(rlang::enquo(choices), rlang::enquo(select), "values") } #' @export @@ -88,7 +89,7 @@ c.specification <- function(...) { names(vector) <- utypes for (t in utypes) { new_type <- vector("list", length = 2) - names(new_type) <- c("names", "select") + names(new_type) <- c("choices", "selected") class(new_type) <- c("type", "list") for (i in seq_along(l)) { if (!t %in% names(l[[i]])) { @@ -97,23 +98,23 @@ c.specification <- function(...) { # Slower but less code duplication: # new_type <- c(new_type, l[[i]][[t]]) # then we need class(new_type) <- c(t, "type", "list") outside the loop - old_names <- new_type$names - old_select <- new_type$select - new_type$names <- c(old_names, l[[i]][[t]][["names"]]) - attr(new_type$names, "original") <- c(orig( - old_names + old_choices <- new_type$choices + old_selected <- new_type$selected + new_type$choices <- c(old_choices, l[[i]][[t]][["choices"]]) + attr(new_type$choices, "original") <- c(orig( + old_choices ), orig(l[[i]][[t]][["names"]])) - new_type$select <- c(old_select, l[[i]][[t]][["select"]]) - attr(new_type$select, "original") <- c(orig(old_select), orig(l[[i]][[t]][["select"]])) + new_type$selected <- c(old_selected, l[[i]][[t]][["selected"]]) + attr(new_type$selected, "original") <- c(orig(old_selected), orig(l[[i]][[t]][["selected"]])) attr(new_type, "delayed") <- any(attr(new_type, "delayed"), attr(l[[i]], "delayed")) } - orig_names <- unique(orig(new_type$names)) - new_type$names <- unique(new_type$names) - attr(new_type$names, "original") <- orig_names + orig_choices <- unique(orig(new_type$choices)) + new_type$choices <- unique(new_type$choices) + attr(new_type$choices, "original") <- orig_choices - orig_select <- unique(orig(new_type$select)) - new_type$select <- unique(new_type$select) - attr(new_type$select, "original") <- orig_select + orig_selected <- unique(orig(new_type$selected)) + new_type$selected <- unique(new_type$selected) + attr(new_type$selected, "original") <- orig_selected class(new_type) <- c(t, "type", "list") vector[[t]] <- new_type } @@ -134,33 +135,33 @@ c.type <- function(...) { names(vector) <- utypes for (t in utypes) { new_type <- vector("list", length = 2) - names(new_type) <- c("names", "select") + names(new_type) <- c("choices", "selected") for (i in seq_along(l)) { if (!is(l[[i]], t)) { next } - old_names <- new_type$names - old_select <- new_type$select - new_type$names <- c(old_names, l[[i]][["names"]]) - attr(new_type$names, "original") <- c(orig( - old_names - ), orig(l[[i]][["names"]])) - new_type$select <- unique(c(old_select, l[[i]][["select"]])) - attr(new_type$select, "original") <- c(orig(old_select), orig(l[[i]][["select"]])) + old_choices <- new_type$choices + old_selected <- new_type$selected + new_type$choices <- c(old_choices, l[[i]][["choices"]]) + attr(new_type$choices, "original") <- c(orig( + old_choices + ), orig(l[[i]][["choices"]])) + new_type$selected <- unique(c(old_selected, l[[i]][["selected"]])) + attr(new_type$selected, "original") <- c(orig(old_selected), orig(l[[i]][["selected"]])) } - orig_names <- unique(orig(new_type$names)) - orig_select <- unique(orig(new_type$select)) + orig_choices <- unique(orig(new_type$choices)) + orig_selected <- unique(orig(new_type$selected)) - new_type$names <- unique(new_type$names) - if (length(new_type$names) == 1) { - new_type$names <- new_type$names[[1]] + new_type$choices <- unique(new_type$choices) + if (length(new_type$choices) == 1) { + new_type$choices <- new_type$choices[[1]] } - attr(new_type$names, "original") <- orig_names + attr(new_type$choices, "original") <- orig_choices - if (length(new_type$select) == 1) { - new_type$select <- new_type$select[[1]] + if (length(new_type$selected) == 1) { + new_type$selected <- new_type$selected[[1]] } - attr(new_type$select, "original") <- orig_select + attr(new_type$selected, "original") <- orig_selected class(new_type) <- c(t, "type", "list") attr(new_type, "delayed") <- is.delayed(new_type) @@ -184,57 +185,39 @@ print.type <- function(x, ...) { return(x) } - nam_functions <- count_functions(x$names) + choices_fns <- count_functions(x$choices) msg_values <- character() - nam_values <- length(x$names) - sum(nam_functions) - if (any(nam_functions)) { - msg_values <- paste0(msg_values, sum(nam_functions), " functions for possible choices.", + choices_values <- length(x$choices) - sum(choices_fns) + if (any(choices_fns)) { + msg_values <- paste0(msg_values, sum(choices_fns), " functions for possible choices.", collapse = "\n" ) } - if (nam_values) { - msg_values <- paste0(msg_values, paste0(rlang::as_label(x$names[!nam_functions]), collapse = ", "), + if (choices_values) { + msg_values <- paste0(msg_values, paste0(rlang::as_label(x$choices[!choices_fns]), collapse = ", "), " as possible choices.", collapse = "\n" ) } - sel_functions <- count_functions(x$select) + selected_fns <- count_functions(x$selected) msg_sel <- character() - sel_values <- length(x$select) - sum(sel_functions) - if (any(sel_functions)) { - msg_sel <- paste0(msg_sel, sum(sel_functions), " functions to select.", + sel_values <- length(x$selected) - sum(selected_fns) + if (any(selected_fns)) { + msg_sel <- paste0(msg_sel, sum(selected_fns), " functions to select.", collapse = "\n" ) } if (sel_values) { - msg_sel <- paste0(msg_sel, paste0(rlang::as_label(x$select[!sel_functions]), collapse = ", "), + msg_sel <- paste0(msg_sel, paste0(rlang::as_label(x$selected[!selected_fns]), collapse = ", "), " selected.", collapse = "\n" ) } - if (!is.null(x[["except"]])) { - exc_functions <- count_functions(x$except) - msg_exc <- character() - sel_values <- length(x$except) - sum(exc_functions) - if (any(exc_functions)) { - msg_exc <- paste0(msg_exc, sum(exc_functions), " functions to exclude.", - collapse = "\n" - ) - } - if (sel_values) { - msg_exc <- paste0(msg_exc, paste0(rlang::as_label(x$except[!exc_functions]), collapse = ", "), - " excluded.", - collapse = "\n" - ) - } - } else { - msg_exc <- character() - } - cat(msg_values, msg_sel, msg_exc) + cat(msg_values, msg_sel) return(x) } diff --git a/man/types.Rd b/man/types.Rd index 10409985..d9c53b25 100644 --- a/man/types.Rd +++ b/man/types.Rd @@ -8,18 +8,18 @@ \alias{values} \title{Type specification} \usage{ -datasets(names, select = 1) +datasets(choices = everything(), select = 1) -variables(names, select = 1) +variables(choices = everything(), select = 1) -mae_colData(names, select = 1) +mae_colData(choices = everything(), select = 1) -values(names, select = 1) +values(choices = everything(), select = 1) } \arguments{ -\item{names}{Character specifying the names or functions to select them. The functions will be applied on the data or the names.} +\item{choices}{<\code{\link[=dplyr_tidy_select]{tidy-select}}> One unquoted expression to be used to pick the choices.} -\item{select}{Character of \code{x} or functions to select on x (only on names or positional not on the data of the variable).} +\item{selected}{<\code{\link[=dplyr_tidy_select]{tidy-select}}> One unquoted expression to be used to pick from choices to be selected.} } \value{ An object of the same class as the function with two elements: names the content of x, and select. @@ -39,6 +39,7 @@ Define how to select and extract data }} \examples{ +datasets() datasets("A") c(datasets("A"), datasets("B")) datasets(where(is.data.frame)) diff --git a/tests/testthat/test-resolver.R b/tests/testthat/test-resolver.R index 02f6c907..af07bdc5 100644 --- a/tests/testthat/test-resolver.R +++ b/tests/testthat/test-resolver.R @@ -16,7 +16,7 @@ test_that("resolver datasets works", { expect_no_error(resolver(df_head, td)) expect_no_error(resolver(df_first, td)) out <- resolver(matrices, td) - expect_length(out$select, 1L) # Because we use 1 + expect_length(out$datasets$selected, 1L) # Because we use 1 expect_error(expect_warning(resolver(df_mean, td))) expect_error(resolver(median_mean, td)) }) @@ -55,6 +55,15 @@ test_that("resolver variables works", { expect_error(resolver(c(data_frames, var_matrices_head), td)) }) +test_that("resolver with missing type works", { + td <- within(teal.data::teal_data(), { + i <- iris + }) + + r <- expect_no_error(resolver(variables(where(is.numeric)), td)) + expect_true(r$variables$selected == "i") +}) + test_that("resolver values works", { df <- datasets("df") matrices <- datasets(where(is.matrix)) @@ -98,22 +107,22 @@ test_that("names and variables are reported", { # This should select A and Ab: # A because the name is all capital letters and # Ab values is all upper case. - # expect_length(out$variables$names, 2) + # expect_length(out$variables$choices, 2) v_all_upper <- variables(where(function(x) { all(x == toupper(x)) })) df_all_upper_variables <- c(d_df, v_all_upper) expect_no_error(out <- resolver(df_all_upper_variables, td)) expect_no_error(out <- resolver(c(datasets("df2"), v_all_upper), td)) - expect_length(out$variables$names, 2L) - expect_no_error(out <- resolver(datasets(function(x) { + expect_length(out$variables$choices, 2L) + expect_no_error(out <- resolver(datasets(where(function(x) { is.data.frame(x) && all(colnames(x) == toupper(colnames(x))) - }), td)) - expect_length(out$names, 1L) + })), td)) + expect_length(out$datasets$choices, 1L) expect_no_error(out <- resolver(datasets(where(function(x) { is.data.frame(x) || any(colnames(x) == toupper(colnames(x))) })), td)) - expect_length(out$names, 2L) + expect_length(out$datasets$choices, 2L) }) test_that("update_spec resolves correctly", { @@ -128,10 +137,10 @@ test_that("update_spec resolves correctly", { ) }) data_frames_factors <- c(datasets(where(is.data.frame)), variables(where(is.factor))) - expect_false(is.null(attr(data_frames_factors$datasets$names, "original"))) - expect_false(is.null(attr(data_frames_factors$datasets$select, "original"))) - expect_false(is.null(attr(data_frames_factors$variables$names, "original"))) - expect_false(is.null(attr(data_frames_factors$variables$select, "original"))) + expect_false(is.null(attr(data_frames_factors$datasets$choices, "original"))) + expect_false(is.null(attr(data_frames_factors$datasets$selected, "original"))) + expect_false(is.null(attr(data_frames_factors$variables$choices, "original"))) + expect_false(is.null(attr(data_frames_factors$variables$selected, "original"))) expect_no_error(resolver(data_frames_factors, td)) }) From ced90532fba7606c740503aabdc6ffb1892b4550 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Mon, 12 May 2025 09:36:20 +0200 Subject: [PATCH 104/142] Fix renaming issues --- NAMESPACE | 1 + R/resolver.R | 2 +- R/types.R | 21 +++++++++++---------- R/update_spec.R | 20 ++++++++++---------- man/types.Rd | 12 ++++++------ tests/testthat/test-types.R | 2 +- 6 files changed, 30 insertions(+), 28 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index c84bac54..bd169a15 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -103,3 +103,4 @@ import(shiny) importFrom(dplyr,"%>%") importFrom(lifecycle,badge) importFrom(methods,is) +importFrom(tidyselect,everything) diff --git a/R/resolver.R b/R/resolver.R index f5e66cfd..0f4ca488 100644 --- a/R/resolver.R +++ b/R/resolver.R @@ -70,7 +70,7 @@ determine.default <- function(type, data, ...) { #' @export determine.list <- function(type, data, ...) { if (is.list(type) && is.null(names(type))) { - l <- lapply(type, determine, data = data, spec = spec) + l <- lapply(type, determine, data = data) return(l) } diff --git a/R/types.R b/R/types.R index ba434533..d1f02fc6 100644 --- a/R/types.R +++ b/R/types.R @@ -41,8 +41,8 @@ type_helper <- function(choices, selected, type) { #' @title Type specification #' @description #' Define how to select and extract data -#' @param choices <[`tidy-select`][dplyr_tidy_select]> One unquoted expression to be used to pick the choices. -#' @param selected <[`tidy-select`][dplyr_tidy_select]> One unquoted expression to be used to pick from choices to be selected. +#' @param choices <[`tidy-select`][dplyr::dplyr_tidy_select]> One unquoted expression to be used to pick the choices. +#' @param selected <[`tidy-select`][dplyr::dplyr_tidy_select]> One unquoted expression to be used to pick from choices to be selected. #' @returns An object of the same class as the function with two elements: names the content of x, and select. #' @examples #' datasets() @@ -52,28 +52,29 @@ type_helper <- function(choices, selected, type) { #' c(datasets("A"), variables(where(is.numeric))) NULL +#' @importFrom tidyselect everything #' @describeIn types Specify datasets. #' @export -datasets <- function(choices = everything(), select = 1) { - type_helper(rlang::enquo(choices), rlang::enquo(select), "datasets") +datasets <- function(choices = tidyselect::everything(), selected = 1) { + type_helper(rlang::enquo(choices), rlang::enquo(selected), "datasets") } #' @describeIn types Specify variables. #' @export -variables <- function(choices = everything(), select = 1) { - type_helper(rlang::enquo(choices), rlang::enquo(select), "variables") +variables <- function(choices = tidyselect::everything(), selected = 1) { + type_helper(rlang::enquo(choices), rlang::enquo(selected), "variables") } #' @describeIn types Specify colData. #' @export -mae_colData <- function(choices = everything(), select = 1) { - type_helper(rlang::enquo(choices), rlang::enquo(select), "colData") +mae_colData <- function(choices = tidyselect::everything(), selected = 1) { + type_helper(rlang::enquo(choices), rlang::enquo(selected), "colData") } #' @describeIn types Specify values. #' @export -values <- function(choices = everything(), select = 1) { - type_helper(rlang::enquo(choices), rlang::enquo(select), "values") +values <- function(choices = tidyselect::everything(), selected = 1) { + type_helper(rlang::enquo(choices), rlang::enquo(selected), "values") } #' @export diff --git a/R/update_spec.R b/R/update_spec.R index a65c53f8..806a451b 100644 --- a/R/update_spec.R +++ b/R/update_spec.R @@ -63,25 +63,25 @@ update_s_spec <- function(spec, type, value) { type <- match.arg(type, spec_types) restart_types <- spec_types[seq_along(spec_types) > which(type == spec_types)] - valid_names <- spec[[type]]$names + valid_names <- spec[[type]]$choices if (!is.list(valid_names) && all(value %in% valid_names)) { original_select <- orig(spec[[type]]$select) - spec[[type]][["select"]] <- value - attr(spec[[type]][["select"]], "original") <- original_select + spec[[type]][["selected"]] <- value + attr(spec[[type]][["selected"]], "original") <- original_select } else if (!is.list(valid_names) && !all(value %in% valid_names)) { - original_select <- orig(spec[[type]]$select) + original_select <- orig(spec[[type]]$selected) valid_values <- intersect(value, valid_names) if (!length(valid_values)) { stop("No valid value provided.") } if (!length(valid_values)) { - spec[[type]][["select"]] <- original_select + spec[[type]][["selected"]] <- original_select } else { - spec[[type]][["select"]] <- valid_values + spec[[type]][["selected"]] <- valid_values } - attr(spec[[type]][["select"]], "original") <- original_select + attr(spec[[type]][["selected"]], "original") <- original_select } else { stop("It seems the specification needs to be resolved first.") } @@ -92,9 +92,9 @@ update_s_spec <- function(spec, type, value) { next } restored_specification <- type_helper( - type = type_restart, - names = orig(spec[[type_restart]]$names), - select = orig(spec[[type_restart]]$select) + orig(spec[[type_restart]]$choices), + orig(spec[[type_restart]]$selected), + type_restart ) spec[[type_restart]] <- restored_specification } diff --git a/man/types.Rd b/man/types.Rd index d9c53b25..2b47a81a 100644 --- a/man/types.Rd +++ b/man/types.Rd @@ -8,18 +8,18 @@ \alias{values} \title{Type specification} \usage{ -datasets(choices = everything(), select = 1) +datasets(choices = tidyselect::everything(), selected = 1) -variables(choices = everything(), select = 1) +variables(choices = tidyselect::everything(), selected = 1) -mae_colData(choices = everything(), select = 1) +mae_colData(choices = tidyselect::everything(), selected = 1) -values(choices = everything(), select = 1) +values(choices = tidyselect::everything(), selected = 1) } \arguments{ -\item{choices}{<\code{\link[=dplyr_tidy_select]{tidy-select}}> One unquoted expression to be used to pick the choices.} +\item{choices}{<\code{\link[dplyr:dplyr_tidy_select]{tidy-select}}> One unquoted expression to be used to pick the choices.} -\item{selected}{<\code{\link[=dplyr_tidy_select]{tidy-select}}> One unquoted expression to be used to pick from choices to be selected.} +\item{selected}{<\code{\link[dplyr:dplyr_tidy_select]{tidy-select}}> One unquoted expression to be used to pick from choices to be selected.} } \value{ An object of the same class as the function with two elements: names the content of x, and select. diff --git a/tests/testthat/test-types.R b/tests/testthat/test-types.R index 2f99472c..dfb4dc0c 100644 --- a/tests/testthat/test-types.R +++ b/tests/testthat/test-types.R @@ -26,7 +26,7 @@ test_that("raw combine of types", { test_that("combine types", { expect_no_error(c( - datasets(where(is.data.frame), select = "df1"), + datasets(where(is.data.frame), selected = "df1"), variables(where(is.numeric)) )) }) From f3e3fa3573e4b4dc268794546dc700ae580b7f32 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Mon, 12 May 2025 10:21:48 +0200 Subject: [PATCH 105/142] Remove unused package --- DESCRIPTION | 1 - 1 file changed, 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index 89ae48f1..6608015d 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -22,7 +22,6 @@ Depends: R (>= 3.6) Imports: checkmate (>= 2.1.0), - cli (>= 3.6.4), dplyr (>= 1.1.0), lifecycle (>= 0.2.0), logger (>= 0.2.0), From 55a8537943bf2ae1a4e3a28a4e1ca450c511e5d2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Mon, 12 May 2025 12:31:30 +0200 Subject: [PATCH 106/142] Renaming --- R/update_spec.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/update_spec.R b/R/update_spec.R index 806a451b..5fcd0245 100644 --- a/R/update_spec.R +++ b/R/update_spec.R @@ -66,7 +66,7 @@ update_s_spec <- function(spec, type, value) { valid_names <- spec[[type]]$choices if (!is.list(valid_names) && all(value %in% valid_names)) { - original_select <- orig(spec[[type]]$select) + original_select <- orig(spec[[type]]$selected) spec[[type]][["selected"]] <- value attr(spec[[type]][["selected"]], "original") <- original_select } else if (!is.list(valid_names) && !all(value %in% valid_names)) { From 6bf1af3388b1a8af6ad6b918277dffc529f84659 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Mon, 12 May 2025 17:38:04 +0200 Subject: [PATCH 107/142] Select instead of merging --- R/merge_dataframes.R | 28 ++++++++++++++++++++++++---- R/module_input.R | 7 +++++-- 2 files changed, 29 insertions(+), 6 deletions(-) diff --git a/R/merge_dataframes.R b/R/merge_dataframes.R index 9e3b97f1..46b98768 100644 --- a/R/merge_dataframes.R +++ b/R/merge_dataframes.R @@ -102,8 +102,22 @@ merge_call_multiple <- function(input, ids, merge_function, data, datasets <- unique(unlist(lapply(input, `[[`, "datasets"), FALSE, FALSE)) stopifnot(is.character(datasets) && length(datasets) >= 1L) number_merges <- length(datasets) - 1L + + out <- vector("list", length = 2) + names(out) <- c("code", "specification") + + if (number_merges == 0L) { + dataset <- names(input) + variables <- input[[1]]$variables + final_call <- call( + "<-", as.name(anl_name), + call("dplyr::select", as.name(dataset), as.names(variables)) + ) + out$code <- teal.code::eval_code(data, final_call) + out$input <- input + return(out) + } stopifnot( - "Number of datasets is enough" = number_merges >= 1L, "Number of arguments for type matches data" = length(merge_function) == number_merges || length(merge_function) == 1L ) if (!missing(ids)) { @@ -119,11 +133,15 @@ merge_call_multiple <- function(input, ids, merge_function, data, if (number_merges == 1L && missing(ids)) { previous <- merge_call_pair(input, merge_function = merge_function, data = data) final_call <- call("<-", x = as.name(anl_name), value = previous) - return(teal.code::eval_code(data, final_call)) + out$code <- teal.code::eval_code(data, final_call) + out$input <- input + return(out) } else if (number_merges == 1L && !missing(ids)) { previous <- merge_call_pair(input, by = ids, merge_function = merge_function, data = data) final_call <- call("<-", x = as.name(anl_name), value = previous) - return(teal.code::eval_code(data, final_call)) + out$code <- teal.code::eval_code(data, final_call) + out$input <- input + return(out) } @@ -161,5 +179,7 @@ merge_call_multiple <- function(input, ids, merge_function, data, previous <- call("%>%", as.name(previous), as.name(current)) } final_call <- call("<-", x = as.name(anl_name), value = previous) - teal.code::eval_code(data, final_call) + out$code <- teal.code::eval_code(data, final_call) + out$input <- input + out } diff --git a/R/module_input.R b/R/module_input.R index 0fd75dcb..e4673565 100644 --- a/R/module_input.R +++ b/R/module_input.R @@ -33,11 +33,14 @@ module_input_ui <- function(id, label, spec) { #' @export module_input_server <- function(id, spec, data) { stopifnot(is.specification(spec)) - stopifnot(is.reactive(data)) stopifnot(is.character(id)) moduleServer(id, function(input, output, session) { react_updates <- reactive({ - d <- data() + if (is.reactive(data)) { + d <- data() + } else { + d <- data + } if (!anyNA(spec) && is.delayed(spec)) { spec <- resolver(spec, d) } From 744a2716026db92eb4f2b230f91578ecfab52d2e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Mon, 12 May 2025 17:42:00 +0200 Subject: [PATCH 108/142] Add function to provide the list of inputs --- R/merge_dataframes.R | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) diff --git a/R/merge_dataframes.R b/R/merge_dataframes.R index 46b98768..5be62380 100644 --- a/R/merge_dataframes.R +++ b/R/merge_dataframes.R @@ -183,3 +183,20 @@ merge_call_multiple <- function(input, ids, merge_function, data, out$input <- input out } + +merge_selector_srv <- function(id, available, data) { + moduleServer( + id, + function(input, output, session) { + req(input) + resolved_spec <- reactive({ + resolved_spec <- lapply(names(available), function(x) { + module_input_server(x, available[[x]], data)() + }) + names(resolved_spec) <- names(available) + resolved_spec + }) + resolved_spec() + } + ) +} From c773304d7e890bfeba04779a449f482ada04a235 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Tue, 13 May 2025 14:07:19 +0200 Subject: [PATCH 109/142] Improve calls and merging --- R/merge_dataframes.R | 122 ++++++++++++++++++++++++++----------------- 1 file changed, 75 insertions(+), 47 deletions(-) diff --git a/R/merge_dataframes.R b/R/merge_dataframes.R index 5be62380..f64870f9 100644 --- a/R/merge_dataframes.R +++ b/R/merge_dataframes.R @@ -66,61 +66,70 @@ extract_ids <- function(input, data) { out <- unique(unlist(l)) } -merge_call_pair <- function(selections, by, data, - merge_function = "dplyr::full_join", - anl_name = "ANL") { - selections <- consolidate_extraction(selections) +merge_call_pair <- function(input_res, by, data, + merge_function = "dplyr::full_join") { + selections <- consolidate_extraction(input_res) stopifnot(length(selections) == 2L) datasets <- unique(unlist(lapply(selections, `[[`, "datasets"), FALSE, FALSE)) stopifnot(length(datasets) >= 2) - by <- extract_ids(input = selections, data) + if (is.reactive(data)) { + data <- data() + } - if (grepl("::", merge_function, fixed = TRUE)) { - m <- strsplit(merge_function, split = "::", fixed = TRUE)[[1]] - data <- teal.code::eval_code(data, call("library", m[1])) - merge_function <- m[2] + if (is.null(by)) { + by <- extract_ids(input = selections, data) } + data <- add_library_call(merge_function, data) + if (!missing(by) && length(by)) { - call_m <- call(merge_function, - x = as.name(datasets[1]), - y = as.name(datasets[2]), - by = by - ) + call_m <- as.call(c( + rlang::parse_expr(merge_function), + list( + x = as.name(datasets[1]), + y = as.name(datasets[2]), + by = by + ) + )) } else { - call_m <- call(merge_function, - x = as.name(datasets[1]), - y = as.name(datasets[2]) - ) + call_m <- as.call(c( + rlang::parse_expr(merge_function), + list( + x = as.name(datasets[1]), + y = as.name(datasets[2]) + ) + )) } call_m } -merge_call_multiple <- function(input, ids, merge_function, data, - anl_name = "ANL") { - input <- consolidate_extraction(input) - datasets <- unique(unlist(lapply(input, `[[`, "datasets"), FALSE, FALSE)) +merge_call_multiple <- function(input_res, ids, data, merge_function = "dplyr::full_join", + anl = "ANL") { + selections <- consolidate_extraction(input_res) + datasets <- unique(unlist(lapply(selections, `[[`, "datasets"), FALSE, FALSE)) stopifnot(is.character(datasets) && length(datasets) >= 1L) number_merges <- length(datasets) - 1L - + if (is.reactive(data)) { + data <- data() + } out <- vector("list", length = 2) names(out) <- c("code", "specification") if (number_merges == 0L) { - dataset <- names(input) - variables <- input[[1]]$variables + dataset <- names(selections) + variables <- selections[[1]]$variables final_call <- call( - "<-", as.name(anl_name), + "<-", as.name(anl), call("dplyr::select", as.name(dataset), as.names(variables)) ) out$code <- teal.code::eval_code(data, final_call) - out$input <- input + out$input <- input_res return(out) } stopifnot( "Number of arguments for type matches data" = length(merge_function) == number_merges || length(merge_function) == 1L ) - if (!missing(ids)) { + if (!missing(ids) && !is.null(ids)) { stopifnot("Number of arguments for ids matches data" = !(is.list(ids) && length(ids) == number_merges)) } if (length(merge_function) != number_merges) { @@ -131,33 +140,33 @@ merge_call_multiple <- function(input, ids, merge_function, data, } if (number_merges == 1L && missing(ids)) { - previous <- merge_call_pair(input, merge_function = merge_function, data = data) - final_call <- call("<-", x = as.name(anl_name), value = previous) + data <- add_library_call(merge_function, data) + previous <- merge_call_pair(selections, merge_function = merge_function, data = data) + final_call <- call("<-", x = as.name(anl), value = previous) out$code <- teal.code::eval_code(data, final_call) - out$input <- input + out$input <- input_res return(out) } else if (number_merges == 1L && !missing(ids)) { - previous <- merge_call_pair(input, by = ids, merge_function = merge_function, data = data) - final_call <- call("<-", x = as.name(anl_name), value = previous) + data <- add_library_call(merge_function, data) + previous <- merge_call_pair(selections, by = ids, merge_function = merge_function, data = data) + final_call <- call("<-", x = as.name(anl), value = previous) out$code <- teal.code::eval_code(data, final_call) - out$input <- input + out$input <- input_res return(out) } - - for (merge_i in seq_len(number_merges)) { if (merge_i == 1L) { datasets_i <- seq_len(2) if (!missing(ids)) { ids <- ids[[merge_i]] - previous <- merge_call_pair(input[datasets_i], + previous <- merge_call_pair(selections[datasets_i], ids, merge_function[merge_i], data = data ) } else { - previous <- merge_call_pair(input[datasets_i], + previous <- merge_call_pair(selections[datasets_i], merge_function[merge_i], data = data ) @@ -165,12 +174,12 @@ merge_call_multiple <- function(input, ids, merge_function, data, } else { datasets_ids <- merge_i:(merge_i + 1L) if (!missing(ids)) { - current <- merge_call_pair(input[datasets_ids], + current <- merge_call_pair(selections[datasets_ids], merge_function = merge_function[merge_i], data = data ) } else { ids <- ids[[merge_i]] - current <- merge_call_pair(input[datasets_ids], + current <- merge_call_pair(selections[datasets_ids], ids, merge_function = merge_function[merge_i], data = data ) @@ -178,25 +187,44 @@ merge_call_multiple <- function(input, ids, merge_function, data, } previous <- call("%>%", as.name(previous), as.name(current)) } - final_call <- call("<-", x = as.name(anl_name), value = previous) + final_call <- call("<-", x = as.name(anl), value = previous) out$code <- teal.code::eval_code(data, final_call) - out$input <- input + out$input <- input_res out } -merge_selector_srv <- function(id, available, data) { +merge_type_srv <- function(id, inputs, data, merge_function = "dplyr::full_join", anl_name = "ANL") { + checkmate::assert_list(inputs, names = "named") + stopifnot(make.names(anl_name) == anl_name) + moduleServer( id, function(input, output, session) { req(input) resolved_spec <- reactive({ - resolved_spec <- lapply(names(available), function(x) { - module_input_server(x, available[[x]], data)() + resolved_spec <- lapply(names(inputs), function(x) { + # Return characters not reactives + module_input_server(x, inputs[[x]], data)() }) - names(resolved_spec) <- names(available) + # Keep input names + names(resolved_spec) <- names(inputs) resolved_spec }) - resolved_spec() + td <- merge_call_multiple(resolved_spec(), NULL, + data, + merge_function = merge_function, anl = anl_name + ) } ) } + +add_library_call <- function(merge_function, data) { + if (is.reactive(data)) { + data <- data() + } + if (grepl("::", merge_function, fixed = TRUE)) { + m <- strsplit(merge_function, split = "::", fixed = TRUE)[[1]] + data <- teal.code::eval_code(data, call("library", m[1])) + } + data +} From 063853436a85129a70f28dbedefdd88626c57ace Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Llu=C3=ADs=20Revilla?= Date: Wed, 14 May 2025 13:04:32 +0200 Subject: [PATCH 110/142] Fix unresolved updates --- R/module_input.R | 27 +++++++++++++++------------ 1 file changed, 15 insertions(+), 12 deletions(-) diff --git a/R/module_input.R b/R/module_input.R index e4673565..65187c09 100644 --- a/R/module_input.R +++ b/R/module_input.R @@ -41,18 +41,23 @@ module_input_server <- function(id, spec, data) { } else { d <- data } + if (!anyNA(spec) && is.delayed(spec)) { spec <- resolver(spec, d) } + for (i in seq_along(names(input))) { variable <- names(input)[i] x <- input[[variable]] - spec_v <- spec[[variable]] - # resolved <- !is.character(spec_v$names) && all(x %in% spec_v$names) && any(!x %in% spec_v$select) - - if (!is.null(x) && any(nzchar(x))) { - spec <- resolver(update_spec(spec, variable, x), d) - } else { + update_is_empty <- !is.null(x) && all(!nzchar(x)) + if (update_is_empty) { + break + } + update_is_valid <- all(x %in% spec[[variable]][["choices"]]) + # Includes for adding or removing but not reordering + selection_is_new <- length(x) != length(spec[[variable]][["selected"]]) + if (update_is_valid && selection_is_new) { + spec <- update_spec(spec, variable, x) spec <- resolver(spec, d) } } @@ -60,15 +65,12 @@ module_input_server <- function(id, spec, data) { }) observe({ - req(react_updates()) - spec <- react_updates() + spec <- req(react_updates()) + req(!is.delayed(spec)) + # Relies on order of arguments for (i in seq_along(spec)) { variable <- names(spec)[i] - # Relies on order of arguments - if (is.delayed(spec[[variable]])) { - break - } shiny::updateSelectInput( session, variable, @@ -85,6 +87,7 @@ module_input_server <- function(id, spec, data) { react_selection <- reactive({ spec <- req(react_updates()) req(!is.delayed(spec)) + # FIXME: breaks with conditional specification: list(spec, spec) selection <- vector("list", length(spec)) names(selection) <- names(spec) for (i in seq_along(spec)) { From a1fc90babceb77719265efadfe4de23b143fcadb Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Tue, 29 Jul 2025 16:23:16 +0200 Subject: [PATCH 111/142] checkpoint - input module reactivity works - merge works for data.frames - inputs minimized to badge-pill --- NAMESPACE | 7 +- R/0-delayed.R | 59 +++++ R/{extract.R => 0-extract.R} | 0 R/0-merge.R | 58 ++++ ...erge_dataframes.R => 0-merge_dataframes.R} | 0 R/0-module_input.R | 136 ++++++++++ R/0-resolver.R | 234 +++++++++++++++++ R/{selector.R => 0-selector.R} | 2 +- R/{types.R => 0-types.R} | 106 ++++---- R/delayed.R | 60 ----- R/module_input.R | 100 ------- R/resolver.R | 248 ------------------ R/update_spec.R | 102 ------- man/determine.Rd | 8 +- man/extract.Rd | 2 +- man/is.delayed.Rd | 6 +- man/resolver.Rd | 2 +- man/types.Rd | 2 +- man/update_spec.Rd | 37 --- tests/testthat/test-types.R | 30 ++- 20 files changed, 585 insertions(+), 614 deletions(-) create mode 100644 R/0-delayed.R rename R/{extract.R => 0-extract.R} (100%) create mode 100644 R/0-merge.R rename R/{merge_dataframes.R => 0-merge_dataframes.R} (100%) create mode 100644 R/0-module_input.R create mode 100644 R/0-resolver.R rename R/{selector.R => 0-selector.R} (90%) rename R/{types.R => 0-types.R} (79%) delete mode 100644 R/delayed.R delete mode 100644 R/module_input.R delete mode 100644 R/resolver.R delete mode 100644 R/update_spec.R delete mode 100644 man/update_spec.Rd diff --git a/NAMESPACE b/NAMESPACE index bd169a15..b83b8eea 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -13,6 +13,7 @@ S3method(determine,datasets) S3method(determine,default) S3method(determine,list) S3method(determine,specification) +S3method(determine,type) S3method(determine,values) S3method(determine,variables) S3method(extract,default) @@ -83,9 +84,10 @@ export(last_choices) export(list_extract_spec) export(mae_colData) export(merge_datasets) +export(merge_expr) export(merge_expression_module) export(merge_expression_srv) -export(module_input_server) +export(module_input_srv) export(module_input_ui) export(no_selected_as_NULL) export(resolve_delayed) @@ -94,7 +96,6 @@ export(select_spec) export(select_spec.default) export(select_spec.delayed_data) export(split_by_sep) -export(update_spec) export(value_choices) export(values) export(variable_choices) @@ -102,5 +103,3 @@ export(variables) import(shiny) importFrom(dplyr,"%>%") importFrom(lifecycle,badge) -importFrom(methods,is) -importFrom(tidyselect,everything) diff --git a/R/0-delayed.R b/R/0-delayed.R new file mode 100644 index 00000000..b04b22f1 --- /dev/null +++ b/R/0-delayed.R @@ -0,0 +1,59 @@ +# Only delay if the type or object really needs it and is not already delayed +as.delayed <- function(x) { + if (is.delayed(x)) { + attr(x, "delayed") <- TRUE + } + x +} + +#' Is the specification resolved? +#' +#' Check that the specification is resolved against a given data source. +#' @param x Object to be evaluated. +#' @returns A single logical value. +#' @examples +#' is.delayed(1) +#' is.delayed(variables("df", "df")) +#' is.delayed(variables("df")) # Unknown selection +#' @export +is.delayed <- function(x) { + UseMethod("is.delayed") +} + +#' @export +#' @method is.delayed default +is.delayed.default <- function(x) { + # FIXME: A warning? + FALSE +} + +# Handling a list of transformers e1 | e2 +#' @export +#' @method is.delayed list +is.delayed.list <- function(x) { + any(vapply(x, is.delayed, logical(1L))) +} + +#' @export +#' @method is.delayed specification +is.delayed.specification <- function(x) { + any(vapply(x, is.delayed, logical(1L))) +} + +#' @export +#' @method is.delayed type +is.delayed.type <- function(x) { + if (!is.na(x)) { + return(!all(is.character(x$choices)) || !all(is.character(x$selected))) + } + FALSE +} + +resolved <- function(x) { + s <- all(is.character(x$choices)) && all(is.character(x$selected)) + if (!s && !all(x$selected %in% x$choices)) { + stop("Selected not resolved.") + } + attr(x, "delayed") <- NULL + x +} diff --git a/R/extract.R b/R/0-extract.R similarity index 100% rename from R/extract.R rename to R/0-extract.R diff --git a/R/0-merge.R b/R/0-merge.R new file mode 100644 index 00000000..ee154c8c --- /dev/null +++ b/R/0-merge.R @@ -0,0 +1,58 @@ +#' @param data (`teal_data`) +#' @param selectors (`list` of `specification`) +#' @param join_fun (`character(1)`) name of the merge function. +#' @param ignore_disconnected (`logical(1)`) +#' @export +merge_expr <- function(data, selectors, join_fun = "dplyr::left_join", ignore_disconnected = TRUE) { + checkmate::assert_class(data, "teal_data") + checkmate::assert_list(selectors, "specification") + checkmate::assert_string(join_fun) + checkmate::assert_flag(ignore_disconnected) + + # IMPORTANT! Merge just need a dispatch on the class of the first object + # as merge (left_join) of data.frame and MAE is still a data.frame + # it is just a matter of "select" which is dataset specific + datanames <- unique(unlist(lapply(selectors, function(x) x$datasets$selected))) + + calls <- expression() + anl_datanames <- character(0) # to follow what anl is composed of (to determine keys) + anl_variables <- character(0) + for (i in seq_along(datanames)) { + dataname <- datanames[i] + this_selectors <- Filter(function(x) identical(x$datasets$selected, dataname), selectors) + this_keys <- teal.data::join_keys(data)[[dataname]] + this_variables <- union( + unlist(this_keys), # todo: all keys or only those which connects `datanames`? + unlist(lapply(this_selectors, function(x) x$variables$selected)) + ) + + # todo: extract call is datasets (class, class) specific + this_call <- call_extract_matrix(dataname = dataname, column = this_variables) + if (i > 1) { + # merge by cumulated keys + merge_keys <- unique(unlist(teal.data::join_keys(data)[[dataname]][names(this_keys) %in% anl_datanames])) + if (!length(merge_keys)) { + msg <- sprintf( + "Merge is not possible. No join_keys between %s and any of %s", + dataname, + sQuote(toString(anl_datanames)) + ) + if (ignore_disconnected) warning(msg, call. = FALSE) else stop(msg, call. = FALSE) + next + } + this_call <- as.call( + list( + str2lang(join_fun), + y = this_call, + by = merge_keys + ) + ) + } + + anl_datanames <- c(anl_datanames, dataname) + anl_variables <- c(anl_variables, this_variables) + calls <- c(calls, this_call) + } + + call("<-", str2lang("anl"), calls_combine_by("%>%", calls)) +} diff --git a/R/merge_dataframes.R b/R/0-merge_dataframes.R similarity index 100% rename from R/merge_dataframes.R rename to R/0-merge_dataframes.R diff --git a/R/0-module_input.R b/R/0-module_input.R new file mode 100644 index 00000000..ac21faa5 --- /dev/null +++ b/R/0-module_input.R @@ -0,0 +1,136 @@ +#' @export +module_input_ui <- function(id, spec) { + ns <- shiny::NS(id) + if (.valid_specification(spec)) { + stop("Unexpected object used as specification.") + } + badge_label <- shiny::textOutput(ns("summary"), container = tags$span) + content <- lapply(spec, function(x) selected_choices_ui(id = ns(is(x)), x)) + tags$div( + # todo: spec to have a label attribute + .badge_dropdown(ns("inputs"), label = badge_label, content = content) + ) +} + +#' @export +module_input_srv <- function(id, spec, data) { + checkmate::assert_string(id) + checkmate::assert_true(.is.specification(spec)) + checkmate::assert_class(data, "reactive") + moduleServer(id, function(input, output, session) { + data_r <- shiny::reactive(if (shiny::is.reactive(data)) data() else data) + spec_r <- shiny::reactiveVal(resolver(spec, shiny::isolate(data_r()))) + + badge_text <- shiny::reactive({ + paste( + lapply(spec_r(), function(x) toString(x$selected)), + collapse = ": " + ) + }) + + # todo: modify when data changes + output$summary <- shiny::renderText(badge_text()) + + lapply(seq_along(spec), function(i) { + selected <- selected_choices_srv( + id = is(spec[[i]]), + x = shiny::reactive(spec_r()[[i]]) + ) + shiny::observeEvent( + selected(), + ignoreInit = TRUE, # because spec_r is a initial state + { + logger::log_info("module_input_server@1 selected has changed. Resolving downstream...") + new_spec_unresolved <- spec + new_spec_unresolved[[i]]$selected <- selected() + if (i > 1) { + # we don't want to resolve previous items + new_spec_unresolved[seq_len(i - 1)] <- spec_r()[seq_len(i - 1)] + } + new_spec <- resolver(new_spec_unresolved, data_r()) + if (!identical(new_spec, spec_r())) { + logger::log_info("Update spec { names(spec)[i] } after selection change.") + spec_r(new_spec) + } + } + ) + }) + + spec_r + }) +} + +selected_choices_ui <- function(id, x) { + ns <- shiny::NS(id) + shiny::selectInput( + inputId = ns("selected"), + label = paste("Select", is(x), collapse = " "), + choices = if (!is.delayed(x$choices)) x$choices, + selected = if (!is.delayed(x$selected)) x$selected, + multiple = isTRUE(x$multiple) + ) +} + +selected_choices_srv <- function(id, x) { + checkmate::assert_string(id) + checkmate::assert_true(is.reactive(x)) + shiny::moduleServer(id, function(input, output, session) { + shiny::observeEvent(x(), { + logger::log_debug("selected_choices_srv@1 x has changed (caused by upstream resolve)") + shiny::updateSelectInput( + inputId = "selected", + choices = x()$choices, + selected = x()$selected + ) + }) + selected <- shiny::reactiveVal() + # todo: if only one choice then replace with the text only + shiny::observeEvent(input$selected, { + if (!identical(input$selected, selected)) { + logger::log_debug("selected_choices_srv@2 input$selected has changed.") + selected(input$selected) + } + }) + selected + }) +} + +.badge_dropdown <- function(id, label, content) { + ns <- shiny::NS(id) + htmltools::tags$div( + htmltools::tags$span( + label, + id = ns("summary_badge"), + class = "badge bg-primary", + style = "cursor: pointer; user-select: none;", + onclick = sprintf( + " + var container = document.getElementById('%s'); + var summary = document.getElementById('%s'); + + if(container.style.display === 'none' || container.style.display === '') { + container.style.display = 'block'; + + // Add click outside handler + setTimeout(function() { + function handleClickOutside(event) { + if (!container.contains(event.target) && !summary.contains(event.target)) { + container.style.display = 'none'; + document.removeEventListener('click', handleClickOutside); + } + } + document.addEventListener('click', handleClickOutside); + }, 10); + } + ", + ns("inputs_container"), + ns("summary_badge") + ) + ), + htmltools::tags$div( + content, + id = ns("inputs_container"), + style = "display: none; position: absolute; background: white; border: 1px solid #ccc; border-radius: 4px; box-shadow: 0 2px 10px rgba(0,0,0,0.1); padding: 10px; z-index: 1000; min-width: 200px;", + ) + ) +} diff --git a/R/0-resolver.R b/R/0-resolver.R new file mode 100644 index 00000000..429481d1 --- /dev/null +++ b/R/0-resolver.R @@ -0,0 +1,234 @@ +#' Resolve the specification +#' +#' Given the specification of some data to extract find if they are available or not. +#' The specification for selecting a variable shouldn't depend on the data of said variable. +#' @param spec A object extraction specification. +#' @param data The qenv where the specification is evaluated. +#' +#' @returns A specification but resolved: the names and selection is the name of the objects (if possible). +#' @export +#' +#' @examples +#' dataset1 <- datasets(where(is.data.frame)) +#' dataset2 <- datasets(where(is.matrix)) +#' spec <- c(dataset1, variables("a", "a")) +#' td <- within(teal.data::teal_data(), { +#' df <- data.frame(a = as.factor(LETTERS[1:5]), b = letters[1:5]) +#' df2 <- data.frame(a = LETTERS[1:5], b = 1:5) +#' m <- matrix() +#' }) +#' resolver(list(spec, dataset2), td) +#' resolver(dataset2, td) +#' resolver(spec, td) +#' spec <- c(dataset1, variables("a", where(is.character))) +#' resolver(spec, td) +resolver <- function(spec, data) { + checkmate::assert_environment(data) + if (!is.delayed(spec)) { + return(spec) + } + + stopifnot(is.list(spec) || .is.specification(spec)) + if (.is.type(spec)) { + spec <- list(spec) + names(spec) <- is(spec[[1]]) + class(spec) <- c("specification", class(spec)) + } + + det <- determine(spec, data) + if (is.null(names(det))) { + return(lapply(det, `[[`, 1)) + } else { + det$x + } +} + +#' A method that should take a type and resolve it. +#' +#' Generic that makes the minimal check on spec. +#' Responsible of subsetting/extract the data received and check that the type matches +#' @param x The specification to resolve. +#' @param data The minimal data required. +#' @return A list with two elements, the `type` resolved and the data extracted. +#' @keywords internal +#' @export +determine <- function(x, data, ...) { + stopifnot(.is.type(x) || is.list(x) || .is.specification(x)) + if (!is.delayed(x)) { + return(list(x = x, data = extract(data, unorig(x$selected)))) + } + UseMethod("determine") +} + +#' @export +determine.default <- function(x, data, ...) { + stop("There is not a specific method to pick choices.") +} + +#' @export +determine.colData <- function(x, data, ...) { + if (!requireNamespace("SummarizedExperiment", quietly = TRUE)) { + stop("Requires SummarizedExperiment package from Bioconductor.") + } + data <- as.data.frame(colData(data)) + + x <- NextMethod("determine", x) + + list(x = x, data = extract(data, unorig(x$selected))) +} + +#' @export +determine.datasets <- function(x, data, ...) { + if (is.null(data)) { + return(list(x = x, data = NULL)) + } else if (!inherits(data, "qenv")) { + stop("Please use qenv() or teal_data() objects.") + } + + # Assumes the object has colnames method (true for major object classes: DataFrame, tibble, Matrix, array) + # FIXME: What happens if colnames is null: colnames(array(dim = c(4, 2))) + x <- NextMethod("determine", x) + + list(x = x, data = extract(data, unorig(x$selected))) +} + +#' @export +determine.list <- function(x, data, ...) { + if (is.list(x) && is.null(names(x))) { + l <- lapply(x, determine, data = data) + return(l) + } + + x <- NextMethod("determine", x) + + list(x = x, data = extract(data, unorig(x$selected))) +} + +#' @export +determine.specification <- function(x, data, ...) { + stopifnot(inherits(data, "qenv")) + + # Adding some default specifications if they are missing + if ("values" %in% names(x) && !"variables" %in% names(x)) { + x <- append(x, list(variables = variables()), length(x) - 1) + } + + if ("variables" %in% names(x) && !"datasets" %in% names(x)) { + x <- append(x, list(variables = datasets()), length(x) - 1) + } + + d <- data + for (i in seq_along(x)) { + di <- determine(x[[i]], d) + # overwrite so that next x in line receives the corresponding data and specification + if (is.null(di$x)) { + next + } + x[[i]] <- di$x + d <- di$data + } + list(x = x, data = data) # It is the transform object resolved. +} + +#' @export +determine.values <- function(x, data, ...) { + if (!is.numeric(data)) { + d <- data + names(d) <- data + } else { + d <- data + } + + # todo: replace with NextMethod? + sel <- .eval_select(d, x$choices) + x$choices <- data[sel] + + sel2 <- .eval_select(d[sel], x$selected) + x$selected <- data[sel][sel2] + + # Not possible to know what is happening + if (is.delayed(x)) { + return(list(x = x, data = NULL)) + } + + list(x = x, data = data[sel]) +} + +#' @export +determine.variables <- function(x, data, ...) { + if (is.null(data)) { + return(list(x = x, data = NULL)) + } else if (length(dim(data)) != 2L) { + stop( + "Can't resolve variables from this object of class ", + toString(sQuote(class(data))) + ) + } + + if (ncol(data) <= 0L) { + stop("Can't pull variable: No variable is available.") + } + + x <- NextMethod("determine", x) + + # Not possible to know what is happening + if (is.delayed(x)) { + return(list(x = x, data = NULL)) + } + # This works for matrices and data.frames of length 1 or multiple + # be aware of drop behavior on tibble vs data.frame + list(x = x, data = extract(data, unorig(x$selected))) +} + +orig <- function(x) { + attr(x, "original") +} + +unorig <- function(x) { + attr(x, "original") <- NULL + x +} + +#' @export +determine.type <- function(x, data) { + x <- determine_choices(x, data) + x <- determine_selected(x, data) +} + +determine_choices <- function(x, data) { + orig_choices <- orig(x$choices) + if (length(orig_choices) == 1L) { + orig_choices <- orig_choices[[1L]] + } + + new_choices <- unique(names(.eval_select(data, x$choices))) + # if (!length(new_choices)) { + # stop("No ", toString(is(x)), " meet the specification.", call. = FALSE) + # } + attr(new_choices, "original") <- orig_choices + x$choices <- new_choices + x +} + +determine_selected <- function(x, data) { + stopifnot(is.character(x$choices)) + if (!is(data, "qenv")) { + data <- extract(data, x$choices) + } else { + # Do not extract; selection would be from the data extracted not from the names. + data <- data[x$choices] + } + orig_selected <- orig(x$selected) + if (length(orig_selected) == 1L) { + orig_selected <- orig_selected[[1L]] + } + + choices <- seq_along(x$choices) + names(choices) <- x$choices + new_selected <- names(.eval_select(data, x$selected)) + + attr(new_selected, "original") <- orig_selected + x$selected <- new_selected + + x +} diff --git a/R/selector.R b/R/0-selector.R similarity index 90% rename from R/selector.R rename to R/0-selector.R index 069f8628..3aca761a 100644 --- a/R/selector.R +++ b/R/0-selector.R @@ -1,4 +1,4 @@ -selector <- function(data, ...) { +.eval_select <- function(data, ...) { if (is.environment(data)) { # To keep the "order" of the names in the extraction: avoids suprises data <- as.list(data)[names(data)] diff --git a/R/types.R b/R/0-types.R similarity index 79% rename from R/types.R rename to R/0-types.R index d1f02fc6..0fd58710 100644 --- a/R/types.R +++ b/R/0-types.R @@ -1,41 +1,3 @@ -is.specification <- function(x) { - inherits(x, "specification") -} - - -valid_specification <- function(x) { - !((is.type(x) || is.specification(x))) -} - -na_type <- function(type) { - out <- NA_character_ - class(out) <- c(type, "type") - out -} - -is.type <- function(x) { - inherits(x, "type") -} - -#' @export -#' @method is.na type -is.na.type <- function(x) { - anyNA(unclass(x[c("names", "selected")])) -} - -#' @export -anyNA.type <- function(x, recursive = FALSE) { - anyNA(unclass(x[c("choices", "selected")]), recursive) -} - -type_helper <- function(choices, selected, type) { - out <- list(choices = choices, selected = selected) - class(out) <- c(type, "type", "list") - attr(out$choices, "original") <- choices - attr(out$selected, "original") <- selected - delay(out) -} - #' @rdname types #' @name Types #' @title Type specification @@ -52,36 +14,48 @@ type_helper <- function(choices, selected, type) { #' c(datasets("A"), variables(where(is.numeric))) NULL -#' @importFrom tidyselect everything #' @describeIn types Specify datasets. #' @export datasets <- function(choices = tidyselect::everything(), selected = 1) { - type_helper(rlang::enquo(choices), rlang::enquo(selected), "datasets") + out <- .selected_choices(choices = rlang::enquo(choices), selected = rlang::enquo(selected)) + class(out) <- c("datasets", class(out)) + out } #' @describeIn types Specify variables. #' @export variables <- function(choices = tidyselect::everything(), selected = 1) { - type_helper(rlang::enquo(choices), rlang::enquo(selected), "variables") + out <- .selected_choices(choices = rlang::enquo(choices), selected = rlang::enquo(selected)) + class(out) <- c("variables", class(out)) + out } #' @describeIn types Specify colData. #' @export mae_colData <- function(choices = tidyselect::everything(), selected = 1) { - type_helper(rlang::enquo(choices), rlang::enquo(selected), "colData") + out <- .selected_choices(choices = rlang::enquo(choices), selected = rlang::enquo(selected)) + class(out) <- c("colData", class(out)) + out } #' @describeIn types Specify values. #' @export values <- function(choices = tidyselect::everything(), selected = 1) { - type_helper(rlang::enquo(choices), rlang::enquo(selected), "values") + out <- .selected_choices(choices = rlang::enquo(choices), selected = rlang::enquo(selected)) + class(out) <- c("values", class(out)) + out +} + +#' @export +anyNA.type <- function(x, recursive = FALSE) { + anyNA(unclass(x[c("choices", "selected")]), recursive = recursive) } #' @export c.specification <- function(...) { l <- list(...) types <- lapply(l, names) - typesc <- vapply(l, is.specification, logical(1L)) + typesc <- vapply(l, .is.specification, logical(1L)) if (!all(typesc)) { stop("An object in position ", which(!typesc), " is not a specification.") } @@ -127,7 +101,7 @@ c.specification <- function(...) { c.type <- function(...) { l <- list(...) types <- lapply(l, is) - typesc <- vapply(l, is.type, logical(1L)) + typesc <- vapply(l, .is.type, logical(1L)) if (!all(typesc)) { stop("An object in position ", which(!typesc), " is not a type.") } @@ -175,9 +149,8 @@ c.type <- function(...) { vector } -simplify_c <- function(x) { - unique(unlist(x, FALSE, FALSE)) -} +#' @export +is.na.type <- function(x) anyNA(x) #' @export print.type <- function(x, ...) { @@ -186,7 +159,7 @@ print.type <- function(x, ...) { return(x) } - choices_fns <- count_functions(x$choices) + choices_fns <- .count_functions(x$choices) msg_values <- character() choices_values <- length(x$choices) - sum(choices_fns) @@ -202,7 +175,7 @@ print.type <- function(x, ...) { ) } - selected_fns <- count_functions(x$selected) + selected_fns <- .count_functions(x$selected) msg_sel <- character() sel_values <- length(x$selected) - sum(selected_fns) @@ -222,10 +195,41 @@ print.type <- function(x, ...) { return(x) } -count_functions <- function(x) { +.count_functions <- function(x) { if (is.list(x)) { vapply(x, is.function, logical(1L)) } else { FALSE } } + +.is.specification <- function(x) { + inherits(x, "specification") +} + +.is.tidyselect <- function(x) { + err <- try(force(x), silent = TRUE) + inherits(err, "error") && grepl("must be used within a *selecting*", err$message) +} + +.is.type <- function(x) { + inherits(x, "type") +} + +.selected_choices <- function(choices, selected, keep_order = FALSE, fixed = FALSE) { + out <- structure( + list(choices = choices, selected = selected), + keep_order = keep_order, + fixed = fixed, + class = "type" + ) + as.delayed(out) +} + +.simplity_c <- function(x) { + unique(unlist(x, FALSE, FALSE)) +} + +.valid_specification <- function(x) { + !((.is.type(x) || .is.specification(x))) +} diff --git a/R/delayed.R b/R/delayed.R deleted file mode 100644 index cb9c70eb..00000000 --- a/R/delayed.R +++ /dev/null @@ -1,60 +0,0 @@ -# Only delay if the type or object really needs it and is not already delayed -delay <- function(x) { - if (is.delayed(x)) { - attr(x, "delayed") <- TRUE - } - x -} - -#' Is the specification resolved? -#' -#' Check that the specification is resolved against a given data source. -#' @param specification Object to be evaluated. -#' @returns A single logical value. -#' @examples -#' is.delayed(1) -#' is.delayed(variables("df", "df")) -#' is.delayed(variables("df")) # Unknown selection -#' @export -is.delayed <- function(specification) { - UseMethod("is.delayed") -} - -#' @export -#' @method is.delayed default -is.delayed.default <- function(specification) { - # FIXME: A warning? - FALSE -} - -# Handling a list of transformers e1 | e2 -#' @export -#' @method is.delayed list -is.delayed.list <- function(specification) { - any(vapply(specification, is.delayed, logical(1L))) -} - -#' @export -#' @method is.delayed specification -is.delayed.specification <- function(specification) { - any(vapply(specification, is.delayed, logical(1L))) -} - -#' @export -#' @method is.delayed type -is.delayed.type <- function(specification) { - if (!is.na(specification)) { - return(!all(is.character(specification$choices)) || !all(is.character(specification$selected))) - } - FALSE -} - -resolved <- function(specification, type = is(specification)) { - s <- all(is.character(specification$choices)) && all(is.character(specification$selected)) - - if (!s && !all(specification$selected %in% specification$choices)) { - stop("Selected ", type, " not resolved.") - } - attr(specification, "delayed") <- NULL - specification -} diff --git a/R/module_input.R b/R/module_input.R deleted file mode 100644 index 65187c09..00000000 --- a/R/module_input.R +++ /dev/null @@ -1,100 +0,0 @@ -helper_input <- function(id, - label, - multiple = FALSE) { - shiny::selectInput( - id, - label, - choices = NULL, - selected = NULL, - multiple = multiple - ) -} - -#' @export -module_input_ui <- function(id, label, spec) { - ns <- NS(id) - input <- tagList( - a(label), - ) - - if (valid_specification(spec)) { - stop("Unexpected object used as specification.") - } - - l <- lapply(spec, function(x) { - helper_input(ns(is(x)), - paste("Select", is(x), collapse = " "), - multiple = is(x) != "datasets" - ) - }) - input <- tagList(input, l) -} - -#' @export -module_input_server <- function(id, spec, data) { - stopifnot(is.specification(spec)) - stopifnot(is.character(id)) - moduleServer(id, function(input, output, session) { - react_updates <- reactive({ - if (is.reactive(data)) { - d <- data() - } else { - d <- data - } - - if (!anyNA(spec) && is.delayed(spec)) { - spec <- resolver(spec, d) - } - - for (i in seq_along(names(input))) { - variable <- names(input)[i] - x <- input[[variable]] - update_is_empty <- !is.null(x) && all(!nzchar(x)) - if (update_is_empty) { - break - } - update_is_valid <- all(x %in% spec[[variable]][["choices"]]) - # Includes for adding or removing but not reordering - selection_is_new <- length(x) != length(spec[[variable]][["selected"]]) - if (update_is_valid && selection_is_new) { - spec <- update_spec(spec, variable, x) - spec <- resolver(spec, d) - } - } - spec - }) - - observe({ - spec <- req(react_updates()) - req(!is.delayed(spec)) - # Relies on order of arguments - for (i in seq_along(spec)) { - variable <- names(spec)[i] - - shiny::updateSelectInput( - session, - variable, - choices = unorig(spec[[variable]]$choices), - selected = unorig(spec[[variable]]$selected) - ) - # FIXME: set on gray the input - # FIXME: Hide input field if any type on specification cannot be solved - } - }) - - - # Full selection #### - react_selection <- reactive({ - spec <- req(react_updates()) - req(!is.delayed(spec)) - # FIXME: breaks with conditional specification: list(spec, spec) - selection <- vector("list", length(spec)) - names(selection) <- names(spec) - for (i in seq_along(spec)) { - variable <- names(spec)[i] - selection[[variable]] <- unorig(spec[[variable]]$selected) - } - selection - }) - }) -} diff --git a/R/resolver.R b/R/resolver.R deleted file mode 100644 index 0f4ca488..00000000 --- a/R/resolver.R +++ /dev/null @@ -1,248 +0,0 @@ -#' Resolve the specification -#' -#' Given the specification of some data to extract find if they are available or not. -#' The specification for selecting a variable shouldn't depend on the data of said variable. -#' @param spec A object extraction specification. -#' @param data The qenv where the specification is evaluated. -#' -#' @returns A specification but resolved: the names and selection is the name of the objects (if possible). -#' @export -#' -#' @examples -#' dataset1 <- datasets(where(is.data.frame)) -#' dataset2 <- datasets(where(is.matrix)) -#' spec <- c(dataset1, variables("a", "a")) -#' td <- within(teal.data::teal_data(), { -#' df <- data.frame(a = as.factor(LETTERS[1:5]), b = letters[1:5]) -#' df2 <- data.frame(a = LETTERS[1:5], b = 1:5) -#' m <- matrix() -#' }) -#' resolver(list(spec, dataset2), td) -#' resolver(dataset2, td) -#' resolver(spec, td) -#' spec <- c(dataset1, variables("a", where(is.character))) -#' resolver(spec, td) -resolver <- function(spec, data) { - if (!inherits(data, "qenv")) { - stop("Please use qenv() or teal_data() objects.") - } - if (!is.delayed(spec)) { - return(spec) - } - - stopifnot(is.list(spec) || is.specification(spec)) - if (is.type(spec)) { - spec <- list(spec) - names(spec) <- is(spec[[1]]) - class(spec) <- c("specification", class(spec)) - } - - det <- determine(spec, data) - if (is.null(names(det))) { - return(lapply(det, `[[`, 1)) - } else { - det$type - } -} - -#' A method that should take a type and resolve it. -#' -#' Generic that makes the minimal check on spec. -#' Responsible of subsetting/extract the data received and check that the type matches -#' @param type The specification to resolve. -#' @param data The minimal data required. -#' @return A list with two elements, the type resolved and the data extracted. -#' @keywords internal -#' @export -determine <- function(type, data, ...) { - stopifnot(is.type(type) || is.list(type) || is.specification(type)) - if (!is.delayed(type)) { - return(list(type = type, data = extract(data, unorig(type$selected)))) - } - UseMethod("determine") -} - -#' @export -determine.default <- function(type, data, ...) { - stop("There is not a specific method to pick choices.") -} - -#' @export -determine.list <- function(type, data, ...) { - if (is.list(type) && is.null(names(type))) { - l <- lapply(type, determine, data = data) - return(l) - } - - type <- eval_type_names(type, data) - type <- eval_type_select(type, data) - - list(type = type, data = extract(data, unorig(type$selected))) -} - -#' @export -determine.colData <- function(type, data, ...) { - if (!requireNamespace("SummarizedExperiment", quietly = TRUE)) { - stop("Requires SummarizedExperiment package from Bioconductor.") - } - data <- as.data.frame(colData(data)) - type <- eval_type_names(type, data) - - if (is.null(type$choices) || !length(type$choices)) { - stop("No ", toString(is(type)), " meet the specification.", call. = FALSE) - } - - type <- eval_type_select(type, data) - - list(type = type, data = extract(data, unorig(type$selected))) -} - -#' @export -determine.specification <- function(type, data, ...) { - stopifnot(inherits(data, "qenv")) - - # Adding some default specifications if they are missing - if ("values" %in% names(type) && !"variables" %in% names(type)) { - type <- append(type, list(variables = variables()), length(type) - 1) - } - - if ("variables" %in% names(type) && !"datasets" %in% names(type)) { - type <- append(type, list(variables = datasets()), length(type) - 1) - } - - d <- data - for (i in seq_along(type)) { - di <- determine(type[[i]], d) - # overwrite so that next type in line receives the corresponding data and specification - if (is.null(di$type)) { - next - } - type[[i]] <- di$type - d <- di$data - } - list(type = type, data = data) # It is the transform object resolved. -} - -#' @export -determine.datasets <- function(type, data, ...) { - if (is.null(data)) { - return(list(type = type, data = NULL)) - } else if (!inherits(data, "qenv")) { - stop("Please use qenv() or teal_data() objects.") - } - - # Assumes the object has colnames method (true for major object classes: DataFrame, tibble, Matrix, array) - # FIXME: What happens if colnames is null: colnames(array(dim = c(4, 2))) - type <- eval_type_names(type, data) - - if (is.null(type$choices) || !length(type$choices)) { - stop("No ", toString(is(type)), " meet the specification.", call. = FALSE) - } - - type <- eval_type_select(type, data) - - list(type = type, data = extract(data, unorig(type$selected))) -} - -#' @export -determine.variables <- function(type, data, ...) { - if (is.null(data)) { - return(list(type = type, data = NULL)) - } else if (length(dim(data)) != 2L) { - stop( - "Can't resolve variables from this object of class ", - toString(sQuote(class(data))) - ) - } - - if (ncol(data) <= 0L) { - stop("Can't pull variable: No variable is available.") - } - - type <- eval_type_names(type, data) - - if (is.null(type$choices) || !length(type$choices)) { - stop("No ", toString(is(type)), " meet the specification.", call. = FALSE) - } - - type <- eval_type_select(type, data) - - # Not possible to know what is happening - if (is.delayed(type)) { - return(list(type = type, data = NULL)) - } - # This works for matrices and data.frames of length 1 or multiple - # be aware of drop behavior on tibble vs data.frame - list(type = type, data = extract(data, unorig(type$selected))) -} - -#' @export -determine.values <- function(type, data, ...) { - if (!is.numeric(data)) { - d <- data - names(d) <- data - } else { - d <- data - } - sel <- selector(d, type$choices) - type$choices <- data[sel] - - - sel2 <- selector(d[sel], type$selected) - type$selected <- data[sel][sel2] - - # Not possible to know what is happening - if (is.delayed(type)) { - return(list(type = type, data = NULL)) - } - - list(type = type, data = data[sel]) -} - -orig <- function(x) { - attr(x, "original") -} - -unorig <- function(x) { - attr(x, "original") <- NULL - x -} - -eval_type_names <- function(type, data) { - orig_choices <- orig(type$choices) - if (length(orig_choices) == 1L) { - orig_choices <- orig_choices[[1L]] - } - - new_choices <- selector(data, type$choices) - - new_choices <- unique(names(new_choices)) - attr(new_choices, "original") <- orig_choices - - type$choices <- new_choices - - type -} - -eval_type_select <- function(type, data) { - stopifnot(is.character(type$choices)) - if (!is(data, "qenv")) { - data <- extract(data, type$choices) - } else { - # Do not extract; selection would be from the data extracted not from the names. - data <- data[type$choices] - } - orig_selected <- orig(type$selected) - if (length(orig_selected) == 1L) { - orig_selected <- orig_selected[[1L]] - } - - choices <- seq_along(type$choices) - names(choices) <- type$choices - new_selected <- names(selector(data, type$selected)) - - attr(new_selected, "original") <- orig_selected - type$selected <- new_selected - - type -} diff --git a/R/update_spec.R b/R/update_spec.R deleted file mode 100644 index 5fcd0245..00000000 --- a/R/update_spec.R +++ /dev/null @@ -1,102 +0,0 @@ -#' Update a specification -#' -#' Update the specification for different selection. -#' @param spec A resolved specification such as one created with datasets and variables. -#' @param type Which type was updated? One of datasets, variables, values. -#' @param value What is the new selection? One that is a valid value for the given type and specification. -#' @return The specification with restored choices and selection if caused by the update. -#' @export -#' @examples -#' td <- within(teal.data::teal_data(), { -#' df <- data.frame( -#' A = as.factor(letters[1:5]), -#' Ab = LETTERS[1:5] -#' ) -#' df_n <- data.frame( -#' C = 1:5, -#' Ab = as.factor(letters[1:5]) -#' ) -#' }) -#' data_frames_factors <- c(datasets(where(is.data.frame)), variables(where(is.factor))) -#' res <- resolver(data_frames_factors, td) -#' update_spec(res, "datasets", "df_n") -#' # update_spec(res, "datasets", "error") -update_spec <- function(spec, type, value) { - if (!is.character(value)) { - stop( - "The updated value is not a character.", - "\nDo you attempt to set a new specification? Please open an issue." - ) - } - - if (valid_specification(spec)) { - stop("Unexpected object used as specification") - } - - if (is.null(names(spec))) { - updated_spec <- lapply(spec, update_s_spec, type = type, value = value) - class(updated_spec) <- class(spec) - return(updated_spec) - } - if (!is.null(names(spec))) { - updated_spec <- update_s_spec(spec, type, value) - } else if (is.type(spec)) { - updated_spec <- update_s_spec(spec, is(spec), value) - } - updated_spec -} - -#' @importFrom methods is -update_s_spec <- function(spec, type, value) { - if (is.type(spec)) { - l <- list(spec) - names(l) <- is(spec) - out <- update_s_spec(l, type, value) - return(out[[is(spec)]]) - } - - if (is.delayed(spec)) { - stop("Specification is not resolved (`!is.delayed(spec)`) can't update selections.") - } - - spec_types <- names(spec) - type <- match.arg(type, spec_types) - restart_types <- spec_types[seq_along(spec_types) > which(type == spec_types)] - - valid_names <- spec[[type]]$choices - - if (!is.list(valid_names) && all(value %in% valid_names)) { - original_select <- orig(spec[[type]]$selected) - spec[[type]][["selected"]] <- value - attr(spec[[type]][["selected"]], "original") <- original_select - } else if (!is.list(valid_names) && !all(value %in% valid_names)) { - original_select <- orig(spec[[type]]$selected) - - valid_values <- intersect(value, valid_names) - if (!length(valid_values)) { - stop("No valid value provided.") - } - if (!length(valid_values)) { - spec[[type]][["selected"]] <- original_select - } else { - spec[[type]][["selected"]] <- valid_values - } - attr(spec[[type]][["selected"]], "original") <- original_select - } else { - stop("It seems the specification needs to be resolved first.") - } - - # Restore to the original specs - for (type_restart in restart_types) { - if (is.na(spec[[type_restart]])) { - next - } - restored_specification <- type_helper( - orig(spec[[type_restart]]$choices), - orig(spec[[type_restart]]$selected), - type_restart - ) - spec[[type_restart]] <- restored_specification - } - spec -} diff --git a/man/determine.Rd b/man/determine.Rd index 6d2b4fe9..97f71e1e 100644 --- a/man/determine.Rd +++ b/man/determine.Rd @@ -1,18 +1,18 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/resolver.R +% Please edit documentation in R/0-resolver.R \name{determine} \alias{determine} \title{A method that should take a type and resolve it.} \usage{ -determine(type, data, ...) +determine(x, data, ...) } \arguments{ -\item{type}{The specification to resolve.} +\item{x}{The specification to resolve.} \item{data}{The minimal data required.} } \value{ -A list with two elements, the type resolved and the data extracted. +A list with two elements, the \code{type} resolved and the data extracted. } \description{ Generic that makes the minimal check on spec. diff --git a/man/extract.Rd b/man/extract.Rd index 9c2ab252..1fba35d0 100644 --- a/man/extract.Rd +++ b/man/extract.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/extract.R +% Please edit documentation in R/0-extract.R \name{extract} \alias{extract} \title{Internal method to extract data from different objects} diff --git a/man/is.delayed.Rd b/man/is.delayed.Rd index 7a83ec6a..f300d3db 100644 --- a/man/is.delayed.Rd +++ b/man/is.delayed.Rd @@ -1,13 +1,13 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/delayed.R +% Please edit documentation in R/0-delayed.R \name{is.delayed} \alias{is.delayed} \title{Is the specification resolved?} \usage{ -is.delayed(specification) +is.delayed(x) } \arguments{ -\item{specification}{Object to be evaluated.} +\item{x}{Object to be evaluated.} } \value{ A single logical value. diff --git a/man/resolver.Rd b/man/resolver.Rd index 108f2f18..61702932 100644 --- a/man/resolver.Rd +++ b/man/resolver.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/resolver.R +% Please edit documentation in R/0-resolver.R \name{resolver} \alias{resolver} \title{Resolve the specification} diff --git a/man/types.Rd b/man/types.Rd index 2b47a81a..8e1c0850 100644 --- a/man/types.Rd +++ b/man/types.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/types.R +% Please edit documentation in R/0-types.R \name{Types} \alias{Types} \alias{datasets} diff --git a/man/update_spec.Rd b/man/update_spec.Rd deleted file mode 100644 index eb750cb4..00000000 --- a/man/update_spec.Rd +++ /dev/null @@ -1,37 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/update_spec.R -\name{update_spec} -\alias{update_spec} -\title{Update a specification} -\usage{ -update_spec(spec, type, value) -} -\arguments{ -\item{spec}{A resolved specification such as one created with datasets and variables.} - -\item{type}{Which type was updated? One of datasets, variables, values.} - -\item{value}{What is the new selection? One that is a valid value for the given type and specification.} -} -\value{ -The specification with restored choices and selection if caused by the update. -} -\description{ -Update the specification for different selection. -} -\examples{ -td <- within(teal.data::teal_data(), { - df <- data.frame( - A = as.factor(letters[1:5]), - Ab = LETTERS[1:5] - ) - df_n <- data.frame( - C = 1:5, - Ab = as.factor(letters[1:5]) - ) -}) -data_frames_factors <- c(datasets(where(is.data.frame)), variables(where(is.factor))) -res <- resolver(data_frames_factors, td) -update_spec(res, "datasets", "df_n") -# update_spec(res, "datasets", "error") -} diff --git a/tests/testthat/test-types.R b/tests/testthat/test-types.R index dfb4dc0c..471d11f3 100644 --- a/tests/testthat/test-types.R +++ b/tests/testthat/test-types.R @@ -1,4 +1,32 @@ -test_that("datasets", { +testthat::describe("selected_choices() basic asserts:", { + it("selected_choices(choices) argument accepts character, integer and tidyselect", { + testthat::expect_no_error(datasets(choices = "test")) + testthat::expect_no_error(datasets(choices = 1)) + testthat::expect_no_error(datasets(choices = tidyselect::everything())) + testthat::expect_error(datasets(choices = character(0))) + testthat::expect_error(datasets(choices = NULL)) + testthat::expect_error(datasets(choices = list())) + }) + it("datasets(selected) argument accepts NULL, character, integer and tidyselect", { + testthat::expect_no_error(datasets(selected = "test")) + testthat::expect_no_error(datasets(selected = 1)) + testthat::expect_no_error(datasets(selected = tidyselect::everything())) + testthat::expect_no_error(datasets(selected = NULL)) + }) + it("datasets(selected) disallow values outside of the non-delayed choices", { + testthat::expect_error(datasets(choices = c("a", "b"), selected = "c") + testthat::expect_error(datasets(choices = c("a", "b"), selected = c("a","c")) + testthat::expect_no_error(datasets(choices = tidyselect::everything(), selected = "c") + testthat::expect_no_error(datasets(choices = 1, selected = "c") + }) + + it("datasets returns datasets object", { + testthat::expect_s3_class(datasets(choices = c("a", "b"), selected = "a"), "datasets") + testthat::expect_s3_class(datasets(choices = c("a", "b"), selected = "a"), "datasets") + }) +}) + +testthat::test_that("datasets", { expect_no_error(dataset0 <- datasets("df", "df")) expect_no_error(dataset1 <- datasets("df")) expect_no_error(dataset2 <- datasets(where(is.matrix))) From a3014a9a8ded685545c1b14d2f08d2da5b71e9aa Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Mon, 25 Aug 2025 19:28:30 +0200 Subject: [PATCH 112/142] WIP merge, 1st POC --- NAMESPACE | 11 +- R/0-delayed.R | 19 +-- R/0-join_keys.R | 18 +++ R/0-merge.R | 235 +++++++++++++++++++++++++++---- R/0-module_input.R | 203 ++++++++++++++++++++------ R/0-module_merge.R | 61 ++++++++ R/0-resolver.R | 98 ++++--------- R/0-types.R | 177 +++++++++-------------- R/call_utils.R | 15 ++ inst/refactor-notes.Rmd | 191 +++++++++++++++++++++++++ man/dot-is_tidyselect.Rd | 20 +++ man/merge_expr.Rd | 26 ++++ man/restoreValue.Rd | 33 +++++ man/tm_merge.Rd | 11 ++ man/types.Rd | 11 +- tests/testthat/test-merge_expr.R | 15 ++ 16 files changed, 873 insertions(+), 271 deletions(-) create mode 100644 R/0-join_keys.R create mode 100644 R/0-module_merge.R create mode 100644 inst/refactor-notes.Rmd create mode 100644 man/dot-is_tidyselect.Rd create mode 100644 man/merge_expr.Rd create mode 100644 man/restoreValue.Rd create mode 100644 man/tm_merge.Rd create mode 100644 tests/testthat/test-merge_expr.R diff --git a/NAMESPACE b/NAMESPACE index 6dcdde35..a9b3d6bd 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,8 +1,6 @@ # Generated by roxygen2: do not edit by hand S3method(anyNA,type) -S3method(c,specification) -S3method(c,type) S3method(data_extract_multiple_srv,FilteredData) S3method(data_extract_multiple_srv,list) S3method(data_extract_multiple_srv,reactive) @@ -11,7 +9,6 @@ S3method(data_extract_srv,list) S3method(determine,colData) S3method(determine,datasets) S3method(determine,default) -S3method(determine,list) S3method(determine,specification) S3method(determine,type) S3method(determine,values) @@ -29,6 +26,10 @@ S3method(merge_expression_module,list) S3method(merge_expression_module,reactive) S3method(merge_expression_srv,list) S3method(merge_expression_srv,reactive) +S3method(module_input_srv,list) +S3method(module_input_srv,specification) +S3method(module_input_ui,list) +S3method(module_input_ui,specification) S3method(print,choices_labeled) S3method(print,delayed_choices_selected) S3method(print,delayed_data_extract_spec) @@ -38,6 +39,7 @@ S3method(print,delayed_value_choices) S3method(print,delayed_variable_choices) S3method(print,filter_spec) S3method(print,type) +S3method(rename,join_keys) S3method(resolve,default) S3method(resolve,delayed_choices_selected) S3method(resolve,delayed_data_extract_spec) @@ -90,11 +92,13 @@ export(merge_expression_srv) export(module_input_srv) export(module_input_ui) export(no_selected_as_NULL) +export(qenv_merge_selectors) export(resolve_delayed) export(resolver) export(select_spec) export(select_spec.default) export(select_spec.delayed_data) +export(spec) export(split_by_sep) export(value_choices) export(values) @@ -102,3 +106,4 @@ export(variable_choices) export(variables) import(shiny) importFrom(dplyr,"%>%") +importFrom(dplyr,rename) diff --git a/R/0-delayed.R b/R/0-delayed.R index b04b22f1..b4909a20 100644 --- a/R/0-delayed.R +++ b/R/0-delayed.R @@ -1,11 +1,3 @@ -# Only delay if the type or object really needs it and is not already delayed -as.delayed <- function(x) { - if (is.delayed(x)) { - attr(x, "delayed") <- TRUE - } - x -} - #' Is the specification resolved? #' #' Check that the specification is resolved against a given data source. @@ -44,16 +36,7 @@ is.delayed.specification <- function(x) { #' @method is.delayed type is.delayed.type <- function(x) { if (!is.na(x)) { - return(!all(is.character(x$choices)) || !all(is.character(x$selected))) + return(!is.character(x$choices) || !is.character(x$selected)) } FALSE } - -resolved <- function(x) { - s <- all(is.character(x$choices)) && all(is.character(x$selected)) - if (!s && !all(x$selected %in% x$choices)) { - stop("Selected not resolved.") - } - attr(x, "delayed") <- NULL - x -} diff --git a/R/0-join_keys.R b/R/0-join_keys.R new file mode 100644 index 00000000..1b5b2bab --- /dev/null +++ b/R/0-join_keys.R @@ -0,0 +1,18 @@ +#' @importFrom dplyr rename +#' @export +rename.join_keys <- function(.data, dataname, ...) { + checkmate::assert_string(dataname) + dots <- list(...) + checkmate::assert_list(dots, types = "character", names = "named") + column <- unlist(dots) + for (other_name in names(.data[[dataname]])) { + keys <- .data[dataname, other_name] + matched_idx <- match(column, names(keys)) + names(keys)[matched_idx] <- names(column) + if (other_name == dataname) { + keys[matched_idx] <- names(column) + } + .data[dataname, other_name] <- keys + } + .data +} diff --git a/R/0-merge.R b/R/0-merge.R index ee154c8c..9ffe63b5 100644 --- a/R/0-merge.R +++ b/R/0-merge.R @@ -1,58 +1,245 @@ -#' @param data (`teal_data`) +#' Merge expression for selectors #' @param selectors (`list` of `specification`) +#' @param output_name (`character(1)`) #' @param join_fun (`character(1)`) name of the merge function. -#' @param ignore_disconnected (`logical(1)`) +#' @param join_keys (`join_keys`) #' @export -merge_expr <- function(data, selectors, join_fun = "dplyr::left_join", ignore_disconnected = TRUE) { - checkmate::assert_class(data, "teal_data") - checkmate::assert_list(selectors, "specification") +merge_expr <- function(selectors, + output_name = "merged", + join_fun = "dplyr::left_join", + join_keys, + allow_cartesian = FALSE) { + checkmate::assert_list(selectors, c("specification", "reactive")) + checkmate::assert_string(output_name) checkmate::assert_string(join_fun) - checkmate::assert_flag(ignore_disconnected) + checkmate::assert_class(join_keys, "join_keys") - # IMPORTANT! Merge just need a dispatch on the class of the first object - # as merge (left_join) of data.frame and MAE is still a data.frame - # it is just a matter of "select" which is dataset specific - datanames <- unique(unlist(lapply(selectors, function(x) x$datasets$selected))) + merge_summary <- .merge_summary_list(selectors, join_keys = join_keys) + join_keys <- merge_summary$join_keys + mapping <- merge_summary$mapping + mapping <- lapply(mapping, function(x) { + # because we need `$new_name = $old_name` to rename in select call + x$variables <- stats::setNames(names(x$variables), unname(x$variables)) + x + }) + datanames <- unique(unlist(lapply(mapping, `[[`, "datasets"))) calls <- expression() anl_datanames <- character(0) # to follow what anl is composed of (to determine keys) - anl_variables <- character(0) + anl_primary_keys <- character(0) # to determine accumulated keys of a merged dataset for (i in seq_along(datanames)) { dataname <- datanames[i] - this_selectors <- Filter(function(x) identical(x$datasets$selected, dataname), selectors) - this_keys <- teal.data::join_keys(data)[[dataname]] - this_variables <- union( - unlist(this_keys), # todo: all keys or only those which connects `datanames`? - unlist(lapply(this_selectors, function(x) x$variables$selected)) + this_mapping <- Filter(function(x) x$datasets == dataname, mapping) + this_foreign_keys <- .fk(join_keys, dataname) + this_primary_keys <- join_keys[dataname, dataname] + this_variables <- c( + this_foreign_keys, + unlist(lapply(unname(this_mapping), `[[`, "variables")) ) + this_variables <- this_variables[!duplicated(unname(this_variables))] # because unique drops names # todo: extract call is datasets (class, class) specific - this_call <- call_extract_matrix(dataname = dataname, column = this_variables) + this_call <- .call_dplyr_select(dataname = dataname, variables = this_variables) if (i > 1) { - # merge by cumulated keys - merge_keys <- unique(unlist(teal.data::join_keys(data)[[dataname]][names(this_keys) %in% anl_datanames])) + merge_keys <- join_keys["anl", dataname] if (!length(merge_keys)) { msg <- sprintf( "Merge is not possible. No join_keys between %s and any of %s", - dataname, + sQuote(dataname), sQuote(toString(anl_datanames)) ) - if (ignore_disconnected) warning(msg, call. = FALSE) else stop(msg, call. = FALSE) + stop(msg, call. = FALSE) next } + anl_vs_this <- setdiff(anl_primary_keys, this_primary_keys) + this_vs_anl <- setdiff(this_primary_keys, anl_primary_keys) + if (length(anl_vs_this) && length(this_vs_anl) && !allow_cartesian) { + validate(need(FALSE, "cartesian join")) # todo: add more info + } this_call <- as.call( list( str2lang(join_fun), y = this_call, - by = merge_keys + by = merge_keys, + suffix = c("", sprintf("_%s", dataname)) ) ) } anl_datanames <- c(anl_datanames, dataname) - anl_variables <- c(anl_variables, this_variables) + anl_primary_keys <- union(anl_primary_keys, this_primary_keys) calls <- c(calls, this_call) } - call("<-", str2lang("anl"), calls_combine_by("%>%", calls)) + call("<-", str2lang(output_name), calls_combine_by("%>%", calls)) +} + + +merge_srv <- function(data, selectors, join_fun = "dplyr::left_join", output_name = "merged") { + checkmate::assert_class(data, "reactive") + checkmate::assert_list(selectors, "specification") + checkmate::assert_string(join_fun) + session <- shiny::getDefaultReactiveDomain() + + inputs_out <- sapply(names(selectors), USE.NAMES = TRUE, function(id) { + module_input_srv(id, spec = selectors[[id]], data = data) + }) + + selectors_r <- reactive(lapply(inputs_out, function(x) x())) + + + merged_data <- reactive({ + req(data(), selectors_r()) + expr <- merge_expr(selectors = selectors_r(), join_keys = teal.data::join_keys(data()), output_name = output_name) + teal.code::eval_code(data(), expr) + }) + + merged_data +} + +#' @export +qenv_merge_selectors <- function(x, + selectors, + output_name = "merged", + join_fun = "dplyr::left_join", + allow_cartesian = TRUE) { + expr <- merge_expr( + selectors = selectors, + output_name = output_name, + join_fun = join_fun, + join_keys = teal.data::join_keys(x), + allow_cartesian = allow_cartesian + ) + eval_code(x, expr) +} + +map_merged <- function(selectors, join_keys) { + .merge_summary_list(selectors, join_keys = join_keys)$mapping +} + + +#' Analyse selectors and guess merge consequences +#' +#' @return list containing: +#' - mapping (`named list`) containing selected values in each selector. This `mapping` +#' is sorted according to correct datasets merge order. +#' - join_keys (`join_keys`) updated `join_keys` containing keys of `ANL` +#' +#' @keywords internal +.merge_summary_list <- function(selectors, join_keys) { + checkmate::assert_list(selectors, c("reactive", "specification")) + if (missing(join_keys)) { + join_keys <- Reduce( + function(all, this) c(all, attr(this, "join_keys")), + x = selectors, + init = teal.data::join_keys() + ) + } + mapping <- lapply( # what has been selected in each selector + selectors, + function(x) { + obj <- if (is.reactive(x)) x() else x + selected <- lapply(obj, function(x) stats::setNames(x$selected, x$selected)) + } + ) + mapped_datanames <- unlist(lapply(mapping, `[[`, "datasets"), use.names = FALSE) + mapping_by_dataset <- split(mapping, mapped_datanames) + + datanames <- unique(mapped_datanames) + if (length(datanames) > 1) { + # datanames are handed over in order of selectors but + # they must be in topological order - otherwise join might not be possible + datanames <- c( + intersect(names(join_keys), datanames), + setdiff(datanames, names(join_keys)) # non-joinable datasets at the end + ) + + # mapping will be reused so needs to be reordered as well + mapping <- mapping[rank(match(mapped_datanames, datanames))] + } + remaining_datanames <- datanames + join_keys <- join_keys[datanames] + anl_colnames <- character(0) + for (dataname in datanames) { + # glossary: + # dataset/dataname: dataset (or its name) in the current iteration (datasets are merged in a loop) + # anl datasets/datanames: datasets (or names) which anl is composed of (this is a cumulative process) + # remaining datasets/datanames: datasets (or names) which are about to be merged + # + # Rules: + # 1. selected variables are added to anl. + # 2. duplicated variables added to anl should be renamed + # 3. anl "inherits" foreign keys from anl datasets to remaining datasets + # 4. foreign keys of current dataset are added to anl join_keys but only if no relation from anl already. + # 5. foreign keys should be renamed if duplicated with anl colnames + # 6. (for later) selected datasets might not be directly mergable, we need to find the "path" which + # will probably involve add intermediate datasets in between to perform merge + remaining_datanames <- setdiff(remaining_datanames, dataname) + mapping_ds <- mapping_by_dataset[[dataname]] + mapping_ds <- lapply(mapping_ds, function(x) { + new_vars <- .suffix_duplicated_vars( + # is dropped by merge call. We should refer this selected foreign-key-variable + # to equivalent key variable added in previous iteration (existing anl foreign key) + # 4. duplicated variables added to anl should be renamed + vars = x$variables, + all_vars = anl_colnames, + suffix = dataname + ) + + # if foreign key of this dataset is selected and if this foreign key took a part in the merge + # then this key is dropped and we need to refer to the first variable + existing_fk <- join_keys[dataname, "anl"] # keys that are already in anl + existing_fk_selected <- intersect(names(existing_fk), x$variables) + new_vars[existing_fk_selected] <- existing_fk[existing_fk_selected] + x$variables <- new_vars + x + }) + mapping[names(mapping_ds)] <- mapping_ds + + this_colnames <- unique(unlist(lapply(mapping_ds, `[[`, "variables"))) + anl_colnames <- c(anl_colnames, this_colnames) + + # todo: if this dataset has no join_keys to anl (anl_datasets) then error saying + # can't merge {dataset} with merged dataset composed of {anl_datasets} + + # ↓ 3. anl "inherits" foreign keys from anl datasets to remaining datasets + this_join_keys <- do.call( + teal.data::join_keys, + lapply( + remaining_datanames, + function(dataset_2) { + new_keys <- join_keys[dataname, dataset_2] + # ↓ 4. foreign keys of current dataset are added to anl join_keys but only if no relation from anl already + if (length(new_keys) && !dataset_2 %in% names(join_keys[["anl"]])) { + # ↓ 5. foreign keys should be renamed if duplicated with anl colnames + new_key_names <- .suffix_duplicated_vars( + vars = names(new_keys), # names because we change the key of dataset_1 (not dataset_2) + all_vars = anl_colnames, + suffix = dataname + ) + names(new_keys) <- new_key_names + join_key(dataset_1 = "anl", dataset_2 = dataset_2, keys = new_keys) + } + } + ) + ) + join_keys <- c(this_join_keys, join_keys) + anl_colnames <- union(anl_colnames, .fk(join_keys, "anl")) + } + + + list(mapping = mapping, join_keys = join_keys) +} + +.fk <- function(x, dataname) { + this_jk <- x[[dataname]] + unique(unlist(lapply(this_jk[!names(this_jk) %in% dataname], names))) +} + +.suffix_duplicated_vars <- function(vars, all_vars, suffix) { + idx_duplicated <- vars %in% all_vars + if (any(idx_duplicated)) { + vars[idx_duplicated] <- sprintf("%s_%s", vars[idx_duplicated], suffix) + } + vars } diff --git a/R/0-module_input.R b/R/0-module_input.R index ac21faa5..198a5e06 100644 --- a/R/0-module_input.R +++ b/R/0-module_input.R @@ -1,29 +1,84 @@ #' @export module_input_ui <- function(id, spec) { + checkmate::assert_string(id) + UseMethod("module_input_ui", spec) +} + +#' @export +module_input_ui.list <- function(id, spec) { + checkmate::assert_list(spec, names = "named") ns <- shiny::NS(id) + sapply( + Filter(length, names(spec)), + USE.NAMES = TRUE, + function(name) module_input_ui(ns(name), spec[[name]]) + ) +} + +#' @export +module_input_ui.specification <- function(id, spec) { if (.valid_specification(spec)) { stop("Unexpected object used as specification.") } - badge_label <- shiny::textOutput(ns("summary"), container = tags$span) - content <- lapply(spec, function(x) selected_choices_ui(id = ns(is(x)), x)) - tags$div( + ns <- shiny::NS(id) + badge_label <- shiny::textOutput(ns("summary"), container = htmltools::tags$span) + # todo: icon or color to indicate a column class + content <- lapply(spec, function(x) .selected_choices_ui(id = ns(is(x)), x)) + htmltools::tags$div( # todo: spec to have a label attribute .badge_dropdown(ns("inputs"), label = badge_label, content = content) ) } #' @export -module_input_srv <- function(id, spec, data) { +module_input_srv <- function(id = "", spec, data) { checkmate::assert_string(id) - checkmate::assert_true(.is.specification(spec)) checkmate::assert_class(data, "reactive") + UseMethod("module_input_srv", spec) +} + +#' @export +module_input_srv.list <- function(id, spec, data) { + sapply( + Filter(length, names(spec)), + USE.NAMES = TRUE, + function(name) module_input_srv(name, spec[[name]], data) + ) +} + +#' @export +module_input_srv.specification <- function(id, spec, data) { moduleServer(id, function(input, output, session) { + attr(spec, ".callback") <- reactiveVal(NULL) # callback to be used outside + data_r <- shiny::reactive(if (shiny::is.reactive(data)) data() else data) - spec_r <- shiny::reactiveVal(resolver(spec, shiny::isolate(data_r()))) + # todo: bookmarking (decide whether it should be built on reactiveVal or setting inputs) + spec_resolved <- shiny::reactiveVal( + restoreValue( + session$ns("selectors"), + resolver(spec, shiny::isolate(data_r())) + ) + ) + session$onBookmark(function(state) { + logger::log_debug("module_input_srv@onBookmark: storing current selectors") + state$values$selectors <- spec_resolved() + }) + + # join_keys are needed to variables after merge + attr(spec_resolved, "join_keys") <- teal.data::join_keys(shiny::isolate(data_r())) # todo: do the same as with .callback badge_text <- shiny::reactive({ paste( - lapply(spec_r(), function(x) toString(x$selected)), + lapply( + spec_resolved(), + function(x) { + if (length(x$selected)) { + toString(x$selected) + } else { + "~" + } + } + ), collapse = ": " ) }) @@ -32,51 +87,76 @@ module_input_srv <- function(id, spec, data) { output$summary <- shiny::renderText(badge_text()) lapply(seq_along(spec), function(i) { - selected <- selected_choices_srv( - id = is(spec[[i]]), - x = shiny::reactive(spec_r()[[i]]) + slot_name <- names(spec)[i] + selected <- .selected_choices_srv( + id = is(spec[[slot_name]]), + x = shiny::reactive(spec_resolved()[[slot_name]]) ) + + # this works as follows: + # Each observer is observes input$selected of i-th element of spec ($datasets, $variables, ...) + # When i-th select input changes then + # - spec_resolved containing current state is being unresolved but only after the i-th element as + # values are sequentially dependent. For example if variables (i=2) is selected we don't want + # to unresolve (restart) dataset. + # - new value (selected) is replacing old value in current slot (i) + # - we call resolve which resolves only "unresolved" (delayed) values + # - new spec is replacing reactiveValue + # Thanks to this design reactive values are triggered only once shiny::observeEvent( selected(), - ignoreInit = TRUE, # because spec_r is a initial state + ignoreInit = TRUE, # because spec_resolved is a initial state { logger::log_info("module_input_server@1 selected has changed. Resolving downstream...") new_spec_unresolved <- spec - new_spec_unresolved[[i]]$selected <- selected() - if (i > 1) { - # we don't want to resolve previous items - new_spec_unresolved[seq_len(i - 1)] <- spec_r()[seq_len(i - 1)] + # ↓ everything after `i` is to resolve + new_spec_unresolved[seq_len(i)] <- spec_resolved()[seq_len(i)] + new_spec_unresolved[[slot_name]]$selected <- selected() + + resolver_warnings <- character() + new_spec_resolved <- withCallingHandlers( + resolver(new_spec_unresolved, data_r()), + warning = function(w) { + resolver_warnings <<- paste(conditionMessage(w), collapse = " ") + } + ) + if (length(resolver_warnings)) { + showNotification(resolver_warnings, type = "error") } - new_spec <- resolver(new_spec_unresolved, data_r()) - if (!identical(new_spec, spec_r())) { - logger::log_info("Update spec { names(spec)[i] } after selection change.") - spec_r(new_spec) + if (!identical(new_spec_resolved, spec_resolved())) { + logger::log_info("Update spec { slot_name } after selection change.") + spec_resolved(new_spec_resolved) } } ) }) - spec_r + spec_resolved }) } -selected_choices_ui <- function(id, x) { +.selected_choices_ui <- function(id, x) { ns <- shiny::NS(id) shiny::selectInput( inputId = ns("selected"), label = paste("Select", is(x), collapse = " "), choices = if (!is.delayed(x$choices)) x$choices, selected = if (!is.delayed(x$selected)) x$selected, - multiple = isTRUE(x$multiple) + multiple = isTRUE(attr(x, "multiple")) ) } -selected_choices_srv <- function(id, x) { +.selected_choices_srv <- function(id, x) { checkmate::assert_string(id) checkmate::assert_true(is.reactive(x)) shiny::moduleServer(id, function(input, output, session) { + # todo: keep_order shiny::observeEvent(x(), { - logger::log_debug("selected_choices_srv@1 x has changed (caused by upstream resolve)") + logger::log_debug(".selected_choices_srv@1 x has changed (caused by upstream resolve)") + if (length(x()$choices) == 1) { + shinyjs::hide("selected") + } + shiny::updateSelectInput( inputId = "selected", choices = x()$choices, @@ -87,7 +167,7 @@ selected_choices_srv <- function(id, x) { # todo: if only one choice then replace with the text only shiny::observeEvent(input$selected, { if (!identical(input$selected, selected)) { - logger::log_debug("selected_choices_srv@2 input$selected has changed.") + logger::log_debug(".selected_choices_srv@2 input$selected has changed.") selected(input$selected) } }) @@ -97,14 +177,18 @@ selected_choices_srv <- function(id, x) { .badge_dropdown <- function(id, label, content) { ns <- shiny::NS(id) - htmltools::tags$div( - htmltools::tags$span( - label, - id = ns("summary_badge"), - class = "badge bg-primary", - style = "cursor: pointer; user-select: none;", - onclick = sprintf( - " + htmltools::tagList( + htmltools::tags$style(".choices-selected-badge-dropdown:has(~ div .shiny-validation-message) { + border-color: red !important; + }"), + htmltools::tags$div( + htmltools::tags$span( + label, + id = ns("summary_badge"), + class = "badge bg-primary choices-selected-badge-dropdown", + style = "cursor: pointer; user-select: none; border: 1px solid transparent;", + onclick = sprintf( + " var container = document.getElementById('%s'); var summary = document.getElementById('%s'); @@ -123,14 +207,53 @@ selected_choices_srv <- function(id, x) { }, 10); } ", - ns("inputs_container"), - ns("summary_badge") + ns("inputs_container"), + ns("summary_badge") + ) + ), + htmltools::tags$div( + content, + id = ns("inputs_container"), + style = "display: none; position: absolute; background: white; border: 1px solid #ccc; border-radius: 4px; box-shadow: 0 2px 10px rgba(0,0,0,0.1); padding: 10px; z-index: 1000; min-width: 200px;", ) - ), - htmltools::tags$div( - content, - id = ns("inputs_container"), - style = "display: none; position: absolute; background: white; border: 1px solid #ccc; border-radius: 4px; box-shadow: 0 2px 10px rgba(0,0,0,0.1); padding: 10px; z-index: 1000; min-width: 200px;", ) ) } + + +#' Restore value from bookmark. +#' +#' Get value from bookmark or return default. +#' +#' Bookmarks can store not only inputs but also arbitrary values. +#' These values are stored by `onBookmark` callbacks and restored by `onBookmarked` callbacks, +#' and they are placed in the `values` environment in the `session$restoreContext` field. +#' Using `teal_data_module` makes it impossible to run the callbacks +#' because the app becomes ready before modules execute and callbacks are registered. +#' In those cases the stored values can still be recovered from the `session` object directly. +#' +#' Note that variable names in the `values` environment are prefixed with module name space names, +#' therefore, when using this function in modules, `value` must be run through the name space function. +#' +#' @param value (`character(1)`) name of value to restore +#' @param default fallback value +#' +#' @return +#' In an application restored from a server-side bookmark, +#' the variable specified by `value` from the `values` environment. +#' Otherwise `default`. +#' +#' @keywords internal +#' +restoreValue <- function(value, default) { # nolint: object_name. + checkmate::assert_character("value") + session_default <- shiny::getDefaultReactiveDomain() + session_parent <- .subset2(session_default, "parent") + session <- if (is.null(session_parent)) session_default else session_parent + + if (isTRUE(session$restoreContext$active) && exists(value, session$restoreContext$values, inherits = FALSE)) { + session$restoreContext$values[[value]] + } else { + default + } +} diff --git a/R/0-module_merge.R b/R/0-module_merge.R new file mode 100644 index 00000000..54eece09 --- /dev/null +++ b/R/0-module_merge.R @@ -0,0 +1,61 @@ +#' Merge module +#' +#' Example module +tm_merge <- function(label = "merge-module", inputs) { + module( + label = label, + ui = function(id, inputs) { + ns <- NS(id) + tags$div( + tags$div( + class = "row g-2", + lapply(names(inputs), function(id) { + tags$div( + class = "col-auto", + tags$strong(tags$label(id)), + teal.transform::module_input_ui( + id = ns(id), + spec = inputs[[id]] + ) + ) + }) + ), + shiny::div( + reactable::reactableOutput(ns("table_merged")), + shiny::verbatimTextOutput(ns("mapped")), + shiny::verbatimTextOutput(ns("src")) + ) + ) + }, + server = function(id, data, inputs) { + moduleServer(id, function(input, output, session) { + selectors <- module_input_srv(id, spec = inputs, data = data) + + merged_q <- reactive({ + req(data()) + lapply(selectors, function(x) req(x())) + teal.transform::qenv_merge_selectors(x = data(), selectors = selectors) + }) + + table_q <- reactive({ + req(merged_q()) + within(merged_q(), reactable::reactable(merged), selectors = selectors) + }) + + output$table_merged <- reactable::renderReactable({ + req(table_q()) + teal.code::get_outputs(table_q())[[1]] + }) + + output$src <- renderPrint({ + styler::style_text( + teal.code::get_code(req(table_q())) + ) + }) + output$mapped <- renderText(yaml::as.yaml(map_merged(selectors))) + }) + }, + ui_args = list(inputs = inputs), + server_args = list(inputs = inputs) + ) +} diff --git a/R/0-resolver.R b/R/0-resolver.R index 429481d1..eb74b6b1 100644 --- a/R/0-resolver.R +++ b/R/0-resolver.R @@ -55,7 +55,7 @@ resolver <- function(spec, data) { determine <- function(x, data, ...) { stopifnot(.is.type(x) || is.list(x) || .is.specification(x)) if (!is.delayed(x)) { - return(list(x = x, data = extract(data, unorig(x$selected)))) + return(list(x = x, data = extract(data, x$selected))) } UseMethod("determine") } @@ -71,10 +71,7 @@ determine.colData <- function(x, data, ...) { stop("Requires SummarizedExperiment package from Bioconductor.") } data <- as.data.frame(colData(data)) - - x <- NextMethod("determine", x) - - list(x = x, data = extract(data, unorig(x$selected))) + NextMethod("determine", x) } #' @export @@ -84,29 +81,14 @@ determine.datasets <- function(x, data, ...) { } else if (!inherits(data, "qenv")) { stop("Please use qenv() or teal_data() objects.") } - # Assumes the object has colnames method (true for major object classes: DataFrame, tibble, Matrix, array) # FIXME: What happens if colnames is null: colnames(array(dim = c(4, 2))) - x <- NextMethod("determine", x) - - list(x = x, data = extract(data, unorig(x$selected))) -} - -#' @export -determine.list <- function(x, data, ...) { - if (is.list(x) && is.null(names(x))) { - l <- lapply(x, determine, data = data) - return(l) - } - - x <- NextMethod("determine", x) - - list(x = x, data = extract(data, unorig(x$selected))) + NextMethod("determine", x) } #' @export determine.specification <- function(x, data, ...) { - stopifnot(inherits(data, "qenv")) + checkmate::assert_class(data, "qenv") # Adding some default specifications if they are missing if ("values" %in% names(x) && !"variables" %in% names(x)) { @@ -117,17 +99,18 @@ determine.specification <- function(x, data, ...) { x <- append(x, list(variables = datasets()), length(x) - 1) } - d <- data + data_i <- data for (i in seq_along(x)) { - di <- determine(x[[i]], d) + determined_i <- determine(x[[i]], data_i) # overwrite so that next x in line receives the corresponding data and specification - if (is.null(di$x)) { + if (is.null(determined_i$x)) { next } - x[[i]] <- di$x - d <- di$data + x[[i]] <- determined_i$x + data_i <- determined_i$data } - list(x = x, data = data) # It is the transform object resolved. + + list(x = x, data = data) } #' @export @@ -169,66 +152,39 @@ determine.variables <- function(x, data, ...) { stop("Can't pull variable: No variable is available.") } - x <- NextMethod("determine", x) - - # Not possible to know what is happening - if (is.delayed(x)) { - return(list(x = x, data = NULL)) - } - # This works for matrices and data.frames of length 1 or multiple - # be aware of drop behavior on tibble vs data.frame - list(x = x, data = extract(data, unorig(x$selected))) -} - -orig <- function(x) { - attr(x, "original") -} - -unorig <- function(x) { - attr(x, "original") <- NULL - x + NextMethod("determine", x) } #' @export determine.type <- function(x, data) { - x <- determine_choices(x, data) - x <- determine_selected(x, data) + x <- .determine_choices(x, data) + x <- .determine_selected(x, data) + list(x = x, data = extract(data, x$selected)) } -determine_choices <- function(x, data) { - orig_choices <- orig(x$choices) - if (length(orig_choices) == 1L) { - orig_choices <- orig_choices[[1L]] +.determine_choices <- function(x, data) { + if (is.delayed(x)) { + new_choices <- unique(names(.eval_select(data, x$choices))) + x$choices <- new_choices } - - new_choices <- unique(names(.eval_select(data, x$choices))) - # if (!length(new_choices)) { - # stop("No ", toString(is(x)), " meet the specification.", call. = FALSE) - # } - attr(new_choices, "original") <- orig_choices - x$choices <- new_choices x } -determine_selected <- function(x, data) { - stopifnot(is.character(x$choices)) +.determine_selected <- function(x, data) { + checkmate::assert_character(x$choices) if (!is(data, "qenv")) { data <- extract(data, x$choices) } else { # Do not extract; selection would be from the data extracted not from the names. data <- data[x$choices] } - orig_selected <- orig(x$selected) - if (length(orig_selected) == 1L) { - orig_selected <- orig_selected[[1L]] + res <- try(unique(names(.eval_select(data, x$selected))), silent = TRUE) + if (inherits(res, "try-error")) { + warning("`selected` outside of possible `choices`. Emptying `selecting` field.", call. = FALSE) + x$selected <- NULL + } else { + x$selected <- res } - choices <- seq_along(x$choices) - names(choices) <- x$choices - new_selected <- names(.eval_select(data, x$selected)) - - attr(new_selected, "original") <- orig_selected - x$selected <- new_selected - x } diff --git a/R/0-types.R b/R/0-types.R index 0fd58710..c70e2f1a 100644 --- a/R/0-types.R +++ b/R/0-types.R @@ -14,34 +14,58 @@ #' c(datasets("A"), variables(where(is.numeric))) NULL +#' @describeIn types specify a selector. +#' @export +spec <- function(...) { + spec <- list(...) + names(spec) <- vapply(spec, FUN = is, FUN.VALUE = character(1)) + structure(spec, class = c("specification", "list")) +} + #' @describeIn types Specify datasets. #' @export datasets <- function(choices = tidyselect::everything(), selected = 1) { - out <- .selected_choices(choices = rlang::enquo(choices), selected = rlang::enquo(selected)) + out <- .selected_choices( + choices = if (.is_tidyselect(choices)) rlang::enquo(choices) else choices, + selected = if (.is_tidyselect(selected)) rlang::enquo(selected) else selected, + multiple = FALSE + ) class(out) <- c("datasets", class(out)) out } #' @describeIn types Specify variables. #' @export -variables <- function(choices = tidyselect::everything(), selected = 1) { - out <- .selected_choices(choices = rlang::enquo(choices), selected = rlang::enquo(selected)) +variables <- function(choices = tidyselect::everything(), selected = 1, multiple = FALSE) { + out <- .selected_choices( + choices = if (.is_tidyselect(choices)) rlang::enquo(choices) else choices, + selected = if (.is_tidyselect(selected)) rlang::enquo(selected) else selected, + multiple = multiple + ) class(out) <- c("variables", class(out)) out } #' @describeIn types Specify colData. #' @export -mae_colData <- function(choices = tidyselect::everything(), selected = 1) { - out <- .selected_choices(choices = rlang::enquo(choices), selected = rlang::enquo(selected)) +mae_colData <- function(choices = tidyselect::everything(), selected = 1, multiple = FALSE) { + out <- .selected_choices( + choices = if (.is_tidyselect(choices)) rlang::enquo(choices) else choices, + selected = if (.is_tidyselect(selected)) rlang::enquo(selected) else selected, + multiple = multiple + ) class(out) <- c("colData", class(out)) out } #' @describeIn types Specify values. #' @export -values <- function(choices = tidyselect::everything(), selected = 1) { - out <- .selected_choices(choices = rlang::enquo(choices), selected = rlang::enquo(selected)) +values <- function(choices = tidyselect::everything(), selected = 1, multiple = FALSE) { + out <- .selected_choices( + choices = if (.is_tidyselect(choices)) rlang::enquo(choices) else choices, + selected = if (.is_tidyselect(selected)) rlang::enquo(selected) else selected, + multiple = multiple + ) class(out) <- c("values", class(out)) out } @@ -51,104 +75,6 @@ anyNA.type <- function(x, recursive = FALSE) { anyNA(unclass(x[c("choices", "selected")]), recursive = recursive) } -#' @export -c.specification <- function(...) { - l <- list(...) - types <- lapply(l, names) - typesc <- vapply(l, .is.specification, logical(1L)) - if (!all(typesc)) { - stop("An object in position ", which(!typesc), " is not a specification.") - } - utypes <- unique(unlist(types, FALSE, FALSE)) - vector <- vector("list", length(utypes)) - names(vector) <- utypes - for (t in utypes) { - new_type <- vector("list", length = 2) - names(new_type) <- c("choices", "selected") - class(new_type) <- c("type", "list") - for (i in seq_along(l)) { - if (!t %in% names(l[[i]])) { - next - } - # Slower but less code duplication: - # new_type <- c(new_type, l[[i]][[t]]) - # then we need class(new_type) <- c(t, "type", "list") outside the loop - old_choices <- new_type$choices - old_selected <- new_type$selected - new_type$choices <- c(old_choices, l[[i]][[t]][["choices"]]) - attr(new_type$choices, "original") <- c(orig( - old_choices - ), orig(l[[i]][[t]][["names"]])) - new_type$selected <- c(old_selected, l[[i]][[t]][["selected"]]) - attr(new_type$selected, "original") <- c(orig(old_selected), orig(l[[i]][[t]][["selected"]])) - attr(new_type, "delayed") <- any(attr(new_type, "delayed"), attr(l[[i]], "delayed")) - } - orig_choices <- unique(orig(new_type$choices)) - new_type$choices <- unique(new_type$choices) - attr(new_type$choices, "original") <- orig_choices - - orig_selected <- unique(orig(new_type$selected)) - new_type$selected <- unique(new_type$selected) - attr(new_type$selected, "original") <- orig_selected - class(new_type) <- c(t, "type", "list") - vector[[t]] <- new_type - } - class(vector) <- c("specification", "list") - vector -} - -#' @export -c.type <- function(...) { - l <- list(...) - types <- lapply(l, is) - typesc <- vapply(l, .is.type, logical(1L)) - if (!all(typesc)) { - stop("An object in position ", which(!typesc), " is not a type.") - } - utypes <- unique(unlist(types, FALSE, FALSE)) - vector <- vector("list", length(utypes)) - names(vector) <- utypes - for (t in utypes) { - new_type <- vector("list", length = 2) - names(new_type) <- c("choices", "selected") - for (i in seq_along(l)) { - if (!is(l[[i]], t)) { - next - } - old_choices <- new_type$choices - old_selected <- new_type$selected - new_type$choices <- c(old_choices, l[[i]][["choices"]]) - attr(new_type$choices, "original") <- c(orig( - old_choices - ), orig(l[[i]][["choices"]])) - new_type$selected <- unique(c(old_selected, l[[i]][["selected"]])) - attr(new_type$selected, "original") <- c(orig(old_selected), orig(l[[i]][["selected"]])) - } - orig_choices <- unique(orig(new_type$choices)) - orig_selected <- unique(orig(new_type$selected)) - - new_type$choices <- unique(new_type$choices) - if (length(new_type$choices) == 1) { - new_type$choices <- new_type$choices[[1]] - } - attr(new_type$choices, "original") <- orig_choices - - if (length(new_type$selected) == 1) { - new_type$selected <- new_type$selected[[1]] - } - attr(new_type$selected, "original") <- orig_selected - - class(new_type) <- c(t, "type", "list") - attr(new_type, "delayed") <- is.delayed(new_type) - vector[[t]] <- new_type - } - if (length(vector) == 1) { - return(vector[[1]]) - } - class(vector) <- c("specification", "list") - vector -} - #' @export is.na.type <- function(x) anyNA(x) @@ -195,6 +121,7 @@ print.type <- function(x, ...) { return(x) } + .count_functions <- function(x) { if (is.list(x)) { vapply(x, is.function, logical(1L)) @@ -216,20 +143,46 @@ print.type <- function(x, ...) { inherits(x, "type") } -.selected_choices <- function(choices, selected, keep_order = FALSE, fixed = FALSE) { +.selected_choices <- function(choices, + selected, + multiple = length(selected) > 1, + keep_order = FALSE) { + is_choices_delayed <- inherits(choices, "quosure") + is_selected_delayed <- inherits(selected, "quosure") + if (is_choices_delayed && !is_selected_delayed) { + warning( + deparse(sys.call(-1)), + "\n - Setting explicit `selected` while `choices` are delayed (set using `tidyselect`) might lead to the", "situation where `selected` is not in dynamically obtained `choices`.", + call. = FALSE + ) + } + out <- structure( list(choices = choices, selected = selected), + multiple = multiple, keep_order = keep_order, - fixed = fixed, class = "type" ) - as.delayed(out) -} - -.simplity_c <- function(x) { - unique(unlist(x, FALSE, FALSE)) } .valid_specification <- function(x) { !((.is.type(x) || .is.specification(x))) } + + +#' Is an object created using tidyselect +#' +#' `choices` and `selected` can be provided using `tidyselect`, (e.g. [tidyselect::everything()] +#' [tidyselect::match()], [tidyselect::starts_with()]). These functions can't be called +#' independently but rather as an argument of function which consumes them. +#' `.is_tidyselect` safely determines if `x` can be evaluated with `tidyselect::eval_select()` +#' @param x `choices` or `selected` +#' @return `logical(1)` +#' @internal +.is_tidyselect <- function(x) { + out <- tryCatch(x, error = function(e) e) + inherits(out, "error") && # because tidyselect calls return error if not used in select + grepl("must be used within a \\*selecting\\* function", paste(out$message, collapse = "\n")) || + checkmate::test_function(out, args = "x") || # because tidyselect::where(foo) returns a function(x, ...) + checkmate::test_integerish(out) # integer is not a column/dataset name +} diff --git a/R/call_utils.R b/R/call_utils.R index 8811c04a..2d342235 100644 --- a/R/call_utils.R +++ b/R/call_utils.R @@ -374,3 +374,18 @@ calls_combine_by <- function(operator, calls) { f = function(x, y) call(operator, x, y) ) } + +#' @param variables (`list` of `character`) variables to select. If list is named then +#' variables will be renamed if their name is different than its value +#' (this produces a call `select(..., = )`). +.call_dplyr_select <- function(dataname, variables) { + as.call( + c( + list( + str2lang("dplyr::select"), + str2lang(dataname) + ), + lapply(unname(variables), str2lang) + ) + ) +} diff --git a/inst/refactor-notes.Rmd b/inst/refactor-notes.Rmd new file mode 100644 index 00000000..bf6a9744 --- /dev/null +++ b/inst/refactor-notes.Rmd @@ -0,0 +1,191 @@ +--- +title: "Refactor Notes" +author: "Development Team" +date: "`r Sys.Date()`" +output: html_document +--- + +# +Consider following tables `orders`, `order_items`, `products`, `customers` connected with join keys +following sql convention `{child}.{parent-singular}_id = {parent}.id`, for example +`orders.customer_id = customers.id`. `teal.data` setup would look like this: + +```{r} +library(teal.data) +data <- within(teal_data(), { + customers <- tibble::tribble( + ~id, ~name, ~age, ~country, + 1, "Alice Johnson", 30, "USA", + 2, "Bob Smith", 25, "Canada", + 3, "Charlie Brown", 35, "UK", + 4, "David Wilson", 28, "Australia", + 5, "Emma Davis", 32, "USA", + 6, "Frank Miller", 27, "Canada", + 7, "Grace Taylor", 29, "UK", + 8, "Henry Clark", 33, "Australia", + 9, "Isabella Martinez", 26, "USA", + 10, "Jack Thompson", 31, "Canada" + ) + + orders <- tibble::tribble( + ~id, ~customer_id, ~order_date, ~total_amount, + 101, 1, as.Date("2024-01-15"), 250.00, + 102, 1, as.Date("2024-02-01"), 150.00, + 103, 2, as.Date("2024-02-10"), 125.00, + 104, 3, as.Date("2024-02-15"), 200.00, + 105, 4, as.Date("2024-02-20"), 175.00, + 106, 5, as.Date("2024-03-01"), 300.00, + 107, 6, as.Date("2024-03-05"), 50.00, + 108, 7, as.Date("2024-03-10"), 225.00, + 109, 8, as.Date("2024-03-12"), 100.00, + 110, 9, as.Date("2024-03-15"), 275.00, + 111, 10, as.Date("2024-03-18"), 125.00, + 112, 2, as.Date("2024-03-20"), 150.00 + ) + + order_items <- tibble::tribble( + ~id, ~order_id, ~product_id, ~quantity, ~unit_price, ~total_price, + 201, 101, 1, 2, 100.00, 200.00, + 202, 101, 2, 1, 50.00, 50.00, + 203, 102, 2, 3, 50.00, 150.00, + 204, 103, 2, 1, 50.00, 50.00, + 205, 103, 3, 1, 75.00, 75.00, + 206, 104, 1, 2, 100.00, 200.00, + 207, 105, 3, 2, 75.00, 150.00, + 208, 105, 2, 1, 50.00, 50.00, + 209, 106, 1, 3, 100.00, 300.00, + 210, 107, 2, 1, 50.00, 50.00, + 211, 108, 1, 1, 100.00, 100.00, + 212, 108, 3, 2, 75.00, 150.00, + 213, 109, 2, 2, 50.00, 100.00, + 214, 110, 1, 2, 100.00, 200.00, + 215, 110, 3, 1, 75.00, 75.00, + 216, 111, 2, 2, 50.00, 100.00, + 217, 111, 1, 1, 100.00, 100.00, + 218, 112, 3, 2, 75.00, 150.00 + ) + + order_files <- tibble::tribble( + ~id, ~order_id, ~file_name, ~file_type, + 301, 101, "invoice_101.pdf", "invoice", + 302, 102, "receipt_102.pdf", "receipt", + 303, 103, "invoice_103.pdf", "invoice", + 304, 104, "receipt_104.pdf", "receipt", + 305, 105, "invoice_105.pdf", "invoice", + 306, 106, "receipt_106.pdf", "receipt", + 307, 107, "invoice_107.pdf", "invoice", + 308, 108, "receipt_108.pdf", "receipt", + 309, 109, "invoice_109.pdf", "invoice", + 310, 110, "receipt_110.pdf", "receipt", + 311, 111, "invoice_111.pdf", "invoice", + 312, 112, "receipt_112.pdf", "receipt" + ) + + products <- tibble::tribble( + ~id, ~name, ~price, ~category, ~stock_quantity, + 401, "Laptop Pro", 100.00, "Electronics", 15, + 402, "Wireless Mouse", 50.00, "Electronics", 50, + 403, "Office Chair", 75.00, "Furniture", 8 + ) + + product_components <- tibble::tribble( + ~id, ~product_id, ~component_name, ~component_type, ~quantity_required, ~cost, + 501, 401, "CPU", "Processor", 1, 25.00, + 502, 401, "RAM", "Memory", 2, 15.00, + 503, 401, "SSD", "Storage", 1, 20.00, + 504, 401, "Screen", "Display", 1, 30.00, + 505, 402, "Optical Sensor", "Sensor", 1, 8.00, + 506, 402, "Wireless Module", "Connectivity", 1, 12.00, + 507, 402, "Battery", "Power", 1, 5.00, + 508, 403, "Steel Frame", "Structure", 1, 35.00, + 509, 403, "Cushion", "Comfort", 1, 20.00, + 510, 403, "Wheels", "Mobility", 5, 3.00 + ) +}) + +join_keys(data) <- join_keys( + join_key("customers", keys = "id"), + join_key("orders", keys = c("id")), + join_key("products", keys = c("id")), + join_key("product_components", keys = c("id")), + # foreign keys + join_key("customers", "orders", keys = c(id = "customer_id")), + join_key("products", "order_items", keys = c(id = "product_id")), + join_key("products", "product_components", keys = c(id = "product_id")), + join_key("orders", "order_items", keys = c(id = "order_id")) +) + +print(join_keys(data)) +``` + +Imagine now a scenario of a `ggplot` where one wants to select `x`, `y`, `color`, `facet_rows`, +`facet_cols`. Of course each input can come from different variables + +```{r, eval=FALSE} +ggplot( + data = ?, + aes( + x = !!sym(input$x), # orders.order_date + y = !!sym(input$y), # order_items.total_price + color = !!sym(input$color) # products.category + ) +) + + geom_line() + + facet_grid( + vars(!!sym(input$facet_rows)) # customers.country + ) +``` + +In order to create above visualization datasets need to be merged as `aes` is related to single +data object. Problem is solvable as `teal.data` has enough information to determine correct +merge call based and selected variables and `join_keys` (describing relationships between datasets). + +Using `dplyr` only we need to perform following merge operation given that following variables have +been selected: + +- x: `orders.order_date` +- y: `sum` of `order_items.order_items.total_price` +- color: `products.category` +- facet_rows: `customers.country` + +```{r} +data_w_merged <- within(data, { + library(dplyr) + anl <- select(orders, id, customer_id, order_date) |> + left_join(select(order_items, order_id, product_id, total_price), by = c(id = "order_id")) |> + left_join(select(products, id, category), by = c(product_id = "id")) |> + left_join(select(customers, id, country), by = c(customer_id = "id")) +}) +``` + +Now `anl` can produce desired visualization + +```{r} +# Create the visualization with merged data - sum moved to ggplot +data_w_plot <- within(data_w_merged, { + library(ggplot2) + + # Create ggplot with sum calculation inside + plot <- ggplot( + data = anl, + aes( + x = order_date, + y = total_price, + color = category + ) + ) + + geom_line() + + facet_grid( + rows = vars(country), + labeller = label_both + ) + + print(plot) +}) + +get_outputs(data_w_plot)[[1]] +``` + + +# Handling ambiguous variables + diff --git a/man/dot-is_tidyselect.Rd b/man/dot-is_tidyselect.Rd new file mode 100644 index 00000000..51e1c004 --- /dev/null +++ b/man/dot-is_tidyselect.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/0-types.R +\name{.is_tidyselect} +\alias{.is_tidyselect} +\title{Is an object created using tidyselect} +\usage{ +.is_tidyselect(x) +} +\arguments{ +\item{x}{\code{choices} or \code{selected}} +} +\value{ +\code{logical(1)} +} +\description{ +\code{choices} and \code{selected} can be provided using \code{tidyselect}, (e.g. \code{\link[tidyselect:everything]{tidyselect::everything()}} +\code{\link[tidyselect:match]{tidyselect::match()}}, \code{\link[tidyselect:starts_with]{tidyselect::starts_with()}}). These functions can't be called +independently but rather as an argument of function which consumes them. +\code{.is_tidyselect} safely determines if \code{x} can be evaluated with \code{tidyselect::eval_select()} +} diff --git a/man/merge_expr.Rd b/man/merge_expr.Rd new file mode 100644 index 00000000..9d4e92e8 --- /dev/null +++ b/man/merge_expr.Rd @@ -0,0 +1,26 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/0-merge.R +\name{merge_expr} +\alias{merge_expr} +\title{Merge expression for selectors} +\usage{ +merge_expr( + selectors, + output_name = "merged", + join_fun = "dplyr::left_join", + join_keys, + allow_cartesian = FALSE +) +} +\arguments{ +\item{selectors}{(\code{list} of \code{specification})} + +\item{output_name}{(\code{character(1)})} + +\item{join_fun}{(\code{character(1)}) name of the merge function.} + +\item{join_keys}{(\code{join_keys})} +} +\description{ +Merge expression for selectors +} diff --git a/man/restoreValue.Rd b/man/restoreValue.Rd new file mode 100644 index 00000000..36fe9751 --- /dev/null +++ b/man/restoreValue.Rd @@ -0,0 +1,33 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/0-module_input.R +\name{restoreValue} +\alias{restoreValue} +\title{Restore value from bookmark.} +\usage{ +restoreValue(value, default) +} +\arguments{ +\item{value}{(\code{character(1)}) name of value to restore} + +\item{default}{fallback value} +} +\value{ +In an application restored from a server-side bookmark, +the variable specified by \code{value} from the \code{values} environment. +Otherwise \code{default}. +} +\description{ +Get value from bookmark or return default. +} +\details{ +Bookmarks can store not only inputs but also arbitrary values. +These values are stored by \code{onBookmark} callbacks and restored by \code{onBookmarked} callbacks, +and they are placed in the \code{values} environment in the \code{session$restoreContext} field. +Using \code{teal_data_module} makes it impossible to run the callbacks +because the app becomes ready before modules execute and callbacks are registered. +In those cases the stored values can still be recovered from the \code{session} object directly. + +Note that variable names in the \code{values} environment are prefixed with module name space names, +therefore, when using this function in modules, \code{value} must be run through the name space function. +} +\keyword{internal} diff --git a/man/tm_merge.Rd b/man/tm_merge.Rd new file mode 100644 index 00000000..98e021a4 --- /dev/null +++ b/man/tm_merge.Rd @@ -0,0 +1,11 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/0-module_merge.R +\name{tm_merge} +\alias{tm_merge} +\title{Merge module} +\usage{ +tm_merge(label = "merge-module", inputs) +} +\description{ +Example module +} diff --git a/man/types.Rd b/man/types.Rd index 8e1c0850..11e1653d 100644 --- a/man/types.Rd +++ b/man/types.Rd @@ -2,19 +2,22 @@ % Please edit documentation in R/0-types.R \name{Types} \alias{Types} +\alias{spec} \alias{datasets} \alias{variables} \alias{mae_colData} \alias{values} \title{Type specification} \usage{ +spec(...) + datasets(choices = tidyselect::everything(), selected = 1) -variables(choices = tidyselect::everything(), selected = 1) +variables(choices = tidyselect::everything(), selected = 1, multiple = FALSE) -mae_colData(choices = tidyselect::everything(), selected = 1) +mae_colData(choices = tidyselect::everything(), selected = 1, multiple = FALSE) -values(choices = tidyselect::everything(), selected = 1) +values(choices = tidyselect::everything(), selected = 1, multiple = FALSE) } \arguments{ \item{choices}{<\code{\link[dplyr:dplyr_tidy_select]{tidy-select}}> One unquoted expression to be used to pick the choices.} @@ -29,6 +32,8 @@ Define how to select and extract data } \section{Functions}{ \itemize{ +\item \code{spec()}: specify a selector. + \item \code{datasets()}: Specify datasets. \item \code{variables()}: Specify variables. diff --git a/tests/testthat/test-merge_expr.R b/tests/testthat/test-merge_expr.R new file mode 100644 index 00000000..2e342ecd --- /dev/null +++ b/tests/testthat/test-merge_expr.R @@ -0,0 +1,15 @@ +testthat::test_that("merge_expr", { + jk <- teal.data::join_keys() + merge_expr( + selectors = list( + x = spec( + datasets(choices = "test", selected = "test"), + variables(choices = letters, selected = letters) + ) + ), + output_name = "elo", + join_fun = "foo", + join_keys = jk, + TRUE + ) +}) From 1ba7cd3f747cd81b7cdc94db9a49be45da4f8815 Mon Sep 17 00:00:00 2001 From: github-actions <41898282+github-actions[bot]@users.noreply.github.com> Date: Mon, 25 Aug 2025 17:40:16 +0000 Subject: [PATCH 113/142] [skip roxygen] [skip vbump] Roxygen Man Pages Auto Update --- man/dot-merge_summary_list.Rd | 20 ++++++++++++++++++++ 1 file changed, 20 insertions(+) create mode 100644 man/dot-merge_summary_list.Rd diff --git a/man/dot-merge_summary_list.Rd b/man/dot-merge_summary_list.Rd new file mode 100644 index 00000000..7dba0256 --- /dev/null +++ b/man/dot-merge_summary_list.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/0-merge.R +\name{.merge_summary_list} +\alias{.merge_summary_list} +\title{Analyse selectors and guess merge consequences} +\usage{ +.merge_summary_list(selectors, join_keys) +} +\value{ +list containing: +\itemize{ +\item mapping (\verb{named list}) containing selected values in each selector. This \code{mapping} +is sorted according to correct datasets merge order. +\item join_keys (\code{join_keys}) updated \code{join_keys} containing keys of \code{ANL} +} +} +\description{ +Analyse selectors and guess merge consequences +} +\keyword{internal} From 8342b1ed40614a705ea0c99c2ccc308348b9e7d1 Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Tue, 26 Aug 2025 08:54:59 +0200 Subject: [PATCH 114/142] - selectInput to pickerInput - use labels in input when possible --- R/0-module_input.R | 38 +++++++++++++++++++++++++++++++------- R/0-resolver.R | 7 ++++++- 2 files changed, 37 insertions(+), 8 deletions(-) diff --git a/R/0-module_input.R b/R/0-module_input.R index 198a5e06..da3d03ab 100644 --- a/R/0-module_input.R +++ b/R/0-module_input.R @@ -40,7 +40,7 @@ module_input_srv <- function(id = "", spec, data) { #' @export module_input_srv.list <- function(id, spec, data) { sapply( - Filter(length, names(spec)), + names(Filter(length, spec)), USE.NAMES = TRUE, function(name) module_input_srv(name, spec[[name]], data) ) @@ -137,12 +137,20 @@ module_input_srv.specification <- function(id, spec, data) { .selected_choices_ui <- function(id, x) { ns <- shiny::NS(id) - shiny::selectInput( + shinyWidgets::pickerInput( inputId = ns("selected"), label = paste("Select", is(x), collapse = " "), - choices = if (!is.delayed(x$choices)) x$choices, - selected = if (!is.delayed(x$selected)) x$selected, - multiple = isTRUE(attr(x, "multiple")) + choices = if (is.character(x$choices)) x$choices, + selected = if (is.character(x$selected)) x$selected, + multiple = isTRUE(attr(x, "multiple")), + choicesOpt = if (is.character(x$choices)) list(content = toupper(x$choices)), + options = list( + "actions-box" = isTRUE(attr(x, "multiple")), + "none-selected-text" = "- Nothing selected -", + "allow-clear" = !isTRUE(attr(x, "multiple")), + "max-options" = ifelse(isTRUE(attr(x, "multiple")), Inf, 1), + "show-subtext" = TRUE + ) ) } @@ -157,10 +165,26 @@ module_input_srv.specification <- function(id, spec, data) { shinyjs::hide("selected") } - shiny::updateSelectInput( + + # todo: add to the input choice icon = attached to choices when determine + content <- ifelse( + names(x()$choices) == unname(x()$choices), + sprintf("%s", x()$choices), + sprintf( + '%s %s', + unname(x()$choices), + names(x()$choices) + ) + ) + + shinyWidgets::updatePickerInput( inputId = "selected", choices = x()$choices, - selected = x()$selected + selected = x()$selected, + choicesOpt = list(content = content), + options = list( + "live-search" = ifelse(length(x()$choices) > 10, TRUE, FALSE) + ) ) }) selected <- shiny::reactiveVal() diff --git a/R/0-resolver.R b/R/0-resolver.R index eb74b6b1..3a91b134 100644 --- a/R/0-resolver.R +++ b/R/0-resolver.R @@ -165,7 +165,12 @@ determine.type <- function(x, data) { .determine_choices <- function(x, data) { if (is.delayed(x)) { new_choices <- unique(names(.eval_select(data, x$choices))) - x$choices <- new_choices + labels <- vapply( + new_choices, + FUN = function(choice) c(attr(data[[choice]], "label"), choice)[1], + FUN.VALUE = character(1) + ) + x$choices <- setNames(new_choices, labels) } x } From afb59bc6d963b9a5f81e98cd4c638b003cd43227 Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Wed, 27 Aug 2025 15:22:10 +0200 Subject: [PATCH 115/142] adding selector helpers --- NAMESPACE | 12 +- R/0-delayed.R | 7 ++ R/0-extract.R | 80 ------------ R/0-merge.R | 3 +- R/0-module_input.R | 37 +++--- R/0-resolver.R | 190 +++++++++++++---------------- R/0-simple-selectors.R | 60 +++++++++ R/0-types.R | 5 +- man/determine.Rd | 2 +- man/{extract.Rd => dot-extract.Rd} | 12 +- man/resolver.Rd | 6 +- man/tidyselectors.Rd | 30 +++++ 12 files changed, 221 insertions(+), 223 deletions(-) delete mode 100644 R/0-extract.R create mode 100644 R/0-simple-selectors.R rename man/{extract.Rd => dot-extract.Rd} (76%) create mode 100644 man/tidyselectors.Rd diff --git a/NAMESPACE b/NAMESPACE index a9b3d6bd..ad3c076c 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,5 +1,7 @@ # Generated by roxygen2: do not edit by hand +S3method(.extract,default) +S3method(.extract,teal_data) S3method(anyNA,type) S3method(data_extract_multiple_srv,FilteredData) S3method(data_extract_multiple_srv,list) @@ -9,12 +11,7 @@ S3method(data_extract_srv,list) S3method(determine,colData) S3method(determine,datasets) S3method(determine,default) -S3method(determine,specification) -S3method(determine,type) -S3method(determine,values) S3method(determine,variables) -S3method(extract,default) -S3method(extract,teal_data) S3method(filter_spec_internal,default) S3method(filter_spec_internal,delayed_data) S3method(is.delayed,default) @@ -67,8 +64,6 @@ export(data_extract_srv) export(data_extract_ui) export(datanames_input) export(datasets) -export(determine) -export(extract) export(filter_spec) export(first_choice) export(first_choices) @@ -80,6 +75,8 @@ export(get_merge_call) export(get_relabel_call) export(is.choices_selected) export(is.delayed) +export(is_categorical) +export(is_key) export(is_single_dataset) export(last_choice) export(last_choices) @@ -91,6 +88,7 @@ export(merge_expression_module) export(merge_expression_srv) export(module_input_srv) export(module_input_ui) +export(no_more_choices_than) export(no_selected_as_NULL) export(qenv_merge_selectors) export(resolve_delayed) diff --git a/R/0-delayed.R b/R/0-delayed.R index b4909a20..cb92dd25 100644 --- a/R/0-delayed.R +++ b/R/0-delayed.R @@ -12,6 +12,13 @@ is.delayed <- function(x) { UseMethod("is.delayed") } +#' @export +#' @method is.delayed default +is.delayed.character <- function(x) { + # FIXME: A warning? + FALSE +} + #' @export #' @method is.delayed default is.delayed.default <- function(x) { diff --git a/R/0-extract.R b/R/0-extract.R deleted file mode 100644 index 6279ec6f..00000000 --- a/R/0-extract.R +++ /dev/null @@ -1,80 +0,0 @@ -#' Internal method to extract data from different objects -#' -#' Required to resolve a specification into something usable (by comparing with the existing data). -#' Required by merging data based on a resolved specification. -#' @param x Object from which a subset/element is required. -#' @param variable Name of the element to be extracted. -#' @param ... Other arguments passed to the specific method. -#' @export -#' @examples -#' extract(iris, "Sepal.Length") -extract <- function(x, variable, ...) { - UseMethod("extract") -} - - -#' @export -extract.default <- function(x, variable, ..., drop = FALSE) { - if (length(dim(x)) == 2L || length(variable) > 1L) { - x[, variable, drop = drop] - } else { - x[[variable]] - } -} - -#' @export -extract.teal_data <- function(x, variable, ...) { - if (length(variable) > 1L) { - x[variable] - } else { - x[[variable]] - } -} - -# @export -# @method extract data.frame -# extract.data.frame <- function(x, variable) { -# # length(variable) == 1L -# x[, variable, drop = TRUE] -# } - -# @export -# extract.qenv <- function(x, variable) { -# x[[variable]] -# } - -# Get code to be evaluated & displayed by modules -extract_srv <- function(id, input, data) { - stopifnot(is.null(input$datasets)) - stopifnot(is.null(input$variables)) - moduleServer( - id, - function(input, output, session) { - obj <- extract(data, input$datasets) - method <- paste0("extract.", class(obj)) - method <- dynGet(method, ifnotfound = "extract.default", inherits = TRUE) - if (identical(method, "extract.default")) { - b <- get("extract.default") - } else { - b <- get(method) - } - # Extract definition - extract_f_def <- call("<-", x = as.name("extract"), value = b) - q <- teal.code::eval_code(data, code = extract_f_def) - - # Extraction happening: - # FIXME assumes only to variables used - output <- call("<-", - x = as.name(input$datasets), value = - substitute( - extract(obj, variables), - list( - obj = as.name(input$datasets), - variables = input$variables - ) - ) - ) - q <- teal.code::eval_code(q, code = output) - } - ) -} diff --git a/R/0-merge.R b/R/0-merge.R index 9ffe63b5..e6e1ab34 100644 --- a/R/0-merge.R +++ b/R/0-merge.R @@ -135,6 +135,7 @@ map_merged <- function(selectors, join_keys) { init = teal.data::join_keys() ) } + mapping <- lapply( # what has been selected in each selector selectors, function(x) { @@ -155,7 +156,7 @@ map_merged <- function(selectors, join_keys) { ) # mapping will be reused so needs to be reordered as well - mapping <- mapping[rank(match(mapped_datanames, datanames))] + mapping <- mapping[order(match(mapped_datanames, datanames))] } remaining_datanames <- datanames join_keys <- join_keys[datanames] diff --git a/R/0-module_input.R b/R/0-module_input.R index da3d03ab..0e28440c 100644 --- a/R/0-module_input.R +++ b/R/0-module_input.R @@ -52,7 +52,6 @@ module_input_srv.specification <- function(id, spec, data) { attr(spec, ".callback") <- reactiveVal(NULL) # callback to be used outside data_r <- shiny::reactive(if (shiny::is.reactive(data)) data() else data) - # todo: bookmarking (decide whether it should be built on reactiveVal or setting inputs) spec_resolved <- shiny::reactiveVal( restoreValue( session$ns("selectors"), @@ -106,6 +105,7 @@ module_input_srv.specification <- function(id, spec, data) { shiny::observeEvent( selected(), ignoreInit = TRUE, # because spec_resolved is a initial state + ignoreNULL = FALSE, { logger::log_info("module_input_server@1 selected has changed. Resolving downstream...") new_spec_unresolved <- spec @@ -113,7 +113,7 @@ module_input_srv.specification <- function(id, spec, data) { new_spec_unresolved[seq_len(i)] <- spec_resolved()[seq_len(i)] new_spec_unresolved[[slot_name]]$selected <- selected() - resolver_warnings <- character() + resolver_warnings <- character(0) new_spec_resolved <- withCallingHandlers( resolver(new_spec_unresolved, data_r()), warning = function(w) { @@ -165,23 +165,22 @@ module_input_srv.specification <- function(id, spec, data) { shinyjs::hide("selected") } - - # todo: add to the input choice icon = attached to choices when determine - content <- ifelse( - names(x()$choices) == unname(x()$choices), - sprintf("%s", x()$choices), - sprintf( - '%s %s', - unname(x()$choices), - names(x()$choices) - ) - ) - shinyWidgets::updatePickerInput( inputId = "selected", choices = x()$choices, selected = x()$selected, - choicesOpt = list(content = content), + choicesOpt = list( + content = ifelse( + # todo: add to the input choice icon = attached to choices when determine + names(x()$choices) == unname(x()$choices), + sprintf("%s", x()$choices), + sprintf( + '%s %s', + unname(x()$choices), + names(x()$choices) + ) + ) + ), options = list( "live-search" = ifelse(length(x()$choices) > 10, TRUE, FALSE) ) @@ -189,10 +188,12 @@ module_input_srv.specification <- function(id, spec, data) { }) selected <- shiny::reactiveVal() # todo: if only one choice then replace with the text only - shiny::observeEvent(input$selected, { - if (!identical(input$selected, selected)) { + shiny::observeEvent(input$selected, ignoreNULL = FALSE, { + # ↓ pickerInput returns "" when nothing selected. This can cause failure during col select (x[,""]) + new_selected <- if (length(input$selected) && !identical(input$selected, "")) input$selected + if (!identical(new_selected, selected())) { logger::log_debug(".selected_choices_srv@2 input$selected has changed.") - selected(input$selected) + selected(new_selected) } }) selected diff --git a/R/0-resolver.R b/R/0-resolver.R index 3a91b134..23fcee27 100644 --- a/R/0-resolver.R +++ b/R/0-resolver.R @@ -22,25 +22,23 @@ #' resolver(spec, td) #' spec <- c(dataset1, variables("a", where(is.character))) #' resolver(spec, td) -resolver <- function(spec, data) { +resolver <- function(x, data) { checkmate::assert_environment(data) - if (!is.delayed(spec)) { - return(spec) - } - - stopifnot(is.list(spec) || .is.specification(spec)) - if (.is.type(spec)) { - spec <- list(spec) - names(spec) <- is(spec[[1]]) - class(spec) <- c("specification", class(spec)) - } - - det <- determine(spec, data) - if (is.null(names(det))) { - return(lapply(det, `[[`, 1)) - } else { - det$x + if (is.delayed(x)) { + data_i <- data + join_keys_i <- teal.data::join_keys(data) + for (i in seq_along(x)) { + determined_i <- determine(x[[i]], data = data_i, join_keys = join_keys_i) + # overwrite so that next x in line receives the corresponding data and specification + if (is.null(determined_i$x)) { + next + } + x[[i]] <- determined_i$x + data_i <- determined_i$data + join_keys_i <- determined_i$join_keys + } } + x } #' A method that should take a type and resolve it. @@ -51,22 +49,17 @@ resolver <- function(spec, data) { #' @param data The minimal data required. #' @return A list with two elements, the `type` resolved and the data extracted. #' @keywords internal -#' @export -determine <- function(x, data, ...) { - stopifnot(.is.type(x) || is.list(x) || .is.specification(x)) - if (!is.delayed(x)) { - return(list(x = x, data = extract(data, x$selected))) - } +determine <- function(x, data, join_keys, ...) { UseMethod("determine") } #' @export -determine.default <- function(x, data, ...) { +determine.default <- function(x, data, join_keys, ...) { stop("There is not a specific method to pick choices.") } #' @export -determine.colData <- function(x, data, ...) { +determine.colData <- function(x, data, join_keys, ...) { if (!requireNamespace("SummarizedExperiment", quietly = TRUE)) { stop("Requires SummarizedExperiment package from Bioconductor.") } @@ -75,70 +68,30 @@ determine.colData <- function(x, data, ...) { } #' @export -determine.datasets <- function(x, data, ...) { +determine.datasets <- function(x, data, join_keys, ...) { + checkmate::assert_environment(data) + checkmate::assert_class(join_keys, "join_keys") if (is.null(data)) { return(list(x = x, data = NULL)) } else if (!inherits(data, "qenv")) { stop("Please use qenv() or teal_data() objects.") } - # Assumes the object has colnames method (true for major object classes: DataFrame, tibble, Matrix, array) - # FIXME: What happens if colnames is null: colnames(array(dim = c(4, 2))) - NextMethod("determine", x) -} - -#' @export -determine.specification <- function(x, data, ...) { - checkmate::assert_class(data, "qenv") - - # Adding some default specifications if they are missing - if ("values" %in% names(x) && !"variables" %in% names(x)) { - x <- append(x, list(variables = variables()), length(x) - 1) - } - if ("variables" %in% names(x) && !"datasets" %in% names(x)) { - x <- append(x, list(variables = datasets()), length(x) - 1) - } + x <- .determine_choices(x, data) + x <- .determine_selected(x, data) - data_i <- data - for (i in seq_along(x)) { - determined_i <- determine(x[[i]], data_i) - # overwrite so that next x in line receives the corresponding data and specification - if (is.null(determined_i$x)) { - next - } - x[[i]] <- determined_i$x - data_i <- determined_i$data + if (length(x$selected) != 1) { + warning("`dataset` must be a single selection. Forcing to first possible choice.") + x$selected <- x$choices[1] } - - list(x = x, data = data) + list(x = x, data = data[[x$selected]], join_keys = join_keys[[x$selected]]) } #' @export -determine.values <- function(x, data, ...) { - if (!is.numeric(data)) { - d <- data - names(d) <- data - } else { - d <- data - } - - # todo: replace with NextMethod? - sel <- .eval_select(d, x$choices) - x$choices <- data[sel] - - sel2 <- .eval_select(d[sel], x$selected) - x$selected <- data[sel][sel2] - - # Not possible to know what is happening - if (is.delayed(x)) { - return(list(x = x, data = NULL)) - } +determine.variables <- function(x, data, join_keys, ...) { + checkmate::assert_multi_class(data, c("data.frame", "tbl_df", "data.table", "DataFrame")) + checkmate::assert_list(join_keys) - list(x = x, data = data[sel]) -} - -#' @export -determine.variables <- function(x, data, ...) { if (is.null(data)) { return(list(x = x, data = NULL)) } else if (length(dim(data)) != 2L) { @@ -152,44 +105,77 @@ determine.variables <- function(x, data, ...) { stop("Can't pull variable: No variable is available.") } - NextMethod("determine", x) -} + # ↓ see ?tidyselectors + for (join_keys_i in join_keys) { + for (key_column in names(join_keys_i)) { + attr(data[[key_column]], "join_key") <- TRUE + } + } -#' @export -determine.type <- function(x, data) { x <- .determine_choices(x, data) x <- .determine_selected(x, data) - list(x = x, data = extract(data, x$selected)) + + list(x = x, data = data[x$selected], join_keys = join_keys) } .determine_choices <- function(x, data) { - if (is.delayed(x)) { - new_choices <- unique(names(.eval_select(data, x$choices))) - labels <- vapply( - new_choices, - FUN = function(choice) c(attr(data[[choice]], "label"), choice)[1], - FUN.VALUE = character(1) - ) - x$choices <- setNames(new_choices, labels) - } + choices <- if (is.character(x$choices)) { + x$choices + } else { + idx <- .eval_select(data, x$choices) + unique(names(data)[idx]) + } + labels <- vapply( + choices, + FUN = function(choice) c(attr(data[[choice]], "label"), choice)[1], + FUN.VALUE = character(1) + ) + x$choices <- setNames(choices, labels) x } .determine_selected <- function(x, data) { - checkmate::assert_character(x$choices) - if (!is(data, "qenv")) { - data <- extract(data, x$choices) - } else { - # Do not extract; selection would be from the data extracted not from the names. + if (!is.null(x$selected) && length(x$choices)) { data <- data[x$choices] + res <- try(unique(names(.eval_select(data, x$selected))), silent = TRUE) + if (inherits(res, "try-error")) { + warning("`selected` outside of possible `choices`. Emptying `selecting` field.", call. = FALSE) + x$selected <- NULL + } else { + x$selected <- res + } } - res <- try(unique(names(.eval_select(data, x$selected))), silent = TRUE) - if (inherits(res, "try-error")) { - warning("`selected` outside of possible `choices`. Emptying `selecting` field.", call. = FALSE) - x$selected <- NULL + x +} + + +#' Internal method to extract data from different objects +#' +#' Required to resolve a specification into something usable (by comparing with the existing data). +#' Required by merging data based on a resolved specification. +#' @param x Object from which a subset/element is required. +#' @param variable Name of the element to be extracted. +#' @param ... Other arguments passed to the specific method. +#' @keywords internal +.extract <- function(x, variable, ...) { + UseMethod(".extract") +} + + +#' @export +.extract.default <- function(x, variable, ..., drop = FALSE) { + if (length(dim(x)) == 2L || length(variable) > 1L) { + x[, variable, drop = drop] } else { - x$selected <- res + x[[variable]] } +} - x +#' @export +.extract.teal_data <- function(x, variable, ...) { + if (length(variable) > 1L) { + x[variable] + } else { + x[variable] + } } diff --git a/R/0-simple-selectors.R b/R/0-simple-selectors.R new file mode 100644 index 00000000..2921ab22 --- /dev/null +++ b/R/0-simple-selectors.R @@ -0,0 +1,60 @@ +#' `tidyselect` helpers +#' +#' +#' @examples +#' # select keys (primary and foreign) +#' variables(choices = is_key()) +#' +#' # select factor column but exclude foreign keys +#' variables(choices = where(~ is.factor(.x) & !is_foreign_key())) +#' @name tidyselectors + +# developer notes: +# in determine join_keys are handed over and in determine.variables attributes are assigned to +# the data columns. It is internally controlled process and it is designed like this because: +# - tidyselect functions don't accept arguments from outside so we can't add join_keys of selected dataset +# during eval_select. +# - having predicates to be utilized by `tidyselect::where` is `tidyselect` compatible and more predictable + + +#' @rdname tidyselectors +#' @export +is_key <- function() { + where(function(x) isTRUE(attr(x, "join_key"))) +} + +#' @rdname tidyselectors +#' @param min.len (`integer(1)`) minimal number of unique values +#' @param max.len (`integer(1)`) maximal number of unique values +#' @export +is_categorical <- function(max.len, min.len) { + # todo: consider making a function which can exit earlier when max.len > length(unique(x)) < min.len + # without a need to compute unique on the whole vector. + if (missing(max.len) && missing(min.len)) { + where(function(x) is.factor(x) || is.character(x)) + } else if (!missing(max.len) && missing(min.len)) { + checkmate::assert_int(max.len, lower = 0) + where(function(x) (is.factor(x) || is.character(x)) && length(unique(x)) <= max.len) + } else if (!missing(min.len) && missing(max.len)) { + checkmate::assert_int(min.len, lower = 0) + where(function(x) (is.factor(x) || is.character(x)) && length(unique(x)) >= min.len) + } else { + checkmate::assert_int(min.len, lower = 0) + checkmate::assert_int(max.len, lower = 0) + checkmate::assert_true(max.len >= min.len) + where(function(x) { + (is.factor(x) || is.character(x)) && { + n <- length(unique(x)) + n >= min.len && n <= max.len + } + }) + } +} + +#' @rdname tidyselectors +#' @export +no_more_choices_than <- function(max.len) { + # todo: consider making a function which can exit earlier when max.len > length(unique(x)) < min.len + # without a need to compute unique on the whole vector. + where(function(x) length(unique(x)) <= max.len) +} diff --git a/R/0-types.R b/R/0-types.R index c70e2f1a..143e2412 100644 --- a/R/0-types.R +++ b/R/0-types.R @@ -181,8 +181,5 @@ print.type <- function(x, ...) { #' @internal .is_tidyselect <- function(x) { out <- tryCatch(x, error = function(e) e) - inherits(out, "error") && # because tidyselect calls return error if not used in select - grepl("must be used within a \\*selecting\\* function", paste(out$message, collapse = "\n")) || - checkmate::test_function(out, args = "x") || # because tidyselect::where(foo) returns a function(x, ...) - checkmate::test_integerish(out) # integer is not a column/dataset name + !is.character(out) } diff --git a/man/determine.Rd b/man/determine.Rd index 97f71e1e..9a0aa23a 100644 --- a/man/determine.Rd +++ b/man/determine.Rd @@ -4,7 +4,7 @@ \alias{determine} \title{A method that should take a type and resolve it.} \usage{ -determine(x, data, ...) +determine(x, data, join_keys, ...) } \arguments{ \item{x}{The specification to resolve.} diff --git a/man/extract.Rd b/man/dot-extract.Rd similarity index 76% rename from man/extract.Rd rename to man/dot-extract.Rd index 1fba35d0..12fafe73 100644 --- a/man/extract.Rd +++ b/man/dot-extract.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/0-extract.R -\name{extract} -\alias{extract} +% Please edit documentation in R/0-resolver.R +\name{.extract} +\alias{.extract} \title{Internal method to extract data from different objects} \usage{ -extract(x, variable, ...) +.extract(x, variable, ...) } \arguments{ \item{x}{Object from which a subset/element is required.} @@ -17,6 +17,4 @@ extract(x, variable, ...) Required to resolve a specification into something usable (by comparing with the existing data). Required by merging data based on a resolved specification. } -\examples{ -extract(iris, "Sepal.Length") -} +\keyword{internal} diff --git a/man/resolver.Rd b/man/resolver.Rd index 61702932..e16a08b3 100644 --- a/man/resolver.Rd +++ b/man/resolver.Rd @@ -4,12 +4,12 @@ \alias{resolver} \title{Resolve the specification} \usage{ -resolver(spec, data) +resolver(x, data) } \arguments{ -\item{spec}{A object extraction specification.} - \item{data}{The qenv where the specification is evaluated.} + +\item{spec}{A object extraction specification.} } \value{ A specification but resolved: the names and selection is the name of the objects (if possible). diff --git a/man/tidyselectors.Rd b/man/tidyselectors.Rd new file mode 100644 index 00000000..0ed33feb --- /dev/null +++ b/man/tidyselectors.Rd @@ -0,0 +1,30 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/0-simple-selectors.R +\name{tidyselectors} +\alias{tidyselectors} +\alias{is_key} +\alias{is_categorical} +\alias{no_more_choices_than} +\title{\code{tidyselect} helpers} +\usage{ +is_key() + +is_categorical(max.len, min.len) + +no_more_choices_than(max.len) +} +\arguments{ +\item{max.len}{(\code{integer(1)}) maximal number of unique values} + +\item{min.len}{(\code{integer(1)}) minimal number of unique values} +} +\description{ +\code{tidyselect} helpers +} +\examples{ +# select keys (primary and foreign) +variables(choices = is_key()) + +# select factor column but exclude foreign keys +variables(choices = where(~ is.factor(.x) & !is_foreign_key())) +} From d209b138f65d897105e5b1bebb84010ecb8fe1de Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Fri, 29 Aug 2025 10:12:13 +0200 Subject: [PATCH 116/142] `spec` to `picks` --- NAMESPACE | 9 +- R/0-delayed.R | 4 +- R/0-merge.R | 6 +- R/0-merge_dataframes.R | 230 ------------------ R/0-module_input.R | 18 +- R/0-module_merge.R | 5 +- R/0-resolver.R | 35 ++- R/0-teal.transform_wrappers.R | 34 +++ ...ple-selectors.R => 0-tidyselect-helpers.R} | 0 R/0-types.R | 150 +++++++----- man/merge_expr.Rd | 2 +- man/tidyselectors.Rd | 2 +- man/types.Rd | 42 +++- 13 files changed, 200 insertions(+), 337 deletions(-) delete mode 100644 R/0-merge_dataframes.R create mode 100644 R/0-teal.transform_wrappers.R rename R/{0-simple-selectors.R => 0-tidyselect-helpers.R} (100%) diff --git a/NAMESPACE b/NAMESPACE index ad3c076c..8350b3bc 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -16,7 +16,7 @@ S3method(filter_spec_internal,default) S3method(filter_spec_internal,delayed_data) S3method(is.delayed,default) S3method(is.delayed,list) -S3method(is.delayed,specification) +S3method(is.delayed,picks) S3method(is.delayed,type) S3method(is.na,type) S3method(merge_expression_module,list) @@ -24,9 +24,9 @@ S3method(merge_expression_module,reactive) S3method(merge_expression_srv,list) S3method(merge_expression_srv,reactive) S3method(module_input_srv,list) -S3method(module_input_srv,specification) +S3method(module_input_srv,picks) S3method(module_input_ui,list) -S3method(module_input_ui,specification) +S3method(module_input_ui,picks) S3method(print,choices_labeled) S3method(print,delayed_choices_selected) S3method(print,delayed_data_extract_spec) @@ -62,6 +62,7 @@ export(data_extract_multiple_srv) export(data_extract_spec) export(data_extract_srv) export(data_extract_ui) +export(datanames) export(datanames_input) export(datasets) export(filter_spec) @@ -90,13 +91,13 @@ export(module_input_srv) export(module_input_ui) export(no_more_choices_than) export(no_selected_as_NULL) +export(picks) export(qenv_merge_selectors) export(resolve_delayed) export(resolver) export(select_spec) export(select_spec.default) export(select_spec.delayed_data) -export(spec) export(split_by_sep) export(value_choices) export(values) diff --git a/R/0-delayed.R b/R/0-delayed.R index cb92dd25..849aef0b 100644 --- a/R/0-delayed.R +++ b/R/0-delayed.R @@ -34,8 +34,8 @@ is.delayed.list <- function(x) { } #' @export -#' @method is.delayed specification -is.delayed.specification <- function(x) { +#' @method is.delayed picks +is.delayed.picks <- function(x) { any(vapply(x, is.delayed, logical(1L))) } diff --git a/R/0-merge.R b/R/0-merge.R index e6e1ab34..123fbc78 100644 --- a/R/0-merge.R +++ b/R/0-merge.R @@ -1,5 +1,5 @@ #' Merge expression for selectors -#' @param selectors (`list` of `specification`) +#' @param selectors (`list` of `picks`) #' @param output_name (`character(1)`) #' @param join_fun (`character(1)`) name of the merge function. #' @param join_keys (`join_keys`) @@ -9,7 +9,7 @@ merge_expr <- function(selectors, join_fun = "dplyr::left_join", join_keys, allow_cartesian = FALSE) { - checkmate::assert_list(selectors, c("specification", "reactive")) + checkmate::assert_list(selectors, c("picks", "reactive")) checkmate::assert_string(output_name) checkmate::assert_string(join_fun) checkmate::assert_class(join_keys, "join_keys") @@ -127,7 +127,7 @@ map_merged <- function(selectors, join_keys) { #' #' @keywords internal .merge_summary_list <- function(selectors, join_keys) { - checkmate::assert_list(selectors, c("reactive", "specification")) + checkmate::assert_list(selectors, c("picks", "reactive")) if (missing(join_keys)) { join_keys <- Reduce( function(all, this) c(all, attr(this, "join_keys")), diff --git a/R/0-merge_dataframes.R b/R/0-merge_dataframes.R deleted file mode 100644 index f64870f9..00000000 --- a/R/0-merge_dataframes.R +++ /dev/null @@ -1,230 +0,0 @@ -# Simplify multiple datasets & variables into the bare minimum necessary. -# This simplifies the number of extractions and merging required -consolidate_extraction <- function(...) { - if (...length() > 1) { - input_resolved <- list(...) - } else { - input_resolved <- ..1 - } - - # Assume the data is a data.frame so no other specifications types are present. - datasets <- lapply(input_resolved, function(x) { - x$datasets - }) - variables <- lapply(input_resolved, function(x) { - x$variables - }) - lapply(unique(datasets), - function(dataset, x, y) { - list( - "datasets" = dataset, - "variables" = unique(unlist(y[x == dataset])) - ) - }, - x = datasets, y = variables - ) -} - -# Function to add ids of data.frames to the output of modules to enable merging them. -add_ids <- function(input, data) { - jk <- teal.data::join_keys(data) - # If no join keys they should be on the input - if (!length(jk)) { - return(input) - } - - datasets <- lapply(input, function(x) { - x$datasets - }) - for (i in seq_along(input)) { - x <- input[[i]] - # Avoid adding as id something already present: No duplicating input. - ids <- setdiff(unique(unlist(jk[[x$datasets]])), x$variables) - input[[i]][["variables"]] <- c(x$variables, ids) - } - input -} - -# Find common ids to enable merging. -extract_ids <- function(input, data) { - jk <- teal.data::join_keys(data) - # No join_keys => input - if (!length(jk)) { - input <- unlist(input) - tab <- table(input) - out <- names(tab)[tab > 1] - - if (!length(out)) { - return(NULL) - } - return(out) - } - - l <- lapply(datasets, function(x, join_keys) { - unique(unlist(jk[[x]])) - }, join_keys = jk) - out <- unique(unlist(l)) -} - -merge_call_pair <- function(input_res, by, data, - merge_function = "dplyr::full_join") { - selections <- consolidate_extraction(input_res) - stopifnot(length(selections) == 2L) - datasets <- unique(unlist(lapply(selections, `[[`, "datasets"), FALSE, FALSE)) - stopifnot(length(datasets) >= 2) - if (is.reactive(data)) { - data <- data() - } - - if (is.null(by)) { - by <- extract_ids(input = selections, data) - } - - data <- add_library_call(merge_function, data) - - if (!missing(by) && length(by)) { - call_m <- as.call(c( - rlang::parse_expr(merge_function), - list( - x = as.name(datasets[1]), - y = as.name(datasets[2]), - by = by - ) - )) - } else { - call_m <- as.call(c( - rlang::parse_expr(merge_function), - list( - x = as.name(datasets[1]), - y = as.name(datasets[2]) - ) - )) - } - call_m -} - -merge_call_multiple <- function(input_res, ids, data, merge_function = "dplyr::full_join", - anl = "ANL") { - selections <- consolidate_extraction(input_res) - datasets <- unique(unlist(lapply(selections, `[[`, "datasets"), FALSE, FALSE)) - stopifnot(is.character(datasets) && length(datasets) >= 1L) - number_merges <- length(datasets) - 1L - if (is.reactive(data)) { - data <- data() - } - out <- vector("list", length = 2) - names(out) <- c("code", "specification") - - if (number_merges == 0L) { - dataset <- names(selections) - variables <- selections[[1]]$variables - final_call <- call( - "<-", as.name(anl), - call("dplyr::select", as.name(dataset), as.names(variables)) - ) - out$code <- teal.code::eval_code(data, final_call) - out$input <- input_res - return(out) - } - stopifnot( - "Number of arguments for type matches data" = length(merge_function) == number_merges || length(merge_function) == 1L - ) - if (!missing(ids) && !is.null(ids)) { - stopifnot("Number of arguments for ids matches data" = !(is.list(ids) && length(ids) == number_merges)) - } - if (length(merge_function) != number_merges) { - merge_function <- rep(merge_function, number_merges) - } - if (!missing(ids) && length(ids) != number_merges) { - ids <- rep(ids, number_merges) - } - - if (number_merges == 1L && missing(ids)) { - data <- add_library_call(merge_function, data) - previous <- merge_call_pair(selections, merge_function = merge_function, data = data) - final_call <- call("<-", x = as.name(anl), value = previous) - out$code <- teal.code::eval_code(data, final_call) - out$input <- input_res - return(out) - } else if (number_merges == 1L && !missing(ids)) { - data <- add_library_call(merge_function, data) - previous <- merge_call_pair(selections, by = ids, merge_function = merge_function, data = data) - final_call <- call("<-", x = as.name(anl), value = previous) - out$code <- teal.code::eval_code(data, final_call) - out$input <- input_res - return(out) - } - - for (merge_i in seq_len(number_merges)) { - if (merge_i == 1L) { - datasets_i <- seq_len(2) - if (!missing(ids)) { - ids <- ids[[merge_i]] - previous <- merge_call_pair(selections[datasets_i], - ids, - merge_function[merge_i], - data = data - ) - } else { - previous <- merge_call_pair(selections[datasets_i], - merge_function[merge_i], - data = data - ) - } - } else { - datasets_ids <- merge_i:(merge_i + 1L) - if (!missing(ids)) { - current <- merge_call_pair(selections[datasets_ids], - merge_function = merge_function[merge_i], data = data - ) - } else { - ids <- ids[[merge_i]] - current <- merge_call_pair(selections[datasets_ids], - ids, - merge_function = merge_function[merge_i], data = data - ) - } - } - previous <- call("%>%", as.name(previous), as.name(current)) - } - final_call <- call("<-", x = as.name(anl), value = previous) - out$code <- teal.code::eval_code(data, final_call) - out$input <- input_res - out -} - -merge_type_srv <- function(id, inputs, data, merge_function = "dplyr::full_join", anl_name = "ANL") { - checkmate::assert_list(inputs, names = "named") - stopifnot(make.names(anl_name) == anl_name) - - moduleServer( - id, - function(input, output, session) { - req(input) - resolved_spec <- reactive({ - resolved_spec <- lapply(names(inputs), function(x) { - # Return characters not reactives - module_input_server(x, inputs[[x]], data)() - }) - # Keep input names - names(resolved_spec) <- names(inputs) - resolved_spec - }) - td <- merge_call_multiple(resolved_spec(), NULL, - data, - merge_function = merge_function, anl = anl_name - ) - } - ) -} - -add_library_call <- function(merge_function, data) { - if (is.reactive(data)) { - data <- data() - } - if (grepl("::", merge_function, fixed = TRUE)) { - m <- strsplit(merge_function, split = "::", fixed = TRUE)[[1]] - data <- teal.code::eval_code(data, call("library", m[1])) - } - data -} diff --git a/R/0-module_input.R b/R/0-module_input.R index 0e28440c..ada6bf8e 100644 --- a/R/0-module_input.R +++ b/R/0-module_input.R @@ -16,9 +16,9 @@ module_input_ui.list <- function(id, spec) { } #' @export -module_input_ui.specification <- function(id, spec) { - if (.valid_specification(spec)) { - stop("Unexpected object used as specification.") +module_input_ui.picks <- function(id, spec) { + if (.valid_picks(spec)) { + stop("Unexpected object used as spec. Use `picks` to create the object.") } ns <- shiny::NS(id) badge_label <- shiny::textOutput(ns("summary"), container = htmltools::tags$span) @@ -47,7 +47,7 @@ module_input_srv.list <- function(id, spec, data) { } #' @export -module_input_srv.specification <- function(id, spec, data) { +module_input_srv.picks <- function(id, spec, data) { moduleServer(id, function(input, output, session) { attr(spec, ".callback") <- reactiveVal(NULL) # callback to be used outside @@ -107,7 +107,11 @@ module_input_srv.specification <- function(id, spec, data) { ignoreInit = TRUE, # because spec_resolved is a initial state ignoreNULL = FALSE, { + if (identical(selected(), spec_resolved()[[slot_name]]$selected)) { + return(NULL) + } logger::log_info("module_input_server@1 selected has changed. Resolving downstream...") + new_spec_unresolved <- spec # ↓ everything after `i` is to resolve new_spec_unresolved[seq_len(i)] <- spec_resolved()[seq_len(i)] @@ -123,10 +127,8 @@ module_input_srv.specification <- function(id, spec, data) { if (length(resolver_warnings)) { showNotification(resolver_warnings, type = "error") } - if (!identical(new_spec_resolved, spec_resolved())) { - logger::log_info("Update spec { slot_name } after selection change.") - spec_resolved(new_spec_resolved) - } + + spec_resolved(new_spec_resolved) } ) }) diff --git a/R/0-module_merge.R b/R/0-module_merge.R index 54eece09..b6c6a262 100644 --- a/R/0-module_merge.R +++ b/R/0-module_merge.R @@ -1,7 +1,7 @@ #' Merge module #' #' Example module -tm_merge <- function(label = "merge-module", inputs) { +tm_merge <- function(label = "merge-module", inputs, transformators = list()) { module( label = label, ui = function(id, inputs) { @@ -56,6 +56,7 @@ tm_merge <- function(label = "merge-module", inputs) { }) }, ui_args = list(inputs = inputs), - server_args = list(inputs = inputs) + server_args = list(inputs = inputs), + transformators = transformators ) } diff --git a/R/0-resolver.R b/R/0-resolver.R index 23fcee27..2ad60006 100644 --- a/R/0-resolver.R +++ b/R/0-resolver.R @@ -24,6 +24,7 @@ #' resolver(spec, td) resolver <- function(x, data) { checkmate::assert_environment(data) + brows if (is.delayed(x)) { data_i <- data join_keys_i <- teal.data::join_keys(data) @@ -55,7 +56,8 @@ determine <- function(x, data, join_keys, ...) { #' @export determine.default <- function(x, data, join_keys, ...) { - stop("There is not a specific method to pick choices.") + browser() + stop("There is not a specific method to picks choices.") } #' @export @@ -115,7 +117,28 @@ determine.variables <- function(x, data, join_keys, ...) { x <- .determine_choices(x, data) x <- .determine_selected(x, data) - list(x = x, data = data[x$selected], join_keys = join_keys) + list(x = x, data = if (length(x$selected) == 1) data[[x$selected]], join_keys = join_keys) +} + +determine.values <- function(x, data, join_keys, ...) { + if (is.character(data) || is.factor(data)) { + d <- data + names(d) <- data + # todo: replace with NextMethod? + x$choices <- unique(names(.eval_select(d, x$choices))) + names(x$choices) <- x$choices + if (length(x$choices)) { + x$selected <- unique(names(.eval_select(x$choices, x$selected))) + } else { + x$selected <- NULL + } + + list(x = x) # nothing more after this (no need to pass data further) + } else { + x$choices <- character(0) + x$selected <- NULL + list(x = x) + } } .determine_choices <- function(x, data) { @@ -137,12 +160,12 @@ determine.variables <- function(x, data, join_keys, ...) { .determine_selected <- function(x, data) { if (!is.null(x$selected) && length(x$choices)) { data <- data[x$choices] - res <- try(unique(names(.eval_select(data, x$selected))), silent = TRUE) - if (inherits(res, "try-error")) { + res <- try(.eval_select(data, x$selected), silent = TRUE) + x$selected <- if (inherits(res, "try-error")) { warning("`selected` outside of possible `choices`. Emptying `selecting` field.", call. = FALSE) - x$selected <- NULL + NULL } else { - x$selected <- res + unique(names(res)) } } x diff --git a/R/0-teal.transform_wrappers.R b/R/0-teal.transform_wrappers.R new file mode 100644 index 00000000..5496ba5f --- /dev/null +++ b/R/0-teal.transform_wrappers.R @@ -0,0 +1,34 @@ +teal_transform_filter <- function(x, label = "Filter") { + checkmate::assert_class(x, "picks") + checkmate::assert_true("values" %in% names(x)) + + teal_transform_module( + label = label, + ui <- function(id) { + ns <- NS(id) + module_input_ui(ns("elo"), spec = x) + }, + server <- function(id, data) { + moduleServer(id, function(input, output, session) { + selector <- module_input_srv("elo", spec = x, data = data) + + reactive({ + req(data(), selector()) + teal.code::eval_code(data(), .make_filter_call(selector())) + }) + }) + } + ) +} + +.make_filter_call <- function(x) { + checkmate::assert_class(x, "picks") + substitute( + dataname <- dplyr::filter(dataname, varname %in% values), + list( + dataname = str2lang(x$datasets$selected), + varname = str2lang(x$variables$selected), + values = x$values$selected + ) + ) +} diff --git a/R/0-simple-selectors.R b/R/0-tidyselect-helpers.R similarity index 100% rename from R/0-simple-selectors.R rename to R/0-tidyselect-helpers.R diff --git a/R/0-types.R b/R/0-types.R index 143e2412..1d6c8f38 100644 --- a/R/0-types.R +++ b/R/0-types.R @@ -1,25 +1,50 @@ +#' Variables choices settings +#' +#' Define choices and default selection of variables from datasets. +#' @param choices <[`tidy-select`][dplyr::dplyr_tidy_select] or `character`> +#' One unquoted expression to be used to picks the choices. +#' @param selected <[`tidy-select`][dplyr::dplyr_tidy_select] or `character`> +#' One unquoted expression to be used to picks from choices to be selected. +#' @returns `picks` object containing specified settings +#' @examples +#' +#' # Initialize selector for `iris` to select columns between `Sepal.Length` and `Petal.Width` +#' # with first +#' picks( +#' datasets(choices = "iris"), +#' variables(choices = Sepal.Length:Petal.Width, selected = 1) +#' ) +#' picks( +#' datasets(choices = c("iris", "mtcars"), selected = "iris"), +#' variables(choices = tidyselect::everything(), selected = 1) +#' ) +#' picks( +#' datasets(choices = c("iris", "mtcars"), selected = 1), +#' variables(choices = tidyselect::where(is.numeric), selected = 1) +#' ) +#' picks( +#' datasets(choices = tidyselect::everything(), selected = 1), +#' variables(choices = is_categorical(min.len = 2, max.len = 15), selected = 1:2) +#' ) #' @rdname types #' @name Types -#' @title Type specification -#' @description -#' Define how to select and extract data -#' @param choices <[`tidy-select`][dplyr::dplyr_tidy_select]> One unquoted expression to be used to pick the choices. -#' @param selected <[`tidy-select`][dplyr::dplyr_tidy_select]> One unquoted expression to be used to pick from choices to be selected. -#' @returns An object of the same class as the function with two elements: names the content of x, and select. -#' @examples -#' datasets() -#' datasets("A") -#' c(datasets("A"), datasets("B")) -#' datasets(where(is.data.frame)) -#' c(datasets("A"), variables(where(is.numeric))) NULL #' @describeIn types specify a selector. #' @export -spec <- function(...) { - spec <- list(...) - names(spec) <- vapply(spec, FUN = is, FUN.VALUE = character(1)) - structure(spec, class = c("specification", "list")) +picks <- function(...) { + # todo: assert that datasets is on the first place? + picks <- list(...) + names(picks) <- vapply(picks, FUN = is, FUN.VALUE = character(1)) + for (i in seq_along(picks)) { + if (isTRUE(picks[[i]]$multiple) && i < length(picks)) { + stop( + names(picks)[i], " has a property `multiple = TRUE` which is forbidden if there are any following elements", + "depending on its selection." + ) + } + } + structure(picks, class = c("picks", "list")) } #' @describeIn types Specify datasets. @@ -46,6 +71,18 @@ variables <- function(choices = tidyselect::everything(), selected = 1, multiple out } +#' @describeIn types Specify variables. +#' @export +values <- function(choices = tidyselect::everything(), selected = 1, multiple = FALSE) { + out <- .selected_choices( + choices = if (.is_tidyselect(choices)) rlang::enquo(choices) else choices, + selected = if (.is_tidyselect(selected)) rlang::enquo(selected) else selected, + multiple = multiple + ) + class(out) <- c("values", class(out)) + out +} + #' @describeIn types Specify colData. #' @export mae_colData <- function(choices = tidyselect::everything(), selected = 1, multiple = FALSE) { @@ -80,58 +117,26 @@ is.na.type <- function(x) anyNA(x) #' @export print.type <- function(x, ...) { - if (is.na(x)) { - cat("Nothing possible") - return(x) - } - - choices_fns <- .count_functions(x$choices) - - msg_values <- character() - choices_values <- length(x$choices) - sum(choices_fns) - if (any(choices_fns)) { - msg_values <- paste0(msg_values, sum(choices_fns), " functions for possible choices.", - collapse = "\n" - ) - } - if (choices_values) { - msg_values <- paste0(msg_values, paste0(rlang::as_label(x$choices[!choices_fns]), collapse = ", "), - " as possible choices.", - collapse = "\n" - ) - } - - selected_fns <- .count_functions(x$selected) - - msg_sel <- character() - sel_values <- length(x$selected) - sum(selected_fns) - if (any(selected_fns)) { - msg_sel <- paste0(msg_sel, sum(selected_fns), " functions to select.", - collapse = "\n" - ) - } - if (sel_values) { - msg_sel <- paste0(msg_sel, paste0(rlang::as_label(x$selected[!selected_fns]), collapse = ", "), - " selected.", - collapse = "\n" - ) - } - - cat(msg_values, msg_sel) + cat( + "choices :", .toString(x$choices), + "\nselected:", .toString(x$selected) + ) return(x) } - -.count_functions <- function(x) { - if (is.list(x)) { - vapply(x, is.function, logical(1L)) - } else { - FALSE +.toString <- function(x) { + if (inherits(x, "quosure")) { + rlang::as_label(x) + } else if (is.vector(x)) { + toString(x, width = 30) + } else if (is.null(x)) { + "~" } } -.is.specification <- function(x) { - inherits(x, "specification") + +.is.picks <- function(x) { + inherits(x, "picks") } .is.tidyselect <- function(x) { @@ -148,8 +153,8 @@ print.type <- function(x, ...) { multiple = length(selected) > 1, keep_order = FALSE) { is_choices_delayed <- inherits(choices, "quosure") - is_selected_delayed <- inherits(selected, "quosure") - if (is_choices_delayed && !is_selected_delayed) { + is_selected_eager <- is.character(selected) + if (is_choices_delayed && is_selected_eager) { warning( deparse(sys.call(-1)), "\n - Setting explicit `selected` while `choices` are delayed (set using `tidyselect`) might lead to the", "situation where `selected` is not in dynamically obtained `choices`.", @@ -165,8 +170,8 @@ print.type <- function(x, ...) { ) } -.valid_specification <- function(x) { - !((.is.type(x) || .is.specification(x))) +.valid_picks <- function(x) { + !((.is.type(x) || .is.picks(x))) } @@ -181,5 +186,16 @@ print.type <- function(x, ...) { #' @internal .is_tidyselect <- function(x) { out <- tryCatch(x, error = function(e) e) - !is.character(out) + !is.character(out) && !is.null(out) +} + +#' @export +datanames <- function(x) { + if (inherits(x, "picks")) { + x <- list(x) + } + checkmate::assert_list(x, c("picks", "NULL")) + unique(unlist(lapply(x, function(x) { + if (is.character(x$datasets$choices)) x$datasets$choices + }))) } diff --git a/man/merge_expr.Rd b/man/merge_expr.Rd index 9d4e92e8..de8cd28c 100644 --- a/man/merge_expr.Rd +++ b/man/merge_expr.Rd @@ -13,7 +13,7 @@ merge_expr( ) } \arguments{ -\item{selectors}{(\code{list} of \code{specification})} +\item{selectors}{(\code{list} of \code{picks})} \item{output_name}{(\code{character(1)})} diff --git a/man/tidyselectors.Rd b/man/tidyselectors.Rd index 0ed33feb..88fe05d7 100644 --- a/man/tidyselectors.Rd +++ b/man/tidyselectors.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/0-simple-selectors.R +% Please edit documentation in R/0-tidyselect-helpers.R \name{tidyselectors} \alias{tidyselectors} \alias{is_key} diff --git a/man/types.Rd b/man/types.Rd index 11e1653d..aca2480b 100644 --- a/man/types.Rd +++ b/man/types.Rd @@ -2,14 +2,14 @@ % Please edit documentation in R/0-types.R \name{Types} \alias{Types} -\alias{spec} +\alias{picks} \alias{datasets} \alias{variables} \alias{mae_colData} \alias{values} -\title{Type specification} +\title{Variables choices settings} \usage{ -spec(...) +picks(...) datasets(choices = tidyselect::everything(), selected = 1) @@ -20,19 +20,21 @@ mae_colData(choices = tidyselect::everything(), selected = 1, multiple = FALSE) values(choices = tidyselect::everything(), selected = 1, multiple = FALSE) } \arguments{ -\item{choices}{<\code{\link[dplyr:dplyr_tidy_select]{tidy-select}}> One unquoted expression to be used to pick the choices.} +\item{choices}{<\code{\link[dplyr:dplyr_tidy_select]{tidy-select}} or \code{character}> +One unquoted expression to be used to picks the choices.} -\item{selected}{<\code{\link[dplyr:dplyr_tidy_select]{tidy-select}}> One unquoted expression to be used to pick from choices to be selected.} +\item{selected}{<\code{\link[dplyr:dplyr_tidy_select]{tidy-select}} or \code{character}> +One unquoted expression to be used to picks from choices to be selected.} } \value{ -An object of the same class as the function with two elements: names the content of x, and select. +\code{picks} object containing specified settings } \description{ -Define how to select and extract data +Define choices and default selection of variables from datasets. } \section{Functions}{ \itemize{ -\item \code{spec()}: specify a selector. +\item \code{picks()}: specify a selector. \item \code{datasets()}: Specify datasets. @@ -44,9 +46,23 @@ Define how to select and extract data }} \examples{ -datasets() -datasets("A") -c(datasets("A"), datasets("B")) -datasets(where(is.data.frame)) -c(datasets("A"), variables(where(is.numeric))) + +# Initialize selector for `iris` to select columns between `Sepal.Length` and `Petal.Width` +# with first +picks( + datasets(choices = "iris"), + variables(choices = Sepal.Length:Petal.Width, selected = 1) +) +picks( + datasets(choices = c("iris", "mtcars"), selected = "iris"), + variables(choices = tidyselect::everything(), selected = 1) +) +picks( + datasets(choices = c("iris", "mtcars"), selected = 1), + variables(choices = tidyselect::where(is.numeric), selected = 1) +) +picks( + datasets(choices = tidyselect::everything(), selected = 1), + variables(choices = is_categorical(min.len = 2, max.len = 15), selected = 1:2) +) } From 61038cd7fd45076dbd588f3f63d298bb5156c64c Mon Sep 17 00:00:00 2001 From: github-actions <41898282+github-actions[bot]@users.noreply.github.com> Date: Fri, 29 Aug 2025 08:17:37 +0000 Subject: [PATCH 117/142] [skip roxygen] [skip vbump] Roxygen Man Pages Auto Update --- man/tm_merge.Rd | 2 +- man/types.Rd | 6 +++++- 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/man/tm_merge.Rd b/man/tm_merge.Rd index 98e021a4..892f54bc 100644 --- a/man/tm_merge.Rd +++ b/man/tm_merge.Rd @@ -4,7 +4,7 @@ \alias{tm_merge} \title{Merge module} \usage{ -tm_merge(label = "merge-module", inputs) +tm_merge(label = "merge-module", inputs, transformators = list()) } \description{ Example module diff --git a/man/types.Rd b/man/types.Rd index aca2480b..d8420ed5 100644 --- a/man/types.Rd +++ b/man/types.Rd @@ -5,8 +5,8 @@ \alias{picks} \alias{datasets} \alias{variables} -\alias{mae_colData} \alias{values} +\alias{mae_colData} \title{Variables choices settings} \usage{ picks(...) @@ -15,6 +15,8 @@ datasets(choices = tidyselect::everything(), selected = 1) variables(choices = tidyselect::everything(), selected = 1, multiple = FALSE) +values(choices = tidyselect::everything(), selected = 1, multiple = FALSE) + mae_colData(choices = tidyselect::everything(), selected = 1, multiple = FALSE) values(choices = tidyselect::everything(), selected = 1, multiple = FALSE) @@ -40,6 +42,8 @@ Define choices and default selection of variables from datasets. \item \code{variables()}: Specify variables. +\item \code{values()}: Specify variables. + \item \code{mae_colData()}: Specify colData. \item \code{values()}: Specify values. From abd4b97abead6251e8da8a398d55c4ea096af399 Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Fri, 5 Sep 2025 10:15:36 +0200 Subject: [PATCH 118/142] WIP --- NAMESPACE | 2 +- R/0-assert.R | 14 ++++ R/0-delayed.R | 14 ---- R/0-merge.R | 75 ++++++++++--------- R/0-module_input.R | 134 +++++++++++++++++++++------------- R/0-resolver.R | 41 ++++++++--- R/0-teal.transform_wrappers.R | 4 +- R/0-to_picks.R | 54 ++++++++++++++ R/0-types.R | 97 +++++++++++++++--------- R/call_utils.R | 19 ++++- man/dot-is_tidyselect.Rd | 3 +- man/types.Rd | 21 +++++- tests/testthat/0-to_picks.R | 39 ++++++++++ 13 files changed, 362 insertions(+), 155 deletions(-) create mode 100644 R/0-assert.R create mode 100644 R/0-to_picks.R create mode 100644 tests/testthat/0-to_picks.R diff --git a/NAMESPACE b/NAMESPACE index 8350b3bc..531c2724 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -11,10 +11,10 @@ S3method(data_extract_srv,list) S3method(determine,colData) S3method(determine,datasets) S3method(determine,default) +S3method(determine,values) S3method(determine,variables) S3method(filter_spec_internal,default) S3method(filter_spec_internal,delayed_data) -S3method(is.delayed,default) S3method(is.delayed,list) S3method(is.delayed,picks) S3method(is.delayed,type) diff --git a/R/0-assert.R b/R/0-assert.R new file mode 100644 index 00000000..84786abd --- /dev/null +++ b/R/0-assert.R @@ -0,0 +1,14 @@ +assert_picks <- function(x) { + +} + +assert_variables <- function(x, multiple, .var.name = checkmate::vname(x)) { + if (!inherits(x, "variables")) { + stop(.var.name, " should be of class variables") + } + + checkmate::assert_flag(multiple) + if (!missing(multiple) && !identical(isTRUE(attr(x, "multiple")), multiple)) { + stop(.var.name, " should have a property multiple = `", multiple, "`.") + } +} diff --git a/R/0-delayed.R b/R/0-delayed.R index 849aef0b..a98578fb 100644 --- a/R/0-delayed.R +++ b/R/0-delayed.R @@ -12,20 +12,6 @@ is.delayed <- function(x) { UseMethod("is.delayed") } -#' @export -#' @method is.delayed default -is.delayed.character <- function(x) { - # FIXME: A warning? - FALSE -} - -#' @export -#' @method is.delayed default -is.delayed.default <- function(x) { - # FIXME: A warning? - FALSE -} - # Handling a list of transformers e1 | e2 #' @export #' @method is.delayed list diff --git a/R/0-merge.R b/R/0-merge.R index 123fbc78..b4d93aa7 100644 --- a/R/0-merge.R +++ b/R/0-merge.R @@ -22,7 +22,6 @@ merge_expr <- function(selectors, x$variables <- stats::setNames(names(x$variables), unname(x$variables)) x }) - datanames <- unique(unlist(lapply(mapping, `[[`, "datasets"))) calls <- expression() anl_datanames <- character(0) # to follow what anl is composed of (to determine keys) @@ -30,6 +29,9 @@ merge_expr <- function(selectors, for (i in seq_along(datanames)) { dataname <- datanames[i] this_mapping <- Filter(function(x) x$datasets == dataname, mapping) + this_filter_mapping <- Filter(function(x) { + "values" %in% names(x) + }, this_mapping) this_foreign_keys <- .fk(join_keys, dataname) this_primary_keys <- join_keys[dataname, dataname] this_variables <- c( @@ -40,6 +42,10 @@ merge_expr <- function(selectors, # todo: extract call is datasets (class, class) specific this_call <- .call_dplyr_select(dataname = dataname, variables = this_variables) + if (length(this_filter_mapping)) { + this_call <- calls_combine_by("%>%", c(this_call, .call_dplyr_filter(this_filter_mapping))) + } + if (i > 1) { merge_keys <- join_keys["anl", dataname] if (!length(merge_keys)) { @@ -168,51 +174,28 @@ map_merged <- function(selectors, join_keys) { # remaining datasets/datanames: datasets (or names) which are about to be merged # # Rules: - # 1. selected variables are added to anl. - # 2. duplicated variables added to anl should be renamed - # 3. anl "inherits" foreign keys from anl datasets to remaining datasets - # 4. foreign keys of current dataset are added to anl join_keys but only if no relation from anl already. - # 5. foreign keys should be renamed if duplicated with anl colnames - # 6. (for later) selected datasets might not be directly mergable, we need to find the "path" which + # 1. anl "inherits" foreign keys from anl datasets to remaining datasets + # 2. foreign keys of current dataset are added to anl join_keys but only if no relation from anl already. + # 3. foreign keys should be renamed if duplicated with anl colnames + # 4. (for later) selected datasets might not be directly mergable, we need to find the "path" which # will probably involve add intermediate datasets in between to perform merge + # 5. selected variables are added to anl. + # 6. duplicated variables added to anl should be renamed remaining_datanames <- setdiff(remaining_datanames, dataname) - mapping_ds <- mapping_by_dataset[[dataname]] - mapping_ds <- lapply(mapping_ds, function(x) { - new_vars <- .suffix_duplicated_vars( - # is dropped by merge call. We should refer this selected foreign-key-variable - # to equivalent key variable added in previous iteration (existing anl foreign key) - # 4. duplicated variables added to anl should be renamed - vars = x$variables, - all_vars = anl_colnames, - suffix = dataname - ) - - # if foreign key of this dataset is selected and if this foreign key took a part in the merge - # then this key is dropped and we need to refer to the first variable - existing_fk <- join_keys[dataname, "anl"] # keys that are already in anl - existing_fk_selected <- intersect(names(existing_fk), x$variables) - new_vars[existing_fk_selected] <- existing_fk[existing_fk_selected] - x$variables <- new_vars - x - }) - mapping[names(mapping_ds)] <- mapping_ds - - this_colnames <- unique(unlist(lapply(mapping_ds, `[[`, "variables"))) - anl_colnames <- c(anl_colnames, this_colnames) # todo: if this dataset has no join_keys to anl (anl_datasets) then error saying # can't merge {dataset} with merged dataset composed of {anl_datasets} - # ↓ 3. anl "inherits" foreign keys from anl datasets to remaining datasets + # ↓ 1. anl "inherits" foreign keys from anl datasets to remaining datasets this_join_keys <- do.call( teal.data::join_keys, lapply( remaining_datanames, function(dataset_2) { new_keys <- join_keys[dataname, dataset_2] - # ↓ 4. foreign keys of current dataset are added to anl join_keys but only if no relation from anl already + # ↓ 2. foreign keys of current dataset are added to anl join_keys but only if no relation from anl already if (length(new_keys) && !dataset_2 %in% names(join_keys[["anl"]])) { - # ↓ 5. foreign keys should be renamed if duplicated with anl colnames + # ↓ 3. foreign keys should be renamed if duplicated with anl colnames new_key_names <- .suffix_duplicated_vars( vars = names(new_keys), # names because we change the key of dataset_1 (not dataset_2) all_vars = anl_colnames, @@ -225,6 +208,32 @@ map_merged <- function(selectors, join_keys) { ) ) join_keys <- c(this_join_keys, join_keys) + + + mapping_ds <- mapping_by_dataset[[dataname]] + mapping_ds <- lapply(mapping_ds, function(x) { + new_vars <- .suffix_duplicated_vars( + # is dropped by merge call. We should refer this selected foreign-key-variable + # to equivalent key variable added in previous iteration (existing anl foreign key) + # 6. duplicated variables added to anl should be renamed + vars = x$variables, + all_vars = anl_colnames, + suffix = dataname + ) + + # if foreign key of this dataset is selected and if this foreign key took a part in the merge + # then this key is dropped and we need to refer to the first variable + existing_fk <- join_keys[dataname, "anl"] # keys that are already in anl + existing_fk_selected <- intersect(names(existing_fk), x$variables) + new_vars[existing_fk_selected] <- existing_fk[existing_fk_selected] + x$variables <- new_vars + x + }) + mapping[names(mapping_ds)] <- mapping_ds + + this_colnames <- unique(unlist(lapply(mapping_ds, `[[`, "variables"))) + anl_colnames <- c(anl_colnames, this_colnames) + anl_colnames <- union(anl_colnames, .fk(join_keys, "anl")) } diff --git a/R/0-module_input.R b/R/0-module_input.R index ada6bf8e..6a757f82 100644 --- a/R/0-module_input.R +++ b/R/0-module_input.R @@ -21,7 +21,7 @@ module_input_ui.picks <- function(id, spec) { stop("Unexpected object used as spec. Use `picks` to create the object.") } ns <- shiny::NS(id) - badge_label <- shiny::textOutput(ns("summary"), container = htmltools::tags$span) + badge_label <- shiny::uiOutput(ns("summary"), container = htmltools::tags$span) # todo: icon or color to indicate a column class content <- lapply(spec, function(x) .selected_choices_ui(id = ns(is(x)), x)) htmltools::tags$div( @@ -66,24 +66,31 @@ module_input_srv.picks <- function(id, spec, data) { # join_keys are needed to variables after merge attr(spec_resolved, "join_keys") <- teal.data::join_keys(shiny::isolate(data_r())) # todo: do the same as with .callback - badge_text <- shiny::reactive({ - paste( + badge <- shiny::reactive({ + tagList( lapply( spec_resolved(), function(x) { - if (length(x$selected)) { + if (inherits(x, "values")) { + if (!identical(as.vector(x$choices), as.vector(x$selected))) { + bsicons::bs_icon("funnel") + } + } else if (length(x$selected)) { toString(x$selected) } else { "~" } } - ), - collapse = ": " + ) ) }) # todo: modify when data changes - output$summary <- shiny::renderText(badge_text()) + output$summary <- shiny::renderUI(badge()) + + observeEvent(data(), { + + }) lapply(seq_along(spec), function(i) { slot_name <- names(spec)[i] @@ -107,7 +114,7 @@ module_input_srv.picks <- function(id, spec, data) { ignoreInit = TRUE, # because spec_resolved is a initial state ignoreNULL = FALSE, { - if (identical(selected(), spec_resolved()[[slot_name]]$selected)) { + if (identical(as.vector(selected()), as.vector(spec_resolved()[[slot_name]]$selected))) { return(NULL) } logger::log_info("module_input_server@1 selected has changed. Resolving downstream...") @@ -139,21 +146,7 @@ module_input_srv.picks <- function(id, spec, data) { .selected_choices_ui <- function(id, x) { ns <- shiny::NS(id) - shinyWidgets::pickerInput( - inputId = ns("selected"), - label = paste("Select", is(x), collapse = " "), - choices = if (is.character(x$choices)) x$choices, - selected = if (is.character(x$selected)) x$selected, - multiple = isTRUE(attr(x, "multiple")), - choicesOpt = if (is.character(x$choices)) list(content = toupper(x$choices)), - options = list( - "actions-box" = isTRUE(attr(x, "multiple")), - "none-selected-text" = "- Nothing selected -", - "allow-clear" = !isTRUE(attr(x, "multiple")), - "max-options" = ifelse(isTRUE(attr(x, "multiple")), Inf, 1), - "show-subtext" = TRUE - ) - ) + uiOutput(ns("selected_container")) } .selected_choices_srv <- function(id, x) { @@ -161,41 +154,72 @@ module_input_srv.picks <- function(id, spec, data) { checkmate::assert_true(is.reactive(x)) shiny::moduleServer(id, function(input, output, session) { # todo: keep_order - shiny::observeEvent(x(), { - logger::log_debug(".selected_choices_srv@1 x has changed (caused by upstream resolve)") - if (length(x()$choices) == 1) { - shinyjs::hide("selected") - } - - shinyWidgets::updatePickerInput( - inputId = "selected", - choices = x()$choices, - selected = x()$selected, - choicesOpt = list( - content = ifelse( - # todo: add to the input choice icon = attached to choices when determine - names(x()$choices) == unname(x()$choices), - sprintf("%s", x()$choices), - sprintf( - '%s %s', - unname(x()$choices), - names(x()$choices) + output$selected_container <- renderUI({ + if (isTRUE(attr(x(), "fixed")) || length(x()$choices) == 1) { + } else if (is.numeric(x()$choices)) { + shinyWidgets::numericRangeInput( + inputId = session$ns("range"), + label = paste("Select", is(x()), collapse = " "), + min = unname(x()$choices[1]), + max = unname(tail(x()$choices, 1)), + value = unname(x()$selected) + ) + } else { + shinyWidgets::pickerInput( + inputId = session$ns("selected"), + label = paste("Select", is(x()), collapse = " "), + choices = x()$choices, + selected = x()$selected, + multiple = attr(x(), "multiple"), + choicesOpt = list( + content = ifelse( + # todo: add to the input choice icon = attached to choices when determine + names(x()$choices) == unname(x()$choices), + sprintf("%s", x()$choices), + sprintf( + '%s %s', + unname(x()$choices), + names(x()$choices) + ) ) + ), + options = list( + "actions-box" = attr(x(), "multiple"), + # "allow-clear" = attr(x(), "multiple") || attr(x(), "allow-clear"), + "live-search" = ifelse(length(x()$choices) > 10, TRUE, FALSE), + # "max-options" = attr(x(), "max-options"), + "none-selected-text" = "- Nothing selected -", + "show-subtext" = TRUE ) - ), - options = list( - "live-search" = ifelse(length(x()$choices) > 10, TRUE, FALSE) ) - ) + } }) + selected <- shiny::reactiveVal() # todo: if only one choice then replace with the text only - shiny::observeEvent(input$selected, ignoreNULL = FALSE, { - # ↓ pickerInput returns "" when nothing selected. This can cause failure during col select (x[,""]) - new_selected <- if (length(input$selected) && !identical(input$selected, "")) input$selected - if (!identical(new_selected, selected())) { + + # for numeric + range_debounced <- reactive(input$range) |> debounce(1000) + shiny::observeEvent(range_debounced(), { + if (length(input$range) != 2) { + return(NULL) + } + if (!identical(input$range, selected())) { logger::log_debug(".selected_choices_srv@2 input$selected has changed.") - selected(new_selected) + selected(input$range) + } + }) + + + # for non-numeric + shiny::observeEvent(input$selected_open, { + if (!isTRUE(input$selection_open)) { + # ↓ pickerInput returns "" when nothing selected. This can cause failure during col select (x[,""]) + new_selected <- if (length(input$selected) && !identical(input$selected, "")) input$selected + if (!identical(new_selected, selected())) { + logger::log_debug(".selected_choices_srv@2 input$selected has changed.") + selected(new_selected) + } } }) selected @@ -222,16 +246,24 @@ module_input_srv.picks <- function(id, spec, data) { if(container.style.display === 'none' || container.style.display === '') { container.style.display = 'block'; + // Trigger Shiny input events to ensure renderUI gets called + $(container).trigger('shown'); + Shiny.bindAll(container); + // Add click outside handler setTimeout(function() { function handleClickOutside(event) { if (!container.contains(event.target) && !summary.contains(event.target)) { container.style.display = 'none'; + $(container).trigger('hidden'); document.removeEventListener('click', handleClickOutside); } } document.addEventListener('click', handleClickOutside); }, 10); + } else { + container.style.display = 'none'; + $(container).trigger('hidden'); } ", ns("inputs_container"), diff --git a/R/0-resolver.R b/R/0-resolver.R index 2ad60006..6481e312 100644 --- a/R/0-resolver.R +++ b/R/0-resolver.R @@ -23,8 +23,8 @@ #' spec <- c(dataset1, variables("a", where(is.character))) #' resolver(spec, td) resolver <- function(x, data) { + checkmate::assert_class(x, "picks") checkmate::assert_environment(data) - brows if (is.delayed(x)) { data_i <- data join_keys_i <- teal.data::join_keys(data) @@ -56,7 +56,6 @@ determine <- function(x, data, join_keys, ...) { #' @export determine.default <- function(x, data, join_keys, ...) { - browser() stop("There is not a specific method to picks choices.") } @@ -86,21 +85,17 @@ determine.datasets <- function(x, data, join_keys, ...) { warning("`dataset` must be a single selection. Forcing to first possible choice.") x$selected <- x$choices[1] } + list(x = x, data = data[[x$selected]], join_keys = join_keys[[x$selected]]) } #' @export determine.variables <- function(x, data, join_keys, ...) { checkmate::assert_multi_class(data, c("data.frame", "tbl_df", "data.table", "DataFrame")) - checkmate::assert_list(join_keys) + checkmate::assert_list(join_keys, null.ok = TRUE) if (is.null(data)) { return(list(x = x, data = NULL)) - } else if (length(dim(data)) != 2L) { - stop( - "Can't resolve variables from this object of class ", - toString(sQuote(class(data))) - ) } if (ncol(data) <= 0L) { @@ -120,6 +115,7 @@ determine.variables <- function(x, data, join_keys, ...) { list(x = x, data = if (length(x$selected) == 1) data[[x$selected]], join_keys = join_keys) } +#' @export determine.values <- function(x, data, join_keys, ...) { if (is.character(data) || is.factor(data)) { d <- data @@ -134,20 +130,26 @@ determine.values <- function(x, data, join_keys, ...) { } list(x = x) # nothing more after this (no need to pass data further) - } else { - x$choices <- character(0) - x$selected <- NULL + } else if (is.numeric(data)) { + x$choices <- range(data) + x$selected <- if (is.numeric(x$selected)) x$selected else x$choices list(x = x) } } .determine_choices <- function(x, data) { - choices <- if (is.character(x$choices)) { + choices <- if (inherits(x$choices, "delayed_data")) { + x$choices$subset(data) + } else if (is.character(x$choices)) { x$choices } else { idx <- .eval_select(data, x$choices) unique(names(data)[idx]) } + if (length(choices) == 0) { + stop("Can't determine choices: ", rlang::as_label(x$choices)) + } + labels <- vapply( choices, FUN = function(choice) c(attr(data[[choice]], "label"), choice)[1], @@ -167,10 +169,25 @@ determine.values <- function(x, data, join_keys, ...) { } else { unique(names(res)) } + if (!isTRUE(x$multiple)) { + x$selected <- x$selected[1] + } } x } +.is_selected_equal <- function(x, y) { + all( + vapply( + seq_along(x), + FUN = function(i) { + identical(as.vector(x[[i]]$selected), as.vector(y[[i]]$selected)) + }, + FUN.VALUE = logical(1) + ) + ) +} + #' Internal method to extract data from different objects #' diff --git a/R/0-teal.transform_wrappers.R b/R/0-teal.transform_wrappers.R index 5496ba5f..c52fc568 100644 --- a/R/0-teal.transform_wrappers.R +++ b/R/0-teal.transform_wrappers.R @@ -6,11 +6,11 @@ teal_transform_filter <- function(x, label = "Filter") { label = label, ui <- function(id) { ns <- NS(id) - module_input_ui(ns("elo"), spec = x) + module_input_ui(ns("transformer"), spec = x) }, server <- function(id, data) { moduleServer(id, function(input, output, session) { - selector <- module_input_srv("elo", spec = x, data = data) + selector <- module_input_srv("transformer", spec = x, data = data) reactive({ req(data(), selector()) diff --git a/R/0-to_picks.R b/R/0-to_picks.R new file mode 100644 index 00000000..2f2c2de2 --- /dev/null +++ b/R/0-to_picks.R @@ -0,0 +1,54 @@ +des_to_picks <- function(x) { + if (inherits(x, "picks")) { + x + } else if (length(x)) { + args <- Filter( + length, + list( + datasets(choices = x$dataname, fixed = TRUE), + select_spec_to_variables(x$select) + # don't use filter_spec as they doesn't have to be linked with selected variables + # as filter_spec can be speciefied on the variable(s) different than select_spec for example: + # (pseudocode) select_spec(AVAL); filter_spec(PARAMCD, AVISIT) + ) + ) + do.call(picks, args) + } +} + +select_spec_to_variables <- function(x) { + if (length(x)) { + variables( + choices = x$choices, + selected = x$selected, + # keep_order = x$ordered, + multiple = x$multiple, + fixed = x$fixed + ) + } +} + + +extract_filters <- function(selectors) { + unlist( + lapply(selectors, function(des) { + if (checkmate::test_list(des, "data_extract_spec")) { + unlist(extract_filters(des), recursive = FALSE) + } else if (inherits(des, "data_extract_spec")) { + filter <- if (inherits(des$filter, "filter_spec")) { + list(des$filter) + } else { + des$filter + } + lapply(filter, function(x) { + picks( + datasets(choices = des$dataname, selected = des$dataname), + variables(choices = x$vars_choices, selected = x$vars_selected, multiple = FALSE), + values(choices = x$choices, selected = x$selected, multiple = x$multiple) + ) + }) + } + }), + recursive = FALSE + ) +} diff --git a/R/0-types.R b/R/0-types.R index 1d6c8f38..28edb789 100644 --- a/R/0-types.R +++ b/R/0-types.R @@ -1,10 +1,14 @@ -#' Variables choices settings +#' Choices/selected settings #' #' Define choices and default selection of variables from datasets. #' @param choices <[`tidy-select`][dplyr::dplyr_tidy_select] or `character`> #' One unquoted expression to be used to picks the choices. #' @param selected <[`tidy-select`][dplyr::dplyr_tidy_select] or `character`> #' One unquoted expression to be used to picks from choices to be selected. +#' @param multiple <`logical(1)`> if more than one selection is possible. +#' @param fixed <`logical(1)`> selection will be fixed and not possible to change interactively. +#' @param ... additional arguments delivered to `pickerInput` +#' #' @returns `picks` object containing specified settings #' @examples #' @@ -35,6 +39,7 @@ NULL picks <- function(...) { # todo: assert that datasets is on the first place? picks <- list(...) + checkmate::assert_list(picks, types = "type") names(picks) <- vapply(picks, FUN = is, FUN.VALUE = character(1)) for (i in seq_along(picks)) { if (isTRUE(picks[[i]]$multiple) && i < length(picks)) { @@ -47,13 +52,30 @@ picks <- function(...) { structure(picks, class = c("picks", "list")) } +#' @export +datanames <- function(x) { + if (inherits(x, "picks")) { + x <- list(x) + } + checkmate::assert_list(x, c("picks", "NULL")) + unique(unlist(lapply(x, function(x) { + if (is.character(x$datasets$choices)) x$datasets$choices + }))) +} + #' @describeIn types Specify datasets. #' @export -datasets <- function(choices = tidyselect::everything(), selected = 1) { +datasets <- function(choices = tidyselect::everything(), + selected = 1, + fixed = !.is_tidyselect(choices) && length(choices) == 1, + ...) { + # todo: implement ... in pickerInput like `max-options`, `allow-clear` out <- .selected_choices( choices = if (.is_tidyselect(choices)) rlang::enquo(choices) else choices, selected = if (.is_tidyselect(selected)) rlang::enquo(selected) else selected, - multiple = FALSE + multiple = FALSE, + fixed = fixed, + ... ) class(out) <- c("datasets", class(out)) out @@ -61,11 +83,17 @@ datasets <- function(choices = tidyselect::everything(), selected = 1) { #' @describeIn types Specify variables. #' @export -variables <- function(choices = tidyselect::everything(), selected = 1, multiple = FALSE) { +variables <- function(choices = tidyselect::everything(), + selected = 1, + multiple = !.is_tidyselect(selected) && length(selected) > 1, + fixed = !.is_tidyselect(choices) && length(choices) == 1, + ...) { out <- .selected_choices( choices = if (.is_tidyselect(choices)) rlang::enquo(choices) else choices, selected = if (.is_tidyselect(selected)) rlang::enquo(selected) else selected, - multiple = multiple + multiple = multiple, + fixed = fixed, + ... ) class(out) <- c("variables", class(out)) out @@ -73,16 +101,23 @@ variables <- function(choices = tidyselect::everything(), selected = 1, multiple #' @describeIn types Specify variables. #' @export -values <- function(choices = tidyselect::everything(), selected = 1, multiple = FALSE) { +values <- function(choices = tidyselect::everything(), + selected = 1, + multiple = !.is_tidyselect(selected) && length(selected) > 1, + fixed = !.is_tidyselect(choices) && length(choices) == 1, + ...) { out <- .selected_choices( choices = if (.is_tidyselect(choices)) rlang::enquo(choices) else choices, selected = if (.is_tidyselect(selected)) rlang::enquo(selected) else selected, - multiple = multiple + multiple = multiple, + fixed = fixed, + ... ) class(out) <- c("values", class(out)) out } + #' @describeIn types Specify colData. #' @export mae_colData <- function(choices = tidyselect::everything(), selected = 1, multiple = FALSE) { @@ -95,18 +130,6 @@ mae_colData <- function(choices = tidyselect::everything(), selected = 1, multip out } -#' @describeIn types Specify values. -#' @export -values <- function(choices = tidyselect::everything(), selected = 1, multiple = FALSE) { - out <- .selected_choices( - choices = if (.is_tidyselect(choices)) rlang::enquo(choices) else choices, - selected = if (.is_tidyselect(selected)) rlang::enquo(selected) else selected, - multiple = multiple - ) - class(out) <- c("values", class(out)) - out -} - #' @export anyNA.type <- function(x, recursive = FALSE) { anyNA(unclass(x[c("choices", "selected")]), recursive = recursive) @@ -151,9 +174,13 @@ print.type <- function(x, ...) { .selected_choices <- function(choices, selected, multiple = length(selected) > 1, - keep_order = FALSE) { - is_choices_delayed <- inherits(choices, "quosure") + keep_order = FALSE, + fixed = FALSE, + ...) { + is_choices_delayed <- inherits(choices, "quosure") || + checkmate::test_multi_class(choices, c("variable_choices", "value_choices")) is_selected_eager <- is.character(selected) + if (is_choices_delayed && is_selected_eager) { warning( deparse(sys.call(-1)), @@ -162,10 +189,20 @@ print.type <- function(x, ...) { ) } + if (inherits(choices, "choices_labeled")) { + choices <- setNames(as.vector(choices), names(choices)) + } + + if (inherits(selected, "choices_labeled")) { + selected <- setNames(as.vector(selected), names(selected)) + } + out <- structure( list(choices = choices, selected = selected), multiple = multiple, keep_order = keep_order, + fixed = fixed, + ..., class = "type" ) } @@ -177,25 +214,15 @@ print.type <- function(x, ...) { #' Is an object created using tidyselect #' +#' @description #' `choices` and `selected` can be provided using `tidyselect`, (e.g. [tidyselect::everything()] -#' [tidyselect::match()], [tidyselect::starts_with()]). These functions can't be called +#' [tidyselect::where()], [tidyselect::starts_with()]). These functions can't be called #' independently but rather as an argument of function which consumes them. #' `.is_tidyselect` safely determines if `x` can be evaluated with `tidyselect::eval_select()` #' @param x `choices` or `selected` #' @return `logical(1)` -#' @internal +#' @keywords internal .is_tidyselect <- function(x) { out <- tryCatch(x, error = function(e) e) - !is.character(out) && !is.null(out) -} - -#' @export -datanames <- function(x) { - if (inherits(x, "picks")) { - x <- list(x) - } - checkmate::assert_list(x, c("picks", "NULL")) - unique(unlist(lapply(x, function(x) { - if (is.character(x$datasets$choices)) x$datasets$choices - }))) + !is.character(out) && !is.null(out) && !inherits(out, "delayed_data") } diff --git a/R/call_utils.R b/R/call_utils.R index 2d342235..dd79b5c0 100644 --- a/R/call_utils.R +++ b/R/call_utils.R @@ -71,11 +71,11 @@ call_condition_choice <- function(varname, choices) { if (length(choices) == 1) { - call("==", varname, choices) + call("==", varname, unname(choices)) } else { c_call <- do.call( "call", - append(list("c"), choices) + append(list("c"), unname(choices)) ) # c_call needed because it needs to be vector call # instead of vector. SummarizedExperiment.subset @@ -104,8 +104,8 @@ call_condition_range <- function(varname, range) { varname <- call_check_parse_varname(varname) call( "&", - call(">=", varname, range[1]), - call("<=", varname, range[2]) + call(">=", varname, unname(range[1])), + call("<=", varname, unname(range[2])) ) } @@ -389,3 +389,14 @@ calls_combine_by <- function(operator, calls) { ) ) } + +.call_dplyr_filter <- function(A) { + predicates <- lapply(unname(A), function(x) { + if (is.numeric(x$values)) { + call_condition_range(varname = x$variables, range = x$values) + } else { + call_condition_choice(varname = x$variables, choices = x$values) + } + }) + as.call(c(list(str2lang("dplyr::filter")), predicates)) +} diff --git a/man/dot-is_tidyselect.Rd b/man/dot-is_tidyselect.Rd index 51e1c004..c55dcfe7 100644 --- a/man/dot-is_tidyselect.Rd +++ b/man/dot-is_tidyselect.Rd @@ -14,7 +14,8 @@ } \description{ \code{choices} and \code{selected} can be provided using \code{tidyselect}, (e.g. \code{\link[tidyselect:everything]{tidyselect::everything()}} -\code{\link[tidyselect:match]{tidyselect::match()}}, \code{\link[tidyselect:starts_with]{tidyselect::starts_with()}}). These functions can't be called +\code{\link[tidyselect:where]{tidyselect::where()}}, \code{\link[tidyselect:starts_with]{tidyselect::starts_with()}}). These functions can't be called independently but rather as an argument of function which consumes them. \code{.is_tidyselect} safely determines if \code{x} can be evaluated with \code{tidyselect::eval_select()} } +\keyword{internal} diff --git a/man/types.Rd b/man/types.Rd index d8420ed5..0d51e402 100644 --- a/man/types.Rd +++ b/man/types.Rd @@ -11,9 +11,20 @@ \usage{ picks(...) -datasets(choices = tidyselect::everything(), selected = 1) +datasets( + choices = tidyselect::everything(), + selected = 1, + fixed = !.is_tidyselect(choices) && length(choices) == 1, + ... +) -variables(choices = tidyselect::everything(), selected = 1, multiple = FALSE) +variables( + choices = tidyselect::everything(), + selected = 1, + multiple = !.is_tidyselect(selected) && length(selected) > 1, + fixed = !.is_tidyselect(choices) && length(choices) == 1, + ... +) values(choices = tidyselect::everything(), selected = 1, multiple = FALSE) @@ -22,11 +33,17 @@ mae_colData(choices = tidyselect::everything(), selected = 1, multiple = FALSE) values(choices = tidyselect::everything(), selected = 1, multiple = FALSE) } \arguments{ +\item{...}{additional arguments delivered to \code{pickerInput}} + \item{choices}{<\code{\link[dplyr:dplyr_tidy_select]{tidy-select}} or \code{character}> One unquoted expression to be used to picks the choices.} \item{selected}{<\code{\link[dplyr:dplyr_tidy_select]{tidy-select}} or \code{character}> One unquoted expression to be used to picks from choices to be selected.} + +\item{fixed}{<\code{logical(1)}> selection will be fixed and not possible to change interactively.} + +\item{multiple}{<\code{logical(1)}> if more than one selection is possible.} } \value{ \code{picks} object containing specified settings diff --git a/tests/testthat/0-to_picks.R b/tests/testthat/0-to_picks.R new file mode 100644 index 00000000..d2abb342 --- /dev/null +++ b/tests/testthat/0-to_picks.R @@ -0,0 +1,39 @@ +testthat::test_that("to_picks converts eager select_spec to variables without ordered, always_selected nor label", { + test <- select_spec( + choices = c("AVAL", "BMRKR1", "AGE"), + selected = "AVAL", + multiple = FALSE, + fixed = FALSE, + label = "Column", + ordered = TRUE, + always_selected = "AGE" + ) + out <- select_spec_to_values(test) + testthat::expect_s3_class(out, "variables") + testthat::expect_identical(out$choices, unclass(test$choices)) + testthat::expect_identical(out$selected, unclass(test$selected)) + testthat::expect_identical(attr(out, "multiple"), test$multiple) +}) + +testthat::test_that("to_picks converts delayed select_spec to variables preserving delayed_data and is resolvable", { + subset_fun <- function(data) names(Filter(is.factor, data)) + test <- select_spec( + choices = variable_choices("ADRS", subset = subset_fun), + selected = "AVISIT", + multiple = FALSE, + fixed = FALSE, + label = "Column", + ordered = TRUE, + always_selected = "AGE" + ) + + out <- suppressWarnings(select_spec_to_values(test)) + testthat::expect_s3_class(out, "variables") + testthat::expect_s3_class(out$choices, "delayed_data") + testthat::expect_identical(out$selected, "AVISIT") + + testthat::expect_identical( + determine(out, data = rADRS, join_keys = join_keys())$x, + variables(choices = subset_fun(rADRS), selected = subset_fun(rADRS)[1]) + ) +}) From 8794289bb8a92c689478f8ac869d0ca1df041c95 Mon Sep 17 00:00:00 2001 From: github-actions <41898282+github-actions[bot]@users.noreply.github.com> Date: Fri, 5 Sep 2025 08:21:53 +0000 Subject: [PATCH 119/142] [skip roxygen] [skip vbump] Roxygen Man Pages Auto Update --- DESCRIPTION | 2 +- man/types.Rd | 14 ++++++++------ 2 files changed, 9 insertions(+), 7 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 6d5247c2..f1f60a1d 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -58,4 +58,4 @@ Encoding: UTF-8 Language: en-US LazyData: true Roxygen: list(markdown = TRUE) -RoxygenNote: 7.3.2 +RoxygenNote: 7.3.3 diff --git a/man/types.Rd b/man/types.Rd index 0d51e402..b80c2cbb 100644 --- a/man/types.Rd +++ b/man/types.Rd @@ -7,7 +7,7 @@ \alias{variables} \alias{values} \alias{mae_colData} -\title{Variables choices settings} +\title{Choices/selected settings} \usage{ picks(...) @@ -26,11 +26,15 @@ variables( ... ) -values(choices = tidyselect::everything(), selected = 1, multiple = FALSE) +values( + choices = tidyselect::everything(), + selected = 1, + multiple = !.is_tidyselect(selected) && length(selected) > 1, + fixed = !.is_tidyselect(choices) && length(choices) == 1, + ... +) mae_colData(choices = tidyselect::everything(), selected = 1, multiple = FALSE) - -values(choices = tidyselect::everything(), selected = 1, multiple = FALSE) } \arguments{ \item{...}{additional arguments delivered to \code{pickerInput}} @@ -63,8 +67,6 @@ Define choices and default selection of variables from datasets. \item \code{mae_colData()}: Specify colData. -\item \code{values()}: Specify values. - }} \examples{ From dfbef1f4c18a4b78bdc6c902905128a5b5e3dd61 Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Fri, 5 Sep 2025 11:08:51 +0200 Subject: [PATCH 120/142] .determine_ to return vectors instead of type --- R/0-resolver.R | 39 +++++++++++++++++++-------------------- 1 file changed, 19 insertions(+), 20 deletions(-) diff --git a/R/0-resolver.R b/R/0-resolver.R index 6481e312..9be36126 100644 --- a/R/0-resolver.R +++ b/R/0-resolver.R @@ -77,9 +77,8 @@ determine.datasets <- function(x, data, join_keys, ...) { } else if (!inherits(data, "qenv")) { stop("Please use qenv() or teal_data() objects.") } - - x <- .determine_choices(x, data) - x <- .determine_selected(x, data) + x$choices <- .determine_choices(x$choices, data = data) + x$selected <- .determine_selected(x$selected, data = data[x$choices], multiple = x$multiple) if (length(x$selected) != 1) { warning("`dataset` must be a single selection. Forcing to first possible choice.") @@ -109,8 +108,10 @@ determine.variables <- function(x, data, join_keys, ...) { } } - x <- .determine_choices(x, data) - x <- .determine_selected(x, data) + new_choices <- .determine_choices(x$choices, data = data) + new_selected <- .determine_selected(x$selected, data = data[new_choices], multiple = x$multiple) + x$choices <- new_choices + x$selected <- new_selected list(x = x, data = if (length(x$selected) == 1) data[[x$selected]], join_keys = join_keys) } @@ -138,16 +139,16 @@ determine.values <- function(x, data, join_keys, ...) { } .determine_choices <- function(x, data) { - choices <- if (inherits(x$choices, "delayed_data")) { - x$choices$subset(data) - } else if (is.character(x$choices)) { - x$choices + choices <- if (inherits(x, "delayed_data")) { + x$subset(data) + } else if (is.character(x)) { + x } else { - idx <- .eval_select(data, x$choices) + idx <- .eval_select(data, x) unique(names(data)[idx]) } if (length(choices) == 0) { - stop("Can't determine choices: ", rlang::as_label(x$choices)) + stop("Can't determine choices: ", rlang::as_label(x)) } labels <- vapply( @@ -155,22 +156,20 @@ determine.values <- function(x, data, join_keys, ...) { FUN = function(choice) c(attr(data[[choice]], "label"), choice)[1], FUN.VALUE = character(1) ) - x$choices <- setNames(choices, labels) - x + setNames(choices, labels) } -.determine_selected <- function(x, data) { - if (!is.null(x$selected) && length(x$choices)) { - data <- data[x$choices] - res <- try(.eval_select(data, x$selected), silent = TRUE) - x$selected <- if (inherits(res, "try-error")) { +.determine_selected <- function(x, data, multiple) { + if (!is.null(x) && length(data)) { + res <- try(.eval_select(data, x), silent = TRUE) + x <- if (inherits(res, "try-error")) { warning("`selected` outside of possible `choices`. Emptying `selecting` field.", call. = FALSE) NULL } else { unique(names(res)) } - if (!isTRUE(x$multiple)) { - x$selected <- x$selected[1] + if (!isTRUE(multiple)) { + x <- x[1] } } x From a97a193bb50a90d2287ab625394ce962a3c1b6aa Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Mon, 8 Sep 2025 06:24:57 +0200 Subject: [PATCH 121/142] "disable" filtered choices --- R/0-module_input.R | 136 +++++++++++++++++++++++++++------------------ R/0-resolver.R | 53 ++++-------------- 2 files changed, 91 insertions(+), 98 deletions(-) diff --git a/R/0-module_input.R b/R/0-module_input.R index 6a757f82..ac12c494 100644 --- a/R/0-module_input.R +++ b/R/0-module_input.R @@ -88,57 +88,68 @@ module_input_srv.picks <- function(id, spec, data) { # todo: modify when data changes output$summary <- shiny::renderUI(badge()) - observeEvent(data(), { + Reduce( + function(data, i) { + slot_name <- names(spec)[i] + selected <- .selected_choices_srv( + id = is(spec[[slot_name]]), + x = shiny::reactive(spec_resolved()[[slot_name]]), + choices_range = reactive({ + if (inherits(data(), c("environment", "data.frame", "DataFrame"))) { + names(data()) + } else if (is.numeric(data())) { + range(data()) + } else if (is.factor(data()) || is.character(data())) { + unique(data()) + } + }) + ) - }) + # this works as follows: + # Each observer is observes input$selected of i-th element of spec ($datasets, $variables, ...) + # When i-th select input changes then + # - spec_resolved containing current state is being unresolved but only after the i-th element as + # values are sequentially dependent. For example if variables (i=2) is selected we don't want + # to unresolve (restart) dataset. + # - new value (selected) is replacing old value in current slot (i) + # - we call resolve which resolves only "unresolved" (delayed) values + # - new spec is replacing reactiveValue + # Thanks to this design reactive values are triggered only once + shiny::observeEvent( + selected(), + ignoreInit = TRUE, # because spec_resolved is a initial state + ignoreNULL = FALSE, + { + if (identical(as.vector(selected()), as.vector(spec_resolved()[[slot_name]]$selected))) { + return(NULL) + } + logger::log_info("module_input_server@1 selected has changed. Resolving downstream...") - lapply(seq_along(spec), function(i) { - slot_name <- names(spec)[i] - selected <- .selected_choices_srv( - id = is(spec[[slot_name]]), - x = shiny::reactive(spec_resolved()[[slot_name]]) - ) + new_spec_unresolved <- spec + # ↓ everything after `i` is to resolve + new_spec_unresolved[seq_len(i)] <- spec_resolved()[seq_len(i)] + new_spec_unresolved[[slot_name]]$selected <- selected() - # this works as follows: - # Each observer is observes input$selected of i-th element of spec ($datasets, $variables, ...) - # When i-th select input changes then - # - spec_resolved containing current state is being unresolved but only after the i-th element as - # values are sequentially dependent. For example if variables (i=2) is selected we don't want - # to unresolve (restart) dataset. - # - new value (selected) is replacing old value in current slot (i) - # - we call resolve which resolves only "unresolved" (delayed) values - # - new spec is replacing reactiveValue - # Thanks to this design reactive values are triggered only once - shiny::observeEvent( - selected(), - ignoreInit = TRUE, # because spec_resolved is a initial state - ignoreNULL = FALSE, - { - if (identical(as.vector(selected()), as.vector(spec_resolved()[[slot_name]]$selected))) { - return(NULL) - } - logger::log_info("module_input_server@1 selected has changed. Resolving downstream...") - - new_spec_unresolved <- spec - # ↓ everything after `i` is to resolve - new_spec_unresolved[seq_len(i)] <- spec_resolved()[seq_len(i)] - new_spec_unresolved[[slot_name]]$selected <- selected() - - resolver_warnings <- character(0) - new_spec_resolved <- withCallingHandlers( - resolver(new_spec_unresolved, data_r()), - warning = function(w) { - resolver_warnings <<- paste(conditionMessage(w), collapse = " ") + resolver_warnings <- character(0) + new_spec_resolved <- withCallingHandlers( + resolver(new_spec_unresolved, data_r()), + warning = function(w) { + resolver_warnings <<- paste(conditionMessage(w), collapse = " ") + } + ) + if (length(resolver_warnings)) { + showNotification(resolver_warnings, type = "error") } - ) - if (length(resolver_warnings)) { - showNotification(resolver_warnings, type = "error") + + spec_resolved(new_spec_resolved) } + ) - spec_resolved(new_spec_resolved) - } - ) - }) + reactive(.extract(x = isolate(spec_resolved()[[slot_name]]), data())) + }, + x = seq_along(spec), + init = data_r + ) spec_resolved }) @@ -149,7 +160,7 @@ module_input_srv.picks <- function(id, spec, data) { uiOutput(ns("selected_container")) } -.selected_choices_srv <- function(id, x) { +.selected_choices_srv <- function(id, x, choices_range) { checkmate::assert_string(id) checkmate::assert_true(is.reactive(x)) shiny::moduleServer(id, function(input, output, session) { @@ -165,21 +176,35 @@ module_input_srv.picks <- function(id, spec, data) { value = unname(x()$selected) ) } else { + # todo: provide information about data class in choices_range() so we can provide icons in the pickerInput + + missing_choices <- setdiff(x()$choices, choices_range()) + + # Reorder choices to put missing ones at the end + available_choices <- x()$choices[!unname(x()$choices) %in% missing_choices] + missing_choices_subset <- x()$choices[unname(x()$choices) %in% missing_choices] + reordered_choices <- c(available_choices, missing_choices_subset) + shinyWidgets::pickerInput( inputId = session$ns("selected"), label = paste("Select", is(x()), collapse = " "), - choices = x()$choices, + choices = reordered_choices, selected = x()$selected, multiple = attr(x(), "multiple"), choicesOpt = list( content = ifelse( # todo: add to the input choice icon = attached to choices when determine - names(x()$choices) == unname(x()$choices), - sprintf("%s", x()$choices), + names(reordered_choices) == unname(reordered_choices), + sprintf( + "%s", + ifelse(unname(reordered_choices) %in% missing_choices, ' style="opacity: 0.5;"', ""), + reordered_choices + ), sprintf( - '%s %s', - unname(x()$choices), - names(x()$choices) + '%s %s', + ifelse(unname(reordered_choices) %in% missing_choices, ' style="opacity: 0.5;"', ""), + unname(reordered_choices), + names(reordered_choices) ) ) ), @@ -189,7 +214,8 @@ module_input_srv.picks <- function(id, spec, data) { "live-search" = ifelse(length(x()$choices) > 10, TRUE, FALSE), # "max-options" = attr(x(), "max-options"), "none-selected-text" = "- Nothing selected -", - "show-subtext" = TRUE + "show-subtext" = TRUE, + "selected-text-format" = "count" ) ) } @@ -215,8 +241,8 @@ module_input_srv.picks <- function(id, spec, data) { shiny::observeEvent(input$selected_open, { if (!isTRUE(input$selection_open)) { # ↓ pickerInput returns "" when nothing selected. This can cause failure during col select (x[,""]) - new_selected <- if (length(input$selected) && !identical(input$selected, "")) input$selected - if (!identical(new_selected, selected())) { + new_selected <- if (length(input$selected) && !identical(input$selected, "")) as.vector(input$selected) + if (!setequal(new_selected, selected())) { logger::log_debug(".selected_choices_srv@2 input$selected has changed.") selected(new_selected) } diff --git a/R/0-resolver.R b/R/0-resolver.R index 9be36126..c0302960 100644 --- a/R/0-resolver.R +++ b/R/0-resolver.R @@ -85,7 +85,8 @@ determine.datasets <- function(x, data, join_keys, ...) { x$selected <- x$choices[1] } - list(x = x, data = data[[x$selected]], join_keys = join_keys[[x$selected]]) + # TODO: .raw_data doesn't contain data created in teal_transform! + list(x = x, data = data$.raw_data[[x$selected]], join_keys = join_keys[[x$selected]]) } #' @export @@ -113,7 +114,7 @@ determine.variables <- function(x, data, join_keys, ...) { x$choices <- new_choices x$selected <- new_selected - list(x = x, data = if (length(x$selected) == 1) data[[x$selected]], join_keys = join_keys) + list(x = x, data = data[[x$selected]], join_keys = join_keys) } #' @export @@ -175,46 +176,12 @@ determine.values <- function(x, data, join_keys, ...) { x } -.is_selected_equal <- function(x, y) { - all( - vapply( - seq_along(x), - FUN = function(i) { - identical(as.vector(x[[i]]$selected), as.vector(y[[i]]$selected)) - }, - FUN.VALUE = logical(1) - ) - ) -} - - -#' Internal method to extract data from different objects -#' -#' Required to resolve a specification into something usable (by comparing with the existing data). -#' Required by merging data based on a resolved specification. -#' @param x Object from which a subset/element is required. -#' @param variable Name of the element to be extracted. -#' @param ... Other arguments passed to the specific method. -#' @keywords internal -.extract <- function(x, variable, ...) { - UseMethod(".extract") -} - - -#' @export -.extract.default <- function(x, variable, ..., drop = FALSE) { - if (length(dim(x)) == 2L || length(variable) > 1L) { - x[, variable, drop = drop] - } else { - x[[variable]] - } -} - -#' @export -.extract.teal_data <- function(x, variable, ...) { - if (length(variable) > 1L) { - x[variable] - } else { - x[variable] +.extract <- function(x, data) { + if (inherits(x, "datasets")) { + data[[x$selected]] + } else if (inherits(x, "variables")) { + if (length(x$selected) == 1) { + data[[x$selected]] + } } } From 3ec348ba33f906105bcb63081f36bede21b383d2 Mon Sep 17 00:00:00 2001 From: github-actions <41898282+github-actions[bot]@users.noreply.github.com> Date: Mon, 8 Sep 2025 04:28:10 +0000 Subject: [PATCH 122/142] [skip roxygen] [skip vbump] Roxygen Man Pages Auto Update --- man/dot-extract.Rd | 20 -------------------- 1 file changed, 20 deletions(-) delete mode 100644 man/dot-extract.Rd diff --git a/man/dot-extract.Rd b/man/dot-extract.Rd deleted file mode 100644 index 12fafe73..00000000 --- a/man/dot-extract.Rd +++ /dev/null @@ -1,20 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/0-resolver.R -\name{.extract} -\alias{.extract} -\title{Internal method to extract data from different objects} -\usage{ -.extract(x, variable, ...) -} -\arguments{ -\item{x}{Object from which a subset/element is required.} - -\item{variable}{Name of the element to be extracted.} - -\item{...}{Other arguments passed to the specific method.} -} -\description{ -Required to resolve a specification into something usable (by comparing with the existing data). -Required by merging data based on a resolved specification. -} -\keyword{internal} From 7044c69a23c65263dbf3eac1ede4aa3b141af7cd Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Tue, 9 Sep 2025 17:16:51 +0200 Subject: [PATCH 123/142] push needed for POC for MDR --- NAMESPACE | 4 +- R/0-merge.R | 92 ++++++++++-------------- R/0-module_input.R | 136 ++++++++++++------------------------ R/0-module_merge.R | 4 ++ R/0-resolver.R | 3 +- man/merge_expr.Rd | 26 ------- man/module_input_ui.Rd | 11 +++ man/qenv_merge_selectors.Rd | 28 ++++++++ 8 files changed, 127 insertions(+), 177 deletions(-) delete mode 100644 man/merge_expr.Rd create mode 100644 man/module_input_ui.Rd create mode 100644 man/qenv_merge_selectors.Rd diff --git a/NAMESPACE b/NAMESPACE index 531c2724..bcbf2e88 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,7 +1,5 @@ # Generated by roxygen2: do not edit by hand -S3method(.extract,default) -S3method(.extract,teal_data) S3method(anyNA,type) S3method(data_extract_multiple_srv,FilteredData) S3method(data_extract_multiple_srv,list) @@ -83,8 +81,8 @@ export(last_choice) export(last_choices) export(list_extract_spec) export(mae_colData) +export(map_merged) export(merge_datasets) -export(merge_expr) export(merge_expression_module) export(merge_expression_srv) export(module_input_srv) diff --git a/R/0-merge.R b/R/0-merge.R index b4d93aa7..4a3155d1 100644 --- a/R/0-merge.R +++ b/R/0-merge.R @@ -1,20 +1,47 @@ #' Merge expression for selectors -#' @param selectors (`list` of `picks`) -#' @param output_name (`character(1)`) +#' @param x ([teal.data::teal_data]) +#' @param selectors (`named list` of `picks`) +#' @param output_name (`character(1)`) name of the merged dataset. #' @param join_fun (`character(1)`) name of the merge function. -#' @param join_keys (`join_keys`) +#' @param allow_cartesian (`logical(1)`) name of the merge function. #' @export -merge_expr <- function(selectors, - output_name = "merged", - join_fun = "dplyr::left_join", - join_keys, - allow_cartesian = FALSE) { - checkmate::assert_list(selectors, c("picks", "reactive")) +qenv_merge_selectors <- function(x, + selectors, + output_name = "merged", + join_fun = "dplyr::left_join", + allow_cartesian = TRUE) { + checkmate::assert_class(x, "teal_data") + checkmate::assert_list(selectors, c("picks", "reactive"), names = "named") + checkmate::assert_string(join_fun) + checkmate::assert_flag(allow_cartesian) + + merge_summary <- .merge_summary_list(selectors, join_keys = teal.data::join_keys(x)) + expr <- .merge_expr( + merge_summary = merge_summary, + output_name = output_name, + join_fun = join_fun, + allow_cartesian = allow_cartesian + ) + merged_q <- eval_code(x, expr) + teal.data::join_keys(merged_q) <- merge_summary$join_keys + merged_q +} + +#' @export +map_merged <- function(selectors, join_keys) { + .merge_summary_list(selectors, join_keys = join_keys)$mapping +} + +#' +.merge_expr <- function(merge_summary, + output_name = "merged", + join_fun = "dplyr::left_join", + allow_cartesian = FALSE) { + checkmate::assert_list(merge_summary) checkmate::assert_string(output_name) checkmate::assert_string(join_fun) - checkmate::assert_class(join_keys, "join_keys") + checkmate::assert_flag(allow_cartesian) - merge_summary <- .merge_summary_list(selectors, join_keys = join_keys) join_keys <- merge_summary$join_keys mapping <- merge_summary$mapping mapping <- lapply(mapping, function(x) { @@ -81,49 +108,6 @@ merge_expr <- function(selectors, } -merge_srv <- function(data, selectors, join_fun = "dplyr::left_join", output_name = "merged") { - checkmate::assert_class(data, "reactive") - checkmate::assert_list(selectors, "specification") - checkmate::assert_string(join_fun) - session <- shiny::getDefaultReactiveDomain() - - inputs_out <- sapply(names(selectors), USE.NAMES = TRUE, function(id) { - module_input_srv(id, spec = selectors[[id]], data = data) - }) - - selectors_r <- reactive(lapply(inputs_out, function(x) x())) - - - merged_data <- reactive({ - req(data(), selectors_r()) - expr <- merge_expr(selectors = selectors_r(), join_keys = teal.data::join_keys(data()), output_name = output_name) - teal.code::eval_code(data(), expr) - }) - - merged_data -} - -#' @export -qenv_merge_selectors <- function(x, - selectors, - output_name = "merged", - join_fun = "dplyr::left_join", - allow_cartesian = TRUE) { - expr <- merge_expr( - selectors = selectors, - output_name = output_name, - join_fun = join_fun, - join_keys = teal.data::join_keys(x), - allow_cartesian = allow_cartesian - ) - eval_code(x, expr) -} - -map_merged <- function(selectors, join_keys) { - .merge_summary_list(selectors, join_keys = join_keys)$mapping -} - - #' Analyse selectors and guess merge consequences #' #' @return list containing: diff --git a/R/0-module_input.R b/R/0-module_input.R index ac12c494..205e9582 100644 --- a/R/0-module_input.R +++ b/R/0-module_input.R @@ -1,3 +1,9 @@ +#' Module's interactive input +#' +#' @description +#' + + #' @export module_input_ui <- function(id, spec) { checkmate::assert_string(id) @@ -26,7 +32,7 @@ module_input_ui.picks <- function(id, spec) { content <- lapply(spec, function(x) .selected_choices_ui(id = ns(is(x)), x)) htmltools::tags$div( # todo: spec to have a label attribute - .badge_dropdown(ns("inputs"), label = badge_label, content = content) + teal::badge_dropdown(id = ns("inputs"), label = badge_label, htmltools::tagList(content)) ) } @@ -117,7 +123,7 @@ module_input_srv.picks <- function(id, spec, data) { # Thanks to this design reactive values are triggered only once shiny::observeEvent( selected(), - ignoreInit = TRUE, # because spec_resolved is a initial state + ignoreInit = TRUE, # because spec_resolved is already resolved and `selected()` is being set ignoreNULL = FALSE, { if (identical(as.vector(selected()), as.vector(spec_resolved()[[slot_name]]$selected))) { @@ -166,7 +172,7 @@ module_input_srv.picks <- function(id, spec, data) { shiny::moduleServer(id, function(input, output, session) { # todo: keep_order output$selected_container <- renderUI({ - if (isTRUE(attr(x(), "fixed")) || length(x()$choices) == 1) { + if (isTRUE(attr(x(), "fixed")) || length(choices_range()) == 1) { } else if (is.numeric(x()$choices)) { shinyWidgets::numericRangeInput( inputId = session$ns("range"), @@ -177,45 +183,45 @@ module_input_srv.picks <- function(id, spec, data) { ) } else { # todo: provide information about data class in choices_range() so we can provide icons in the pickerInput - missing_choices <- setdiff(x()$choices, choices_range()) + reordered_choices <- c( + x()$choices[!unname(x()$choices) %in% missing_choices], + x()$choices[unname(x()$choices) %in% missing_choices] + ) - # Reorder choices to put missing ones at the end - available_choices <- x()$choices[!unname(x()$choices) %in% missing_choices] - missing_choices_subset <- x()$choices[unname(x()$choices) %in% missing_choices] - reordered_choices <- c(available_choices, missing_choices_subset) - - shinyWidgets::pickerInput( - inputId = session$ns("selected"), - label = paste("Select", is(x()), collapse = " "), - choices = reordered_choices, - selected = x()$selected, - multiple = attr(x(), "multiple"), - choicesOpt = list( - content = ifelse( - # todo: add to the input choice icon = attached to choices when determine - names(reordered_choices) == unname(reordered_choices), - sprintf( - "%s", - ifelse(unname(reordered_choices) %in% missing_choices, ' style="opacity: 0.5;"', ""), - reordered_choices - ), - sprintf( - '%s %s', - ifelse(unname(reordered_choices) %in% missing_choices, ' style="opacity: 0.5;"', ""), - unname(reordered_choices), - names(reordered_choices) + htmltools::div( + style = "max-width: 500px;", + shinyWidgets::pickerInput( + inputId = session$ns("selected"), + label = paste("Select", is(x()), collapse = " "), + choices = reordered_choices, + selected = x()$selected, + multiple = attr(x(), "multiple"), + choicesOpt = list( + content = ifelse( + # todo: add to the input choice icon = attached to choices when determine + names(reordered_choices) == unname(reordered_choices), + sprintf( + "%s", + ifelse(unname(reordered_choices) %in% missing_choices, ' style="opacity: 0.5;"', ""), + reordered_choices + ), + sprintf( + '%s %s', + ifelse(unname(reordered_choices) %in% missing_choices, ' style="opacity: 0.5;"', ""), + unname(reordered_choices), + names(reordered_choices) + ) ) + ), + options = list( + "actions-box" = attr(x(), "multiple"), + # "allow-clear" = attr(x(), "multiple") || attr(x(), "allow-clear"), + "live-search" = ifelse(length(x()$choices) > 10, TRUE, FALSE), + # "max-options" = attr(x(), "max-options"), + "none-selected-text" = "- Nothing selected -", + "show-subtext" = TRUE ) - ), - options = list( - "actions-box" = attr(x(), "multiple"), - # "allow-clear" = attr(x(), "multiple") || attr(x(), "allow-clear"), - "live-search" = ifelse(length(x()$choices) > 10, TRUE, FALSE), - # "max-options" = attr(x(), "max-options"), - "none-selected-text" = "- Nothing selected -", - "show-subtext" = TRUE, - "selected-text-format" = "count" ) ) } @@ -252,60 +258,6 @@ module_input_srv.picks <- function(id, spec, data) { }) } -.badge_dropdown <- function(id, label, content) { - ns <- shiny::NS(id) - htmltools::tagList( - htmltools::tags$style(".choices-selected-badge-dropdown:has(~ div .shiny-validation-message) { - border-color: red !important; - }"), - htmltools::tags$div( - htmltools::tags$span( - label, - id = ns("summary_badge"), - class = "badge bg-primary choices-selected-badge-dropdown", - style = "cursor: pointer; user-select: none; border: 1px solid transparent;", - onclick = sprintf( - " - var container = document.getElementById('%s'); - var summary = document.getElementById('%s'); - - if(container.style.display === 'none' || container.style.display === '') { - container.style.display = 'block'; - - // Trigger Shiny input events to ensure renderUI gets called - $(container).trigger('shown'); - Shiny.bindAll(container); - - // Add click outside handler - setTimeout(function() { - function handleClickOutside(event) { - if (!container.contains(event.target) && !summary.contains(event.target)) { - container.style.display = 'none'; - $(container).trigger('hidden'); - document.removeEventListener('click', handleClickOutside); - } - } - document.addEventListener('click', handleClickOutside); - }, 10); - } else { - container.style.display = 'none'; - $(container).trigger('hidden'); - } - ", - ns("inputs_container"), - ns("summary_badge") - ) - ), - htmltools::tags$div( - content, - id = ns("inputs_container"), - style = "display: none; position: absolute; background: white; border: 1px solid #ccc; border-radius: 4px; box-shadow: 0 2px 10px rgba(0,0,0,0.1); padding: 10px; z-index: 1000; min-width: 200px;", - ) - ) - ) -} - - #' Restore value from bookmark. #' #' Get value from bookmark or return default. diff --git a/R/0-module_merge.R b/R/0-module_merge.R index b6c6a262..5c9a3d8a 100644 --- a/R/0-module_merge.R +++ b/R/0-module_merge.R @@ -22,6 +22,7 @@ tm_merge <- function(label = "merge-module", inputs, transformators = list()) { ), shiny::div( reactable::reactableOutput(ns("table_merged")), + shiny::verbatimTextOutput(ns("join_keys")), shiny::verbatimTextOutput(ns("mapped")), shiny::verbatimTextOutput(ns("src")) ) @@ -52,6 +53,9 @@ tm_merge <- function(label = "merge-module", inputs, transformators = list()) { teal.code::get_code(req(table_q())) ) }) + + output$join_keys <- renderPrint(teal.data::join_keys(merged_q())) + output$mapped <- renderText(yaml::as.yaml(map_merged(selectors))) }) }, diff --git a/R/0-resolver.R b/R/0-resolver.R index c0302960..c9a7942d 100644 --- a/R/0-resolver.R +++ b/R/0-resolver.R @@ -85,8 +85,7 @@ determine.datasets <- function(x, data, join_keys, ...) { x$selected <- x$choices[1] } - # TODO: .raw_data doesn't contain data created in teal_transform! - list(x = x, data = data$.raw_data[[x$selected]], join_keys = join_keys[[x$selected]]) + list(x = x, data = data[[x$selected]], join_keys = join_keys[[x$selected]]) } #' @export diff --git a/man/merge_expr.Rd b/man/merge_expr.Rd deleted file mode 100644 index de8cd28c..00000000 --- a/man/merge_expr.Rd +++ /dev/null @@ -1,26 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/0-merge.R -\name{merge_expr} -\alias{merge_expr} -\title{Merge expression for selectors} -\usage{ -merge_expr( - selectors, - output_name = "merged", - join_fun = "dplyr::left_join", - join_keys, - allow_cartesian = FALSE -) -} -\arguments{ -\item{selectors}{(\code{list} of \code{picks})} - -\item{output_name}{(\code{character(1)})} - -\item{join_fun}{(\code{character(1)}) name of the merge function.} - -\item{join_keys}{(\code{join_keys})} -} -\description{ -Merge expression for selectors -} diff --git a/man/module_input_ui.Rd b/man/module_input_ui.Rd new file mode 100644 index 00000000..3bad7883 --- /dev/null +++ b/man/module_input_ui.Rd @@ -0,0 +1,11 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/0-module_input.R +\name{module_input_ui} +\alias{module_input_ui} +\title{Module's interactive input} +\usage{ +module_input_ui(id, spec) +} +\description{ +Module's interactive input +} diff --git a/man/qenv_merge_selectors.Rd b/man/qenv_merge_selectors.Rd new file mode 100644 index 00000000..b30dc648 --- /dev/null +++ b/man/qenv_merge_selectors.Rd @@ -0,0 +1,28 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/0-merge.R +\name{qenv_merge_selectors} +\alias{qenv_merge_selectors} +\title{Merge expression for selectors} +\usage{ +qenv_merge_selectors( + x, + selectors, + output_name = "merged", + join_fun = "dplyr::left_join", + allow_cartesian = TRUE +) +} +\arguments{ +\item{x}{(\link[teal.data:teal_data]{teal.data::teal_data})} + +\item{selectors}{(\verb{named list} of \code{picks})} + +\item{output_name}{(\code{character(1)}) name of the merged dataset.} + +\item{join_fun}{(\code{character(1)}) name of the merge function.} + +\item{allow_cartesian}{(\code{logical(1)}) name of the merge function.} +} +\description{ +Merge expression for selectors +} From 4d914788ca6998c4671e31fe8f26b80b1199faba Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Fri, 12 Sep 2025 11:34:27 +0200 Subject: [PATCH 124/142] fix double precision difference between input (R>js>R conversion) and R --- R/0-module_input.R | 136 +++++++++++++++++++++------------------ R/0-resolver.R | 29 +++------ R/0-tidyselect-helpers.R | 7 -- 3 files changed, 82 insertions(+), 90 deletions(-) diff --git a/R/0-module_input.R b/R/0-module_input.R index 205e9582..10e22c0d 100644 --- a/R/0-module_input.R +++ b/R/0-module_input.R @@ -97,18 +97,11 @@ module_input_srv.picks <- function(id, spec, data) { Reduce( function(data, i) { slot_name <- names(spec)[i] + resolved_on_data <- reactive(determine(x = spec[[i]], data = data())) selected <- .selected_choices_srv( id = is(spec[[slot_name]]), x = shiny::reactive(spec_resolved()[[slot_name]]), - choices_range = reactive({ - if (inherits(data(), c("environment", "data.frame", "DataFrame"))) { - names(data()) - } else if (is.numeric(data())) { - range(data()) - } else if (is.factor(data()) || is.character(data())) { - unique(data()) - } - }) + choices_range = reactive(resolved_on_data()$x$choices) ) # this works as follows: @@ -126,7 +119,8 @@ module_input_srv.picks <- function(id, spec, data) { ignoreInit = TRUE, # because spec_resolved is already resolved and `selected()` is being set ignoreNULL = FALSE, { - if (identical(as.vector(selected()), as.vector(spec_resolved()[[slot_name]]$selected))) { + if (isTRUE(all.equal(selected(), spec_resolved()[[slot_name]]$selected, tolerance = 1e-15))) { + # tolerance 1e-15 is a max precision (significant digits) in widgets. return(NULL) } logger::log_info("module_input_server@1 selected has changed. Resolving downstream...") @@ -151,7 +145,7 @@ module_input_srv.picks <- function(id, spec, data) { } ) - reactive(.extract(x = isolate(spec_resolved()[[slot_name]]), data())) + reactive(resolved_on_data()$data) }, x = seq_along(spec), init = data_r @@ -171,77 +165,32 @@ module_input_srv.picks <- function(id, spec, data) { checkmate::assert_true(is.reactive(x)) shiny::moduleServer(id, function(input, output, session) { # todo: keep_order + selected <- shiny::reactiveVal(isolate(x())$selected) output$selected_container <- renderUI({ if (isTRUE(attr(x(), "fixed")) || length(choices_range()) == 1) { } else if (is.numeric(x()$choices)) { - shinyWidgets::numericRangeInput( - inputId = session$ns("range"), - label = paste("Select", is(x()), collapse = " "), - min = unname(x()$choices[1]), - max = unname(tail(x()$choices, 1)), - value = unname(x()$selected) - ) + .selected_choices_ui_numeric(session$ns("range"), x = x, choices_range = choices_range) } else { # todo: provide information about data class in choices_range() so we can provide icons in the pickerInput - missing_choices <- setdiff(x()$choices, choices_range()) - reordered_choices <- c( - x()$choices[!unname(x()$choices) %in% missing_choices], - x()$choices[unname(x()$choices) %in% missing_choices] - ) - - htmltools::div( - style = "max-width: 500px;", - shinyWidgets::pickerInput( - inputId = session$ns("selected"), - label = paste("Select", is(x()), collapse = " "), - choices = reordered_choices, - selected = x()$selected, - multiple = attr(x(), "multiple"), - choicesOpt = list( - content = ifelse( - # todo: add to the input choice icon = attached to choices when determine - names(reordered_choices) == unname(reordered_choices), - sprintf( - "%s", - ifelse(unname(reordered_choices) %in% missing_choices, ' style="opacity: 0.5;"', ""), - reordered_choices - ), - sprintf( - '%s %s', - ifelse(unname(reordered_choices) %in% missing_choices, ' style="opacity: 0.5;"', ""), - unname(reordered_choices), - names(reordered_choices) - ) - ) - ), - options = list( - "actions-box" = attr(x(), "multiple"), - # "allow-clear" = attr(x(), "multiple") || attr(x(), "allow-clear"), - "live-search" = ifelse(length(x()$choices) > 10, TRUE, FALSE), - # "max-options" = attr(x(), "max-options"), - "none-selected-text" = "- Nothing selected -", - "show-subtext" = TRUE - ) - ) - ) + .selected_choices_ui_categorical(session$ns("selected"), x = x, choices_range = choices_range) } }) - selected <- shiny::reactiveVal() - # todo: if only one choice then replace with the text only - # for numeric range_debounced <- reactive(input$range) |> debounce(1000) shiny::observeEvent(range_debounced(), { if (length(input$range) != 2) { return(NULL) } - if (!identical(input$range, selected())) { + if (!isTRUE(all.equal(input$range, selected(), tolerance = 1e-15))) { + # tolerance 1e-15 is a max precision (significant digits) in widgets. logger::log_debug(".selected_choices_srv@2 input$selected has changed.") selected(input$range) } }) + .selected_choices_srv_categorical("selected", x = x, choices_range = choices_range) + # for non-numeric shiny::observeEvent(input$selected_open, { @@ -258,6 +207,67 @@ module_input_srv.picks <- function(id, spec, data) { }) } + +.selected_choices_ui_numeric <- function(id, x, choices_range) { + shinyWidgets::numericRangeInput( + inputId = id, + label = paste("Select", is(x()), collapse = " "), + min = unname(x()$choices[1]), + max = unname(tail(x()$choices, 1)), + value = unname(x()$selected) + ) +} + + + +.selected_choices_ui_categorical <- function(id, x, choices_range) { + missing_choices <- setdiff(x()$choices, choices_range()) + reordered_choices <- x()$choices[order(unname(x()$choices) %in% missing_choices)] + + htmltools::div( + style = "max-width: 500px;", + shinyWidgets::pickerInput( + inputId = id, + label = paste("Select", is(x()), collapse = " "), + choices = reordered_choices, + selected = x()$selected, + multiple = attr(x(), "multiple"), + choicesOpt = list( + content = ifelse( + # todo: add to the input choice icon = attached to choices when determine + names(reordered_choices) == unname(reordered_choices), + sprintf( + "%s", + ifelse(unname(reordered_choices) %in% missing_choices, ' style="opacity: 0.5;"', ""), + reordered_choices + ), + sprintf( + '%s %s', + ifelse(unname(reordered_choices) %in% missing_choices, ' style="opacity: 0.5;"', ""), + unname(reordered_choices), + names(reordered_choices) + ) + ) + ), + options = list( + "actions-box" = attr(x(), "multiple"), + # "allow-clear" = attr(x(), "multiple") || attr(x(), "allow-clear"), + "live-search" = ifelse(length(x()$choices) > 10, TRUE, FALSE), + # "max-options" = attr(x(), "max-options"), + "none-selected-text" = "- Nothing selected -", + "show-subtext" = TRUE + ) + ) + ) +} + +.selected_choices_srv_numeric <- function(id, x, choices_range) { + +} + +.selected_choices_srv_categorical <- function(id, x, choices_range) { +} + #' Restore value from bookmark. #' #' Get value from bookmark or return default. diff --git a/R/0-resolver.R b/R/0-resolver.R index c9a7942d..0471e7cc 100644 --- a/R/0-resolver.R +++ b/R/0-resolver.R @@ -27,16 +27,14 @@ resolver <- function(x, data) { checkmate::assert_environment(data) if (is.delayed(x)) { data_i <- data - join_keys_i <- teal.data::join_keys(data) for (i in seq_along(x)) { - determined_i <- determine(x[[i]], data = data_i, join_keys = join_keys_i) + determined_i <- determine(x[[i]], data = data_i) # overwrite so that next x in line receives the corresponding data and specification if (is.null(determined_i$x)) { next } x[[i]] <- determined_i$x data_i <- determined_i$data - join_keys_i <- determined_i$join_keys } } x @@ -50,17 +48,17 @@ resolver <- function(x, data) { #' @param data The minimal data required. #' @return A list with two elements, the `type` resolved and the data extracted. #' @keywords internal -determine <- function(x, data, join_keys, ...) { +determine <- function(x, data, ...) { UseMethod("determine") } #' @export -determine.default <- function(x, data, join_keys, ...) { +determine.default <- function(x, data, ...) { stop("There is not a specific method to picks choices.") } #' @export -determine.colData <- function(x, data, join_keys, ...) { +determine.colData <- function(x, data) { if (!requireNamespace("SummarizedExperiment", quietly = TRUE)) { stop("Requires SummarizedExperiment package from Bioconductor.") } @@ -69,9 +67,8 @@ determine.colData <- function(x, data, join_keys, ...) { } #' @export -determine.datasets <- function(x, data, join_keys, ...) { +determine.datasets <- function(x, data) { checkmate::assert_environment(data) - checkmate::assert_class(join_keys, "join_keys") if (is.null(data)) { return(list(x = x, data = NULL)) } else if (!inherits(data, "qenv")) { @@ -85,13 +82,12 @@ determine.datasets <- function(x, data, join_keys, ...) { x$selected <- x$choices[1] } - list(x = x, data = data[[x$selected]], join_keys = join_keys[[x$selected]]) + list(x = x, data = data[[x$selected]]) } #' @export -determine.variables <- function(x, data, join_keys, ...) { +determine.variables <- function(x, data) { checkmate::assert_multi_class(data, c("data.frame", "tbl_df", "data.table", "DataFrame")) - checkmate::assert_list(join_keys, null.ok = TRUE) if (is.null(data)) { return(list(x = x, data = NULL)) @@ -101,23 +97,16 @@ determine.variables <- function(x, data, join_keys, ...) { stop("Can't pull variable: No variable is available.") } - # ↓ see ?tidyselectors - for (join_keys_i in join_keys) { - for (key_column in names(join_keys_i)) { - attr(data[[key_column]], "join_key") <- TRUE - } - } - new_choices <- .determine_choices(x$choices, data = data) new_selected <- .determine_selected(x$selected, data = data[new_choices], multiple = x$multiple) x$choices <- new_choices x$selected <- new_selected - list(x = x, data = data[[x$selected]], join_keys = join_keys) + list(x = x, data = data[[x$selected]]) } #' @export -determine.values <- function(x, data, join_keys, ...) { +determine.values <- function(x, data) { if (is.character(data) || is.factor(data)) { d <- data names(d) <- data diff --git a/R/0-tidyselect-helpers.R b/R/0-tidyselect-helpers.R index 2921ab22..8b01d85e 100644 --- a/R/0-tidyselect-helpers.R +++ b/R/0-tidyselect-helpers.R @@ -16,13 +16,6 @@ # during eval_select. # - having predicates to be utilized by `tidyselect::where` is `tidyselect` compatible and more predictable - -#' @rdname tidyselectors -#' @export -is_key <- function() { - where(function(x) isTRUE(attr(x, "join_key"))) -} - #' @rdname tidyselectors #' @param min.len (`integer(1)`) minimal number of unique values #' @param max.len (`integer(1)`) maximal number of unique values From d1406e1294a4d6e4ad0cbce669a86d375907e3d7 Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Fri, 12 Sep 2025 16:23:57 +0200 Subject: [PATCH 125/142] choices/selected reactive to data --- R/0-module_input.R | 216 ++++++++++++++++++++++++++------------------- 1 file changed, 123 insertions(+), 93 deletions(-) diff --git a/R/0-module_input.R b/R/0-module_input.R index 10e22c0d..28f7715e 100644 --- a/R/0-module_input.R +++ b/R/0-module_input.R @@ -29,7 +29,7 @@ module_input_ui.picks <- function(id, spec) { ns <- shiny::NS(id) badge_label <- shiny::uiOutput(ns("summary"), container = htmltools::tags$span) # todo: icon or color to indicate a column class - content <- lapply(spec, function(x) .selected_choices_ui(id = ns(is(x)), x)) + content <- lapply(spec, function(x) .selected_choices_ui(id = ns(is(x)))) htmltools::tags$div( # todo: spec to have a label attribute teal::badge_dropdown(id = ns("inputs"), label = badge_label, htmltools::tagList(content)) @@ -96,56 +96,45 @@ module_input_srv.picks <- function(id, spec, data) { Reduce( function(data, i) { - slot_name <- names(spec)[i] - resolved_on_data <- reactive(determine(x = spec[[i]], data = data())) - selected <- .selected_choices_srv( - id = is(spec[[slot_name]]), - x = shiny::reactive(spec_resolved()[[slot_name]]), - choices_range = reactive(resolved_on_data()$x$choices) + choices <- reactiveVal(isolate(spec_resolved())[[i]]$choices) + selected <- reactiveVal(isolate(spec_resolved())[[i]]$selected) + all_choices <- reactive(determine(x = spec[[i]], data = data())$x$choices) + + observeEvent(all_choices(), ignoreInit = TRUE, { + if (!all(spec_resolved()[[i]]$selected %in% all_choices())) { + logger::log_debug("module_input_srv@1 selected is outside of the possible choices for { names(spec)[i] }") + .update_rv(selected, intersect(spec_resolved()[[i]]$selected, all_choices())) + } + if (!isTRUE(all.equal(spec_resolved()[[i]]$choices, all_choices()))) { + logger::log_debug("module_input_srv@1 choices are outside of the possible choices for { names(spec)[i] }") + .update_rv(choices, all_choices()) + } + }) + + observeEvent(spec_resolved()[[i]], ignoreInit = TRUE, { + .update_rv(choices, spec_resolved()[[i]]$choices) + .update_rv(selected, spec_resolved()[[i]]$selected) + }) + + args <- attributes(spec[[i]]) + .selected_choices_srv( + id = is(spec[[i]]), + type = is(spec[[i]]), + choices = choices, + selected = selected, + args = args[!names(args) %in% c("names", "class")] ) # this works as follows: # Each observer is observes input$selected of i-th element of spec ($datasets, $variables, ...) - # When i-th select input changes then - # - spec_resolved containing current state is being unresolved but only after the i-th element as - # values are sequentially dependent. For example if variables (i=2) is selected we don't want - # to unresolve (restart) dataset. - # - new value (selected) is replacing old value in current slot (i) - # - we call resolve which resolves only "unresolved" (delayed) values - # - new spec is replacing reactiveValue - # Thanks to this design reactive values are triggered only once shiny::observeEvent( selected(), ignoreInit = TRUE, # because spec_resolved is already resolved and `selected()` is being set - ignoreNULL = FALSE, - { - if (isTRUE(all.equal(selected(), spec_resolved()[[slot_name]]$selected, tolerance = 1e-15))) { - # tolerance 1e-15 is a max precision (significant digits) in widgets. - return(NULL) - } - logger::log_info("module_input_server@1 selected has changed. Resolving downstream...") - - new_spec_unresolved <- spec - # ↓ everything after `i` is to resolve - new_spec_unresolved[seq_len(i)] <- spec_resolved()[seq_len(i)] - new_spec_unresolved[[slot_name]]$selected <- selected() - - resolver_warnings <- character(0) - new_spec_resolved <- withCallingHandlers( - resolver(new_spec_unresolved, data_r()), - warning = function(w) { - resolver_warnings <<- paste(conditionMessage(w), collapse = " ") - } - ) - if (length(resolver_warnings)) { - showNotification(resolver_warnings, type = "error") - } - - spec_resolved(new_spec_resolved) - } + ignoreNULL = FALSE, # because input$selected can be empty + .resolve(selected(), slot_idx = i, spec_resolved = spec_resolved, old_spec = spec, data = data_r()) ) - reactive(resolved_on_data()$data) + reactive(.extract(x = isolate(spec_resolved()[[i]]), data())) }, x = seq_along(spec), init = data_r @@ -155,24 +144,37 @@ module_input_srv.picks <- function(id, spec, data) { }) } -.selected_choices_ui <- function(id, x) { +.selected_choices_ui <- function(id) { ns <- shiny::NS(id) uiOutput(ns("selected_container")) } -.selected_choices_srv <- function(id, x, choices_range) { +.selected_choices_srv <- function(id, type, choices, selected, args) { checkmate::assert_string(id) - checkmate::assert_true(is.reactive(x)) + checkmate::assert_class(choices, "reactiveVal") + checkmate::assert_class(selected, "reactiveVal") + checkmate::assert_list(args) + shiny::moduleServer(id, function(input, output, session) { # todo: keep_order - selected <- shiny::reactiveVal(isolate(x())$selected) output$selected_container <- renderUI({ - if (isTRUE(attr(x(), "fixed")) || length(choices_range()) == 1) { - } else if (is.numeric(x()$choices)) { - .selected_choices_ui_numeric(session$ns("range"), x = x, choices_range = choices_range) + if (isTRUE(args$fixed) || length(choices()) == 1) { + } else if (is.numeric(choices())) { + .selected_choices_ui_numeric(session$ns("range"), + type = type, + choices = choices(), + selected = selected(), + args = args + ) } else { - # todo: provide information about data class in choices_range() so we can provide icons in the pickerInput - .selected_choices_ui_categorical(session$ns("selected"), x = x, choices_range = choices_range) + # todo: provide information about data class so we can provide icons in the pickerInput + .selected_choices_ui_categorical( + session$ns("selected"), + type = type, + choices = choices(), + selected = selected(), + args = args + ) } }) @@ -182,16 +184,9 @@ module_input_srv.picks <- function(id, spec, data) { if (length(input$range) != 2) { return(NULL) } - if (!isTRUE(all.equal(input$range, selected(), tolerance = 1e-15))) { - # tolerance 1e-15 is a max precision (significant digits) in widgets. - logger::log_debug(".selected_choices_srv@2 input$selected has changed.") - selected(input$range) - } + .update_rv(selected, input$range) }) - .selected_choices_srv_categorical("selected", x = x, choices_range = choices_range) - - # for non-numeric shiny::observeEvent(input$selected_open, { if (!isTRUE(input$selection_open)) { @@ -207,53 +202,42 @@ module_input_srv.picks <- function(id, spec, data) { }) } - -.selected_choices_ui_numeric <- function(id, x, choices_range) { +.selected_choices_ui_numeric <- function(id, type, choices, selected, args) { shinyWidgets::numericRangeInput( inputId = id, - label = paste("Select", is(x()), collapse = " "), - min = unname(x()$choices[1]), - max = unname(tail(x()$choices, 1)), - value = unname(x()$selected) + label = paste("Select", type, collapse = " "), + min = unname(choices[1]), + max = unname(tail(choices, 1)), + value = unname(selected) ) } - - -.selected_choices_ui_categorical <- function(id, x, choices_range) { - missing_choices <- setdiff(x()$choices, choices_range()) - reordered_choices <- x()$choices[order(unname(x()$choices) %in% missing_choices)] - +.selected_choices_ui_categorical <- function(id, type, choices, selected, args) { htmltools::div( style = "max-width: 500px;", shinyWidgets::pickerInput( inputId = id, - label = paste("Select", is(x()), collapse = " "), - choices = reordered_choices, - selected = x()$selected, - multiple = attr(x(), "multiple"), + label = paste("Select", type, collapse = " "), + choices = choices, + selected = selected, + multiple = args$multiple, choicesOpt = list( content = ifelse( # todo: add to the input choice icon = attached to choices when determine - names(reordered_choices) == unname(reordered_choices), - sprintf( - "%s", - ifelse(unname(reordered_choices) %in% missing_choices, ' style="opacity: 0.5;"', ""), - reordered_choices - ), + names(choices) == unname(choices), + sprintf("%s", choices), sprintf( - '%s %s', - ifelse(unname(reordered_choices) %in% missing_choices, ' style="opacity: 0.5;"', ""), - unname(reordered_choices), - names(reordered_choices) + '%s %s', + unname(choices), + names(choices) ) ) ), options = list( - "actions-box" = attr(x(), "multiple"), - # "allow-clear" = attr(x(), "multiple") || attr(x(), "allow-clear"), - "live-search" = ifelse(length(x()$choices) > 10, TRUE, FALSE), - # "max-options" = attr(x(), "max-options"), + "actions-box" = args$multiple, + # "allow-clear" = args$multiple || args$`allow-clear`, + "live-search" = length(choices) > 10, + # "max-options" = args$`max-options`, "none-selected-text" = "- Nothing selected -", "show-subtext" = TRUE ) @@ -261,13 +245,59 @@ module_input_srv.picks <- function(id, spec, data) { ) } -.selected_choices_srv_numeric <- function(id, x, choices_range) { - +.update_rv <- function(rv, value, log) { + if (!isTRUE(all.equal(rv(), value, tolerance = 1e-15))) { + # tolerance 1e-15 is a max precision (significant digits) in widgets. + rv(value) + } } -.selected_choices_srv_categorical <- function(id, x, choices_range) { -} +#' Resolve downstream after selected changes +#' +#' @description +#' When i-th select input changes then +#' - spec_resolved containing current state is being unresolved but only after the i-th element as +#' values are sequentially dependent. For example if variables (i=2) is selected we don't want +#' to unresolve (restart) dataset. +#' - new value (selected) is replacing old value in current slot (i) +#' - we call resolve which resolves only "unresolved" (delayed) values +#' - new spec is replacing reactiveValue +#' Thanks to this design reactive values are triggered only once +#' @param selected (`vector`) rather `character`, or `factor`. `numeric(2)` for `values()` based on numeric column. +#' @param slot_idx (`integer`) +#' @param spec_resolved (`reactiveVal`) +#' @param old_spec (`picks`) +#' @param data (`any` asserted further in `resolver`) +#' @keywords internal +.resolve <- function(selected, slot_idx, spec_resolved, old_spec, data) { + checkmate::assert_atomic_vector(selected) + checkmate::assert_integerish(slot_idx, lower = 1) + checkmate::assert_class(spec_resolved, "reactiveVal") + checkmate::assert_class(old_spec, "picks") + + if (isTRUE(all.equal(selected, spec_resolved()[[slot_idx]]$selected, tolerance = 1e-15))) { + return(NULL) + } + logger::log_info("module_input_server@1 selected has changed. Resolving downstream...") + + new_spec_unresolved <- old_spec + # ↓ everything after `slot_idx` is to resolve + new_spec_unresolved[seq_len(slot_idx - 1)] <- spec_resolved()[seq_len(slot_idx - 1)] + new_spec_unresolved[[slot_idx]]$selected <- selected + + resolver_warnings <- character(0) + new_spec_resolved <- withCallingHandlers( + resolver(new_spec_unresolved, data), + warning = function(w) { + resolver_warnings <<- paste(conditionMessage(w), collapse = " ") + } + ) + if (length(resolver_warnings)) { + showNotification(resolver_warnings, type = "error") + } + spec_resolved(new_spec_resolved) +} #' Restore value from bookmark. #' #' Get value from bookmark or return default. From 677d0cc3957209cb4a452ecd5597e4ccecd67a53 Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Mon, 15 Sep 2025 15:00:52 +0200 Subject: [PATCH 126/142] sealing up reactive mechanism --- NAMESPACE | 1 - R/0-module_input.R | 39 ++++++++++++++++++++++++--------------- inst/refactor-notes.Rmd | 1 + man/determine.Rd | 2 +- man/dot-resolve.Rd | 33 +++++++++++++++++++++++++++++++++ man/tidyselectors.Rd | 3 --- 6 files changed, 59 insertions(+), 20 deletions(-) create mode 100644 man/dot-resolve.Rd diff --git a/NAMESPACE b/NAMESPACE index bcbf2e88..900ea2c2 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -75,7 +75,6 @@ export(get_relabel_call) export(is.choices_selected) export(is.delayed) export(is_categorical) -export(is_key) export(is_single_dataset) export(last_choice) export(last_choices) diff --git a/R/0-module_input.R b/R/0-module_input.R index 28f7715e..beb30dca 100644 --- a/R/0-module_input.R +++ b/R/0-module_input.R @@ -101,19 +101,31 @@ module_input_srv.picks <- function(id, spec, data) { all_choices <- reactive(determine(x = spec[[i]], data = data())$x$choices) observeEvent(all_choices(), ignoreInit = TRUE, { - if (!all(spec_resolved()[[i]]$selected %in% all_choices())) { - logger::log_debug("module_input_srv@1 selected is outside of the possible choices for { names(spec)[i] }") - .update_rv(selected, intersect(spec_resolved()[[i]]$selected, all_choices())) + current_choices <- spec_resolved()[[i]]$choices + current_selected <- spec_resolved()[[i]]$selected + + unavailable_selected <- setdiff(current_selected, all_choices()) + if (length(unavailable_selected)) { + log <- sprintf( + "module_input_srv@1 %s$%s$selected is outside of the possible choices: %s", + id, names(spec)[i], toString(unavailable_selected) + ) + .update_rv(selected, intersect(spec_resolved()[[i]]$selected, all_choices()), log) } - if (!isTRUE(all.equal(spec_resolved()[[i]]$choices, all_choices()))) { - logger::log_debug("module_input_srv@1 choices are outside of the possible choices for { names(spec)[i] }") - .update_rv(choices, all_choices()) + + unavailable_choices <- setdiff(current_choices, all_choices()) + if (length(unavailable_choices)) { + log <- sprintf( + "module_input_srv@1 %s$%s$choices is outside of the possible choices: %s", + id, names(spec)[i], toString(unavailable_choices) + ) + .update_rv(choices, all_choices(), log) } }) observeEvent(spec_resolved()[[i]], ignoreInit = TRUE, { - .update_rv(choices, spec_resolved()[[i]]$choices) - .update_rv(selected, spec_resolved()[[i]]$selected) + .update_rv(choices, spec_resolved()[[i]]$choices, log = "module_input_srv@1 update input choices") + .update_rv(selected, spec_resolved()[[i]]$selected, log = "module_input_srv@1 update input selected") }) args <- attributes(spec[[i]]) @@ -184,7 +196,7 @@ module_input_srv.picks <- function(id, spec, data) { if (length(input$range) != 2) { return(NULL) } - .update_rv(selected, input$range) + .update_rv(selected, input$range, log = ".selected_choices_srv@1 update selected after input changed") }) # for non-numeric @@ -192,10 +204,7 @@ module_input_srv.picks <- function(id, spec, data) { if (!isTRUE(input$selection_open)) { # ↓ pickerInput returns "" when nothing selected. This can cause failure during col select (x[,""]) new_selected <- if (length(input$selected) && !identical(input$selected, "")) as.vector(input$selected) - if (!setequal(new_selected, selected())) { - logger::log_debug(".selected_choices_srv@2 input$selected has changed.") - selected(new_selected) - } + .update_rv(selected, new_selected, log = ".selected_choices_srv@1 update selected after input changed") } }) selected @@ -246,8 +255,8 @@ module_input_srv.picks <- function(id, spec, data) { } .update_rv <- function(rv, value, log) { - if (!isTRUE(all.equal(rv(), value, tolerance = 1e-15))) { - # tolerance 1e-15 is a max precision (significant digits) in widgets. + if (!isTRUE(all.equal(rv(), value, tolerance = 1e-15))) { # tolerance 1e-15 is a max precision in widgets. + logger::log_debug(log) rv(value) } } diff --git a/inst/refactor-notes.Rmd b/inst/refactor-notes.Rmd index bf6a9744..bdbbdd39 100644 --- a/inst/refactor-notes.Rmd +++ b/inst/refactor-notes.Rmd @@ -189,3 +189,4 @@ get_outputs(data_w_plot)[[1]] # Handling ambiguous variables + diff --git a/man/determine.Rd b/man/determine.Rd index 9a0aa23a..97f71e1e 100644 --- a/man/determine.Rd +++ b/man/determine.Rd @@ -4,7 +4,7 @@ \alias{determine} \title{A method that should take a type and resolve it.} \usage{ -determine(x, data, join_keys, ...) +determine(x, data, ...) } \arguments{ \item{x}{The specification to resolve.} diff --git a/man/dot-resolve.Rd b/man/dot-resolve.Rd new file mode 100644 index 00000000..d4993330 --- /dev/null +++ b/man/dot-resolve.Rd @@ -0,0 +1,33 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/0-module_input.R +\name{.resolve} +\alias{.resolve} +\title{Resolve downstream after selected changes} +\usage{ +.resolve(selected, slot_idx, spec_resolved, old_spec, data) +} +\arguments{ +\item{selected}{(\code{vector}) rather \code{character}, or \code{factor}. \code{numeric(2)} for \code{values()} based on numeric column.} + +\item{slot_idx}{(\code{integer})} + +\item{spec_resolved}{(\code{reactiveVal})} + +\item{old_spec}{(\code{picks})} + +\item{data}{(\code{any} asserted further in \code{resolver})} +} +\description{ +@description +When i-th select input changes then +\itemize{ +\item spec_resolved containing current state is being unresolved but only after the i-th element as +values are sequentially dependent. For example if variables (i=2) is selected we don't want +to unresolve (restart) dataset. +\item new value (selected) is replacing old value in current slot (i) +\item we call resolve which resolves only "unresolved" (delayed) values +\item new spec is replacing reactiveValue +Thanks to this design reactive values are triggered only once +} +} +\keyword{internal} diff --git a/man/tidyselectors.Rd b/man/tidyselectors.Rd index 88fe05d7..9b552d4f 100644 --- a/man/tidyselectors.Rd +++ b/man/tidyselectors.Rd @@ -2,13 +2,10 @@ % Please edit documentation in R/0-tidyselect-helpers.R \name{tidyselectors} \alias{tidyselectors} -\alias{is_key} \alias{is_categorical} \alias{no_more_choices_than} \title{\code{tidyselect} helpers} \usage{ -is_key() - is_categorical(max.len, min.len) no_more_choices_than(max.len) From 5815d267abb3803b3773af30a5639e8ff7bab46e Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Wed, 17 Sep 2025 07:22:27 +0200 Subject: [PATCH 127/142] fix bug when numeric range is change outside of the transformer (eg filter panel) --- R/0-module_input.R | 31 +++++++++++++++---------------- R/0-resolver.R | 12 ++++++------ 2 files changed, 21 insertions(+), 22 deletions(-) diff --git a/R/0-module_input.R b/R/0-module_input.R index beb30dca..e4663c35 100644 --- a/R/0-module_input.R +++ b/R/0-module_input.R @@ -103,24 +103,23 @@ module_input_srv.picks <- function(id, spec, data) { observeEvent(all_choices(), ignoreInit = TRUE, { current_choices <- spec_resolved()[[i]]$choices current_selected <- spec_resolved()[[i]]$selected + .update_rv( + selected, + if (is.numeric(all_choices())) { + all_choices() + } else { + intersect(spec_resolved()[[i]]$selected, all_choices()) + }, + sprintf("module_input_srv@1 %s$%s$selected is outside of the possible choices", id, names(spec)[i]) + ) - unavailable_selected <- setdiff(current_selected, all_choices()) - if (length(unavailable_selected)) { - log <- sprintf( - "module_input_srv@1 %s$%s$selected is outside of the possible choices: %s", - id, names(spec)[i], toString(unavailable_selected) - ) - .update_rv(selected, intersect(spec_resolved()[[i]]$selected, all_choices()), log) - } - - unavailable_choices <- setdiff(current_choices, all_choices()) - if (length(unavailable_choices)) { - log <- sprintf( - "module_input_srv@1 %s$%s$choices is outside of the possible choices: %s", - id, names(spec)[i], toString(unavailable_choices) + .update_rv( + choices, + all_choices(), + sprintf( + "module_input_srv@1 %s$%s$choices is outside of the possible choices", id, names(spec)[i] ) - .update_rv(choices, all_choices(), log) - } + ) }) observeEvent(spec_resolved()[[i]], ignoreInit = TRUE, { diff --git a/R/0-resolver.R b/R/0-resolver.R index 0471e7cc..cf0f737c 100644 --- a/R/0-resolver.R +++ b/R/0-resolver.R @@ -82,7 +82,7 @@ determine.datasets <- function(x, data) { x$selected <- x$choices[1] } - list(x = x, data = data[[x$selected]]) + list(x = x, data = .extract(x, data)) } #' @export @@ -102,7 +102,7 @@ determine.variables <- function(x, data) { x$choices <- new_choices x$selected <- new_selected - list(x = x, data = data[[x$selected]]) + list(x = x, data = .extract(x, data)) } #' @export @@ -165,10 +165,10 @@ determine.values <- function(x, data) { } .extract <- function(x, data) { - if (inherits(x, "datasets")) { - data[[x$selected]] - } else if (inherits(x, "variables")) { - if (length(x$selected) == 1) { + if (length(x$selected) == 1) { + if (inherits(x, "datasets")) { + data[[x$selected]] + } else if (inherits(x, "variables")) { data[[x$selected]] } } From e4e2b36d7bd832be28720a9e5f4728fb1114939e Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Tue, 23 Sep 2025 07:07:12 +0200 Subject: [PATCH 128/142] minor errors --- R/0-assert.R | 14 ------- R/0-module_input.R | 1 + R/0-resolver.R | 57 ++++++++++++-------------- R/0-to_picks.R | 50 +++++++++++------------ R/call_utils.R | 2 +- tests/testthat/0-to_picks.R | 80 +++++++++++++++++++++++++++++++++++-- 6 files changed, 128 insertions(+), 76 deletions(-) delete mode 100644 R/0-assert.R diff --git a/R/0-assert.R b/R/0-assert.R deleted file mode 100644 index 84786abd..00000000 --- a/R/0-assert.R +++ /dev/null @@ -1,14 +0,0 @@ -assert_picks <- function(x) { - -} - -assert_variables <- function(x, multiple, .var.name = checkmate::vname(x)) { - if (!inherits(x, "variables")) { - stop(.var.name, " should be of class variables") - } - - checkmate::assert_flag(multiple) - if (!missing(multiple) && !identical(isTRUE(attr(x, "multiple")), multiple)) { - stop(.var.name, " should have a property multiple = `", multiple, "`.") - } -} diff --git a/R/0-module_input.R b/R/0-module_input.R index e4663c35..16263f76 100644 --- a/R/0-module_input.R +++ b/R/0-module_input.R @@ -106,6 +106,7 @@ module_input_srv.picks <- function(id, spec, data) { .update_rv( selected, if (is.numeric(all_choices())) { + # todo: implement Date and POSIXct as well all_choices() } else { intersect(spec_resolved()[[i]]$selected, all_choices()) diff --git a/R/0-resolver.R b/R/0-resolver.R index cf0f737c..2f859e21 100644 --- a/R/0-resolver.R +++ b/R/0-resolver.R @@ -74,14 +74,13 @@ determine.datasets <- function(x, data) { } else if (!inherits(data, "qenv")) { stop("Please use qenv() or teal_data() objects.") } - x$choices <- .determine_choices(x$choices, data = data) - x$selected <- .determine_selected(x$selected, data = data[x$choices], multiple = x$multiple) - - if (length(x$selected) != 1) { - warning("`dataset` must be a single selection. Forcing to first possible choice.") - x$selected <- x$choices[1] - } + x$choices <- .determine_choices(x$choices, data = data) + x$selected <- .determine_selected( + x$selected, + data = data[intersect(x$choices, names(data))], + multiple = attr(x, "multiple") + ) list(x = x, data = .extract(x, data)) } @@ -94,13 +93,15 @@ determine.variables <- function(x, data) { } if (ncol(data) <= 0L) { - stop("Can't pull variable: No variable is available.") + stop("Can't pull variable: No variables is available.") } - new_choices <- .determine_choices(x$choices, data = data) - new_selected <- .determine_selected(x$selected, data = data[new_choices], multiple = x$multiple) - x$choices <- new_choices - x$selected <- new_selected + x$choices <- .determine_choices(x$choices, data = data) + x$selected <- .determine_selected( + x$selected, + data = data[intersect(x$choices, colnames(data))], + multiple = attr(x, "multiple") + ) list(x = x, data = .extract(x, data)) } @@ -108,34 +109,26 @@ determine.variables <- function(x, data) { #' @export determine.values <- function(x, data) { if (is.character(data) || is.factor(data)) { - d <- data - names(d) <- data - # todo: replace with NextMethod? - x$choices <- unique(names(.eval_select(d, x$choices))) - names(x$choices) <- x$choices - if (length(x$choices)) { - x$selected <- unique(names(.eval_select(x$choices, x$selected))) - } else { - x$selected <- NULL + d <- unique(data) + x$choices <- .determine_choices(x$choices, data = setNames(d, d)) # .determine_* uses names + x$selected <- if (length(x$choices)) { + .determine_selected(x$selected, data = setNames(x$choices, x$choices), multiple = attr(x, "multiple")) } - list(x = x) # nothing more after this (no need to pass data further) - } else if (is.numeric(data)) { - x$choices <- range(data) - x$selected <- if (is.numeric(x$selected)) x$selected else x$choices + } else if (is.numeric(data) || inherits(data, c("Date", "POSIXct"))) { + x$choices <- range(data, na.rm = TRUE) + x$selected <- if (is.numeric(x$selected) || inherits(data, c("Date", "POSIXct"))) x$selected else x$choices list(x = x) } } .determine_choices <- function(x, data) { - choices <- if (inherits(x, "delayed_data")) { - x$subset(data) - } else if (is.character(x)) { - x - } else { - idx <- .eval_select(data, x) - unique(names(data)[idx]) + if (is.character(x) && length(x)) { + return(x) } + + idx <- .eval_select(data, x) + choices <- unique(names(data)[idx]) if (length(choices) == 0) { stop("Can't determine choices: ", rlang::as_label(x)) } diff --git a/R/0-to_picks.R b/R/0-to_picks.R index 2f2c2de2..294252cb 100644 --- a/R/0-to_picks.R +++ b/R/0-to_picks.R @@ -1,3 +1,9 @@ +to_picks <- function(x, dataname) { + if (checkmate::test_list(x, "data_extract_spec")) { + + } +} + des_to_picks <- function(x) { if (inherits(x, "picks")) { x @@ -7,9 +13,9 @@ des_to_picks <- function(x) { list( datasets(choices = x$dataname, fixed = TRUE), select_spec_to_variables(x$select) - # don't use filter_spec as they doesn't have to be linked with selected variables + # don't use filter_spec as they are not necessary linked with `select` (selected variables) # as filter_spec can be speciefied on the variable(s) different than select_spec for example: - # (pseudocode) select_spec(AVAL); filter_spec(PARAMCD, AVISIT) + # for example: #pseudocode select = select_spec(AVAL); filter = filter_spec(PARAMCD)) ) ) do.call(picks, args) @@ -28,27 +34,21 @@ select_spec_to_variables <- function(x) { } } - -extract_filters <- function(selectors) { - unlist( - lapply(selectors, function(des) { - if (checkmate::test_list(des, "data_extract_spec")) { - unlist(extract_filters(des), recursive = FALSE) - } else if (inherits(des, "data_extract_spec")) { - filter <- if (inherits(des$filter, "filter_spec")) { - list(des$filter) - } else { - des$filter - } - lapply(filter, function(x) { - picks( - datasets(choices = des$dataname, selected = des$dataname), - variables(choices = x$vars_choices, selected = x$vars_selected, multiple = FALSE), - values(choices = x$choices, selected = x$selected, multiple = x$multiple) - ) - }) - } - }), - recursive = FALSE - ) +extract_filters <- function(elem, dataname) { + if (inherits(elem, "filter_spec")) { + picks( + datasets(choices = dataname, selected = dataname), + variables(choices = elem$vars_choices, selected = elem$vars_selected, multiple = FALSE), # can't be multiple + values(choices = elem$choices, selected = elem$selected, multiple = elem$multiple) + ) + } else if (checkmate::test_list(elem, "filter_spec")) { + lapply(elem, extract_filters, dataname = dataname) + } else if (inherits(elem, "data_extract_spec")) { + extract_filters(elem$filter, dataname = elem$dataname) + } else if (checkmate::test_list(elem, c("data_extract_spec", "list", "NULL"))) { + unlist( + lapply(Filter(length, elem), extract_filters), + recursive = FALSE + ) + } } diff --git a/R/call_utils.R b/R/call_utils.R index dd79b5c0..fca29b9b 100644 --- a/R/call_utils.R +++ b/R/call_utils.R @@ -385,7 +385,7 @@ calls_combine_by <- function(operator, calls) { str2lang("dplyr::select"), str2lang(dataname) ), - lapply(unname(variables), str2lang) + lapply(unname(variables), as.name) ) ) } diff --git a/tests/testthat/0-to_picks.R b/tests/testthat/0-to_picks.R index d2abb342..7dab4ca6 100644 --- a/tests/testthat/0-to_picks.R +++ b/tests/testthat/0-to_picks.R @@ -8,7 +8,8 @@ testthat::test_that("to_picks converts eager select_spec to variables without or ordered = TRUE, always_selected = "AGE" ) - out <- select_spec_to_values(test) + + out <- select_spec_to_variables(test) testthat::expect_s3_class(out, "variables") testthat::expect_identical(out$choices, unclass(test$choices)) testthat::expect_identical(out$selected, unclass(test$selected)) @@ -27,13 +28,84 @@ testthat::test_that("to_picks converts delayed select_spec to variables preservi always_selected = "AGE" ) - out <- suppressWarnings(select_spec_to_values(test)) + out <- suppressWarnings(select_spec_to_variables(test)) testthat::expect_s3_class(out, "variables") testthat::expect_s3_class(out$choices, "delayed_data") testthat::expect_identical(out$selected, "AVISIT") testthat::expect_identical( - determine(out, data = rADRS, join_keys = join_keys())$x, - variables(choices = subset_fun(rADRS), selected = subset_fun(rADRS)[1]) + determine(out, data = rADRS)$x, + determine(variables(choices = subset_fun(rADRS), selected = "AVISIT"), data = rADRS)$x + ) +}) + +testthat::test_that("extract_filters pulls converts filter_spec to picks with value", { + des <- data_extract_spec( + dataname = "ADLB", + filter = list( + filter_spec( + vars = "PARAMCD", + choices = value_choices(data$ADLB, "PARAMCD", "PARAM"), + selected = levels(data$ADLB$PARAMCD)[1], + multiple = FALSE, + label = "Select lab:" + ), + filter_spec( + vars = "AVISIT", + choices = levels(data$ADLB$AVISIT), + selected = levels(data$ADLB$AVISIT)[1], + multiple = FALSE, + label = "Select visit:" + ) + ) + ) + + + extract_filters(des) +}) + + +testthat::test_that("to_picks", { + des <- list( + data_extract_spec( + dataname = "ADSL", + select = select_spec( + choices = variable_choices(data$ADSL), + selected = "AGE", + multiple = FALSE, + fixed = FALSE + ) + ), + data_extract_spec( + dataname = "ADLB", + select = select_spec( + choices = variable_choices(data$ADLB, c("AVAL", "CHG", "PCHG", "ANRIND", "BASE")), + selected = "AVAL", + multiple = FALSE, + fixed = FALSE + ), + filter = list( + filter_spec( + vars = "PARAMCD", + choices = value_choices(data$ADLB, "PARAMCD", "PARAM"), + selected = levels(data$ADLB$PARAMCD)[1], + multiple = FALSE, + label = "Select lab:" + ), + filter_spec( + vars = "AVISIT", + choices = levels(data$ADLB$AVISIT), + selected = levels(data$ADLB$AVISIT)[1], + multiple = FALSE, + label = "Select visit:" + ) + ) + ) ) + + to_picks() }) + +# can't convert list(data_extract_spec("ADSL", ...), data_extract_spec("ADTTE", ...)) reliably +# to picks as picks can't conditionally determine next step based on the dataset selection +# From 8b33a3473c51bde459f813df69f90a7c9afad3a3 Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Tue, 23 Sep 2025 15:51:08 +0200 Subject: [PATCH 129/142] WIP --- R/0-merge.R | 239 ----------------------------------------- R/0-module_input.R | 84 +++++++-------- R/0-module_merge.R | 259 +++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 301 insertions(+), 281 deletions(-) delete mode 100644 R/0-merge.R diff --git a/R/0-merge.R b/R/0-merge.R deleted file mode 100644 index 4a3155d1..00000000 --- a/R/0-merge.R +++ /dev/null @@ -1,239 +0,0 @@ -#' Merge expression for selectors -#' @param x ([teal.data::teal_data]) -#' @param selectors (`named list` of `picks`) -#' @param output_name (`character(1)`) name of the merged dataset. -#' @param join_fun (`character(1)`) name of the merge function. -#' @param allow_cartesian (`logical(1)`) name of the merge function. -#' @export -qenv_merge_selectors <- function(x, - selectors, - output_name = "merged", - join_fun = "dplyr::left_join", - allow_cartesian = TRUE) { - checkmate::assert_class(x, "teal_data") - checkmate::assert_list(selectors, c("picks", "reactive"), names = "named") - checkmate::assert_string(join_fun) - checkmate::assert_flag(allow_cartesian) - - merge_summary <- .merge_summary_list(selectors, join_keys = teal.data::join_keys(x)) - expr <- .merge_expr( - merge_summary = merge_summary, - output_name = output_name, - join_fun = join_fun, - allow_cartesian = allow_cartesian - ) - merged_q <- eval_code(x, expr) - teal.data::join_keys(merged_q) <- merge_summary$join_keys - merged_q -} - -#' @export -map_merged <- function(selectors, join_keys) { - .merge_summary_list(selectors, join_keys = join_keys)$mapping -} - -#' -.merge_expr <- function(merge_summary, - output_name = "merged", - join_fun = "dplyr::left_join", - allow_cartesian = FALSE) { - checkmate::assert_list(merge_summary) - checkmate::assert_string(output_name) - checkmate::assert_string(join_fun) - checkmate::assert_flag(allow_cartesian) - - join_keys <- merge_summary$join_keys - mapping <- merge_summary$mapping - mapping <- lapply(mapping, function(x) { - # because we need `$new_name = $old_name` to rename in select call - x$variables <- stats::setNames(names(x$variables), unname(x$variables)) - x - }) - datanames <- unique(unlist(lapply(mapping, `[[`, "datasets"))) - calls <- expression() - anl_datanames <- character(0) # to follow what anl is composed of (to determine keys) - anl_primary_keys <- character(0) # to determine accumulated keys of a merged dataset - for (i in seq_along(datanames)) { - dataname <- datanames[i] - this_mapping <- Filter(function(x) x$datasets == dataname, mapping) - this_filter_mapping <- Filter(function(x) { - "values" %in% names(x) - }, this_mapping) - this_foreign_keys <- .fk(join_keys, dataname) - this_primary_keys <- join_keys[dataname, dataname] - this_variables <- c( - this_foreign_keys, - unlist(lapply(unname(this_mapping), `[[`, "variables")) - ) - this_variables <- this_variables[!duplicated(unname(this_variables))] # because unique drops names - - # todo: extract call is datasets (class, class) specific - this_call <- .call_dplyr_select(dataname = dataname, variables = this_variables) - if (length(this_filter_mapping)) { - this_call <- calls_combine_by("%>%", c(this_call, .call_dplyr_filter(this_filter_mapping))) - } - - if (i > 1) { - merge_keys <- join_keys["anl", dataname] - if (!length(merge_keys)) { - msg <- sprintf( - "Merge is not possible. No join_keys between %s and any of %s", - sQuote(dataname), - sQuote(toString(anl_datanames)) - ) - stop(msg, call. = FALSE) - next - } - anl_vs_this <- setdiff(anl_primary_keys, this_primary_keys) - this_vs_anl <- setdiff(this_primary_keys, anl_primary_keys) - if (length(anl_vs_this) && length(this_vs_anl) && !allow_cartesian) { - validate(need(FALSE, "cartesian join")) # todo: add more info - } - this_call <- as.call( - list( - str2lang(join_fun), - y = this_call, - by = merge_keys, - suffix = c("", sprintf("_%s", dataname)) - ) - ) - } - - anl_datanames <- c(anl_datanames, dataname) - anl_primary_keys <- union(anl_primary_keys, this_primary_keys) - calls <- c(calls, this_call) - } - - call("<-", str2lang(output_name), calls_combine_by("%>%", calls)) -} - - -#' Analyse selectors and guess merge consequences -#' -#' @return list containing: -#' - mapping (`named list`) containing selected values in each selector. This `mapping` -#' is sorted according to correct datasets merge order. -#' - join_keys (`join_keys`) updated `join_keys` containing keys of `ANL` -#' -#' @keywords internal -.merge_summary_list <- function(selectors, join_keys) { - checkmate::assert_list(selectors, c("picks", "reactive")) - if (missing(join_keys)) { - join_keys <- Reduce( - function(all, this) c(all, attr(this, "join_keys")), - x = selectors, - init = teal.data::join_keys() - ) - } - - mapping <- lapply( # what has been selected in each selector - selectors, - function(x) { - obj <- if (is.reactive(x)) x() else x - selected <- lapply(obj, function(x) stats::setNames(x$selected, x$selected)) - } - ) - mapped_datanames <- unlist(lapply(mapping, `[[`, "datasets"), use.names = FALSE) - mapping_by_dataset <- split(mapping, mapped_datanames) - - datanames <- unique(mapped_datanames) - if (length(datanames) > 1) { - # datanames are handed over in order of selectors but - # they must be in topological order - otherwise join might not be possible - datanames <- c( - intersect(names(join_keys), datanames), - setdiff(datanames, names(join_keys)) # non-joinable datasets at the end - ) - - # mapping will be reused so needs to be reordered as well - mapping <- mapping[order(match(mapped_datanames, datanames))] - } - remaining_datanames <- datanames - join_keys <- join_keys[datanames] - anl_colnames <- character(0) - for (dataname in datanames) { - # glossary: - # dataset/dataname: dataset (or its name) in the current iteration (datasets are merged in a loop) - # anl datasets/datanames: datasets (or names) which anl is composed of (this is a cumulative process) - # remaining datasets/datanames: datasets (or names) which are about to be merged - # - # Rules: - # 1. anl "inherits" foreign keys from anl datasets to remaining datasets - # 2. foreign keys of current dataset are added to anl join_keys but only if no relation from anl already. - # 3. foreign keys should be renamed if duplicated with anl colnames - # 4. (for later) selected datasets might not be directly mergable, we need to find the "path" which - # will probably involve add intermediate datasets in between to perform merge - # 5. selected variables are added to anl. - # 6. duplicated variables added to anl should be renamed - remaining_datanames <- setdiff(remaining_datanames, dataname) - - # todo: if this dataset has no join_keys to anl (anl_datasets) then error saying - # can't merge {dataset} with merged dataset composed of {anl_datasets} - - # ↓ 1. anl "inherits" foreign keys from anl datasets to remaining datasets - this_join_keys <- do.call( - teal.data::join_keys, - lapply( - remaining_datanames, - function(dataset_2) { - new_keys <- join_keys[dataname, dataset_2] - # ↓ 2. foreign keys of current dataset are added to anl join_keys but only if no relation from anl already - if (length(new_keys) && !dataset_2 %in% names(join_keys[["anl"]])) { - # ↓ 3. foreign keys should be renamed if duplicated with anl colnames - new_key_names <- .suffix_duplicated_vars( - vars = names(new_keys), # names because we change the key of dataset_1 (not dataset_2) - all_vars = anl_colnames, - suffix = dataname - ) - names(new_keys) <- new_key_names - join_key(dataset_1 = "anl", dataset_2 = dataset_2, keys = new_keys) - } - } - ) - ) - join_keys <- c(this_join_keys, join_keys) - - - mapping_ds <- mapping_by_dataset[[dataname]] - mapping_ds <- lapply(mapping_ds, function(x) { - new_vars <- .suffix_duplicated_vars( - # is dropped by merge call. We should refer this selected foreign-key-variable - # to equivalent key variable added in previous iteration (existing anl foreign key) - # 6. duplicated variables added to anl should be renamed - vars = x$variables, - all_vars = anl_colnames, - suffix = dataname - ) - - # if foreign key of this dataset is selected and if this foreign key took a part in the merge - # then this key is dropped and we need to refer to the first variable - existing_fk <- join_keys[dataname, "anl"] # keys that are already in anl - existing_fk_selected <- intersect(names(existing_fk), x$variables) - new_vars[existing_fk_selected] <- existing_fk[existing_fk_selected] - x$variables <- new_vars - x - }) - mapping[names(mapping_ds)] <- mapping_ds - - this_colnames <- unique(unlist(lapply(mapping_ds, `[[`, "variables"))) - anl_colnames <- c(anl_colnames, this_colnames) - - anl_colnames <- union(anl_colnames, .fk(join_keys, "anl")) - } - - - list(mapping = mapping, join_keys = join_keys) -} - -.fk <- function(x, dataname) { - this_jk <- x[[dataname]] - unique(unlist(lapply(this_jk[!names(this_jk) %in% dataname], names))) -} - -.suffix_duplicated_vars <- function(vars, all_vars, suffix) { - idx_duplicated <- vars %in% all_vars - if (any(idx_duplicated)) { - vars[idx_duplicated] <- sprintf("%s_%s", vars[idx_duplicated], suffix) - } - vars -} diff --git a/R/0-module_input.R b/R/0-module_input.R index 16263f76..87c2eb29 100644 --- a/R/0-module_input.R +++ b/R/0-module_input.R @@ -32,6 +32,7 @@ module_input_ui.picks <- function(id, spec) { content <- lapply(spec, function(x) .selected_choices_ui(id = ns(is(x)))) htmltools::tags$div( # todo: spec to have a label attribute + # todo: badge to have css attribute to control the size - make CSS rule - can be controlled globally and module-ly teal::badge_dropdown(id = ns("inputs"), label = badge_label, htmltools::tagList(content)) ) } @@ -55,44 +56,37 @@ module_input_srv.list <- function(id, spec, data) { #' @export module_input_srv.picks <- function(id, spec, data) { moduleServer(id, function(input, output, session) { - attr(spec, ".callback") <- reactiveVal(NULL) # callback to be used outside - data_r <- shiny::reactive(if (shiny::is.reactive(data)) data() else data) spec_resolved <- shiny::reactiveVal( restoreValue( - session$ns("selectors"), + session$ns("picks"), resolver(spec, shiny::isolate(data_r())) ) ) session$onBookmark(function(state) { - logger::log_debug("module_input_srv@onBookmark: storing current selectors") - state$values$selectors <- spec_resolved() + logger::log_debug("module_input_srv@onBookmark: storing current picks") + state$values$picks <- spec_resolved() }) # join_keys are needed to variables after merge - attr(spec_resolved, "join_keys") <- teal.data::join_keys(shiny::isolate(data_r())) # todo: do the same as with .callback + attr(spec_resolved, "join_keys") <- teal.data::join_keys(shiny::isolate(data_r())) badge <- shiny::reactive({ - tagList( - lapply( - spec_resolved(), - function(x) { - if (inherits(x, "values")) { - if (!identical(as.vector(x$choices), as.vector(x$selected))) { - bsicons::bs_icon("funnel") - } - } else if (length(x$selected)) { - toString(x$selected) - } else { - "~" - } + lapply( + spec_resolved(), + function(x) { + label <- if (length(x$selected)) { + toString(x$selected) + } else { + "~" } - ) + label + } ) }) # todo: modify when data changes - output$summary <- shiny::renderUI(badge()) + output$summary <- shiny::renderUI(tagList(badge())) Reduce( function(data, i) { @@ -104,22 +98,12 @@ module_input_srv.picks <- function(id, spec, data) { current_choices <- spec_resolved()[[i]]$choices current_selected <- spec_resolved()[[i]]$selected .update_rv( - selected, - if (is.numeric(all_choices())) { - # todo: implement Date and POSIXct as well - all_choices() - } else { - intersect(spec_resolved()[[i]]$selected, all_choices()) - }, + selected, .intersect(current_selected, all_choices()), sprintf("module_input_srv@1 %s$%s$selected is outside of the possible choices", id, names(spec)[i]) ) - .update_rv( - choices, - all_choices(), - sprintf( - "module_input_srv@1 %s$%s$choices is outside of the possible choices", id, names(spec)[i] - ) + choices, all_choices(), + sprintf("module_input_srv@1 %s$%s$choices is outside of the possible choices", id, names(spec)[i]) ) }) @@ -170,10 +154,13 @@ module_input_srv.picks <- function(id, spec, data) { shiny::moduleServer(id, function(input, output, session) { # todo: keep_order output$selected_container <- renderUI({ + logger::log_debug(".selected_choices_srv@1 rerender input") if (isTRUE(args$fixed) || length(choices()) == 1) { + } else if (is.numeric(choices())) { - .selected_choices_ui_numeric(session$ns("range"), - type = type, + .selected_choices_ui_numeric( + session$ns("range"), + label = sprintf("Select %s range:", type), choices = choices(), selected = selected(), args = args @@ -182,7 +169,7 @@ module_input_srv.picks <- function(id, spec, data) { # todo: provide information about data class so we can provide icons in the pickerInput .selected_choices_ui_categorical( session$ns("selected"), - type = type, + label = sprintf("Select %s:", type), choices = choices(), selected = selected(), args = args @@ -196,7 +183,7 @@ module_input_srv.picks <- function(id, spec, data) { if (length(input$range) != 2) { return(NULL) } - .update_rv(selected, input$range, log = ".selected_choices_srv@1 update selected after input changed") + .update_rv(selected, input$range, log = ".selected_choices_srv@2 update selected after input changed") }) # for non-numeric @@ -211,22 +198,22 @@ module_input_srv.picks <- function(id, spec, data) { }) } -.selected_choices_ui_numeric <- function(id, type, choices, selected, args) { +.selected_choices_ui_numeric <- function(id, label, choices, selected, args) { shinyWidgets::numericRangeInput( inputId = id, - label = paste("Select", type, collapse = " "), + label = label, min = unname(choices[1]), max = unname(tail(choices, 1)), value = unname(selected) ) } -.selected_choices_ui_categorical <- function(id, type, choices, selected, args) { +.selected_choices_ui_categorical <- function(id, label, choices, selected, args) { htmltools::div( style = "max-width: 500px;", shinyWidgets::pickerInput( inputId = id, - label = paste("Select", type, collapse = " "), + label = label, choices = choices, selected = selected, multiple = args$multiple, @@ -307,6 +294,7 @@ module_input_srv.picks <- function(id, spec, data) { spec_resolved(new_spec_resolved) } + #' Restore value from bookmark. #' #' Get value from bookmark or return default. @@ -343,3 +331,15 @@ restoreValue <- function(value, default) { # nolint: object_name. default } } + + +.intersect <- function(x, y) { + if (is.numeric(x) && is.numeric(y)) { + c( + max(x[1], y[1], na.rm = TRUE), + min(x[2], y[2], na.rm = TRUE) + ) + } else { + intersect(x, y) + } +} diff --git a/R/0-module_merge.R b/R/0-module_merge.R index 5c9a3d8a..fec4293d 100644 --- a/R/0-module_merge.R +++ b/R/0-module_merge.R @@ -64,3 +64,262 @@ tm_merge <- function(label = "merge-module", inputs, transformators = list()) { transformators = transformators ) } + + + +#' @export +merge_srv <- function(id, selectors, data, output_name = "merged", join_fun = "dplyr::left_join") { + moduleServer(id, function(input, output, session) { + merged_q <- reactive({ + req(data()) + qenv_merge_selectors(data(), selectors = selectors, output_name = output_name, join_fun = join_fun) + }) + merge_vars <- reactive(lapply(map_merged(selectors), function(x) x$variables)) + + vars_origins <- reactive( + lapply(selectors, function(x) { + lapply(x(), `[[`, "selected") + }) + ) + list( + data = merged_q, + merge_vars = merge_vars, + vars_origins = vars_origins + ) + }) +} + + +#' Merge expression for selectors +#' @param x ([teal.data::teal_data]) +#' @param selectors (`named list` of `picks`) +#' @param output_name (`character(1)`) name of the merged dataset. +#' @param join_fun (`character(1)`) name of the merge function. +#' @export +qenv_merge_selectors <- function(x, + selectors, + output_name = "merged", + join_fun = "dplyr::left_join") { + checkmate::assert_class(x, "teal_data") + checkmate::assert_list(selectors, c("picks", "reactive"), names = "named") + checkmate::assert_string(join_fun) + + merge_summary <- .merge_summary_list(selectors, join_keys = teal.data::join_keys(x)) + expr <- .merge_expr( + merge_summary = merge_summary, + output_name = output_name, + join_fun = join_fun + ) + merged_q <- eval_code(x, expr) + teal.data::join_keys(merged_q) <- merge_summary$join_keys + merged_q +} + +#' @export +map_merged <- function(selectors, join_keys) { + .merge_summary_list(selectors, join_keys = join_keys)$mapping +} + +#' +.merge_expr <- function(merge_summary, + output_name = "merged", + join_fun = "dplyr::left_join") { + checkmate::assert_list(merge_summary) + checkmate::assert_string(output_name) + checkmate::assert_string(join_fun) + + join_keys <- merge_summary$join_keys + mapping <- merge_summary$mapping + mapping <- lapply(mapping, function(x) { + # because we need `$new_name = $old_name` to rename in select call + x$variables <- stats::setNames(names(x$variables), unname(x$variables)) + x + }) + datanames <- unique(unlist(lapply(mapping, `[[`, "datasets"))) + calls <- expression() + anl_datanames <- character(0) # to follow what anl is composed of (to determine keys) + anl_primary_keys <- character(0) # to determine accumulated keys of a merged dataset + for (i in seq_along(datanames)) { + dataname <- datanames[i] + this_mapping <- Filter(function(x) x$datasets == dataname, mapping) + this_filter_mapping <- Filter(function(x) { + "values" %in% names(x) + }, this_mapping) + this_foreign_keys <- .fk(join_keys, dataname) + this_primary_keys <- join_keys[dataname, dataname] + this_variables <- c( + this_foreign_keys, + unlist(lapply(unname(this_mapping), `[[`, "variables")) + ) + this_variables <- this_variables[!duplicated(unname(this_variables))] # because unique drops names + + # todo: extract call is datasets (class, class) specific + this_call <- .call_dplyr_select(dataname = dataname, variables = this_variables) + if (length(this_filter_mapping)) { + this_call <- calls_combine_by("%>%", c(this_call, .call_dplyr_filter(this_filter_mapping))) + } + + if (i > 1) { + merge_keys <- join_keys["anl", dataname] + if (!length(merge_keys)) { + msg <- sprintf( + "Merge is not possible. No join_keys between %s and any of %s", + sQuote(dataname), + sQuote(toString(anl_datanames)) + ) + stop(msg, call. = FALSE) + next + } + anl_vs_this <- setdiff(anl_primary_keys, this_primary_keys) + this_vs_anl <- setdiff(this_primary_keys, anl_primary_keys) + if (length(anl_vs_this) && length(this_vs_anl)) { + # validate(need(FALSE, "cartesian join")) # todo: add more info + } + this_call <- as.call( + list( + str2lang(join_fun), + y = this_call, + by = merge_keys, + suffix = c("", sprintf("_%s", dataname)) + ) + ) + } + + anl_datanames <- c(anl_datanames, dataname) + anl_primary_keys <- union(anl_primary_keys, this_primary_keys) + calls <- c(calls, this_call) + } + + call("<-", str2lang(output_name), calls_combine_by("%>%", calls)) +} + + +#' Analyse selectors and guess merge consequences +#' +#' @return list containing: +#' - mapping (`named list`) containing selected values in each selector. This `mapping` +#' is sorted according to correct datasets merge order. +#' - join_keys (`join_keys`) updated `join_keys` containing keys of `ANL` +#' +#' @keywords internal +.merge_summary_list <- function(selectors, join_keys) { + checkmate::assert_list(selectors, c("picks", "reactive")) + if (missing(join_keys)) { + join_keys <- Reduce( + function(all, this) c(all, attr(this, "join_keys")), + x = selectors, + init = teal.data::join_keys() + ) + } + + mapping <- lapply( # what has been selected in each selector + selectors, + function(x) { + obj <- if (is.reactive(x)) x() else x + selected <- lapply(obj, function(x) stats::setNames(x$selected, x$selected)) + } + ) + mapped_datanames <- unlist(lapply(mapping, `[[`, "datasets"), use.names = FALSE) + mapping_by_dataset <- split(mapping, mapped_datanames) + + datanames <- unique(mapped_datanames) + if (length(datanames) > 1) { + # datanames are handed over in order of selectors but + # they must be in topological order - otherwise join might not be possible + datanames <- c( + intersect(names(join_keys), datanames), + setdiff(datanames, names(join_keys)) # non-joinable datasets at the end + ) + + # mapping will be reused so needs to be reordered as well + mapping <- mapping[order(match(mapped_datanames, datanames))] + } + remaining_datanames <- datanames + join_keys <- join_keys[datanames] + anl_colnames <- character(0) + for (dataname in datanames) { + # glossary: + # dataset/dataname: dataset (or its name) in the current iteration (datasets are merged in a loop) + # anl datasets/datanames: datasets (or names) which anl is composed of (this is a cumulative process) + # remaining datasets/datanames: datasets (or names) which are about to be merged + # + # Rules: + # 1. anl "inherits" foreign keys from anl datasets to remaining datasets + # 2. foreign keys of current dataset are added to anl join_keys but only if no relation from anl already. + # 3. foreign keys should be renamed if duplicated with anl colnames + # 4. (for later) selected datasets might not be directly mergable, we need to find the "path" which + # will probably involve add intermediate datasets in between to perform merge + # 5. selected variables are added to anl. + # 6. duplicated variables added to anl should be renamed + remaining_datanames <- setdiff(remaining_datanames, dataname) + + # todo: if this dataset has no join_keys to anl (anl_datasets) then error saying + # can't merge {dataset} with merged dataset composed of {anl_datasets} + + # ↓ 1. anl "inherits" foreign keys from anl datasets to remaining datasets + this_join_keys <- do.call( + teal.data::join_keys, + lapply( + remaining_datanames, + function(dataset_2) { + new_keys <- join_keys[dataname, dataset_2] + # ↓ 2. foreign keys of current dataset are added to anl join_keys but only if no relation from anl already + if (length(new_keys) && !dataset_2 %in% names(join_keys[["anl"]])) { + # ↓ 3. foreign keys should be renamed if duplicated with anl colnames + new_key_names <- .suffix_duplicated_vars( + vars = names(new_keys), # names because we change the key of dataset_1 (not dataset_2) + all_vars = anl_colnames, + suffix = dataname + ) + names(new_keys) <- new_key_names + join_key(dataset_1 = "anl", dataset_2 = dataset_2, keys = new_keys) + } + } + ) + ) + join_keys <- c(this_join_keys, join_keys) + + + mapping_ds <- mapping_by_dataset[[dataname]] + mapping_ds <- lapply(mapping_ds, function(x) { + new_vars <- .suffix_duplicated_vars( + # is dropped by merge call. We should refer this selected foreign-key-variable + # to equivalent key variable added in previous iteration (existing anl foreign key) + # 6. duplicated variables added to anl should be renamed + vars = x$variables, + all_vars = anl_colnames, + suffix = dataname + ) + + # if foreign key of this dataset is selected and if this foreign key took a part in the merge + # then this key is dropped and we need to refer to the first variable + existing_fk <- join_keys[dataname, "anl"] # keys that are already in anl + existing_fk_selected <- intersect(names(existing_fk), x$variables) + new_vars[existing_fk_selected] <- existing_fk[existing_fk_selected] + x$variables <- new_vars + x + }) + mapping[names(mapping_ds)] <- mapping_ds + + this_colnames <- unique(unlist(lapply(mapping_ds, `[[`, "variables"))) + anl_colnames <- c(anl_colnames, this_colnames) + + anl_colnames <- union(anl_colnames, .fk(join_keys, "anl")) + } + + + list(mapping = mapping, join_keys = join_keys) +} + +.fk <- function(x, dataname) { + this_jk <- x[[dataname]] + unique(unlist(lapply(this_jk[!names(this_jk) %in% dataname], names))) +} + +.suffix_duplicated_vars <- function(vars, all_vars, suffix) { + idx_duplicated <- vars %in% all_vars + if (any(idx_duplicated)) { + vars[idx_duplicated] <- sprintf("%s_%s", vars[idx_duplicated], suffix) + } + vars +} From db9d038aadc669a17658a0a87fd6f36c537dd8f5 Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Wed, 24 Sep 2025 13:57:56 +0200 Subject: [PATCH 130/142] POC1 --- NAMESPACE | 1 + R/0-module_input.R | 3 +-- R/0-teal.transform_wrappers.R | 34 ---------------------------------- R/0-types.R | 4 ++-- man/dot-merge_summary_list.Rd | 2 +- man/qenv_merge_selectors.Rd | 7 ++----- 6 files changed, 7 insertions(+), 44 deletions(-) delete mode 100644 R/0-teal.transform_wrappers.R diff --git a/NAMESPACE b/NAMESPACE index 900ea2c2..19a365a9 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -84,6 +84,7 @@ export(map_merged) export(merge_datasets) export(merge_expression_module) export(merge_expression_srv) +export(merge_srv) export(module_input_srv) export(module_input_ui) export(no_more_choices_than) diff --git a/R/0-module_input.R b/R/0-module_input.R index 87c2eb29..a445937a 100644 --- a/R/0-module_input.R +++ b/R/0-module_input.R @@ -266,7 +266,7 @@ module_input_srv.picks <- function(id, spec, data) { #' @param data (`any` asserted further in `resolver`) #' @keywords internal .resolve <- function(selected, slot_idx, spec_resolved, old_spec, data) { - checkmate::assert_atomic_vector(selected) + checkmate::assert_vector(selected, null.ok = TRUE) checkmate::assert_integerish(slot_idx, lower = 1) checkmate::assert_class(spec_resolved, "reactiveVal") checkmate::assert_class(old_spec, "picks") @@ -332,7 +332,6 @@ restoreValue <- function(value, default) { # nolint: object_name. } } - .intersect <- function(x, y) { if (is.numeric(x) && is.numeric(y)) { c( diff --git a/R/0-teal.transform_wrappers.R b/R/0-teal.transform_wrappers.R deleted file mode 100644 index c52fc568..00000000 --- a/R/0-teal.transform_wrappers.R +++ /dev/null @@ -1,34 +0,0 @@ -teal_transform_filter <- function(x, label = "Filter") { - checkmate::assert_class(x, "picks") - checkmate::assert_true("values" %in% names(x)) - - teal_transform_module( - label = label, - ui <- function(id) { - ns <- NS(id) - module_input_ui(ns("transformer"), spec = x) - }, - server <- function(id, data) { - moduleServer(id, function(input, output, session) { - selector <- module_input_srv("transformer", spec = x, data = data) - - reactive({ - req(data(), selector()) - teal.code::eval_code(data(), .make_filter_call(selector())) - }) - }) - } - ) -} - -.make_filter_call <- function(x) { - checkmate::assert_class(x, "picks") - substitute( - dataname <- dplyr::filter(dataname, varname %in% values), - list( - dataname = str2lang(x$datasets$selected), - varname = str2lang(x$variables$selected), - values = x$values$selected - ) - ) -} diff --git a/R/0-types.R b/R/0-types.R index 28edb789..4c274ccb 100644 --- a/R/0-types.R +++ b/R/0-types.R @@ -42,10 +42,10 @@ picks <- function(...) { checkmate::assert_list(picks, types = "type") names(picks) <- vapply(picks, FUN = is, FUN.VALUE = character(1)) for (i in seq_along(picks)) { - if (isTRUE(picks[[i]]$multiple) && i < length(picks)) { + if (isTRUE(attr(picks[[i]], "multiple")) && i < length(picks)) { stop( names(picks)[i], " has a property `multiple = TRUE` which is forbidden if there are any following elements", - "depending on its selection." + " depending on its selection." ) } } diff --git a/man/dot-merge_summary_list.Rd b/man/dot-merge_summary_list.Rd index 7dba0256..4f4441c8 100644 --- a/man/dot-merge_summary_list.Rd +++ b/man/dot-merge_summary_list.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/0-merge.R +% Please edit documentation in R/0-module_merge.R \name{.merge_summary_list} \alias{.merge_summary_list} \title{Analyse selectors and guess merge consequences} diff --git a/man/qenv_merge_selectors.Rd b/man/qenv_merge_selectors.Rd index b30dc648..f2e4a55c 100644 --- a/man/qenv_merge_selectors.Rd +++ b/man/qenv_merge_selectors.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/0-merge.R +% Please edit documentation in R/0-module_merge.R \name{qenv_merge_selectors} \alias{qenv_merge_selectors} \title{Merge expression for selectors} @@ -8,8 +8,7 @@ qenv_merge_selectors( x, selectors, output_name = "merged", - join_fun = "dplyr::left_join", - allow_cartesian = TRUE + join_fun = "dplyr::left_join" ) } \arguments{ @@ -20,8 +19,6 @@ qenv_merge_selectors( \item{output_name}{(\code{character(1)}) name of the merged dataset.} \item{join_fun}{(\code{character(1)}) name of the merge function.} - -\item{allow_cartesian}{(\code{logical(1)}) name of the merge function.} } \description{ Merge expression for selectors From 905c7876228d850b8a8616aa3971838409003706 Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Wed, 24 Sep 2025 15:09:35 +0200 Subject: [PATCH 131/142] don't trigger when changing selection --- R/0-module_input.R | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/R/0-module_input.R b/R/0-module_input.R index a445937a..ce4707f9 100644 --- a/R/0-module_input.R +++ b/R/0-module_input.R @@ -153,11 +153,13 @@ module_input_srv.picks <- function(id, spec, data) { shiny::moduleServer(id, function(input, output, session) { # todo: keep_order + + is_numeric <- reactive(is.numeric(choices())) + output$selected_container <- renderUI({ - logger::log_debug(".selected_choices_srv@1 rerender input") + logger::log_debug(".selected_choices_srv@1 rerender {type} input") if (isTRUE(args$fixed) || length(choices()) == 1) { - - } else if (is.numeric(choices())) { + } else if (is_numeric()) { .selected_choices_ui_numeric( session$ns("range"), label = sprintf("Select %s range:", type), @@ -166,7 +168,7 @@ module_input_srv.picks <- function(id, spec, data) { args = args ) } else { - # todo: provide information about data class so we can provide icons in the pickerInput + # todo: provide information about choices() class so we can provide icons in the pickerInput .selected_choices_ui_categorical( session$ns("selected"), label = sprintf("Select %s:", type), @@ -175,7 +177,7 @@ module_input_srv.picks <- function(id, spec, data) { args = args ) } - }) + }) |> bindEvent(is_numeric(), choices()) # never change on selected() # for numeric range_debounced <- reactive(input$range) |> debounce(1000) @@ -270,7 +272,6 @@ module_input_srv.picks <- function(id, spec, data) { checkmate::assert_integerish(slot_idx, lower = 1) checkmate::assert_class(spec_resolved, "reactiveVal") checkmate::assert_class(old_spec, "picks") - if (isTRUE(all.equal(selected, spec_resolved()[[slot_idx]]$selected, tolerance = 1e-15))) { return(NULL) } From 5bde18ed0eea70255cf3f254c147ec16fb562a28 Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Wed, 24 Sep 2025 15:43:58 +0200 Subject: [PATCH 132/142] value(selected = everything) by default --- R/0-types.R | 4 ++-- man/types.Rd | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/R/0-types.R b/R/0-types.R index 4c274ccb..8f522379 100644 --- a/R/0-types.R +++ b/R/0-types.R @@ -102,8 +102,8 @@ variables <- function(choices = tidyselect::everything(), #' @describeIn types Specify variables. #' @export values <- function(choices = tidyselect::everything(), - selected = 1, - multiple = !.is_tidyselect(selected) && length(selected) > 1, + selected = tidyselect::everything(), + multiple = TRUE, fixed = !.is_tidyselect(choices) && length(choices) == 1, ...) { out <- .selected_choices( diff --git a/man/types.Rd b/man/types.Rd index b80c2cbb..70c2a9db 100644 --- a/man/types.Rd +++ b/man/types.Rd @@ -28,8 +28,8 @@ variables( values( choices = tidyselect::everything(), - selected = 1, - multiple = !.is_tidyselect(selected) && length(selected) > 1, + selected = tidyselect::everything(), + multiple = TRUE, fixed = !.is_tidyselect(choices) && length(choices) == 1, ... ) From 67493a7e30c71181c70740d5f33a376325b43d50 Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Fri, 26 Sep 2025 13:15:52 +0200 Subject: [PATCH 133/142] implement keep_order --- R/0-module_input.R | 5 +++-- R/{0-types.R => 0-picks.R} | 4 ++++ 2 files changed, 7 insertions(+), 2 deletions(-) rename R/{0-types.R => 0-picks.R} (96%) diff --git a/R/0-module_input.R b/R/0-module_input.R index ce4707f9..e4e6e395 100644 --- a/R/0-module_input.R +++ b/R/0-module_input.R @@ -152,8 +152,6 @@ module_input_srv.picks <- function(id, spec, data) { checkmate::assert_list(args) shiny::moduleServer(id, function(input, output, session) { - # todo: keep_order - is_numeric <- reactive(is.numeric(choices())) output$selected_container <- renderUI({ @@ -193,6 +191,9 @@ module_input_srv.picks <- function(id, spec, data) { if (!isTRUE(input$selection_open)) { # ↓ pickerInput returns "" when nothing selected. This can cause failure during col select (x[,""]) new_selected <- if (length(input$selected) && !identical(input$selected, "")) as.vector(input$selected) + if (args$keep_order) { + new_selected <- c(intersect(selected(), new_selected), setdiff(new_selected, selected())) + } .update_rv(selected, new_selected, log = ".selected_choices_srv@1 update selected after input changed") } }) diff --git a/R/0-types.R b/R/0-picks.R similarity index 96% rename from R/0-types.R rename to R/0-picks.R index 8f522379..3f0b1e74 100644 --- a/R/0-types.R +++ b/R/0-picks.R @@ -7,6 +7,8 @@ #' One unquoted expression to be used to picks from choices to be selected. #' @param multiple <`logical(1)`> if more than one selection is possible. #' @param fixed <`logical(1)`> selection will be fixed and not possible to change interactively. +#' @param keep_order <`logical(1)`> if the selected should follow the selection order. If `FALSE` +#' `selected` returned from `srv_module_input()` would be ordered according to order in `choices`. #' @param ... additional arguments delivered to `pickerInput` #' #' @returns `picks` object containing specified settings @@ -87,12 +89,14 @@ variables <- function(choices = tidyselect::everything(), selected = 1, multiple = !.is_tidyselect(selected) && length(selected) > 1, fixed = !.is_tidyselect(choices) && length(choices) == 1, + keep_order = FALSE, ...) { out <- .selected_choices( choices = if (.is_tidyselect(choices)) rlang::enquo(choices) else choices, selected = if (.is_tidyselect(selected)) rlang::enquo(selected) else selected, multiple = multiple, fixed = fixed, + keep_order = keep_order, ... ) class(out) <- c("variables", class(out)) From 764333d235c0d7444f9b99d84b115e8fb74c3a07 Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Wed, 1 Oct 2025 14:44:56 +0200 Subject: [PATCH 134/142] allow-empty --- R/0-module_input.R | 6 ++---- R/0-picks.R | 3 +++ R/0-resolver.R | 2 ++ 3 files changed, 7 insertions(+), 4 deletions(-) diff --git a/R/0-module_input.R b/R/0-module_input.R index e4e6e395..40eaeb49 100644 --- a/R/0-module_input.R +++ b/R/0-module_input.R @@ -153,7 +153,6 @@ module_input_srv.picks <- function(id, spec, data) { shiny::moduleServer(id, function(input, output, session) { is_numeric <- reactive(is.numeric(choices())) - output$selected_container <- renderUI({ logger::log_debug(".selected_choices_srv@1 rerender {type} input") if (isTRUE(args$fixed) || length(choices()) == 1) { @@ -188,7 +187,7 @@ module_input_srv.picks <- function(id, spec, data) { # for non-numeric shiny::observeEvent(input$selected_open, { - if (!isTRUE(input$selection_open)) { + if (!isTRUE(input$selected_open)) { # ↓ pickerInput returns "" when nothing selected. This can cause failure during col select (x[,""]) new_selected <- if (length(input$selected) && !identical(input$selected, "")) as.vector(input$selected) if (args$keep_order) { @@ -234,9 +233,8 @@ module_input_srv.picks <- function(id, spec, data) { ), options = list( "actions-box" = args$multiple, - # "allow-clear" = args$multiple || args$`allow-clear`, + "allow-clear" = is.null(selected) || isTRUE(args$allow_empty), "live-search" = length(choices) > 10, - # "max-options" = args$`max-options`, "none-selected-text" = "- Nothing selected -", "show-subtext" = TRUE ) diff --git a/R/0-picks.R b/R/0-picks.R index 3f0b1e74..6184cf00 100644 --- a/R/0-picks.R +++ b/R/0-picks.R @@ -84,12 +84,14 @@ datasets <- function(choices = tidyselect::everything(), } #' @describeIn types Specify variables. +#' @param allow_empty (`logical(1)`) whether `selected = NULL` is possible. #' @export variables <- function(choices = tidyselect::everything(), selected = 1, multiple = !.is_tidyselect(selected) && length(selected) > 1, fixed = !.is_tidyselect(choices) && length(choices) == 1, keep_order = FALSE, + allow_empty = !.is_tidyselect(selected) && (is.null(selected) || multiple), ...) { out <- .selected_choices( choices = if (.is_tidyselect(choices)) rlang::enquo(choices) else choices, @@ -97,6 +99,7 @@ variables <- function(choices = tidyselect::everything(), multiple = multiple, fixed = fixed, keep_order = keep_order, + allow_empty = allow_empty, ... ) class(out) <- c("variables", class(out)) diff --git a/R/0-resolver.R b/R/0-resolver.R index 2f859e21..c6b72e4e 100644 --- a/R/0-resolver.R +++ b/R/0-resolver.R @@ -32,6 +32,8 @@ resolver <- function(x, data) { # overwrite so that next x in line receives the corresponding data and specification if (is.null(determined_i$x)) { next + # todo: what to do if previous is.null(selected) && allow_empty? + # should we break a loop? } x[[i]] <- determined_i$x data_i <- determined_i$data From 13073292a52a49250b78577dbb5a768990fd837d Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Tue, 7 Oct 2025 13:46:56 +0200 Subject: [PATCH 135/142] - adding icons to pickerInput-choicesOpt - multiple variables concatenates values --- NAMESPACE | 12 + R/{call_utils.R => 0-call_utils.R} | 15 +- R/0-module_input.R | 208 +++++++++----- R/0-module_merge.R | 420 ++++++++++++++++++++++------ R/0-picks.R | 31 +- R/0-resolver.R | 38 ++- R/0-to_picks.R | 2 +- man/call_check_parse_varname.Rd | 2 +- man/call_condition_choice.Rd | 2 +- man/call_condition_logical.Rd | 2 +- man/call_condition_range.Rd | 2 +- man/call_condition_range_date.Rd | 2 +- man/call_condition_range_posixct.Rd | 2 +- man/call_extract_array.Rd | 2 +- man/call_extract_list.Rd | 2 +- man/call_extract_matrix.Rd | 2 +- man/call_with_colon.Rd | 2 +- man/calls_combine_by.Rd | 2 +- man/dot-check_merge_keys.Rd | 18 ++ man/dot-is_tidyselect.Rd | 2 +- man/dot-resolve.Rd | 6 +- man/merge_srv.Rd | 251 +++++++++++++++++ man/qenv_merge_selectors.Rd | 25 -- man/types.Rd | 28 +- 24 files changed, 835 insertions(+), 243 deletions(-) rename R/{call_utils.R => 0-call_utils.R} (97%) create mode 100644 man/dot-check_merge_keys.Rd create mode 100644 man/merge_srv.Rd delete mode 100644 man/qenv_merge_selectors.Rd diff --git a/NAMESPACE b/NAMESPACE index 19a365a9..08e6f889 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,5 +1,17 @@ # Generated by roxygen2: do not edit by hand +S3method(.picker_icon,Date) +S3method(.picker_icon,MultiAssayExperiment) +S3method(.picker_icon,POSIXct) +S3method(.picker_icon,POSIXlt) +S3method(.picker_icon,character) +S3method(.picker_icon,data.frame) +S3method(.picker_icon,default) +S3method(.picker_icon,factor) +S3method(.picker_icon,integer) +S3method(.picker_icon,logical) +S3method(.picker_icon,numeric) +S3method(.picker_icon,primary_key) S3method(anyNA,type) S3method(data_extract_multiple_srv,FilteredData) S3method(data_extract_multiple_srv,list) diff --git a/R/call_utils.R b/R/0-call_utils.R similarity index 97% rename from R/call_utils.R rename to R/0-call_utils.R index fca29b9b..238ab855 100644 --- a/R/call_utils.R +++ b/R/0-call_utils.R @@ -395,7 +395,20 @@ calls_combine_by <- function(operator, calls) { if (is.numeric(x$values)) { call_condition_range(varname = x$variables, range = x$values) } else { - call_condition_choice(varname = x$variables, choices = x$values) + variable <- if (length(x$variables) > 1) { + as.call( + c( + list( + quote(paste) + ), + unname(lapply(x$variables, as.name)), + list(sep = ", ") + ) + ) + } else { + x$variables + } + call_condition_choice(varname = variable, choices = x$values) } }) as.call(c(list(str2lang("dplyr::filter")), predicates)) diff --git a/R/0-module_input.R b/R/0-module_input.R index 40eaeb49..3cc6f515 100644 --- a/R/0-module_input.R +++ b/R/0-module_input.R @@ -5,35 +5,42 @@ #' @export -module_input_ui <- function(id, spec) { +module_input_ui <- function(id, spec, container = "badge_dropdown") { checkmate::assert_string(id) UseMethod("module_input_ui", spec) } #' @export -module_input_ui.list <- function(id, spec) { +module_input_ui.list <- function(id, spec, container = "badge_dropdown") { checkmate::assert_list(spec, names = "named") ns <- shiny::NS(id) sapply( Filter(length, names(spec)), USE.NAMES = TRUE, - function(name) module_input_ui(ns(name), spec[[name]]) + function(name) module_input_ui(ns(name), spec[[name]], container = container) ) } #' @export -module_input_ui.picks <- function(id, spec) { +module_input_ui.picks <- function(id, spec, container = "badge_dropdown") { if (.valid_picks(spec)) { stop("Unexpected object used as spec. Use `picks` to create the object.") } ns <- shiny::NS(id) badge_label <- shiny::uiOutput(ns("summary"), container = htmltools::tags$span) - # todo: icon or color to indicate a column class + content <- lapply(spec, function(x) .selected_choices_ui(id = ns(is(x)))) htmltools::tags$div( # todo: spec to have a label attribute # todo: badge to have css attribute to control the size - make CSS rule - can be controlled globally and module-ly - teal::badge_dropdown(id = ns("inputs"), label = badge_label, htmltools::tagList(content)) + if (identical(container, "badge_dropdown")) { + teal::badge_dropdown(id = ns("inputs"), label = badge_label, htmltools::tagList(content)) + } else { + if (!any(sapply(htmltools::tags, identical, container))) { + stop("Container should be one of `htmltools::tags`") + } + container(content) + } ) } @@ -85,40 +92,50 @@ module_input_srv.picks <- function(id, spec, data) { ) }) - # todo: modify when data changes output$summary <- shiny::renderUI(tagList(badge())) Reduce( - function(data, i) { - choices <- reactiveVal(isolate(spec_resolved())[[i]]$choices) - selected <- reactiveVal(isolate(spec_resolved())[[i]]$selected) - all_choices <- reactive(determine(x = spec[[i]], data = data())$x$choices) + function(data, slot_name) { + choices <- reactiveVal(isolate(spec_resolved())[[slot_name]]$choices) + selected <- reactiveVal(isolate(spec_resolved())[[slot_name]]$selected) + all_choices <- reactive(determine(x = spec[[slot_name]], data = data())$x$choices) observeEvent(all_choices(), ignoreInit = TRUE, { - current_choices <- spec_resolved()[[i]]$choices - current_selected <- spec_resolved()[[i]]$selected + current_choices <- spec_resolved()[[slot_name]]$choices + current_selected <- spec_resolved()[[slot_name]]$selected + + new_selected <- if (is.numeric(current_selected) && is.numeric(all_choices())) { + c( + max(current_selected[1], all_choices()[1], na.rm = TRUE), + min(current_selected[2], all_choices()[2], na.rm = TRUE) + ) + } else { + intersect(current_selected, all_choices()) + } + .update_rv( - selected, .intersect(current_selected, all_choices()), - sprintf("module_input_srv@1 %s$%s$selected is outside of the possible choices", id, names(spec)[i]) + selected, new_selected, + sprintf("module_input_srv@1 %s$%s$selected is outside of the possible choices", id, slot_name) ) .update_rv( choices, all_choices(), - sprintf("module_input_srv@1 %s$%s$choices is outside of the possible choices", id, names(spec)[i]) + sprintf("module_input_srv@1 %s$%s$choices is outside of the possible choices", id, slot_name) ) }) - observeEvent(spec_resolved()[[i]], ignoreInit = TRUE, { - .update_rv(choices, spec_resolved()[[i]]$choices, log = "module_input_srv@1 update input choices") - .update_rv(selected, spec_resolved()[[i]]$selected, log = "module_input_srv@1 update input selected") + observeEvent(spec_resolved()[[slot_name]], ignoreInit = TRUE, ignoreNULL = FALSE, { + .update_rv(choices, spec_resolved()[[slot_name]]$choices, log = "module_input_srv@1 update input choices") + .update_rv(selected, spec_resolved()[[slot_name]]$selected, log = "module_input_srv@1 update input selected") }) - args <- attributes(spec[[i]]) + args <- attributes(spec[[slot_name]]) .selected_choices_srv( - id = is(spec[[i]]), - type = is(spec[[i]]), + id = is(spec[[slot_name]]), + type = is(spec[[slot_name]]), choices = choices, selected = selected, - args = args[!names(args) %in% c("names", "class")] + args = args[!names(args) %in% c("names", "class")], + data = data ) # this works as follows: @@ -127,12 +144,12 @@ module_input_srv.picks <- function(id, spec, data) { selected(), ignoreInit = TRUE, # because spec_resolved is already resolved and `selected()` is being set ignoreNULL = FALSE, # because input$selected can be empty - .resolve(selected(), slot_idx = i, spec_resolved = spec_resolved, old_spec = spec, data = data_r()) + .resolve(selected(), slot_name = slot_name, spec_resolved = spec_resolved, old_spec = spec, data = data_r()) ) - reactive(.extract(x = isolate(spec_resolved()[[i]]), data())) + reactive(.extract(x = isolate(spec_resolved()[[slot_name]]), data())) }, - x = seq_along(spec), + x = names(spec), init = data_r ) @@ -145,7 +162,7 @@ module_input_srv.picks <- function(id, spec, data) { uiOutput(ns("selected_container")) } -.selected_choices_srv <- function(id, type, choices, selected, args) { +.selected_choices_srv <- function(id, type, choices, selected, data, args) { checkmate::assert_string(id) checkmate::assert_class(choices, "reactiveVal") checkmate::assert_class(selected, "reactiveVal") @@ -153,9 +170,28 @@ module_input_srv.picks <- function(id, spec, data) { shiny::moduleServer(id, function(input, output, session) { is_numeric <- reactive(is.numeric(choices())) + choices_opt_content <- reactive({ + if (type != "values") { + sapply( + choices(), + function(choice) { + icon <- toString(icon(.picker_icon(data()[[choice]]), lib = "font-awesome")) + label <- attr(data()[[choice]], "label") + paste( + icon, + choice, + if (!is.null(label) && !is.na(label) && !identical(label, choice)) { + toString(tags$small(label, class = "text-muted")) + } + ) + } + ) + } + }) + output$selected_container <- renderUI({ logger::log_debug(".selected_choices_srv@1 rerender {type} input") - if (isTRUE(args$fixed) || length(choices()) == 1) { + if (isTRUE(args$fixed) || length(choices()) <= 1) { } else if (is_numeric()) { .selected_choices_ui_numeric( session$ns("range"), @@ -165,13 +201,14 @@ module_input_srv.picks <- function(id, spec, data) { args = args ) } else { - # todo: provide information about choices() class so we can provide icons in the pickerInput .selected_choices_ui_categorical( session$ns("selected"), label = sprintf("Select %s:", type), choices = choices(), selected = selected(), - args = args + multiple = args$multiple, + choicesOpt = list(content = isolate(choices_opt_content())), + args = args[!names(args) %in% c("multiple")] ) } }) |> bindEvent(is_numeric(), choices()) # never change on selected() @@ -190,7 +227,7 @@ module_input_srv.picks <- function(id, spec, data) { if (!isTRUE(input$selected_open)) { # ↓ pickerInput returns "" when nothing selected. This can cause failure during col select (x[,""]) new_selected <- if (length(input$selected) && !identical(input$selected, "")) as.vector(input$selected) - if (args$keep_order) { + if (args$ordered) { new_selected <- c(intersect(selected(), new_selected), setdiff(new_selected, selected())) } .update_rv(selected, new_selected, log = ".selected_choices_srv@1 update selected after input changed") @@ -210,7 +247,7 @@ module_input_srv.picks <- function(id, spec, data) { ) } -.selected_choices_ui_categorical <- function(id, label, choices, selected, args) { +.selected_choices_ui_categorical <- function(id, label, choices, selected, multiple, choicesOpt, args) { htmltools::div( style = "max-width: 500px;", shinyWidgets::pickerInput( @@ -218,30 +255,27 @@ module_input_srv.picks <- function(id, spec, data) { label = label, choices = choices, selected = selected, - multiple = args$multiple, - choicesOpt = list( - content = ifelse( - # todo: add to the input choice icon = attached to choices when determine - names(choices) == unname(choices), - sprintf("%s", choices), - sprintf( - '%s %s', - unname(choices), - names(choices) - ) - ) - ), - options = list( - "actions-box" = args$multiple, - "allow-clear" = is.null(selected) || isTRUE(args$allow_empty), - "live-search" = length(choices) > 10, - "none-selected-text" = "- Nothing selected -", - "show-subtext" = TRUE + multiple = multiple, + choicesOpt = choicesOpt, + options = c( + list( + "actions-box" = !multiple, + "live-search" = length(choices) > 10, + "none-selected-text" = "- Nothing selected -", + "show-subtext" = TRUE + ), + args ) ) ) } +#' Update reactive values with log +#' +#' Update reactive values only if values differ to avoid unnecessary reactive trigger +#' @param rv (`reactiveVal`) +#' @param value (`vector`) +#' @param log (`character(1)`) message to `log_debug` .update_rv <- function(rv, value, log) { if (!isTRUE(all.equal(rv(), value, tolerance = 1e-15))) { # tolerance 1e-15 is a max precision in widgets. logger::log_debug(log) @@ -266,18 +300,19 @@ module_input_srv.picks <- function(id, spec, data) { #' @param old_spec (`picks`) #' @param data (`any` asserted further in `resolver`) #' @keywords internal -.resolve <- function(selected, slot_idx, spec_resolved, old_spec, data) { +.resolve <- function(selected, slot_name, spec_resolved, old_spec, data) { checkmate::assert_vector(selected, null.ok = TRUE) - checkmate::assert_integerish(slot_idx, lower = 1) + checkmate::assert_string(slot_name) checkmate::assert_class(spec_resolved, "reactiveVal") checkmate::assert_class(old_spec, "picks") - if (isTRUE(all.equal(selected, spec_resolved()[[slot_idx]]$selected, tolerance = 1e-15))) { + if (isTRUE(all.equal(selected, spec_resolved()[[slot_name]]$selected, tolerance = 1e-15))) { return(NULL) } logger::log_info("module_input_server@1 selected has changed. Resolving downstream...") new_spec_unresolved <- old_spec # ↓ everything after `slot_idx` is to resolve + slot_idx <- which(names(old_spec) == slot_name) new_spec_unresolved[seq_len(slot_idx - 1)] <- spec_resolved()[seq_len(slot_idx - 1)] new_spec_unresolved[[slot_idx]]$selected <- selected @@ -332,13 +367,60 @@ restoreValue <- function(value, default) { # nolint: object_name. } } -.intersect <- function(x, y) { - if (is.numeric(x) && is.numeric(y)) { - c( - max(x[1], y[1], na.rm = TRUE), - min(x[2], y[2], na.rm = TRUE) - ) - } else { - intersect(x, y) - } +#' `pickerInput` choices icons +#' +#' Icons describing a class of the choice +#' @param x (`any`) object which class will determine icon +#' @return html-tag in form of `character(1)` +#' @keywords internal +.picker_icon <- function(x) { + UseMethod(".picker_icon") } + +#' @keywords internal +#' @export +.picker_icon.numeric <- function(x) "arrow-up-1-9" + +#' @keywords internal +#' @export +.picker_icon.integer <- function(x) "arrow-up-1-9" + +#' @keywords internal +#' @export +.picker_icon.logical <- function(x) "pause" + +#' @keywords internal +#' @export +.picker_icon.Date <- function(x) "calendar" + +#' @keywords internal +#' @export +.picker_icon.POSIXct <- function(x) "calendar" + +#' @keywords internal +#' @export +.picker_icon.POSIXlt <- function(x) "calendar" + +#' @keywords internal +#' @export +.picker_icon.factor <- function(x) "chart-bar" + +#' @keywords internal +#' @export +.picker_icon.character <- function(x) "font" + +#' @keywords internal +#' @export +.picker_icon.primary_key <- function(x) "key" + +#' @keywords internal +#' @export +.picker_icon.data.frame <- function(x) "table" + +#' @keywords internal +#' @export +.picker_icon.MultiAssayExperiment <- function(x) "layer-group" + +#' @keywords internal +#' @export +.picker_icon.default <- function(x) "circle-question" diff --git a/R/0-module_merge.R b/R/0-module_merge.R index fec4293d..82d4e6c5 100644 --- a/R/0-module_merge.R +++ b/R/0-module_merge.R @@ -32,15 +32,11 @@ tm_merge <- function(label = "merge-module", inputs, transformators = list()) { moduleServer(id, function(input, output, session) { selectors <- module_input_srv(id, spec = inputs, data = data) - merged_q <- reactive({ - req(data()) - lapply(selectors, function(x) req(x())) - teal.transform::qenv_merge_selectors(x = data(), selectors = selectors) - }) + merged <- merge_srv("merge", data = data, selectors = selectors) table_q <- reactive({ - req(merged_q()) - within(merged_q(), reactable::reactable(merged), selectors = selectors) + req(merged$data()) + within(merged$data(), reactable::reactable(merged), selectors = selectors) }) output$table_merged <- reactable::renderReactable({ @@ -54,9 +50,9 @@ tm_merge <- function(label = "merge-module", inputs, transformators = list()) { ) }) - output$join_keys <- renderPrint(teal.data::join_keys(merged_q())) + output$join_keys <- renderPrint(teal.data::join_keys(merged$data())) - output$mapped <- renderText(yaml::as.yaml(map_merged(selectors))) + output$mapped <- renderText(yaml::as.yaml(merged$merge_vars())) }) }, ui_args = list(inputs = inputs), @@ -66,63 +62,275 @@ tm_merge <- function(label = "merge-module", inputs, transformators = list()) { } - +#' Merge Server Function for Dataset Integration +#' +#' @description +#' `merge_srv` is a powerful Shiny server function that orchestrates the merging of multiple datasets +#' based on user selections from `picks` objects. It creates a reactive merged dataset (`teal_data` object) +#' and tracks which variables from each selector are included in the final merged output. +#' +#' This function serves as the bridge between user interface selections (managed by selectors) and +#' the actual data merging logic. It automatically handles: +#' - Dataset joining based on join keys +#' - Variable selection and renaming to avoid conflicts +#' - Reactive updates when user selections change +#' - Generation of reproducible R code for the merge operation +#' +#' @param id (`character(1)`) Module ID for the Shiny module namespace +#' @param data (`reactive`) A reactive expression returning a [teal.data::teal_data] object containing +#' the source datasets to be merged. This object must have join keys defined via +#' [teal.data::join_keys()] to enable proper dataset relationships. +#' @param selectors (`named list`) A named list of selector objects. Each element can be: +#' - A `picks` object defining dataset and variable selections +#' - A `reactive` expression returning a `picks` object +#' The names of this list are used as identifiers for tracking which variables come from which selector. +#' @param output_name (`character(1)`) Name of the merged dataset that will be created in the +#' returned `teal_data` object. Default is `"anl"`. This name will be used in the generated R code. +#' @param join_fun (`character(1)`) The joining function to use for merging datasets. Must be a +#' qualified function name (e.g., `"dplyr::left_join"`, `"dplyr::inner_join"`, `"dplyr::full_join"`). +#' Default is `"dplyr::inner_join"`. The function must accept `by` and `suffix` parameters. +#' +#' @return A `list` with two reactive elements: +#' \describe{ +#' \item{`data`}{A `reactive` returning a [teal.data::teal_data] object containing the merged dataset. +#' The merged dataset is named according to `output_name` parameter. The `teal_data` object includes: +#' - The merged dataset with all selected variables +#' - Complete R code to reproduce the merge operation +#' - Updated join keys reflecting the merged dataset structure} +#' \item{`merge_vars`}{A `reactive` returning a named list mapping selector names to their selected +#' variables in the merged dataset. The structure is: +#' `list(selector_name_1 = c("var1", "var2"), selector_name_2 = c("var3", "var4"), ...)`. +#' Variable names reflect any renaming that occurred during the merge to avoid conflicts.} +#' } +#' +#' @section How It Works: +#' +#' The `merge_srv` function performs the following steps: +#' +#' 1. **Receives Input Data**: Takes a reactive `teal_data` object containing source datasets with +#' defined join keys +#' +#' 2. **Processes Selectors**: Evaluates each selector (whether static `picks` or reactive) to +#' determine which datasets and variables are selected +#' +#' 3. **Determines Merge Order**: Uses [qenv_merge_selectors()] to analyze join keys and determine +#' the optimal order for merging datasets (topological sort based on relationships) +#' +#' 4. **Handles Variable Conflicts**: Automatically renames variables when: +#' - Multiple selectors choose variables with the same name from different datasets +#' - Foreign key variables would conflict with existing variables +#' - Renaming follows the pattern `variable_datasetname` +#' +#' 5. **Performs Merge**: Generates and executes merge code that: +#' - Selects only required variables from each dataset +#' - Applies any filters defined in selectors +#' - Joins datasets using specified join function and join keys +#' - Maintains reproducibility through generated R code +#' +#' 6. **Updates Join Keys**: Creates new join key relationships for the merged dataset ("anl") +#' relative to remaining datasets in the `teal_data` object +#' +#' 7. **Tracks Variables**: Uses [map_merged()] to maintain a mapping of which variables in the +#' merged dataset came from which selector +#' +#' @section Usage Pattern: +#' +#' ```r +#' # In your Shiny server function +#' merged <- merge_srv( +#' id = "merge", +#' data = reactive(my_teal_data), +#' selectors = list( +#' selector1 = picks(...), +#' selector2 = reactive(picks(...)) +#' ), +#' output_name = "anl", +#' join_fun = "dplyr::left_join" +#' ) +#' +#' # Access merged data +#' merged_data <- merged$data() # teal_data object with merged dataset +#' anl <- merged_data[["anl"]] # The actual merged data.frame/tibble +#' +#' # Get variable mapping +#' vars <- merged$merge_vars() +#' # Returns: list(selector1 = c("VAR1", "VAR2"), selector2 = c("VAR3", "VAR4_ADSL")) +#' +#' # Get reproducible code +#' code <- teal.code::get_code(merged_data) +#' ``` +#' +#' @section Merge Logic Details: +#' +#' **Dataset Order**: Datasets are merged in topological order based on join keys. The first dataset +#' acts as the "left" side of the join, and subsequent datasets are joined one by one. +#' +#' **Join Keys**: The function uses join keys from the source `teal_data` object to determine: +#' - Which datasets can be joined together +#' - Which columns to use for joining (the `by` parameter) +#' - Whether datasets need intermediate joins (not yet implemented) +#' +#' **Variable Selection**: For each dataset being merged: +#' - Selects user-chosen variables from selectors +#' - Includes foreign key variables needed for joining (even if not explicitly selected) +#' - Removes duplicate foreign keys after join (they're already in the left dataset) +#' +#' **Conflict Resolution**: When variable names conflict: +#' - Variables from later datasets get suffixed with `_dataname` +#' - Foreign keys that match are merged (not duplicated) +#' - The mapping returned in `merge_vars` reflects the final names +#' +#' @section Integration with Selectors: +#' +#' `merge_srv` is designed to work with [module_input_srv()] which creates selector objects: +#' +#' ```r +#' # Create selectors in server +#' selectors <- module_input_srv( +#' spec = list( +#' adsl = picks(...), +#' adae = picks(...) +#' ), +#' data = data +#' ) +#' +#' # Pass to merge_srv +#' merged <- merge_srv( +#' id = "merge", +#' data = data, +#' selectors = selectors +#' ) +#' ``` +#' +#' @seealso +#' - [qenv_merge_selectors()] for the underlying merge logic +#' - [map_merged()] for variable mapping functionality +#' - [module_input_srv()] for creating selectors +#' - [teal.data::join_keys()] for defining dataset relationships +#' +#' @examples +#' \dontrun{ +#' # Complete example with CDISC data +#' library(teal.transform) +#' library(teal.data) +#' library(shiny) +#' +#' # Prepare data with join keys +#' data <- teal_data() +#' data <- within(data, { +#' ADSL <- teal.data::rADSL +#' ADAE <- teal.data::rADAE +#' }) +#' join_keys(data) <- default_cdisc_join_keys[c("ADSL", "ADAE")] +#' +#' # Create Shiny app +#' ui <- fluidPage( +#' module_input_ui("adsl", picks(datasets("ADSL"), variables())), +#' module_input_ui("adae", picks(datasets("ADAE"), variables())), +#' verbatimTextOutput("code"), +#' verbatimTextOutput("vars") +#' ) +#' +#' server <- function(input, output, session) { +#' # Create selectors +#' selectors <- list( +#' adsl = module_input_srv("adsl", +#' data = reactive(data), +#' spec = picks(datasets("ADSL"), variables()) +#' ), +#' adae = module_input_srv("adae", +#' data = reactive(data), +#' spec = picks(datasets("ADAE"), variables()) +#' ) +#' ) +#' +#' # Merge datasets +#' merged <- merge_srv( +#' id = "merge", +#' data = reactive(data), +#' selectors = selectors, +#' output_name = "anl", +#' join_fun = "dplyr::left_join" +#' ) +#' +#' # Display results +#' output$code <- renderPrint({ +#' cat(teal.code::get_code(merged$data())) +#' }) +#' +#' output$vars <- renderPrint({ +#' merged$merge_vars() +#' }) +#' } +#' +#' shinyApp(ui, server) +#' } +#' #' @export -merge_srv <- function(id, selectors, data, output_name = "merged", join_fun = "dplyr::left_join") { +# todo: merge_ui to display error message somewhere (at least) +# - if this dataset has no join_keys to anl (anl_datasets) then error saying +# can't merge {dataset} with merged dataset composed of {anl_datasets} + +merge_srv <- function(id, data, selectors, output_name = "anl", join_fun = "dplyr::inner_join") { + checkmate::assert_list(selectors, "reactive", names = "named") moduleServer(id, function(input, output, session) { + # selectors is a list of reactive picks. + selectors_unwrapped <- reactive({ + lapply(selectors, function(x) req(x())) + }) + merged_q <- reactive({ - req(data()) - qenv_merge_selectors(data(), selectors = selectors, output_name = output_name, join_fun = join_fun) + req(data(), selectors_unwrapped()) + .qenv_merge( + data(), + selectors = selectors_unwrapped(), + output_name = output_name, + join_fun = join_fun + ) }) - merge_vars <- reactive(lapply(map_merged(selectors), function(x) x$variables)) - vars_origins <- reactive( - lapply(selectors, function(x) { - lapply(x(), `[[`, "selected") - }) - ) - list( - data = merged_q, - merge_vars = merge_vars, - vars_origins = vars_origins + merge_vars <- eventReactive( + selectors_unwrapped(), + { + req(selectors_unwrapped()) + lapply( + .merge_summary_list(selectors_unwrapped(), join_keys = join_keys(data()))$mapping, + function(selector) unname(selector$variables) + ) + } ) + list(data = merged_q, merge_vars = merge_vars) }) } -#' Merge expression for selectors -#' @param x ([teal.data::teal_data]) -#' @param selectors (`named list` of `picks`) -#' @param output_name (`character(1)`) name of the merged dataset. -#' @param join_fun (`character(1)`) name of the merge function. -#' @export -qenv_merge_selectors <- function(x, - selectors, - output_name = "merged", - join_fun = "dplyr::left_join") { + +#' @keywords internal +.qenv_merge <- function(x, + selectors, + output_name = "anl", + join_fun = "dplyr::left_join") { checkmate::assert_class(x, "teal_data") - checkmate::assert_list(selectors, c("picks", "reactive"), names = "named") + checkmate::assert_list(selectors, "picks", names = "named") checkmate::assert_string(join_fun) + # Early validation of merge keys between datasets + datanames <- unique(unlist(lapply(selectors, function(selector) selector$datasets$selected))) + .assert_merge_keys(datanames, teal.data::join_keys(x)) + merge_summary <- .merge_summary_list(selectors, join_keys = teal.data::join_keys(x)) - expr <- .merge_expr( - merge_summary = merge_summary, - output_name = output_name, - join_fun = join_fun - ) + + expr <- .merge_expr(merge_summary = merge_summary, output_name = output_name, join_fun = join_fun) + merged_q <- eval_code(x, expr) teal.data::join_keys(merged_q) <- merge_summary$join_keys merged_q } -#' @export -map_merged <- function(selectors, join_keys) { - .merge_summary_list(selectors, join_keys = join_keys)$mapping -} -#' +#' @keywords internal .merge_expr <- function(merge_summary, - output_name = "merged", + output_name = "anl", join_fun = "dplyr::left_join") { checkmate::assert_list(merge_summary) checkmate::assert_string(output_name) @@ -138,13 +346,11 @@ map_merged <- function(selectors, join_keys) { datanames <- unique(unlist(lapply(mapping, `[[`, "datasets"))) calls <- expression() anl_datanames <- character(0) # to follow what anl is composed of (to determine keys) - anl_primary_keys <- character(0) # to determine accumulated keys of a merged dataset + anl_primary_keys <- character(0) # to determine accumulated keys of anl for (i in seq_along(datanames)) { dataname <- datanames[i] this_mapping <- Filter(function(x) x$datasets == dataname, mapping) - this_filter_mapping <- Filter(function(x) { - "values" %in% names(x) - }, this_mapping) + this_filter_mapping <- Filter(x = this_mapping, function(x) "values" %in% names(x)) this_foreign_keys <- .fk(join_keys, dataname) this_primary_keys <- join_keys[dataname, dataname] this_variables <- c( @@ -153,23 +359,13 @@ map_merged <- function(selectors, join_keys) { ) this_variables <- this_variables[!duplicated(unname(this_variables))] # because unique drops names - # todo: extract call is datasets (class, class) specific this_call <- .call_dplyr_select(dataname = dataname, variables = this_variables) if (length(this_filter_mapping)) { + # todo: make sure filter call is not executed when setequal(selected, all_possible_choices) this_call <- calls_combine_by("%>%", c(this_call, .call_dplyr_filter(this_filter_mapping))) } if (i > 1) { - merge_keys <- join_keys["anl", dataname] - if (!length(merge_keys)) { - msg <- sprintf( - "Merge is not possible. No join_keys between %s and any of %s", - sQuote(dataname), - sQuote(toString(anl_datanames)) - ) - stop(msg, call. = FALSE) - next - } anl_vs_this <- setdiff(anl_primary_keys, this_primary_keys) this_vs_anl <- setdiff(this_primary_keys, anl_primary_keys) if (length(anl_vs_this) && length(this_vs_anl)) { @@ -179,7 +375,7 @@ map_merged <- function(selectors, join_keys) { list( str2lang(join_fun), y = this_call, - by = merge_keys, + by = join_keys["anl", dataname], suffix = c("", sprintf("_%s", dataname)) ) ) @@ -194,30 +390,21 @@ map_merged <- function(selectors, join_keys) { } -#' Analyse selectors and guess merge consequences +#' Analyse selectors and concludes a merge parameters #' #' @return list containing: #' - mapping (`named list`) containing selected values in each selector. This `mapping` -#' is sorted according to correct datasets merge order. +#' is sorted according to correct datasets merge order. `variables` contains names of the +#' variables in `ANL` #' - join_keys (`join_keys`) updated `join_keys` containing keys of `ANL` #' #' @keywords internal .merge_summary_list <- function(selectors, join_keys) { - checkmate::assert_list(selectors, c("picks", "reactive")) - if (missing(join_keys)) { - join_keys <- Reduce( - function(all, this) c(all, attr(this, "join_keys")), - x = selectors, - init = teal.data::join_keys() - ) - } - + checkmate::assert_list(selectors, "picks") + checkmate::assert_class(join_keys, "join_keys") mapping <- lapply( # what has been selected in each selector selectors, - function(x) { - obj <- if (is.reactive(x)) x() else x - selected <- lapply(obj, function(x) stats::setNames(x$selected, x$selected)) - } + function(selector) lapply(selector, function(x) stats::setNames(x$selected, x$selected)) ) mapped_datanames <- unlist(lapply(mapping, `[[`, "datasets"), use.names = FALSE) mapping_by_dataset <- split(mapping, mapped_datanames) @@ -227,7 +414,7 @@ map_merged <- function(selectors, join_keys) { # datanames are handed over in order of selectors but # they must be in topological order - otherwise join might not be possible datanames <- c( - intersect(names(join_keys), datanames), + intersect(names(join_keys), datanames), # join_keys are in topological order setdiff(datanames, names(join_keys)) # non-joinable datasets at the end ) @@ -253,9 +440,6 @@ map_merged <- function(selectors, join_keys) { # 6. duplicated variables added to anl should be renamed remaining_datanames <- setdiff(remaining_datanames, dataname) - # todo: if this dataset has no join_keys to anl (anl_datasets) then error saying - # can't merge {dataset} with merged dataset composed of {anl_datasets} - # ↓ 1. anl "inherits" foreign keys from anl datasets to remaining datasets this_join_keys <- do.call( teal.data::join_keys, @@ -317,9 +501,85 @@ map_merged <- function(selectors, join_keys) { } .suffix_duplicated_vars <- function(vars, all_vars, suffix) { + names <- names(vars) idx_duplicated <- vars %in% all_vars if (any(idx_duplicated)) { + # make sure that names are unchanged! vars[idx_duplicated] <- sprintf("%s_%s", vars[idx_duplicated], suffix) } vars } + +#' Check if datasets can be merged in topological order +#' +#' Determines the topological order from join_keys, then checks that each dataset +#' can be joined with at least one of the previously accumulated datasets. +#' +#' @param datanames (`character`) Vector of dataset names to be merged +#' @param join_keys (`join_keys`) The join keys object +#' +#' @keywords internal +.check_merge_keys <- function(datanames, join_keys) { + # No validation needed for single dataset + if (length(datanames) <= 1) { + return(TRUE) + } + + # Get topological order from join_keys (this is the canonical ordering) + topological_order <- names(join_keys) + + # Filter to only selected datasets and maintain topological order + ordered_datasets <- intersect(topological_order, datanames) + + # Check if any dataset has no keys defined at all + if (length(ordered_datasets) != length(datanames)) { + datasets_without_keys <- setdiff(datanames, ordered_datasets) + return( + sprintf( + "Cannot merge datasets. The following dataset%s no join keys defined: %s.\n\nPlease define join keys using teal.data::join_keys().", + if (length(datasets_without_keys) == 1) " has" else "s have", + paste(sprintf("'%s'", datasets_without_keys), collapse = ", ") + ) + ) + } + + # First dataset doesn't need validation + if (length(ordered_datasets) <= 1) { + return(TRUE) + } + + # Iteratively check if each dataset can join with accumulated datasets + accumulated <- ordered_datasets[1] + + for (i in seq(2, length(ordered_datasets))) { + current_dataset <- ordered_datasets[i] + can_join <- FALSE + + # Check if current dataset has join keys with ANY accumulated dataset + for (prev_dataset in accumulated) { + if (length(join_keys[current_dataset, prev_dataset]) > 0) { + can_join <- TRUE + break + } + } + + if (!can_join) { + return( + sprintf( + "Cannot merge dataset '%s'. No join keys found between '%s' and any of the accumulated datasets: %s.\n\nPlease define join keys using teal.data::join_keys().", + current_dataset, + current_dataset, + paste(sprintf("'%s'", accumulated), collapse = ", ") + ) + ) + } + + # Add current dataset to accumulated + accumulated <- c(accumulated, current_dataset) + } + + TRUE +} + +#' @rdname .check_merge_keys +.assert_merge_keys <- checkmate::makeAssertionFunction(.check_merge_keys) diff --git a/R/0-picks.R b/R/0-picks.R index 6184cf00..4fea877c 100644 --- a/R/0-picks.R +++ b/R/0-picks.R @@ -7,7 +7,7 @@ #' One unquoted expression to be used to picks from choices to be selected. #' @param multiple <`logical(1)`> if more than one selection is possible. #' @param fixed <`logical(1)`> selection will be fixed and not possible to change interactively. -#' @param keep_order <`logical(1)`> if the selected should follow the selection order. If `FALSE` +#' @param ordered <`logical(1)`> if the selected should follow the selection order. If `FALSE` #' `selected` returned from `srv_module_input()` would be ordered according to order in `choices`. #' @param ... additional arguments delivered to `pickerInput` #' @@ -39,18 +39,10 @@ NULL #' @describeIn types specify a selector. #' @export picks <- function(...) { - # todo: assert that datasets is on the first place? - picks <- list(...) + picks <- rlang::dots_list(..., .ignore_empty = "trailing") checkmate::assert_list(picks, types = "type") + checkmate::assert_class(picks[[1]], "datasets") names(picks) <- vapply(picks, FUN = is, FUN.VALUE = character(1)) - for (i in seq_along(picks)) { - if (isTRUE(attr(picks[[i]], "multiple")) && i < length(picks)) { - stop( - names(picks)[i], " has a property `multiple = TRUE` which is forbidden if there are any following elements", - " depending on its selection." - ) - } - } structure(picks, class = c("picks", "list")) } @@ -65,13 +57,12 @@ datanames <- function(x) { }))) } -#' @describeIn types Specify datasets. +#' @rdname picks #' @export datasets <- function(choices = tidyselect::everything(), selected = 1, fixed = !.is_tidyselect(choices) && length(choices) == 1, ...) { - # todo: implement ... in pickerInput like `max-options`, `allow-clear` out <- .selected_choices( choices = if (.is_tidyselect(choices)) rlang::enquo(choices) else choices, selected = if (.is_tidyselect(selected)) rlang::enquo(selected) else selected, @@ -83,23 +74,21 @@ datasets <- function(choices = tidyselect::everything(), out } -#' @describeIn types Specify variables. -#' @param allow_empty (`logical(1)`) whether `selected = NULL` is possible. +#' @rdname picks #' @export variables <- function(choices = tidyselect::everything(), selected = 1, multiple = !.is_tidyselect(selected) && length(selected) > 1, fixed = !.is_tidyselect(choices) && length(choices) == 1, - keep_order = FALSE, - allow_empty = !.is_tidyselect(selected) && (is.null(selected) || multiple), + ordered = FALSE, ...) { out <- .selected_choices( choices = if (.is_tidyselect(choices)) rlang::enquo(choices) else choices, selected = if (.is_tidyselect(selected)) rlang::enquo(selected) else selected, multiple = multiple, fixed = fixed, - keep_order = keep_order, - allow_empty = allow_empty, + ordered = ordered, + `allow-clear` = !.is_tidyselect(selected) && (is.null(selected) || multiple), ... ) class(out) <- c("variables", class(out)) @@ -181,7 +170,7 @@ print.type <- function(x, ...) { .selected_choices <- function(choices, selected, multiple = length(selected) > 1, - keep_order = FALSE, + ordered = FALSE, fixed = FALSE, ...) { is_choices_delayed <- inherits(choices, "quosure") || @@ -207,7 +196,7 @@ print.type <- function(x, ...) { out <- structure( list(choices = choices, selected = selected), multiple = multiple, - keep_order = keep_order, + ordered = ordered, fixed = fixed, ..., class = "type" diff --git a/R/0-resolver.R b/R/0-resolver.R index c6b72e4e..a51e9473 100644 --- a/R/0-resolver.R +++ b/R/0-resolver.R @@ -28,15 +28,14 @@ resolver <- function(x, data) { if (is.delayed(x)) { data_i <- data for (i in seq_along(x)) { - determined_i <- determine(x[[i]], data = data_i) - # overwrite so that next x in line receives the corresponding data and specification - if (is.null(determined_i$x)) { - next - # todo: what to do if previous is.null(selected) && allow_empty? - # should we break a loop? + x[[i]] <- if (is.null(data_i)) { + # remove subsequent elements if nothing selected in the previous one + NULL + } else { + determined_i <- determine(x[[i]], data = data_i) + data_i <- determined_i$data + determined_i$x } - x[[i]] <- determined_i$x - data_i <- determined_i$data } } x @@ -110,7 +109,17 @@ determine.variables <- function(x, data) { #' @export determine.values <- function(x, data) { + if (is.null(data) || ncol(data) == 0) { + return(list(x = NULL)) + } + data <- if (ncol(data) > 1) { # todo: to limit number of possible columns to concat + apply(data, 1, toString) + } else { + data[[1]] + } + if (is.character(data) || is.factor(data)) { + # todo: what to do with NA choices? d <- unique(data) x$choices <- .determine_choices(x$choices, data = setNames(d, d)) # .determine_* uses names x$selected <- if (length(x$choices)) { @@ -118,6 +127,9 @@ determine.values <- function(x, data) { } list(x = x) # nothing more after this (no need to pass data further) } else if (is.numeric(data) || inherits(data, c("Date", "POSIXct"))) { + if (all(is.na(data))) { + return(list(x = NULL)) + } x$choices <- range(data, na.rm = TRUE) x$selected <- if (is.numeric(x$selected) || inherits(data, c("Date", "POSIXct"))) x$selected else x$choices list(x = x) @@ -160,11 +172,9 @@ determine.values <- function(x, data) { } .extract <- function(x, data) { - if (length(x$selected) == 1) { - if (inherits(x, "datasets")) { - data[[x$selected]] - } else if (inherits(x, "variables")) { - data[[x$selected]] - } + if (length(x$selected) == 1 && inherits(x, "datasets")) { + data[[x$selected]] + } else if (all(x$selected %in% names(data))) { + data[x$selected] } } diff --git a/R/0-to_picks.R b/R/0-to_picks.R index 294252cb..af3fd7d9 100644 --- a/R/0-to_picks.R +++ b/R/0-to_picks.R @@ -27,7 +27,7 @@ select_spec_to_variables <- function(x) { variables( choices = x$choices, selected = x$selected, - # keep_order = x$ordered, + # ordered = x$ordered, multiple = x$multiple, fixed = x$fixed ) diff --git a/man/call_check_parse_varname.Rd b/man/call_check_parse_varname.Rd index ac3cc617..b872dbdf 100644 --- a/man/call_check_parse_varname.Rd +++ b/man/call_check_parse_varname.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/call_utils.R +% Please edit documentation in R/0-call_utils.R \name{call_check_parse_varname} \alias{call_check_parse_varname} \title{Checks \code{varname} argument and convert to call} diff --git a/man/call_condition_choice.Rd b/man/call_condition_choice.Rd index 5e005c86..635e1605 100644 --- a/man/call_condition_choice.Rd +++ b/man/call_condition_choice.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/call_utils.R +% Please edit documentation in R/0-call_utils.R \name{call_condition_choice} \alias{call_condition_choice} \title{Choices condition call} diff --git a/man/call_condition_logical.Rd b/man/call_condition_logical.Rd index 44c2dd4d..5ce91ef5 100644 --- a/man/call_condition_logical.Rd +++ b/man/call_condition_logical.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/call_utils.R +% Please edit documentation in R/0-call_utils.R \name{call_condition_logical} \alias{call_condition_logical} \title{\code{logical} variable condition call} diff --git a/man/call_condition_range.Rd b/man/call_condition_range.Rd index 6fc816a8..28921c72 100644 --- a/man/call_condition_range.Rd +++ b/man/call_condition_range.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/call_utils.R +% Please edit documentation in R/0-call_utils.R \name{call_condition_range} \alias{call_condition_range} \title{\code{numeric} range condition call} diff --git a/man/call_condition_range_date.Rd b/man/call_condition_range_date.Rd index ec16327e..0e744520 100644 --- a/man/call_condition_range_date.Rd +++ b/man/call_condition_range_date.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/call_utils.R +% Please edit documentation in R/0-call_utils.R \name{call_condition_range_date} \alias{call_condition_range_date} \title{\code{Date} range condition call} diff --git a/man/call_condition_range_posixct.Rd b/man/call_condition_range_posixct.Rd index 3f2bc967..02b77508 100644 --- a/man/call_condition_range_posixct.Rd +++ b/man/call_condition_range_posixct.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/call_utils.R +% Please edit documentation in R/0-call_utils.R \name{call_condition_range_posixct} \alias{call_condition_range_posixct} \title{\code{POSIXct} range condition call} diff --git a/man/call_extract_array.Rd b/man/call_extract_array.Rd index 1cad599f..1baa383a 100644 --- a/man/call_extract_array.Rd +++ b/man/call_extract_array.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/call_utils.R +% Please edit documentation in R/0-call_utils.R \name{call_extract_array} \alias{call_extract_array} \title{Get call to subset and select array} diff --git a/man/call_extract_list.Rd b/man/call_extract_list.Rd index 49029ae8..f910e6f0 100644 --- a/man/call_extract_list.Rd +++ b/man/call_extract_list.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/call_utils.R +% Please edit documentation in R/0-call_utils.R \name{call_extract_list} \alias{call_extract_list} \title{Compose extract call with \code{$} operator} diff --git a/man/call_extract_matrix.Rd b/man/call_extract_matrix.Rd index 6ae8514d..2d676e2f 100644 --- a/man/call_extract_matrix.Rd +++ b/man/call_extract_matrix.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/call_utils.R +% Please edit documentation in R/0-call_utils.R \name{call_extract_matrix} \alias{call_extract_matrix} \title{Get call to subset and select matrix} diff --git a/man/call_with_colon.Rd b/man/call_with_colon.Rd index 42f4e6ce..9f2296a5 100644 --- a/man/call_with_colon.Rd +++ b/man/call_with_colon.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/call_utils.R +% Please edit documentation in R/0-call_utils.R \name{call_with_colon} \alias{call_with_colon} \title{Create a call using a function in a given namespace} diff --git a/man/calls_combine_by.Rd b/man/calls_combine_by.Rd index 8d3fa9f6..7345b409 100644 --- a/man/calls_combine_by.Rd +++ b/man/calls_combine_by.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/call_utils.R +% Please edit documentation in R/0-call_utils.R \name{calls_combine_by} \alias{calls_combine_by} \title{Combine calls by operator} diff --git a/man/dot-check_merge_keys.Rd b/man/dot-check_merge_keys.Rd new file mode 100644 index 00000000..04b4203b --- /dev/null +++ b/man/dot-check_merge_keys.Rd @@ -0,0 +1,18 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/0-module_merge.R +\name{.check_merge_keys} +\alias{.check_merge_keys} +\title{Check if datasets can be merged in topological order} +\usage{ +.check_merge_keys(datanames, join_keys) +} +\arguments{ +\item{datanames}{(\code{character}) Vector of dataset names to be merged} + +\item{join_keys}{(\code{join_keys}) The join keys object} +} +\description{ +Determines the topological order from join_keys, then checks that each dataset +can be joined with at least one of the previously accumulated datasets. +} +\keyword{internal} diff --git a/man/dot-is_tidyselect.Rd b/man/dot-is_tidyselect.Rd index c55dcfe7..7fa9bb48 100644 --- a/man/dot-is_tidyselect.Rd +++ b/man/dot-is_tidyselect.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/0-types.R +% Please edit documentation in R/0-picks.R \name{.is_tidyselect} \alias{.is_tidyselect} \title{Is an object created using tidyselect} diff --git a/man/dot-resolve.Rd b/man/dot-resolve.Rd index d4993330..4c042cfc 100644 --- a/man/dot-resolve.Rd +++ b/man/dot-resolve.Rd @@ -4,18 +4,18 @@ \alias{.resolve} \title{Resolve downstream after selected changes} \usage{ -.resolve(selected, slot_idx, spec_resolved, old_spec, data) +.resolve(selected, slot_name, spec_resolved, old_spec, data) } \arguments{ \item{selected}{(\code{vector}) rather \code{character}, or \code{factor}. \code{numeric(2)} for \code{values()} based on numeric column.} -\item{slot_idx}{(\code{integer})} - \item{spec_resolved}{(\code{reactiveVal})} \item{old_spec}{(\code{picks})} \item{data}{(\code{any} asserted further in \code{resolver})} + +\item{slot_idx}{(\code{integer})} } \description{ @description diff --git a/man/merge_srv.Rd b/man/merge_srv.Rd new file mode 100644 index 00000000..22ecdafb --- /dev/null +++ b/man/merge_srv.Rd @@ -0,0 +1,251 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/0-module_merge.R +\name{merge_srv} +\alias{merge_srv} +\alias{qenv_merge_selectors} +\alias{map_merged} +\title{Merge Server Function for Dataset Integration} +\usage{ +merge_srv( + id, + data, + selectors, + output_name = "merged", + join_fun = "dplyr::inner_join" +) + +qenv_merge_selectors( + x, + selectors, + output_name = "merged", + join_fun = "dplyr::left_join" +) + +map_merged(selectors, join_keys) +} +\arguments{ +\item{id}{(\code{character(1)}) Module ID for the Shiny module namespace} + +\item{data}{(\code{reactive}) A reactive expression returning a \link[teal.data:teal_data]{teal.data::teal_data} object containing +the source datasets to be merged. This object must have join keys defined via +\code{\link[teal.data:join_keys]{teal.data::join_keys()}} to enable proper dataset relationships.} + +\item{selectors}{(\verb{named list}) A named list of selector objects. Each element can be: +\itemize{ +\item A \code{picks} object defining dataset and variable selections +\item A \code{reactive} expression returning a \code{picks} object +The names of this list are used as identifiers for tracking which variables come from which selector. +}} + +\item{output_name}{(\code{character(1)}) Name of the merged dataset that will be created in the +returned \code{teal_data} object. Default is \code{"merged"}. This name will be used in the generated R code.} + +\item{join_fun}{(\code{character(1)}) The joining function to use for merging datasets. Must be a +qualified function name (e.g., \code{"dplyr::left_join"}, \code{"dplyr::inner_join"}, \code{"dplyr::full_join"}). +Default is \code{"dplyr::inner_join"}. The function must accept \code{by} and \code{suffix} parameters.} +} +\value{ +A \code{list} with two reactive elements: +\describe{ +\item{\code{data}}{A \code{reactive} returning a \link[teal.data:teal_data]{teal.data::teal_data} object containing the merged dataset. +The merged dataset is named according to \code{output_name} parameter. The \code{teal_data} object includes: +- The merged dataset with all selected variables +- Complete R code to reproduce the merge operation +- Updated join keys reflecting the merged dataset structure} +\item{\code{merge_vars}}{A \code{reactive} returning a named list mapping selector names to their selected +variables in the merged dataset. The structure is: +\code{list(selector_name_1 = c("var1", "var2"), selector_name_2 = c("var3", "var4"), ...)}. +Variable names reflect any renaming that occurred during the merge to avoid conflicts.} +} +} +\description{ +\code{merge_srv} is a powerful Shiny server function that orchestrates the merging of multiple datasets +based on user selections from \code{picks} objects. It creates a reactive merged dataset (\code{teal_data} object) +and tracks which variables from each selector are included in the final merged output. + +This function serves as the bridge between user interface selections (managed by selectors) and +the actual data merging logic. It automatically handles: +\itemize{ +\item Dataset joining based on join keys +\item Variable selection and renaming to avoid conflicts +\item Reactive updates when user selections change +\item Generation of reproducible R code for the merge operation +} +} +\section{How It Works}{ + + +The \code{merge_srv} function performs the following steps: +\enumerate{ +\item \strong{Receives Input Data}: Takes a reactive \code{teal_data} object containing source datasets with +defined join keys +\item \strong{Processes Selectors}: Evaluates each selector (whether static \code{picks} or reactive) to +determine which datasets and variables are selected +\item \strong{Determines Merge Order}: Uses \code{\link[=qenv_merge_selectors]{qenv_merge_selectors()}} to analyze join keys and determine +the optimal order for merging datasets (topological sort based on relationships) +\item \strong{Handles Variable Conflicts}: Automatically renames variables when: +\itemize{ +\item Multiple selectors choose variables with the same name from different datasets +\item Foreign key variables would conflict with existing variables +\item Renaming follows the pattern \code{variable_datasetname} +} +\item \strong{Performs Merge}: Generates and executes merge code that: +\itemize{ +\item Selects only required variables from each dataset +\item Applies any filters defined in selectors +\item Joins datasets using specified join function and join keys +\item Maintains reproducibility through generated R code +} +\item \strong{Updates Join Keys}: Creates new join key relationships for the merged dataset ("anl") +relative to remaining datasets in the \code{teal_data} object +\item \strong{Tracks Variables}: Uses \code{\link[=map_merged]{map_merged()}} to maintain a mapping of which variables in the +merged dataset came from which selector +} +} + +\section{Usage Pattern}{ + + +\if{html}{\out{
}}\preformatted{# In your Shiny server function +merged <- merge_srv( + id = "merge", + data = reactive(my_teal_data), + selectors = list( + selector1 = picks(...), + selector2 = reactive(picks(...)) + ), + output_name = "anl", + join_fun = "dplyr::left_join" +) + +# Access merged data +merged_data <- merged$data() # teal_data object with merged dataset +anl <- merged_data[["anl"]] # The actual merged data.frame/tibble + +# Get variable mapping +vars <- merged$merge_vars() +# Returns: list(selector1 = c("VAR1", "VAR2"), selector2 = c("VAR3", "VAR4_ADSL")) + +# Get reproducible code +code <- teal.code::get_code(merged_data) +}\if{html}{\out{
}} +} + +\section{Merge Logic Details}{ + + +\strong{Dataset Order}: Datasets are merged in topological order based on join keys. The first dataset +acts as the "left" side of the join, and subsequent datasets are joined one by one. + +\strong{Join Keys}: The function uses join keys from the source \code{teal_data} object to determine: +\itemize{ +\item Which datasets can be joined together +\item Which columns to use for joining (the \code{by} parameter) +\item Whether datasets need intermediate joins (not yet implemented) +} + +\strong{Variable Selection}: For each dataset being merged: +\itemize{ +\item Selects user-chosen variables from selectors +\item Includes foreign key variables needed for joining (even if not explicitly selected) +\item Removes duplicate foreign keys after join (they're already in the left dataset) +} + +\strong{Conflict Resolution}: When variable names conflict: +\itemize{ +\item Variables from later datasets get suffixed with \verb{_dataname} +\item Foreign keys that match are merged (not duplicated) +\item The mapping returned in \code{merge_vars} reflects the final names +} +} + +\section{Integration with Selectors}{ + + +\code{merge_srv} is designed to work with \code{\link[=module_input_srv]{module_input_srv()}} which creates selector objects: + +\if{html}{\out{
}}\preformatted{# Create selectors in server +selectors <- module_input_srv( + spec = list( + adsl = picks(...), + adae = picks(...) + ), + data = data +) + +# Pass to merge_srv +merged <- merge_srv( + id = "merge", + data = data, + selectors = selectors +) +}\if{html}{\out{
}} +} + +\examples{ +\dontrun{ +# Complete example with CDISC data +library(teal.transform) +library(teal.data) +library(shiny) + +# Prepare data with join keys +data <- teal_data() +data <- within(data, { + ADSL <- teal.data::rADSL + ADAE <- teal.data::rADAE +}) +join_keys(data) <- default_cdisc_join_keys[c("ADSL", "ADAE")] + +# Create Shiny app +ui <- fluidPage( + module_input_ui("adsl", picks(datasets("ADSL"), variables())), + module_input_ui("adae", picks(datasets("ADAE"), variables())), + verbatimTextOutput("code"), + verbatimTextOutput("vars") +) + +server <- function(input, output, session) { + # Create selectors + selectors <- list( + adsl = module_input_srv("adsl", + data = reactive(data), + spec = picks(datasets("ADSL"), variables()) + ), + adae = module_input_srv("adae", + data = reactive(data), + spec = picks(datasets("ADAE"), variables()) + ) + ) + + # Merge datasets + merged <- merge_srv( + id = "merge", + data = reactive(data), + selectors = selectors, + output_name = "anl", + join_fun = "dplyr::left_join" + ) + + # Display results + output$code <- renderPrint({ + cat(teal.code::get_code(merged$data())) + }) + + output$vars <- renderPrint({ + merged$merge_vars() + }) +} + +shinyApp(ui, server) +} + +} +\seealso{ +\itemize{ +\item \code{\link[=qenv_merge_selectors]{qenv_merge_selectors()}} for the underlying merge logic +\item \code{\link[=map_merged]{map_merged()}} for variable mapping functionality +\item \code{\link[=module_input_srv]{module_input_srv()}} for creating selectors +\item \code{\link[teal.data:join_keys]{teal.data::join_keys()}} for defining dataset relationships +} +} diff --git a/man/qenv_merge_selectors.Rd b/man/qenv_merge_selectors.Rd deleted file mode 100644 index f2e4a55c..00000000 --- a/man/qenv_merge_selectors.Rd +++ /dev/null @@ -1,25 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/0-module_merge.R -\name{qenv_merge_selectors} -\alias{qenv_merge_selectors} -\title{Merge expression for selectors} -\usage{ -qenv_merge_selectors( - x, - selectors, - output_name = "merged", - join_fun = "dplyr::left_join" -) -} -\arguments{ -\item{x}{(\link[teal.data:teal_data]{teal.data::teal_data})} - -\item{selectors}{(\verb{named list} of \code{picks})} - -\item{output_name}{(\code{character(1)}) name of the merged dataset.} - -\item{join_fun}{(\code{character(1)}) name of the merge function.} -} -\description{ -Merge expression for selectors -} diff --git a/man/types.Rd b/man/types.Rd index 70c2a9db..1e92812e 100644 --- a/man/types.Rd +++ b/man/types.Rd @@ -1,31 +1,14 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/0-types.R +% Please edit documentation in R/0-picks.R \name{Types} \alias{Types} \alias{picks} -\alias{datasets} -\alias{variables} \alias{values} \alias{mae_colData} \title{Choices/selected settings} \usage{ picks(...) -datasets( - choices = tidyselect::everything(), - selected = 1, - fixed = !.is_tidyselect(choices) && length(choices) == 1, - ... -) - -variables( - choices = tidyselect::everything(), - selected = 1, - multiple = !.is_tidyselect(selected) && length(selected) > 1, - fixed = !.is_tidyselect(choices) && length(choices) == 1, - ... -) - values( choices = tidyselect::everything(), selected = tidyselect::everything(), @@ -45,9 +28,12 @@ One unquoted expression to be used to picks the choices.} \item{selected}{<\code{\link[dplyr:dplyr_tidy_select]{tidy-select}} or \code{character}> One unquoted expression to be used to picks from choices to be selected.} +\item{multiple}{<\code{logical(1)}> if more than one selection is possible.} + \item{fixed}{<\code{logical(1)}> selection will be fixed and not possible to change interactively.} -\item{multiple}{<\code{logical(1)}> if more than one selection is possible.} +\item{keep_order}{<\code{logical(1)}> if the selected should follow the selection order. If \code{FALSE} +\code{selected} returned from \code{srv_module_input()} would be ordered according to order in \code{choices}.} } \value{ \code{picks} object containing specified settings @@ -59,10 +45,6 @@ Define choices and default selection of variables from datasets. \itemize{ \item \code{picks()}: specify a selector. -\item \code{datasets()}: Specify datasets. - -\item \code{variables()}: Specify variables. - \item \code{values()}: Specify variables. \item \code{mae_colData()}: Specify colData. From e6c39dfde565cb307e16d4c92035d791212c7839 Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Tue, 21 Oct 2025 15:58:15 +0200 Subject: [PATCH 136/142] WIP cleanup - tests --- NAMESPACE | 25 +- R/0-badge_dropdown.R | 35 + R/0-datanames.R | 76 +++ R/0-delayed.R | 35 - R/0-join_keys.R | 18 - R/0-module_merge.R | 110 +--- R/{0-module_input.R => 0-module_picks.R} | 79 ++- R/0-picks.R | 295 ++++++--- R/0-print.R | 79 +++ R/0-resolver.R | 45 ++ R/0-selector.R | 14 - R/0-tm_merge.R | 63 ++ inst/badge-dropdown/script.js | 31 + inst/badge-dropdown/style.css | 61 ++ inst/refactor-notes.Rmd | 192 ------ inst/refactor-notes.md | 787 +++++++++++++++++++++++ man/badge_dropdown.Rd | 22 + man/datanames.Rd | 77 +++ man/dot-merge_summary_list.Rd | 7 +- man/dot-picker_icon.Rd | 18 + man/dot-resolve.Rd | 2 +- man/dot-update_rv.Rd | 18 + man/is.delayed.Rd | 6 +- man/merge_srv.Rd | 46 +- man/module_input_ui.Rd | 11 - man/picks.Rd | 197 ++++++ man/picks_module.Rd | 66 ++ man/restoreValue.Rd | 2 +- man/tm_merge.Rd | 2 +- man/types.Rd | 73 --- tests/testthat/0-to_picks.R | 111 ---- tests/testthat/test-0-picks.R | 461 +++++++++++++ tests/testthat/test-0-print.R | 72 +++ tests/testthat/test-Queue.R | 78 --- tests/testthat/test-delayed.R | 12 - tests/testthat/test-merge_expr.R | 15 - tests/testthat/test-resolver.R | 186 ------ tests/testthat/test-types.R | 73 --- 38 files changed, 2422 insertions(+), 1078 deletions(-) create mode 100644 R/0-badge_dropdown.R create mode 100644 R/0-datanames.R delete mode 100644 R/0-delayed.R delete mode 100644 R/0-join_keys.R rename R/{0-module_input.R => 0-module_picks.R} (82%) create mode 100644 R/0-print.R delete mode 100644 R/0-selector.R create mode 100644 R/0-tm_merge.R create mode 100644 inst/badge-dropdown/script.js create mode 100644 inst/badge-dropdown/style.css delete mode 100644 inst/refactor-notes.Rmd create mode 100644 inst/refactor-notes.md create mode 100644 man/badge_dropdown.Rd create mode 100644 man/datanames.Rd create mode 100644 man/dot-picker_icon.Rd create mode 100644 man/dot-update_rv.Rd delete mode 100644 man/module_input_ui.Rd create mode 100644 man/picks.Rd create mode 100644 man/picks_module.Rd delete mode 100644 man/types.Rd delete mode 100644 tests/testthat/0-to_picks.R create mode 100644 tests/testthat/test-0-picks.R create mode 100644 tests/testthat/test-0-print.R delete mode 100644 tests/testthat/test-Queue.R delete mode 100644 tests/testthat/test-delayed.R delete mode 100644 tests/testthat/test-merge_expr.R delete mode 100644 tests/testthat/test-resolver.R delete mode 100644 tests/testthat/test-types.R diff --git a/NAMESPACE b/NAMESPACE index 08e6f889..43c132cc 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -12,7 +12,6 @@ S3method(.picker_icon,integer) S3method(.picker_icon,logical) S3method(.picker_icon,numeric) S3method(.picker_icon,primary_key) -S3method(anyNA,type) S3method(data_extract_multiple_srv,FilteredData) S3method(data_extract_multiple_srv,list) S3method(data_extract_multiple_srv,reactive) @@ -25,18 +24,19 @@ S3method(determine,values) S3method(determine,variables) S3method(filter_spec_internal,default) S3method(filter_spec_internal,delayed_data) +S3method(format,picks) +S3method(format,type) S3method(is.delayed,list) S3method(is.delayed,picks) S3method(is.delayed,type) -S3method(is.na,type) S3method(merge_expression_module,list) S3method(merge_expression_module,reactive) S3method(merge_expression_srv,list) S3method(merge_expression_srv,reactive) -S3method(module_input_srv,list) -S3method(module_input_srv,picks) -S3method(module_input_ui,list) -S3method(module_input_ui,picks) +S3method(picks_srv,list) +S3method(picks_srv,picks) +S3method(picks_ui,list) +S3method(picks_ui,picks) S3method(print,choices_labeled) S3method(print,delayed_choices_selected) S3method(print,delayed_data_extract_spec) @@ -45,8 +45,8 @@ S3method(print,delayed_select_spec) S3method(print,delayed_value_choices) S3method(print,delayed_variable_choices) S3method(print,filter_spec) +S3method(print,picks) S3method(print,type) -S3method(rename,join_keys) S3method(resolve,default) S3method(resolve,delayed_choices_selected) S3method(resolve,delayed_data_extract_spec) @@ -67,6 +67,7 @@ export(all_choices) export(check_no_multiple_selection) export(choices_labeled) export(choices_selected) +export(col_data) export(compose_and_enable_validators) export(data_extract_multiple_srv) export(data_extract_spec) @@ -78,6 +79,7 @@ export(datasets) export(filter_spec) export(first_choice) export(first_choices) +export(format) export(format_data_extract) export(get_anl_relabel_call) export(get_dataset_prefixed_col_names) @@ -85,24 +87,20 @@ export(get_extract_datanames) export(get_merge_call) export(get_relabel_call) export(is.choices_selected) -export(is.delayed) export(is_categorical) export(is_single_dataset) export(last_choice) export(last_choices) export(list_extract_spec) -export(mae_colData) -export(map_merged) export(merge_datasets) export(merge_expression_module) export(merge_expression_srv) export(merge_srv) -export(module_input_srv) -export(module_input_ui) export(no_more_choices_than) export(no_selected_as_NULL) export(picks) -export(qenv_merge_selectors) +export(picks_srv) +export(picks_ui) export(resolve_delayed) export(resolver) export(select_spec) @@ -115,4 +113,3 @@ export(variable_choices) export(variables) import(shiny) importFrom(dplyr,"%>%") -importFrom(dplyr,rename) diff --git a/R/0-badge_dropdown.R b/R/0-badge_dropdown.R new file mode 100644 index 00000000..0b42c58d --- /dev/null +++ b/R/0-badge_dropdown.R @@ -0,0 +1,35 @@ +#' Dropdown badge +#' +#' Dropdown button in a form of a badge with `bg-primary` as default style +#' Clicking badge shows a dropdown containing any `HTML` element. Folded dropdown +#' doesn't trigger display output which means that items rendered using `render*` +#' will be recomputed only when dropdown is show. +#' +#' @param id (`character(1)`) shiny module's id +#' @param label (`shiny.tag`) Label displayed on a badge. +#' @param ... (`shiny.tag`) Content of a dropdown. +#' @keywords internal +badge_dropdown <- function(id, label, content) { + ns <- shiny::NS(id) + htmltools::tagList( + htmltools::singleton(htmltools::tags$head( + htmltools::includeCSS(system.file("badge-dropdown", "style.css", package = "teal.transform")), + htmltools::includeScript(system.file("badge-dropdown", "script.js", package = "teal.transform")) + )), + htmltools::tags$div( + class = "badge-dropdown-wrapper", + htmltools::tags$span( + id = ns("summary_badge"), + class = "badge bg-primary rounded-pill badge-dropdown", + tags$span(class = "badge-dropdown-label", label), + tags$span(class = "badge-dropdown-icon", bsicons::bs_icon("caret-down-fill")), + onclick = sprintf("toggleBadgeDropdown('%s', '%s')", ns("summary_badge"), ns("inputs_container")) + ), + htmltools::tags$div( + content, + id = ns("inputs_container"), + style = "visibility: hidden; opacity: 0; pointer-events: none; position: absolute; background: white; border: 1px solid #ccc; border-radius: 4px; box-shadow: 0 2px 10px rgba(0,0,0,0.1); padding: 10px; z-index: 1000; min-width: 200px; transition: opacity 0.2s ease;", + ) + ) + ) +} diff --git a/R/0-datanames.R b/R/0-datanames.R new file mode 100644 index 00000000..dea1e1eb --- /dev/null +++ b/R/0-datanames.R @@ -0,0 +1,76 @@ +#' Extract dataset names from picks objects +#' +#' `datanames()` extracts the names of all datasets referenced in one or more `picks` objects. +#' This is useful for determining which datasets need to be available in the data environment +#' before a module can function properly. +#' +#' @param x (`picks` object, a list of `picks`) +#' +#' @return A character vector of unique dataset names. Only returns names when dataset choices +#' are specified as character vectors (static choices). Returns `NULL` or empty vector when +#' datasets are specified using `tidyselect` expressions (dynamic choices), since the actual +#' dataset names cannot be determined until runtime. +#' +#' @details +#' The function examines the `datasets()` component of each `picks` object and extracts +#' dataset names only when they are explicitly specified as character vectors. This allows +#' modules to declare their data dependencies upfront. +#' +#' ## Behavior with different choice types +#' +#' - **Static choices**: When `datasets(choices = c("iris", "mtcars"))` uses character vectors, +#' `datanames()` returns `c("iris", "mtcars")`. +#' +#' - **Dynamic choices**: When `datasets(choices = tidyselect::everything())` or other +#' tidyselect expressions are used, `datanames()` cannot determine the dataset names in +#' advance and returns an empty result. +#' +#' - **Mixed lists**: When processing multiple `picks` objects, only the statically defined +#' dataset names are extracted and combined. +#' +#' @examples +#' # Single picks object with one dataset +#' p1 <- picks( +#' datasets(choices = "iris", selected = "iris"), +#' variables(choices = tidyselect::everything(), selected = 1) +#' ) +#' datanames(p1) # Returns "iris" +#' +#' # Single picks object with multiple datasets +#' p2 <- picks( +#' datasets(choices = c("iris", "mtcars"), selected = "iris"), +#' variables(choices = tidyselect::where(is.numeric), selected = 1) +#' ) +#' datanames(p2) # Returns c("iris", "mtcars") +#' +#' # List of picks objects +#' p3 <- picks( +#' datasets(choices = c("chickwts", "PlantGrowth"), selected = 1), +#' variables(choices = tidyselect::everything(), selected = 1) +#' ) +#' datanames(list(p1, p2, p3)) # Returns c("iris", "mtcars", "chickwts", "PlantGrowth") +#' +#' # Dynamic choices - cannot determine dataset names +#' p4 <- picks( +#' datasets(choices = tidyselect::where(is.data.frame), selected = 1), +#' variables(choices = tidyselect::everything(), selected = 1) +#' ) +#' datanames(p4) # Returns NULL or empty vector +#' +#' # List with NULL values (filtered out automatically) +#' datanames(list(p1, NULL, p2)) # Returns c("iris", "mtcars") +#' +#' # Duplicate dataset names are removed +#' datanames(list(p1, p1, p2)) # Returns c("iris", "mtcars") - no duplicates +#' +#' @seealso [picks()], [datasets()] +#' @export +datanames <- function(x) { + if (inherits(x, "picks")) { + x <- list(x) + } + checkmate::assert_list(x, c("picks", "NULL")) + unique(unlist(lapply(x, function(x) { + if (is.character(x$datasets$choices)) x$datasets$choices + }))) +} diff --git a/R/0-delayed.R b/R/0-delayed.R deleted file mode 100644 index a98578fb..00000000 --- a/R/0-delayed.R +++ /dev/null @@ -1,35 +0,0 @@ -#' Is the specification resolved? -#' -#' Check that the specification is resolved against a given data source. -#' @param x Object to be evaluated. -#' @returns A single logical value. -#' @examples -#' is.delayed(1) -#' is.delayed(variables("df", "df")) -#' is.delayed(variables("df")) # Unknown selection -#' @export -is.delayed <- function(x) { - UseMethod("is.delayed") -} - -# Handling a list of transformers e1 | e2 -#' @export -#' @method is.delayed list -is.delayed.list <- function(x) { - any(vapply(x, is.delayed, logical(1L))) -} - -#' @export -#' @method is.delayed picks -is.delayed.picks <- function(x) { - any(vapply(x, is.delayed, logical(1L))) -} - -#' @export -#' @method is.delayed type -is.delayed.type <- function(x) { - if (!is.na(x)) { - return(!is.character(x$choices) || !is.character(x$selected)) - } - FALSE -} diff --git a/R/0-join_keys.R b/R/0-join_keys.R deleted file mode 100644 index 1b5b2bab..00000000 --- a/R/0-join_keys.R +++ /dev/null @@ -1,18 +0,0 @@ -#' @importFrom dplyr rename -#' @export -rename.join_keys <- function(.data, dataname, ...) { - checkmate::assert_string(dataname) - dots <- list(...) - checkmate::assert_list(dots, types = "character", names = "named") - column <- unlist(dots) - for (other_name in names(.data[[dataname]])) { - keys <- .data[dataname, other_name] - matched_idx <- match(column, names(keys)) - names(keys)[matched_idx] <- names(column) - if (other_name == dataname) { - keys[matched_idx] <- names(column) - } - .data[dataname, other_name] <- keys - } - .data -} diff --git a/R/0-module_merge.R b/R/0-module_merge.R index 82d4e6c5..17e19d80 100644 --- a/R/0-module_merge.R +++ b/R/0-module_merge.R @@ -1,67 +1,3 @@ -#' Merge module -#' -#' Example module -tm_merge <- function(label = "merge-module", inputs, transformators = list()) { - module( - label = label, - ui = function(id, inputs) { - ns <- NS(id) - tags$div( - tags$div( - class = "row g-2", - lapply(names(inputs), function(id) { - tags$div( - class = "col-auto", - tags$strong(tags$label(id)), - teal.transform::module_input_ui( - id = ns(id), - spec = inputs[[id]] - ) - ) - }) - ), - shiny::div( - reactable::reactableOutput(ns("table_merged")), - shiny::verbatimTextOutput(ns("join_keys")), - shiny::verbatimTextOutput(ns("mapped")), - shiny::verbatimTextOutput(ns("src")) - ) - ) - }, - server = function(id, data, inputs) { - moduleServer(id, function(input, output, session) { - selectors <- module_input_srv(id, spec = inputs, data = data) - - merged <- merge_srv("merge", data = data, selectors = selectors) - - table_q <- reactive({ - req(merged$data()) - within(merged$data(), reactable::reactable(merged), selectors = selectors) - }) - - output$table_merged <- reactable::renderReactable({ - req(table_q()) - teal.code::get_outputs(table_q())[[1]] - }) - - output$src <- renderPrint({ - styler::style_text( - teal.code::get_code(req(table_q())) - ) - }) - - output$join_keys <- renderPrint(teal.data::join_keys(merged$data())) - - output$mapped <- renderText(yaml::as.yaml(merged$merge_vars())) - }) - }, - ui_args = list(inputs = inputs), - server_args = list(inputs = inputs), - transformators = transformators - ) -} - - #' Merge Server Function for Dataset Integration #' #' @description @@ -97,7 +33,7 @@ tm_merge <- function(label = "merge-module", inputs, transformators = list()) { #' - The merged dataset with all selected variables #' - Complete R code to reproduce the merge operation #' - Updated join keys reflecting the merged dataset structure} -#' \item{`merge_vars`}{A `reactive` returning a named list mapping selector names to their selected +#' \item{`variables`}{A `reactive` returning a named list mapping selector names to their selected #' variables in the merged dataset. The structure is: #' `list(selector_name_1 = c("var1", "var2"), selector_name_2 = c("var3", "var4"), ...)`. #' Variable names reflect any renaming that occurred during the merge to avoid conflicts.} @@ -113,13 +49,13 @@ tm_merge <- function(label = "merge-module", inputs, transformators = list()) { #' 2. **Processes Selectors**: Evaluates each selector (whether static `picks` or reactive) to #' determine which datasets and variables are selected #' -#' 3. **Determines Merge Order**: Uses [qenv_merge_selectors()] to analyze join keys and determine -#' the optimal order for merging datasets (topological sort based on relationships) +#' 3. **Determines Merge Order**: Uses topological sort based on the `join_keys` to determine +#' the optimal order for merging datasets. #' #' 4. **Handles Variable Conflicts**: Automatically renames variables when: #' - Multiple selectors choose variables with the same name from different datasets #' - Foreign key variables would conflict with existing variables -#' - Renaming follows the pattern `variable_datasetname` +#' - Renaming follows the pattern `{column-name}_{dataset-name}` #' #' 5. **Performs Merge**: Generates and executes merge code that: #' - Selects only required variables from each dataset @@ -130,8 +66,7 @@ tm_merge <- function(label = "merge-module", inputs, transformators = list()) { #' 6. **Updates Join Keys**: Creates new join key relationships for the merged dataset ("anl") #' relative to remaining datasets in the `teal_data` object #' -#' 7. **Tracks Variables**: Uses [map_merged()] to maintain a mapping of which variables in the -#' merged dataset came from which selector +#' 7. **Tracks Variables**: Keeps track of the variable names in the merged dataset #' #' @section Usage Pattern: #' @@ -153,7 +88,7 @@ tm_merge <- function(label = "merge-module", inputs, transformators = list()) { #' anl <- merged_data[["anl"]] # The actual merged data.frame/tibble #' #' # Get variable mapping -#' vars <- merged$merge_vars() +#' vars <- merged$variables() #' # Returns: list(selector1 = c("VAR1", "VAR2"), selector2 = c("VAR3", "VAR4_ADSL")) #' #' # Get reproducible code @@ -182,11 +117,11 @@ tm_merge <- function(label = "merge-module", inputs, transformators = list()) { #' #' @section Integration with Selectors: #' -#' `merge_srv` is designed to work with [module_input_srv()] which creates selector objects: +#' `merge_srv` is designed to work with [picks_srv()] which creates selector objects: #' #' ```r #' # Create selectors in server -#' selectors <- module_input_srv( +#' selectors <- picks_srv( #' spec = list( #' adsl = picks(...), #' adae = picks(...) @@ -203,9 +138,7 @@ tm_merge <- function(label = "merge-module", inputs, transformators = list()) { #' ``` #' #' @seealso -#' - [qenv_merge_selectors()] for the underlying merge logic -#' - [map_merged()] for variable mapping functionality -#' - [module_input_srv()] for creating selectors +#' - [picks_srv()] for creating selectors #' - [teal.data::join_keys()] for defining dataset relationships #' #' @examples @@ -225,8 +158,8 @@ tm_merge <- function(label = "merge-module", inputs, transformators = list()) { #' #' # Create Shiny app #' ui <- fluidPage( -#' module_input_ui("adsl", picks(datasets("ADSL"), variables())), -#' module_input_ui("adae", picks(datasets("ADAE"), variables())), +#' picks_ui("adsl", picks(datasets("ADSL"), variables())), +#' picks_ui("adae", picks(datasets("ADAE"), variables())), #' verbatimTextOutput("code"), #' verbatimTextOutput("vars") #' ) @@ -234,11 +167,11 @@ tm_merge <- function(label = "merge-module", inputs, transformators = list()) { #' server <- function(input, output, session) { #' # Create selectors #' selectors <- list( -#' adsl = module_input_srv("adsl", +#' adsl = picks_srv("adsl", #' data = reactive(data), #' spec = picks(datasets("ADSL"), variables()) #' ), -#' adae = module_input_srv("adae", +#' adae = picks_srv("adae", #' data = reactive(data), #' spec = picks(datasets("ADAE"), variables()) #' ) @@ -259,7 +192,7 @@ tm_merge <- function(label = "merge-module", inputs, transformators = list()) { #' }) #' #' output$vars <- renderPrint({ -#' merged$merge_vars() +#' merged$variables() #' }) #' } #' @@ -270,8 +203,11 @@ tm_merge <- function(label = "merge-module", inputs, transformators = list()) { # todo: merge_ui to display error message somewhere (at least) # - if this dataset has no join_keys to anl (anl_datasets) then error saying # can't merge {dataset} with merged dataset composed of {anl_datasets} - -merge_srv <- function(id, data, selectors, output_name = "anl", join_fun = "dplyr::inner_join") { +merge_srv <- function(id, + data, + selectors, + output_name = "anl", + join_fun = "dplyr::inner_join") { checkmate::assert_list(selectors, "reactive", names = "named") moduleServer(id, function(input, output, session) { # selectors is a list of reactive picks. @@ -279,7 +215,7 @@ merge_srv <- function(id, data, selectors, output_name = "anl", join_fun = "dply lapply(selectors, function(x) req(x())) }) - merged_q <- reactive({ + data_r <- reactive({ req(data(), selectors_unwrapped()) .qenv_merge( data(), @@ -289,17 +225,17 @@ merge_srv <- function(id, data, selectors, output_name = "anl", join_fun = "dply ) }) - merge_vars <- eventReactive( + variables_selected <- eventReactive( selectors_unwrapped(), { req(selectors_unwrapped()) lapply( - .merge_summary_list(selectors_unwrapped(), join_keys = join_keys(data()))$mapping, + .merge_summary_list(selectors_unwrapped(), join_keys = teal.data::join_keys(data()))$mapping, function(selector) unname(selector$variables) ) } ) - list(data = merged_q, merge_vars = merge_vars) + list(data = data_r, variables = variables_selected) }) } diff --git a/R/0-module_input.R b/R/0-module_picks.R similarity index 82% rename from R/0-module_input.R rename to R/0-module_picks.R index 3cc6f515..f51a2270 100644 --- a/R/0-module_input.R +++ b/R/0-module_picks.R @@ -1,40 +1,70 @@ -#' Module's interactive input +#' Interactive picks #' #' @description +#' `r lifecycle::badge("experimental")` #' +#' Creates UI and server components for interactive [picks()] in Shiny modules. The module is based on +#' configuration provided via [picks()] and its responsibility is to determine relevant input +#' values +#' +#' +#' The module supports both single and combined specifications: +#' - Single `picks` objects for a single input +#' - Named lists of `picks` objects for multiple inputs +#' +#' @param id (`character(1)`) Shiny module ID +#' @param spec (`picks` or `list`) Specification object created by `picks()` or a named list of such objects +#' @param container (`character(1)` or `function`) UI container type. Default is `"badge_dropdown"`. +#' Can also be one of `htmltools::tags` functions +#' @param data (`reactive`) Reactive expression returning the data object to be used for populating choices +#' +#' @return +#' - `picks_ui()`: UI elements for the input controls +#' - `picks_srv()`: Server-side reactive logic returning the processed data +#' +#' @details +#' The module uses S3 method dispatch to handle different types of specifications: +#' - `.picks` methods handle single specification +#' - `.list` methods handle multiple specifications +#' +#' The UI component (`picks_ui`) creates the visual elements, while the +#' server component (`picks_srv`) manages the reactive logic, +#' +#' @seealso [picks()] for creating specification objects +#' +#' @name picks_module +NULL - +#' @rdname picks_module #' @export -module_input_ui <- function(id, spec, container = "badge_dropdown") { +picks_ui <- function(id, spec, container = "badge_dropdown") { checkmate::assert_string(id) - UseMethod("module_input_ui", spec) + UseMethod("picks_ui", spec) } +#' @rdname picks_module #' @export -module_input_ui.list <- function(id, spec, container = "badge_dropdown") { +picks_ui.list <- function(id, spec, container = "badge_dropdown") { checkmate::assert_list(spec, names = "named") ns <- shiny::NS(id) sapply( Filter(length, names(spec)), USE.NAMES = TRUE, - function(name) module_input_ui(ns(name), spec[[name]], container = container) + function(name) picks_ui(ns(name), spec[[name]], container = container) ) } +#' @rdname picks_module #' @export -module_input_ui.picks <- function(id, spec, container = "badge_dropdown") { - if (.valid_picks(spec)) { - stop("Unexpected object used as spec. Use `picks` to create the object.") - } +picks_ui.picks <- function(id, spec, container = "badge_dropdown") { ns <- shiny::NS(id) badge_label <- shiny::uiOutput(ns("summary"), container = htmltools::tags$span) content <- lapply(spec, function(x) .selected_choices_ui(id = ns(is(x)))) htmltools::tags$div( - # todo: spec to have a label attribute # todo: badge to have css attribute to control the size - make CSS rule - can be controlled globally and module-ly if (identical(container, "badge_dropdown")) { - teal::badge_dropdown(id = ns("inputs"), label = badge_label, htmltools::tagList(content)) + badge_dropdown(id = ns("inputs"), label = badge_label, htmltools::tagList(content)) } else { if (!any(sapply(htmltools::tags, identical, container))) { stop("Container should be one of `htmltools::tags`") @@ -44,24 +74,27 @@ module_input_ui.picks <- function(id, spec, container = "badge_dropdown") { ) } +#' @rdname picks_module #' @export -module_input_srv <- function(id = "", spec, data) { +picks_srv <- function(id = "", spec, data) { checkmate::assert_string(id) checkmate::assert_class(data, "reactive") - UseMethod("module_input_srv", spec) + UseMethod("picks_srv", spec) } +#' @rdname picks_module #' @export -module_input_srv.list <- function(id, spec, data) { +picks_srv.list <- function(id, spec, data) { sapply( names(Filter(length, spec)), USE.NAMES = TRUE, - function(name) module_input_srv(name, spec[[name]], data) + function(name) picks_srv(name, spec[[name]], data) ) } +#' @rdname picks_module #' @export -module_input_srv.picks <- function(id, spec, data) { +picks_srv.picks <- function(id, spec, data) { moduleServer(id, function(input, output, session) { data_r <- shiny::reactive(if (shiny::is.reactive(data)) data() else data) spec_resolved <- shiny::reactiveVal( @@ -71,7 +104,7 @@ module_input_srv.picks <- function(id, spec, data) { ) ) session$onBookmark(function(state) { - logger::log_debug("module_input_srv@onBookmark: storing current picks") + logger::log_debug("picks_srv@onBookmark: storing current picks") state$values$picks <- spec_resolved() }) @@ -115,17 +148,17 @@ module_input_srv.picks <- function(id, spec, data) { .update_rv( selected, new_selected, - sprintf("module_input_srv@1 %s$%s$selected is outside of the possible choices", id, slot_name) + sprintf("picks_srv@1 %s$%s$selected is outside of the possible choices", id, slot_name) ) .update_rv( choices, all_choices(), - sprintf("module_input_srv@1 %s$%s$choices is outside of the possible choices", id, slot_name) + sprintf("picks_srv@1 %s$%s$choices is outside of the possible choices", id, slot_name) ) }) observeEvent(spec_resolved()[[slot_name]], ignoreInit = TRUE, ignoreNULL = FALSE, { - .update_rv(choices, spec_resolved()[[slot_name]]$choices, log = "module_input_srv@1 update input choices") - .update_rv(selected, spec_resolved()[[slot_name]]$selected, log = "module_input_srv@1 update input selected") + .update_rv(choices, spec_resolved()[[slot_name]]$choices, log = "picks_srv@1 update input choices") + .update_rv(selected, spec_resolved()[[slot_name]]$selected, log = "picks_srv@1 update input selected") }) args <- attributes(spec[[slot_name]]) @@ -308,7 +341,7 @@ module_input_srv.picks <- function(id, spec, data) { if (isTRUE(all.equal(selected, spec_resolved()[[slot_name]]$selected, tolerance = 1e-15))) { return(NULL) } - logger::log_info("module_input_server@1 selected has changed. Resolving downstream...") + logger::log_info("picks_server@1 selected has changed. Resolving downstream...") new_spec_unresolved <- old_spec # ↓ everything after `slot_idx` is to resolve diff --git a/R/0-picks.R b/R/0-picks.R index 4fea877c..7820542e 100644 --- a/R/0-picks.R +++ b/R/0-picks.R @@ -1,71 +1,202 @@ #' Choices/selected settings #' -#' Define choices and default selection of variables from datasets. -#' @param choices <[`tidy-select`][dplyr::dplyr_tidy_select] or `character`> -#' One unquoted expression to be used to picks the choices. -#' @param selected <[`tidy-select`][dplyr::dplyr_tidy_select] or `character`> -#' One unquoted expression to be used to picks from choices to be selected. -#' @param multiple <`logical(1)`> if more than one selection is possible. -#' @param fixed <`logical(1)`> selection will be fixed and not possible to change interactively. -#' @param ordered <`logical(1)`> if the selected should follow the selection order. If `FALSE` +#' Define choices and default selection for variables. `picks` allows app-developer to specify +#' `datasets`, `variables` and `values` to be selected by app-user during Shiny session. +#' Functions are based on the idea of `choices/selected` where app-developer provides `choices` +#' and what is `selected` by default. App-user though changes `selected` interactively in +#' [`picks_module`] +#' +#' @param choices ([`tidyselect::language`] or `character`) +#' Available values to choose. +#' @param selected ([`tidyselect::language`] or `character`) +#' Choices to be selected. +#' @param multiple (`logical(1)`) if more than one selection is possible. +#' @param fixed (`logical(1)`) selection will be fixed and not possible to change interactively. +#' @param ordered (`logical(1)`) if the selected should follow the selection order. If `FALSE` #' `selected` returned from `srv_module_input()` would be ordered according to order in `choices`. #' @param ... additional arguments delivered to `pickerInput` #' -#' @returns `picks` object containing specified settings -#' @examples +#' @details +#' # `tidyselect` support +#' +#' Both `choices` and `selected` parameters support `tidyselect` syntax, enabling dynamic +#' and flexible variable selection patterns. This allows choices to be determined at runtime +#' based on data characteristics rather than hardcoded values. +#' +#' ## Using tidyselect for `choices` +#' +#' When `choices` uses tidyselect, the available options are determined dynamically based on +#' the selected dataset's structure: +#' +#' - `tidyselect::everything()` - All variables/datasets +#' - `tidyselect::starts_with("prefix")` - Variables starting with a prefix +#' - `tidyselect::ends_with("suffix")` - Variables ending with a suffix +#' - `tidyselect::contains("pattern")` - Variables containing a pattern +#' - `tidyselect::matches("regex")` - Variables matching a regular expression +#' - `tidyselect::where(predicate)` - Variables/datasets satisfying a predicate function +#' - `tidyselect::all_of(vars)` - All specified variables (error if missing) +#' - `tidyselect::any_of(vars)` - Any specified variables (silent if missing) +#' - Range selectors like `Sepal.Length:Petal.Width` - Variables between two positions +#' +#' ## Using tidyselect for `selected` +#' +#' The `selected` parameter can use: +#' +#' - Numeric indices (e.g., `1`, `1:3`, `c(1, 3, 5)`) - Select by position +#' - Character vectors (e.g., `"Species"`, `c("mpg", "cyl")`) - Select by name +#' - `tidyselect::everything()` - Select all available choices +#' - Other tidyselect helpers as needed +#' +#' **Warning:** Using explicit character values for `selected` with dynamic `choices` may +#' cause issues if the selected values are not present in the dynamically determined choices. +#' Prefer using numeric indices (e.g., `1` for first variable) when `choices` is dynamic. +#' +#' # Structure and element dependencies +#' +#' The `picks()` function creates a hierarchical structure where elements depend on their +#' predecessors, enabling cascading reactive updates during Shiny sessions. +#' +#' ## Element hierarchy +#' +#' A `picks` object must follow this order: +#' +#' 1. **`datasets()`** - to select a dataset. Always the first element (required). +#' 2. **`variables()`** - To select columns from the chosen dataset. +#' 3. **`values()`** - To select specific values from the chosen variable(s). +#' +#' Each element's choices are evaluated within the context of its predecessor's selection. +#' +#' ## How dependencies work +#' +#' - **Single dataset**: When `datasets(choices = "iris")` specifies one dataset, the +#' `variables()` choices are evaluated against that dataset's columns. +#' +#' - **Multiple datasets**: When `datasets(choices = c("iris", "mtcars"))` allows multiple +#' options, `variables()` choices are re-evaluated each time the user selects a different +#' dataset. This creates a reactive dependency where variable choices update automatically. +#' +#' - **Dynamic datasets**: When using `datasets(choices = tidyselect::where(is.data.frame))`, +#' all available data frames are discovered at runtime, and variable choices adapt to +#' whichever dataset the user selects. +#' +#' - **Variable to values**: Similarly, `values()` choices are evaluated based on the +#' selected variable(s), allowing users to filter specific levels or values. +#' +#' ## Best practices #' -#' # Initialize selector for `iris` to select columns between `Sepal.Length` and `Petal.Width` -#' # with first +#' - Always start with `datasets()` - this is enforced by validation +#' - Use dynamic `choices` in `variables()` when working with multiple datasets to ensure +#' compatibility across different data structures +#' - Prefer `tidyselect::everything()` or `tidyselect::where()` predicates for flexible +#' variable selection that works across datasets with different schemas +#' - Use numeric indices for `selected` when `choices` are dynamic to avoid referencing +#' variables that may not exist in all datasets +#' +#' ## Example: Three-level hierarchy +#' +#' ```r +#' picks( +#' datasets(choices = c("iris", "mtcars"), selected = "iris"), +#' variables(choices = tidyselect::where(is.numeric), selected = 1), +#' values(choices = tidyselect::everything(), selected = 1:10) +#' ) +#' ``` +#' +#' In this example: +#' - User first selects a dataset (iris or mtcars) +#' - Variable choices update to show only numeric columns from selected dataset +#' - After selecting a variable, value choices show all unique values from that column +#' +#' @examples +#' # Select columns from iris dataset using range selector #' picks( #' datasets(choices = "iris"), #' variables(choices = Sepal.Length:Petal.Width, selected = 1) #' ) +#' +#' # Single variable selection from iris dataset +#' picks( +#' datasets(choices = "iris", selected = "iris"), +#' variables(choices = c("Sepal.Length", "Sepal.Width"), selected = "Sepal.Length", multiple = FALSE) +#' ) +#' +#' # Dynamic selection: any variable from iris, first selected by default +#' picks( +#' datasets(choices = "iris", selected = "iris"), +#' variables(choices = tidyselect::everything(), selected = 1, multiple = FALSE) +#' ) +#' +#' # Multiple dataset choices: variable choices will update when dataset changes #' picks( #' datasets(choices = c("iris", "mtcars"), selected = "iris"), -#' variables(choices = tidyselect::everything(), selected = 1) +#' variables(choices = tidyselect::everything(), selected = 1, multiple = FALSE) #' ) +#' +#' # Select from any dataset, filter by numeric variables #' picks( #' datasets(choices = c("iris", "mtcars"), selected = 1), #' variables(choices = tidyselect::where(is.numeric), selected = 1) #' ) +#' +#' # Fully dynamic: auto-discover datasets and variables +#' picks( +#' datasets(choices = tidyselect::where(is.data.frame), selected = 1), +#' variables(choices = tidyselect::everything(), selected = 1, multiple = FALSE) +#' ) +#' +#' # Select categorical variables with length constraints #' picks( #' datasets(choices = tidyselect::everything(), selected = 1), #' variables(choices = is_categorical(min.len = 2, max.len = 15), selected = 1:2) #' ) -#' @rdname types -#' @name Types -NULL - -#' @describeIn types specify a selector. +#' #' @export picks <- function(...) { picks <- rlang::dots_list(..., .ignore_empty = "trailing") checkmate::assert_list(picks, types = "type") - checkmate::assert_class(picks[[1]], "datasets") - names(picks) <- vapply(picks, FUN = is, FUN.VALUE = character(1)) - structure(picks, class = c("picks", "list")) -} + if (!inherits(picks[[1]], "datasets")) { + stop("picks() requires datasets() as the first element", call. = FALSE) + } -#' @export -datanames <- function(x) { - if (inherits(x, "picks")) { - x <- list(x) + # Check if values exists and is preceded by variables + element_classes <- vapply(picks, FUN = is, FUN.VALUE = character(1)) + values_idx <- which(element_classes == "values") + + if (length(values_idx) > 0) { + variables_idx <- which(element_classes == "variables") + if (length(variables_idx) == 0) { + stop("picks() requires variables() before values()", call. = FALSE) + } + if (values_idx != variables_idx + 1) { + stop("values() must immediately follow variables() in picks()", call. = FALSE) + } } - checkmate::assert_list(x, c("picks", "NULL")) - unique(unlist(lapply(x, function(x) { - if (is.character(x$datasets$choices)) x$datasets$choices - }))) + + names(picks) <- element_classes + structure(picks, class = c("picks", "list")) } #' @rdname picks #' @export datasets <- function(choices = tidyselect::everything(), selected = 1, - fixed = !.is_tidyselect(choices) && length(choices) == 1, + fixed = NULL, ...) { + if (is.null(fixed)) { + fixed <- !.is_tidyselect(choices) && length(choices) == 1 + } + + selected_q <- if (.is_tidyselect(selected)) { + rlang::enquo(selected) + } else if (is.character(selected) && length(selected) == 1) { + selected + } else { + stop("datasets(selected) should either be `character(>0)` or `tidyselect-select-helper`") + } + out <- .selected_choices( choices = if (.is_tidyselect(choices)) rlang::enquo(choices) else choices, - selected = if (.is_tidyselect(selected)) rlang::enquo(selected) else selected, + selected = selected_q, multiple = FALSE, fixed = fixed, ... @@ -78,10 +209,17 @@ datasets <- function(choices = tidyselect::everything(), #' @export variables <- function(choices = tidyselect::everything(), selected = 1, - multiple = !.is_tidyselect(selected) && length(selected) > 1, - fixed = !.is_tidyselect(choices) && length(choices) == 1, + multiple = NULL, + fixed = NULL, ordered = FALSE, ...) { + if (is.null(multiple)) { + multiple <- !.is_tidyselect(selected) && length(selected) > 1 + } + if (is.null(fixed)) { + fixed <- !.is_tidyselect(choices) && length(choices) == 1 + } + out <- .selected_choices( choices = if (.is_tidyselect(choices)) rlang::enquo(choices) else choices, selected = if (.is_tidyselect(selected)) rlang::enquo(selected) else selected, @@ -95,13 +233,16 @@ variables <- function(choices = tidyselect::everything(), out } -#' @describeIn types Specify variables. +#' @rdname picks #' @export values <- function(choices = tidyselect::everything(), selected = tidyselect::everything(), multiple = TRUE, - fixed = !.is_tidyselect(choices) && length(choices) == 1, + fixed = NULL, ...) { + if (is.null(fixed)) { + fixed <- !.is_tidyselect(choices) && length(choices) == 1 + } out <- .selected_choices( choices = if (.is_tidyselect(choices)) rlang::enquo(choices) else choices, selected = if (.is_tidyselect(selected)) rlang::enquo(selected) else selected, @@ -114,58 +255,19 @@ values <- function(choices = tidyselect::everything(), } -#' @describeIn types Specify colData. +#' @rdname picks #' @export -mae_colData <- function(choices = tidyselect::everything(), selected = 1, multiple = FALSE) { +col_data <- function(choices = tidyselect::everything(), selected = 1, multiple = FALSE) { out <- .selected_choices( choices = if (.is_tidyselect(choices)) rlang::enquo(choices) else choices, selected = if (.is_tidyselect(selected)) rlang::enquo(selected) else selected, multiple = multiple ) - class(out) <- c("colData", class(out)) + class(out) <- c("col_data", class(out)) out } -#' @export -anyNA.type <- function(x, recursive = FALSE) { - anyNA(unclass(x[c("choices", "selected")]), recursive = recursive) -} -#' @export -is.na.type <- function(x) anyNA(x) - -#' @export -print.type <- function(x, ...) { - cat( - "choices :", .toString(x$choices), - "\nselected:", .toString(x$selected) - ) - return(x) -} - -.toString <- function(x) { - if (inherits(x, "quosure")) { - rlang::as_label(x) - } else if (is.vector(x)) { - toString(x, width = 30) - } else if (is.null(x)) { - "~" - } -} - - -.is.picks <- function(x) { - inherits(x, "picks") -} - -.is.tidyselect <- function(x) { - err <- try(force(x), silent = TRUE) - inherits(err, "error") && grepl("must be used within a *selecting*", err$message) -} - -.is.type <- function(x) { - inherits(x, "type") -} .selected_choices <- function(choices, selected, @@ -173,24 +275,28 @@ print.type <- function(x, ...) { ordered = FALSE, fixed = FALSE, ...) { - is_choices_delayed <- inherits(choices, "quosure") || - checkmate::test_multi_class(choices, c("variable_choices", "value_choices")) + is_choices_delayed <- rlang::is_quosure(choices) + is_choices_eager <- is.character(choices) && length(choices) is_selected_eager <- is.character(selected) - + if (!(is_choices_delayed || is_choices_eager)) { + stop("`choices` should either be `character(>0)` or `tidyselect-select-helper`") + } if (is_choices_delayed && is_selected_eager) { warning( deparse(sys.call(-1)), - "\n - Setting explicit `selected` while `choices` are delayed (set using `tidyselect`) might lead to the", "situation where `selected` is not in dynamically obtained `choices`.", + "\n - Setting explicit `selected` while `choices` are delayed (set using `tidyselect`) doesn't ", + "guarantee that `selected` is a subset of `choices`.", call. = FALSE ) } - if (inherits(choices, "choices_labeled")) { - choices <- setNames(as.vector(choices), names(choices)) - } - - if (inherits(selected, "choices_labeled")) { - selected <- setNames(as.vector(selected), names(selected)) + if (is.character(choices) && is.character(selected) && any(!selected %in% choices)) { + not_in_choices <- setdiff(selected, choices) + stop(sprintf( + "Some `selected`:{%s}\nare not a subset of `choices`: {%s}", + toString(sQuote(not_in_choices)), + toString(sQuote(choices)) + )) } out <- structure( @@ -203,11 +309,6 @@ print.type <- function(x, ...) { ) } -.valid_picks <- function(x) { - !((.is.type(x) || .is.picks(x))) -} - - #' Is an object created using tidyselect #' #' @description @@ -219,6 +320,10 @@ print.type <- function(x, ...) { #' @return `logical(1)` #' @keywords internal .is_tidyselect <- function(x) { - out <- tryCatch(x, error = function(e) e) - !is.character(out) && !is.null(out) && !inherits(out, "delayed_data") + out <- suppressWarnings(tryCatch(x, error = function(e) e)) + inherits(out, "error") && grepl("must be used within a \\*selecting\\* function", out$message) || # e.g. everything + inherits(out, "error") && grepl("object .+ not found", out$message) || # e.g. var:var2 + inherits(out, "error") && grepl("operations are possible", out$message) || # e.g. where() | where() + is.function(out) || # e.g. where(is.numeric) + checkmate::test_integerish(out, min.len = 1) # e.g. 1:5 } diff --git a/R/0-print.R b/R/0-print.R new file mode 100644 index 00000000..da17a668 --- /dev/null +++ b/R/0-print.R @@ -0,0 +1,79 @@ +#' @export +print.type <- function(x, ...) { + cat(format(x, indent = 0)) + invisible(x) +} + +#' @export +print.picks <- function(x, ...) { + cat(format(x, indent = 0)) + invisible(x) +} + +#' @export +format <- function(x, indent = 0) { + UseMethod("format") +} + +#' @export +format.picks <- function(x, indent = 0) { + out <- .indent(sprintf("%s\n", .bold("")), indent) + for (i in seq_along(x)) { + element_name <- names(x)[i] + out <- paste0(out, .indent(sprintf(" %s:\n", .bold(sprintf("<%s>", element_name))), indent)) + out <- paste0(out, .format_type_content(x[[i]], indent + 4)) + out <- paste0(out, .format_type_attributes(x[[i]], indent + 4)) + } + out +} + +#' @export +format.type <- function(x, indent = 0) { + element_class <- setdiff(class(x), "type")[1] + out <- .indent(sprintf("%s\n", .bold(sprintf("<%s>", element_class))), indent) + out <- paste0(out, .format_type_content(x, indent + 2)) + out <- paste0(out, .format_type_attributes(x, indent + 2)) + out +} + +.format_type_content <- function(x, indent = 0) { + out <- .indent(sprintf("%s %s\n", "choices:", .format_type_value(x$choices)), indent) + out <- paste0(out, .indent(sprintf("%s %s\n", "selected:", .format_type_value(x$selected)), indent)) + out +} + +.format_type_attributes <- function(x, indent = 0) { + attrs <- attributes(x) + attrs_to_show <- attrs[!names(attrs) %in% c("class", "names")] + if (length(attrs_to_show) > 0) { + attrs_str <- vapply(names(attrs_to_show), function(name) { + value <- attrs_to_show[[name]] + sprintf("%s=%s", name, paste(value, collapse = ",")) + }, character(1)) + paste0(.indent(.italic(paste(attrs_str, collapse = ", ")), indent), "\n") + } else { + "" + } +} + +.format_type_value <- function(x) { + choices_str <- if (rlang::is_quosure(x)) { + rlang::as_label(x) + } else if (length(x) == 0) { + "~" + } else { + paste(x, collapse = ", ") + } +} + +.indent <- function(x, n) { + paste(formatC("", width = n), x) +} + +.bold <- function(x) { + sprintf("\033[1m%s\033[0m", x) +} + +.italic <- function(x) { + sprintf("\033[3m%s\033[0m", x) +} diff --git a/R/0-resolver.R b/R/0-resolver.R index a51e9473..f8cdbf1c 100644 --- a/R/0-resolver.R +++ b/R/0-resolver.R @@ -41,6 +41,36 @@ resolver <- function(x, data) { x } +#' Is the specification resolved? +#' +#' Check that the specification is resolved against a given data source. +#' @param x Object to be evaluated. +#' @returns A single logical value. +#' @keywords internal +is.delayed <- function(x) { + UseMethod("is.delayed") +} + +# Handling a list of transformers e1 | e2 +#' @export +#' @method is.delayed list +is.delayed.list <- function(x) { + any(vapply(x, is.delayed, logical(1L))) +} + +#' @export +#' @method is.delayed picks +is.delayed.picks <- function(x) { + any(vapply(x, is.delayed, logical(1L))) +} + +#' @export +#' @method is.delayed type +is.delayed.type <- function(x) { + !is.character(x$choices) || !is.character(x$selected) +} + + #' A method that should take a type and resolve it. #' #' Generic that makes the minimal check on spec. @@ -178,3 +208,18 @@ determine.values <- function(x, data) { data[x$selected] } } + +.eval_select <- function(data, ...) { + if (is.environment(data)) { + # To keep the "order" of the names in the extraction: avoids suprises + data <- as.list(data)[names(data)] + } else if (length(dim(data)) == 2L) { + data <- as.data.frame(data) + } + + if (is.null(names(data))) { + stop("Can't extract the data.") + } + pos <- tidyselect::eval_select(expr = ..., data) + pos +} diff --git a/R/0-selector.R b/R/0-selector.R deleted file mode 100644 index 3aca761a..00000000 --- a/R/0-selector.R +++ /dev/null @@ -1,14 +0,0 @@ -.eval_select <- function(data, ...) { - if (is.environment(data)) { - # To keep the "order" of the names in the extraction: avoids suprises - data <- as.list(data)[names(data)] - } else if (length(dim(data)) == 2L) { - data <- as.data.frame(data) - } - - if (is.null(names(data))) { - stop("Can't extract the data.") - } - pos <- tidyselect::eval_select(expr = ..., data) - pos -} diff --git a/R/0-tm_merge.R b/R/0-tm_merge.R new file mode 100644 index 00000000..a06a5bef --- /dev/null +++ b/R/0-tm_merge.R @@ -0,0 +1,63 @@ +#' Merge module +#' +#' Example module +tm_merge <- function(label = "merge-module", inputs, transformators = list()) { + # todo: move to vignette + module( + label = label, + ui = function(id, inputs) { + ns <- NS(id) + tags$div( + tags$div( + class = "row g-2", + lapply(names(inputs), function(id) { + tags$div( + class = "col-auto", + tags$strong(tags$label(id)), + teal.transform::picks_ui( + id = ns(id), + spec = inputs[[id]] + ) + ) + }) + ), + shiny::div( + reactable::reactableOutput(ns("table_merged")), + shiny::verbatimTextOutput(ns("join_keys")), + shiny::verbatimTextOutput(ns("mapped")), + shiny::verbatimTextOutput(ns("src")) + ) + ) + }, + server = function(id, data, inputs) { + moduleServer(id, function(input, output, session) { + selectors <- picks_srv(id, spec = inputs, data = data) + + merged <- merge_srv("merge", data = data, selectors = selectors) + + table_q <- reactive({ + req(merged$data()) + within(merged$data(), reactable::reactable(anl), selectors = selectors) + }) + + output$table_merged <- reactable::renderReactable({ + req(table_q()) + teal.code::get_outputs(table_q())[[1]] + }) + + output$src <- renderPrint({ + styler::style_text( + teal.code::get_code(req(table_q())) + ) + }) + + output$mapped <- renderText(yaml::as.yaml(merged$variables())) + + output$join_keys <- renderPrint(teal.data::join_keys(merged$data())) + }) + }, + ui_args = list(inputs = inputs), + server_args = list(inputs = inputs), + transformators = transformators + ) +} diff --git a/inst/badge-dropdown/script.js b/inst/badge-dropdown/script.js new file mode 100644 index 00000000..d044f709 --- /dev/null +++ b/inst/badge-dropdown/script.js @@ -0,0 +1,31 @@ +function toggleBadgeDropdown(summaryId, containerId) { + var container = document.getElementById(containerId); + var summary = document.getElementById(summaryId); + + if(container.style.visibility === 'hidden' || container.style.visibility === '') { + container.style.visibility = 'visible'; + container.style.opacity = '1'; + container.style.pointerEvents = 'auto'; + $(container).trigger('shown'); + Shiny.bindAll(container); + + // Add click outside handler + setTimeout(function() { + function handleClickOutside(event) { + if (!container.contains(event.target) && !summary.contains(event.target)) { + container.style.visibility = 'hidden'; + container.style.opacity = '0'; + container.style.pointerEvents = 'none'; + $(container).trigger('hidden'); + document.removeEventListener('click', handleClickOutside); + } + } + document.addEventListener('click', handleClickOutside); + }, 10); + } else { + container.style.visibility = 'hidden'; + container.style.opacity = '0'; + container.style.pointerEvents = 'none'; + $(container).trigger('hidden'); + } +} \ No newline at end of file diff --git a/inst/badge-dropdown/style.css b/inst/badge-dropdown/style.css new file mode 100644 index 00000000..24f12a91 --- /dev/null +++ b/inst/badge-dropdown/style.css @@ -0,0 +1,61 @@ +.badge-dropdown { + padding: 0.25rem 0.5rem; + font-size: 0.75rem; + border-radius: 0.375rem; + line-height: 1.2; + min-width: auto; + width: 130px; + overflow-x: auto; + white-space: nowrap; + position: relative; + padding-right: .5rem; +} + +.badge-dropdown:has(~ * .shiny-validation-message), +.badge-dropdown:has(~ * .shiny-output-error) { + border: 2px solid red; +} + +.badge-dropdown-label { + display: block; + max-width: calc(100% - .5rem); + overflow-x: auto; + white-space: nowrap; + scrollbar-width: none; + -ms-overflow-style: none; + text-align: left; +} + +.badge-dropdown-label::-webkit-scrollbar { + display: none; +} + +.badge-dropdown-icon { + position: absolute; + top: 50%; + right: 0.5rem; + transform: translateY(-50%); + background: inherit; + z-index: 1; + pointer-events: none; + opacity: 0; + transition: opacity 0.2s ease; +} + +.badge-dropdown:hover .badge-dropdown-icon { + opacity: 1; +} + + +.badge-dropdown .btn { + padding: 0.25rem 0.5rem; + font-size: 0.75rem; + border-radius: 0.375rem; + line-height: 1.2; + min-width: auto; +} + +.badge-dropdown .btn::after { + margin-left: 0.25rem; + vertical-align: 0.1em; +} \ No newline at end of file diff --git a/inst/refactor-notes.Rmd b/inst/refactor-notes.Rmd deleted file mode 100644 index bdbbdd39..00000000 --- a/inst/refactor-notes.Rmd +++ /dev/null @@ -1,192 +0,0 @@ ---- -title: "Refactor Notes" -author: "Development Team" -date: "`r Sys.Date()`" -output: html_document ---- - -# -Consider following tables `orders`, `order_items`, `products`, `customers` connected with join keys -following sql convention `{child}.{parent-singular}_id = {parent}.id`, for example -`orders.customer_id = customers.id`. `teal.data` setup would look like this: - -```{r} -library(teal.data) -data <- within(teal_data(), { - customers <- tibble::tribble( - ~id, ~name, ~age, ~country, - 1, "Alice Johnson", 30, "USA", - 2, "Bob Smith", 25, "Canada", - 3, "Charlie Brown", 35, "UK", - 4, "David Wilson", 28, "Australia", - 5, "Emma Davis", 32, "USA", - 6, "Frank Miller", 27, "Canada", - 7, "Grace Taylor", 29, "UK", - 8, "Henry Clark", 33, "Australia", - 9, "Isabella Martinez", 26, "USA", - 10, "Jack Thompson", 31, "Canada" - ) - - orders <- tibble::tribble( - ~id, ~customer_id, ~order_date, ~total_amount, - 101, 1, as.Date("2024-01-15"), 250.00, - 102, 1, as.Date("2024-02-01"), 150.00, - 103, 2, as.Date("2024-02-10"), 125.00, - 104, 3, as.Date("2024-02-15"), 200.00, - 105, 4, as.Date("2024-02-20"), 175.00, - 106, 5, as.Date("2024-03-01"), 300.00, - 107, 6, as.Date("2024-03-05"), 50.00, - 108, 7, as.Date("2024-03-10"), 225.00, - 109, 8, as.Date("2024-03-12"), 100.00, - 110, 9, as.Date("2024-03-15"), 275.00, - 111, 10, as.Date("2024-03-18"), 125.00, - 112, 2, as.Date("2024-03-20"), 150.00 - ) - - order_items <- tibble::tribble( - ~id, ~order_id, ~product_id, ~quantity, ~unit_price, ~total_price, - 201, 101, 1, 2, 100.00, 200.00, - 202, 101, 2, 1, 50.00, 50.00, - 203, 102, 2, 3, 50.00, 150.00, - 204, 103, 2, 1, 50.00, 50.00, - 205, 103, 3, 1, 75.00, 75.00, - 206, 104, 1, 2, 100.00, 200.00, - 207, 105, 3, 2, 75.00, 150.00, - 208, 105, 2, 1, 50.00, 50.00, - 209, 106, 1, 3, 100.00, 300.00, - 210, 107, 2, 1, 50.00, 50.00, - 211, 108, 1, 1, 100.00, 100.00, - 212, 108, 3, 2, 75.00, 150.00, - 213, 109, 2, 2, 50.00, 100.00, - 214, 110, 1, 2, 100.00, 200.00, - 215, 110, 3, 1, 75.00, 75.00, - 216, 111, 2, 2, 50.00, 100.00, - 217, 111, 1, 1, 100.00, 100.00, - 218, 112, 3, 2, 75.00, 150.00 - ) - - order_files <- tibble::tribble( - ~id, ~order_id, ~file_name, ~file_type, - 301, 101, "invoice_101.pdf", "invoice", - 302, 102, "receipt_102.pdf", "receipt", - 303, 103, "invoice_103.pdf", "invoice", - 304, 104, "receipt_104.pdf", "receipt", - 305, 105, "invoice_105.pdf", "invoice", - 306, 106, "receipt_106.pdf", "receipt", - 307, 107, "invoice_107.pdf", "invoice", - 308, 108, "receipt_108.pdf", "receipt", - 309, 109, "invoice_109.pdf", "invoice", - 310, 110, "receipt_110.pdf", "receipt", - 311, 111, "invoice_111.pdf", "invoice", - 312, 112, "receipt_112.pdf", "receipt" - ) - - products <- tibble::tribble( - ~id, ~name, ~price, ~category, ~stock_quantity, - 401, "Laptop Pro", 100.00, "Electronics", 15, - 402, "Wireless Mouse", 50.00, "Electronics", 50, - 403, "Office Chair", 75.00, "Furniture", 8 - ) - - product_components <- tibble::tribble( - ~id, ~product_id, ~component_name, ~component_type, ~quantity_required, ~cost, - 501, 401, "CPU", "Processor", 1, 25.00, - 502, 401, "RAM", "Memory", 2, 15.00, - 503, 401, "SSD", "Storage", 1, 20.00, - 504, 401, "Screen", "Display", 1, 30.00, - 505, 402, "Optical Sensor", "Sensor", 1, 8.00, - 506, 402, "Wireless Module", "Connectivity", 1, 12.00, - 507, 402, "Battery", "Power", 1, 5.00, - 508, 403, "Steel Frame", "Structure", 1, 35.00, - 509, 403, "Cushion", "Comfort", 1, 20.00, - 510, 403, "Wheels", "Mobility", 5, 3.00 - ) -}) - -join_keys(data) <- join_keys( - join_key("customers", keys = "id"), - join_key("orders", keys = c("id")), - join_key("products", keys = c("id")), - join_key("product_components", keys = c("id")), - # foreign keys - join_key("customers", "orders", keys = c(id = "customer_id")), - join_key("products", "order_items", keys = c(id = "product_id")), - join_key("products", "product_components", keys = c(id = "product_id")), - join_key("orders", "order_items", keys = c(id = "order_id")) -) - -print(join_keys(data)) -``` - -Imagine now a scenario of a `ggplot` where one wants to select `x`, `y`, `color`, `facet_rows`, -`facet_cols`. Of course each input can come from different variables - -```{r, eval=FALSE} -ggplot( - data = ?, - aes( - x = !!sym(input$x), # orders.order_date - y = !!sym(input$y), # order_items.total_price - color = !!sym(input$color) # products.category - ) -) + - geom_line() + - facet_grid( - vars(!!sym(input$facet_rows)) # customers.country - ) -``` - -In order to create above visualization datasets need to be merged as `aes` is related to single -data object. Problem is solvable as `teal.data` has enough information to determine correct -merge call based and selected variables and `join_keys` (describing relationships between datasets). - -Using `dplyr` only we need to perform following merge operation given that following variables have -been selected: - -- x: `orders.order_date` -- y: `sum` of `order_items.order_items.total_price` -- color: `products.category` -- facet_rows: `customers.country` - -```{r} -data_w_merged <- within(data, { - library(dplyr) - anl <- select(orders, id, customer_id, order_date) |> - left_join(select(order_items, order_id, product_id, total_price), by = c(id = "order_id")) |> - left_join(select(products, id, category), by = c(product_id = "id")) |> - left_join(select(customers, id, country), by = c(customer_id = "id")) -}) -``` - -Now `anl` can produce desired visualization - -```{r} -# Create the visualization with merged data - sum moved to ggplot -data_w_plot <- within(data_w_merged, { - library(ggplot2) - - # Create ggplot with sum calculation inside - plot <- ggplot( - data = anl, - aes( - x = order_date, - y = total_price, - color = category - ) - ) + - geom_line() + - facet_grid( - rows = vars(country), - labeller = label_both - ) - - print(plot) -}) - -get_outputs(data_w_plot)[[1]] -``` - - -# Handling ambiguous variables - - diff --git a/inst/refactor-notes.md b/inst/refactor-notes.md new file mode 100644 index 00000000..77190254 --- /dev/null +++ b/inst/refactor-notes.md @@ -0,0 +1,787 @@ +--- +title: "Refactor Notes" +author: "Development Team" +date: "`r Sys.Date()`" +output: html_document +--- + +# Motivation + +## Merging relational data + + +Consider following tables `orders`, `order_items`, `products`, `customers` connected with join keys +following sql convention `{child}.{$parent}_id = {$parent+"s"}.id`, for example +`orders.customer_id = customers.id`. `teal.data` setup would look like this: + +
+Sample data setup with relational tables and join keys + +```r +library(teal.data) +data <- within(teal_data(), { + customers <- tibble::tribble( + ~id, ~name, ~age, ~country, + 1, "Alice Johnson", 30, "USA", + 2, "Bob Smith", 25, "Canada", + 3, "Charlie Brown", 35, "UK", + 4, "David Wilson", 28, "Australia", + 5, "Emma Davis", 32, "USA", + 6, "Frank Miller", 27, "Canada", + 7, "Grace Taylor", 29, "UK", + 8, "Henry Clark", 33, "Australia", + 9, "Isabella Martinez", 26, "USA", + 10, "Jack Thompson", 31, "Canada" + ) + + orders <- tibble::tribble( + ~id, ~customer_id, ~order_date, ~total_amount, + 101, 1, as.Date("2024-01-15"), 250.00, + 102, 1, as.Date("2024-02-01"), 150.00, + 103, 2, as.Date("2024-02-10"), 125.00, + 104, 3, as.Date("2024-02-15"), 200.00, + 105, 4, as.Date("2024-02-20"), 175.00, + 106, 5, as.Date("2024-03-01"), 300.00, + 107, 6, as.Date("2024-03-05"), 50.00, + 108, 7, as.Date("2024-03-10"), 225.00, + 109, 8, as.Date("2024-03-12"), 100.00, + 110, 9, as.Date("2024-03-15"), 275.00, + 111, 10, as.Date("2024-03-18"), 125.00, + 112, 2, as.Date("2024-03-20"), 150.00 + ) + + order_items <- tibble::tribble( + ~id, ~order_id, ~product_id, ~quantity, ~unit_price, ~total_price, + 201, 101, 1, 2, 100.00, 200.00, + 202, 101, 2, 1, 50.00, 50.00, + 203, 102, 2, 3, 50.00, 150.00, + 204, 103, 2, 1, 50.00, 50.00, + 205, 103, 3, 1, 75.00, 75.00, + 206, 104, 1, 2, 100.00, 200.00, + 207, 105, 3, 2, 75.00, 150.00, + 208, 105, 2, 1, 50.00, 50.00, + 209, 106, 1, 3, 100.00, 300.00, + 210, 107, 2, 1, 50.00, 50.00, + 211, 108, 1, 1, 100.00, 100.00, + 212, 108, 3, 2, 75.00, 150.00, + 213, 109, 2, 2, 50.00, 100.00, + 214, 110, 1, 2, 100.00, 200.00, + 215, 110, 3, 1, 75.00, 75.00, + 216, 111, 2, 2, 50.00, 100.00, + 217, 111, 1, 1, 100.00, 100.00, + 218, 112, 3, 2, 75.00, 150.00 + ) + + order_files <- tibble::tribble( + ~id, ~order_id, ~file_name, ~file_type, + 301, 101, "invoice_101.pdf", "invoice", + 302, 102, "receipt_102.pdf", "receipt", + 303, 103, "invoice_103.pdf", "invoice", + 304, 104, "receipt_104.pdf", "receipt", + 305, 105, "invoice_105.pdf", "invoice", + 306, 106, "receipt_106.pdf", "receipt", + 307, 107, "invoice_107.pdf", "invoice", + 308, 108, "receipt_108.pdf", "receipt", + 309, 109, "invoice_109.pdf", "invoice", + 310, 110, "receipt_110.pdf", "receipt", + 311, 111, "invoice_111.pdf", "invoice", + 312, 112, "receipt_112.pdf", "receipt" + ) + + products <- tibble::tribble( + ~id, ~name, ~price, ~category, ~stock_quantity, + 401, "Laptop Pro", 100.00, "Electronics", 15, + 402, "Wireless Mouse", 50.00, "Electronics", 50, + 403, "Office Chair", 75.00, "Furniture", 8 + ) + + product_components <- tibble::tribble( + ~id, ~product_id, ~component_name, ~component_type, ~quantity_required, ~cost, + 501, 401, "CPU", "Processor", 1, 25.00, + 502, 401, "RAM", "Memory", 2, 15.00, + 503, 401, "SSD", "Storage", 1, 20.00, + 504, 401, "Screen", "Display", 1, 30.00, + 505, 402, "Optical Sensor", "Sensor", 1, 8.00, + 506, 402, "Wireless Module", "Connectivity", 1, 12.00, + 507, 402, "Battery", "Power", 1, 5.00, + 508, 403, "Steel Frame", "Structure", 1, 35.00, + 509, 403, "Cushion", "Comfort", 1, 20.00, + 510, 403, "Wheels", "Mobility", 5, 3.00 + ) +}) + +join_keys(data) <- join_keys( + join_key("customers", keys = "id"), + join_key("orders", keys = c("id")), + join_key("products", keys = c("id")), + join_key("product_components", keys = c("id")), + # foreign keys + join_key("customers", "orders", keys = c(id = "customer_id")), + join_key("products", "order_items", keys = c(id = "product_id")), + join_key("products", "product_components", keys = c(id = "product_id")), + join_key("orders", "order_items", keys = c(id = "order_id")) +) + +print(join_keys(data)) +``` + +
+ +Imagine now a scenario of a `ggplot` where one wants to select `x`, `y`, `color`, `facet_rows`, +`facet_cols` from any variable in any dataset. + +
+Example ggplot with dynamic variable selection + +```r +ggplot( + data = ?, + aes( + x = !!sym(input$x), # orders.order_date + y = !!sym(input$y), # order_items.total_price + color = !!sym(input$color) # products.category + ) +) + + geom_line() + + facet_grid( + vars(!!sym(input$facet_rows)) # customers.country + ) +``` + +
+ +In order to create above visualization, datasets need to be merged as `ggplot::aes` is related to single +data object. Problem is solvable as `teal.data` has enough information to determine correct +merge call based and selected variables and `join_keys` (describing relationships between datasets). + +Using `dplyr` only we need to perform following merge operation given that following variables have +been selected: + +- x: `orders.order_date` +- y: `order_items.order_items.total_price` +- color: `products.category` +- facet_rows: `customers.country` + +
+Merge operation using dplyr joins + +```r +data_w_merged <- within(data, { + anl <- dplyr::select(orders, id, customer_id, order_date) %>% + dplyr::left_join(dplyr::select(order_items, order_id, product_id, total_price), by = c(id = "order_id")) %>% + dplyr::left_join(dplyr::select(products, id, category), by = c(product_id = "id")) %>% + dplyr::left_join(dplyr::select(customers, id, country), by = c(customer_id = "id")) +}) +``` + +
+ +Now `anl` can produce desired visualization + +
+Creating visualization with merged dataset + +```r +# Create the visualization with merged data - sum moved to ggplot +data_w_plot <- within(data_w_merged, { + library(ggplot2) + + # Create ggplot with sum calculation inside + plot <- ggplot( + data = anl, + aes( + x = order_date, + y = total_price, + color = category + ) + ) + + geom_line() + + facet_grid( + rows = vars(country), + labeller = label_both + ) + + print(plot) +}) + +get_outputs(data_w_plot)[[1]] +``` + +
+ +### Handling ambiguous variables + +When merging datasets containing duplicated variable names `dplyr::*_join(suffix = c(".x", ".y"))` automatically +adds a suffix to the columns, so that names are alway unique. + +## Merging interactively + +Developing system which can interactively handle merge is a challenging task not only for a reasons described above +but also due to additional layers which need to control described operation. These layers include: + +1. Providing an API for app-developer to enable and set specific merge configuration. +2. Providing robust, easy to use merge-modules which can handle weirdest app-developer needs (1) and provide meaningful information to the app-user about consequences of the data/variable selections. + +# 1. Configure possible selection + +## picks and choices/selected + +We came with an idea of `picks` which allows app-developer to specify `datasets`, `variables` and `values` to be selected by app-user during an app run. Each of them is based on the idea of `choices/selected` where app-developer +provides `choices` and what is `selected` by default. App-user though changes `selected` interactively. + +```mermaid +graph TB + subgraph AppDeveloper["👨‍💻 App Developer (Configuration Time)"] + Dev[App Developer] + end + + subgraph Variables["variables()"] + VAR_Choices["choices
(choices set by app-developer)"] + VAR_Selected["selected
(default set by app-developer)"] + end + + subgraph AppUser["👤 App User (Runtime)"] + User[App User] + UI["selectInput
(UI Component)"] + end + + Dev -->|"sets choices"| VAR_Choices + Dev -->|"sets default selected"| VAR_Selected + VAR_Choices -->|"displayed in"| UI + VAR_Selected -->|"initial value in"| UI + UI -->|"presents choices"| User + User -->|"changes selection"| VAR_Selected + + classDef devStyle fill:#e1f5ff,stroke:#0066cc,stroke-width:2px + classDef userStyle fill:#fff4e1,stroke:#cc6600,stroke-width:2px + classDef choicesStyle fill:#d4edda,stroke:#28a745,stroke-width:2px + classDef selectedStyle fill:#fff3cd,stroke:#ffc107,stroke-width:2px + + class Dev devStyle + class User,UI userStyle + class VAR_Choices choicesStyle + class VAR_Selected selectedStyle +``` + + +New design bases on an idea that a module can consume its arguments referring to any variable in any dataset. Consider following example, where: +- a module uses `x`, `y` and `facet` arguments to create an interactive inputs, +- user can select a variable from any dataset for `x`, `y`, `facet` +- visualization will be build on a merged dataset containing these three variables + +```r +# pseudocode +tm_example <- function(x, y, facet) { + ui = function(id, x, y, facet) ...., # creates placeholders for inputs + server = function(id, x, y, facet) { + moduleServer(id, function(input, output, session) { + output$plot <- renderPlot({ + merged_dataset |> + ggplot( + aes( + x = , + y = + ) + ) + geom_point() + facet_wrap(vars()) + }) + }) + } +} +``` + +To provide choices and default selection for `x`, `y` and `facet` we propose following api: + +
+Proposed API using picks() for variable selection + +```r +# pseudocode +tm_example( + x = picks( + datasets(, ), + variables(, ) + ), + y = picks( + datasets(, ), + variables(, ) + ), + facet = picks( + datasets(, ), + variables(, ) + ) +) +``` + +
+ +Where each function creates an object which holds the information consumed by the framework. `choices` and `selected` can be either: +- explicit character denoting the name of the objects +- Natural number denoting index of column +- `tidyselect` selection_helpers (`?tidyselect::language`) + +## Relationship between `picks` elements + +Each `picks` element is evaluated in a sequence starting from `datasets`. `selected` in one of them determines possible choices of the next one. For example: + +If `datasets` is selected to be `iris`, then following variables's `choices` will be variables of iris. `selected` can't be something else than a `choices` and so on. + +```mermaid +graph TB + subgraph "picks()" + subgraph "datasets()" + DS_Choices["choices
(available datasets)"] + DS_Selected["selected
(chosen dataset)"] + end + + subgraph "variables()" + VAR_Choices["choices
(available variables)"] + VAR_Selected["selected
(chosen variable)"] + end + end + + DS_Choices -->|"user selects from"| DS_Selected + DS_Selected -->|"determines"| VAR_Choices + VAR_Choices -->|"user selects from"| VAR_Selected + + DS_Selected -.->|"e.g., if 'iris' selected"| VAR_Choices + VAR_Choices -.->|"then choices become
iris columns"| VAR_Selected + + classDef choicesStyle fill:#d4edda,stroke:#28a745,stroke-width:2px + classDef selectedStyle fill:#fff3cd,stroke:#ffc107,stroke-width:2px + classDef flowStyle fill:#e8f4f8,stroke:#0066cc,stroke-width:1px,stroke-dasharray: 5 5 + + class DS_Choices,VAR_Choices choicesStyle + class DS_Selected,VAR_Selected selectedStyle + + style DS_Selected stroke-width:3px + style VAR_Choices stroke-width:3px +``` + + + +## Example settings + +Please read carefully the code and see the description to understand how `picks` work. + +### Strict variables picks + +`picks` below will create an input in the module where single variable can be selected from `c("Sepal.Length", "Sepal.Width")`. `multiple = FALSE` disallow user to select more than one choice. + +
+Example: Strict variable picks with single selection + +```r +picks( + datasets(choices = "iris", selected = "iris"), + variables(choices = c("Sepal.Length", "Sepal.Width"), selected = "Sepal.Length", multiple = FALSE) +) +``` + +
+ +### Dynamic variables choices + +Following `picks` will create an input in the module where user will be able to select any variable from iris (any = `everything()`) and by default `1`-st will be selected. Be careful, setting explicit `selected` when `choices` throws a warning as it is not certain for example that `"Species" %in% everything()`. + +
+Example: Dynamic variable choices with tidyselect + +```r +picks( + datasets(choices = "iris", selected = "iris"), + variables(choices = tidyselect::everything(), selected = 1, multiple = FALSE) +) +``` + +
+ +### Dynamic variables from multiple datasets + +Consider a situation when one wants to select a variable from either `iris` or `mtcars`. Instead of forcing app-developer to enumerate all possible choices for `iris` and `mtcars`. Following picks will create two related inputs for datasets and for variables. Input for variables will automatically update when dataset selection changes. + +
+Example: Multiple datasets with dynamic variables + +```r +picks( + datasets(choices = c("iris", "mtcars"), selected = "iris"), + variables(choices = tidyselect::everything(), selected = 1, multiple = FALSE) +) +``` + +
+ +### Dynamic everything + +In extreme scenario also lists of datasets could be unknown. Or to avoid writing too much text, one can specify following `picks`. + +
+Example: Fully dynamic dataset and variable selection + +```r +picks( + datasets(choices = tidyselect::where(is.data.frame), selected = 1), + variables(choices = tidyselect::everything(), selected = 1, multiple = FALSE) +) +``` + +
+ +## Implementation in `teal_module` + +`teal_module` will accept `x`, `y` and `facet` and hand-over them to both `ui` and `server`. + +
+Module definition with picks arguments + +```r +tm_example <- function(x, y, facet) { + module( + ui = ui_example, + server = srv_example, + ui_args = list(x = x, y = y, facet = facet), + server_args = list(x = x, y = y, facet = facet) + ) +} +``` + +
+ +On the `ui` part it is necessary to call `picks_ui` for each `picks` object. + +
+UI implementation with picks_ui + +```r +ui_example <- function(id, x, y, facet) { + ns <- NS(id) + div( + picks_ui(id = ns("x"), spec = x), + picks_ui(id = ns("y"), spec = y), + picks_ui(id = ns("facet"), spec = facet), + plotOutput(ns("plot")) + ) +} +``` + +
+ +In the `server`, `picks` are utilized in `picks_srv` which can be called per each pick, or for all at once (as in the example below). `picks_srv` is used only to resolve dynamic choices/selected and to handle interaction between inputs. `selectors` contain a list of selected datasets/variables for each `pick`. In this example `selectors` structure looks like this: + +```yaml +x: (reactiveVal) + datasets: + choices: ... + selected: ... + variables: + choices: ... + selected: ... +y: ... +facet: ... +``` + +To create a merged-dataset using information from app-user selection one needs to call `merge_srv`. `picks_srv` doesn't do anything else than controlling a selection for a number of reasons: + +- One might want to use different set of `variables` to perform merge. For example, some might be controlled with `picks_ui/srv` and have an UI element and some might be fixed and added optionally to the `merge_srv(selectors)`. +- Before merge is performed, one might want to validate if the selection is correct from a module perspective. + +`merge_srv` returns a list with two reactives: +- `data`: `teal_data` object with merged dataset and +- `merge_vars`: named list of variables. List is named after selector name, for example `merge_vars()$facet` + +
+Server implementation with merge_srv + +```r +srv_example <- function(id, data, x, y, facet) { + moduleServer(id, function(input, output, session) { + selectors <- picks_srv(data = data, spec = list(x = x, y = y, facet = facet)) + + merged <- merge_srv("merge", data = data, selectors = selectors) + + plot_q <- reactive({ + within(merged$data(), + { + merged %>% + ggplot(aes(x = x, y = y)) + + geom_point() + + facet_wrap(vars(facet)) + }, + x = str2lang(merged$variables()$x), + y = str2lang(merged$variables()$y), + facet = str2lang(merged$variables()$facet) + ) + }) + + output$plot <- renderPlot({ + req(plot_q()) + rev(get_outputs(plot_q()))[[1]] + }) + }) +} +``` + +
+ +## App example + +
+Complete working app example with relational data and dynamic merging + +```r +devtools::load_all("teal.data") +devtools::load_all("teal.transform") +devtools::load_all("teal") +devtools::load_all("teal.modules.general") +library(dplyr) + +data <- within(teal.data::teal_data(), { + customers <- tibble::tribble( + ~id, ~name, ~age, ~country, + 1, "Alice Johnson", 30, "USA", + 2, "Bob Smith", 25, "Canada", + 3, "Charlie Brown", 35, "UK", + 4, "David Wilson", 28, "Australia", + 5, "Emma Davis", 32, "USA", + 6, "Frank Miller", 27, "Canada", + 7, "Grace Taylor", 29, "UK", + 8, "Henry Clark", 33, "Australia", + 9, "Isabella Martinez", 26, "USA", + 10, "Jack Thompson", 31, "Canada" + ) + + orders <- tibble::tribble( + ~id, ~customer_id, ~order_date, ~total_amount, + 101, 1, as.Date("2024-01-15"), 250.00, + 102, 1, as.Date("2024-02-01"), 150.00, + 103, 2, as.Date("2024-02-10"), 125.00, + 104, 3, as.Date("2024-02-15"), 200.00, + 105, 4, as.Date("2024-02-20"), 175.00, + 106, 5, as.Date("2024-03-01"), 300.00, + 107, 6, as.Date("2024-03-05"), 50.00, + 108, 7, as.Date("2024-03-10"), 225.00, + 109, 8, as.Date("2024-03-12"), 100.00, + 110, 9, as.Date("2024-03-15"), 275.00, + 111, 10, as.Date("2024-03-18"), 125.00, + 112, 2, as.Date("2024-03-20"), 150.00 + ) + + order_items <- tibble::tribble( + ~id, ~order_id, ~product_id, ~quantity, ~unit_price, ~total_price, + 201, 101, 401, 2, 100.00, 200.00, + 202, 101, 402, 1, 50.00, 50.00, + 203, 102, 402, 3, 50.00, 150.00, + 204, 103, 402, 1, 50.00, 50.00, + 205, 103, 403, 1, 75.00, 75.00, + 206, 104, 401, 2, 100.00, 200.00, + 207, 105, 403, 2, 75.00, 150.00, + 208, 105, 402, 1, 50.00, 50.00, + 209, 106, 401, 3, 100.00, 300.00, + 210, 107, 402, 1, 50.00, 50.00, + 211, 108, 401, 1, 100.00, 100.00, + 212, 108, 403, 2, 75.00, 150.00, + 213, 109, 402, 2, 50.00, 100.00, + 214, 110, 401, 2, 100.00, 200.00, + 215, 110, 403, 1, 75.00, 75.00, + 216, 111, 402, 2, 50.00, 100.00, + 217, 111, 401, 1, 100.00, 100.00, + 218, 112, 403, 2, 75.00, 150.00 + ) + + order_files <- tibble::tribble( + ~id, ~order_id, ~file_name, ~file_type, + 301, 101, "invoice_101.pdf", "invoice", + 302, 102, "receipt_102.pdf", "receipt", + 303, 103, "invoice_103.pdf", "invoice", + 304, 104, "receipt_104.pdf", "receipt", + 305, 105, "invoice_105.pdf", "invoice", + 306, 106, "receipt_106.pdf", "receipt", + 307, 107, "invoice_107.pdf", "invoice", + 308, 108, "receipt_108.pdf", "receipt", + 309, 109, "invoice_109.pdf", "invoice", + 310, 110, "receipt_110.pdf", "receipt", + 311, 111, "invoice_111.pdf", "invoice", + 312, 112, "receipt_112.pdf", "receipt" + ) + + products <- tibble::tribble( + ~id, ~name, ~price, ~category, ~stock_quantity, + 401, "Laptop Pro", 100.00, "Electronics", 15, + 402, "Wireless Mouse", 50.00, "Electronics", 50, + 403, "Office Chair", 75.00, "Furniture", 8 + ) + + product_components <- tibble::tribble( + ~id, ~product_id, ~component_name, ~component_type, ~quantity_required, ~cost, + 501, 401, "CPU", "Processor", 1, 25.00, + 502, 401, "RAM", "Memory", 2, 15.00, + 503, 401, "SSD", "Storage", 1, 20.00, + 504, 401, "Screen", "Display", 1, 30.00, + 505, 402, "Optical Sensor", "Sensor", 1, 8.00, + 506, 402, "Wireless Module", "Connectivity", 1, 12.00, + 507, 402, "Battery", "Power", 1, 5.00, + 508, 403, "Steel Frame", "Structure", 1, 35.00, + 509, 403, "Cushion", "Comfort", 1, 20.00, + 510, 403, "Wheels", "Mobility", 5, 3.00 + ) + + iris <- iris + mtcars <- mtcars + iris$id <- seq_len(nrow(iris)) + mtcars$id <- seq_len(nrow(mtcars)) + ADSL <- rADSL + ADTTE <- rADTTE + ADRS <- rADRS + ADAE <- rADAE + ADLB <- rADLB + ADTR <- rADTR +}) + +join_keys(data) <- c( + teal.data::default_cdisc_join_keys[c("ADSL", "ADTTE", "ADRS", "ADAE", "ADQS", "ADTR", "ADLB")], + teal.data::join_keys( + join_key("iris", keys = "id"), + join_key("mtcars", keys = "id"), + teal.data::join_key("customers", keys = "id"), + teal.data::join_key("orders", keys = c("id")), + teal.data::join_key("products", keys = c("id")), + teal.data::join_key("product_components", keys = c("id")), + # foreign keys + teal.data::join_key("customers", "orders", keys = c(id = "customer_id")), + teal.data::join_key("products", "order_items", keys = c(id = "product_id")), + teal.data::join_key("products", "product_components", keys = c(id = "product_id")), + teal.data::join_key("orders", "order_items", keys = c(id = "order_id")), + # add missing keys + teal.data::join_key("ADTR", "ADTR", keys = c("STUDYID", "USUBJID", "PARAMCD", "AVISIT")), + teal.data::join_key("ADSL", "ADTR", keys = c("STUDYID", "USUBJID")) + ) +) + +tm_example <- function(x, y, facet) { + module( + ui = ui_example, + server = srv_example, + ui_args = list(x = x, y = y, facet = facet), + server_args = list(x = x, y = y, facet = facet) + ) +} + +ui_example <- function(id, x, y, facet) { + ns <- NS(id) + div( + picks_ui(id = ns("x"), spec = x), + picks_ui(id = ns("y"), spec = y), + picks_ui(id = ns("facet"), spec = facet), + plotOutput(ns("plot")) + ) +} + +srv_example <- function(id, data, x, y, facet) { + moduleServer(id, function(input, output, session) { + selectors <- picks_srv(data = data, spec = list(x = x, y = y, facet = facet)) + + merged <- merge_srv("merge", data = data, selectors = selectors) + + plot_q <- reactive({ + within(merged$data(), + { + anl %>% + ggplot(aes(x = x, y = y)) + + geom_point() + + facet_wrap(vars(facet)) + }, + x = str2lang(merged$variables()$x), + y = str2lang(merged$variables()$y), + facet = str2lang(merged$variables()$facet) + ) + }) + + output$plot <- renderPlot({ + req(plot_q()) + rev(get_outputs(plot_q()))[[1]] + }) + }) +} + +app <- init( + data = data, + modules = modules( + tm_example( + x = picks( + datasets("orders"), + variables(selected = "order_date") + ), + y = picks( + datasets("order_items"), + variables(selected = "total_price") + ), + facet = picks( + datasets("customers"), + variables(selected = "country") + + ) + ), + modules( + label = "Display e2e configuration", + tm_merge( + label = "adam", + inputs = list( + a = picks( + datasets("ADTTE"), + variables(multiple = TRUE) + ), + b = picks( + datasets(choices = tidyselect::where(is.data.frame), selected = "ADSL"), + variables(is_categorical(min.len = 2, max.len = 20), selected = 1, multiple = TRUE) + ), + c = picks( + datasets(tidyselect::everything(), "ADTTE"), + variables(choices = c(AGE:ARM, PARAMCD), selected = AGE, multiple = TRUE) + ), + d = picks( + datasets(choices = "ADRS", selected = "ADRS"), + variables(choices = "PARAM", selected = "PARAM"), + values(selected = tidyselect::everything(), multiple = TRUE) + ), + e = picks( + datasets(selected = "ADSL"), + variables( + choices = variable_choices("whatever", subset = function(data) { + idx <- vapply(data, is.factor, logical(1)) + names(data)[idx] + }) + ) + ) + ) + ), + tm_merge( + label = "non adam", + inputs = list( + a = picks( + datasets( + choices = tidyselect::where(is.data.frame) & !tidyselect::starts_with("AD"), + selected = "orders" + ), + variables( + selected = "order_date", + multiple = TRUE + ) + ), + b = picks( + datasets(selected = "products"), + variables(selected = "price", multiple = TRUE) + ), + c = picks( + datasets(selected = "order_items"), + variables(multiple = TRUE) + ) + ) + ) + ) + ) +) + +shinyApp(app$ui, app$server, enableBookmarking = "server") +``` + +
diff --git a/man/badge_dropdown.Rd b/man/badge_dropdown.Rd new file mode 100644 index 00000000..97df8808 --- /dev/null +++ b/man/badge_dropdown.Rd @@ -0,0 +1,22 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/0-badge_dropdown.R +\name{badge_dropdown} +\alias{badge_dropdown} +\title{Dropdown badge} +\usage{ +badge_dropdown(id, label, content) +} +\arguments{ +\item{id}{(\code{character(1)}) shiny module's id} + +\item{label}{(\code{shiny.tag}) Label displayed on a badge.} + +\item{...}{(\code{shiny.tag}) Content of a dropdown.} +} +\description{ +Dropdown button in a form of a badge with \code{bg-primary} as default style +Clicking badge shows a dropdown containing any \code{HTML} element. Folded dropdown +doesn't trigger display output which means that items rendered using \verb{render*} +will be recomputed only when dropdown is show. +} +\keyword{internal} diff --git a/man/datanames.Rd b/man/datanames.Rd new file mode 100644 index 00000000..0441408d --- /dev/null +++ b/man/datanames.Rd @@ -0,0 +1,77 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/0-datanames.R +\name{datanames} +\alias{datanames} +\title{Extract dataset names from picks objects} +\usage{ +datanames(x) +} +\arguments{ +\item{x}{(\code{picks} object, a list of \code{picks})} +} +\value{ +A character vector of unique dataset names. Only returns names when dataset choices +are specified as character vectors (static choices). Returns \code{NULL} or empty vector when +datasets are specified using \code{tidyselect} expressions (dynamic choices), since the actual +dataset names cannot be determined until runtime. +} +\description{ +\code{datanames()} extracts the names of all datasets referenced in one or more \code{picks} objects. +This is useful for determining which datasets need to be available in the data environment +before a module can function properly. +} +\details{ +The function examines the \code{datasets()} component of each \code{picks} object and extracts +dataset names only when they are explicitly specified as character vectors. This allows +modules to declare their data dependencies upfront. +\subsection{Behavior with different choice types}{ +\itemize{ +\item \strong{Static choices}: When \code{datasets(choices = c("iris", "mtcars"))} uses character vectors, +\code{datanames()} returns \code{c("iris", "mtcars")}. +\item \strong{Dynamic choices}: When \code{datasets(choices = tidyselect::everything())} or other +tidyselect expressions are used, \code{datanames()} cannot determine the dataset names in +advance and returns an empty result. +\item \strong{Mixed lists}: When processing multiple \code{picks} objects, only the statically defined +dataset names are extracted and combined. +} +} +} +\examples{ +# Single picks object with one dataset +p1 <- picks( + datasets(choices = "iris", selected = "iris"), + variables(choices = tidyselect::everything(), selected = 1) +) +datanames(p1) # Returns "iris" + +# Single picks object with multiple datasets +p2 <- picks( + datasets(choices = c("iris", "mtcars"), selected = "iris"), + variables(choices = tidyselect::where(is.numeric), selected = 1) +) +datanames(p2) # Returns c("iris", "mtcars") + +# List of picks objects +p3 <- picks( + datasets(choices = c("chickwts", "PlantGrowth"), selected = 1), + variables(choices = tidyselect::everything(), selected = 1) +) +datanames(list(p1, p2, p3)) # Returns c("iris", "mtcars", "chickwts", "PlantGrowth") + +# Dynamic choices - cannot determine dataset names +p4 <- picks( + datasets(choices = tidyselect::where(is.data.frame), selected = 1), + variables(choices = tidyselect::everything(), selected = 1) +) +datanames(p4) # Returns NULL or empty vector + +# List with NULL values (filtered out automatically) +datanames(list(p1, NULL, p2)) # Returns c("iris", "mtcars") + +# Duplicate dataset names are removed +datanames(list(p1, p1, p2)) # Returns c("iris", "mtcars") - no duplicates + +} +\seealso{ +\code{\link[=picks]{picks()}}, \code{\link[=datasets]{datasets()}} +} diff --git a/man/dot-merge_summary_list.Rd b/man/dot-merge_summary_list.Rd index 4f4441c8..27b0a1e1 100644 --- a/man/dot-merge_summary_list.Rd +++ b/man/dot-merge_summary_list.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/0-module_merge.R \name{.merge_summary_list} \alias{.merge_summary_list} -\title{Analyse selectors and guess merge consequences} +\title{Analyse selectors and concludes a merge parameters} \usage{ .merge_summary_list(selectors, join_keys) } @@ -10,11 +10,12 @@ list containing: \itemize{ \item mapping (\verb{named list}) containing selected values in each selector. This \code{mapping} -is sorted according to correct datasets merge order. +is sorted according to correct datasets merge order. \code{variables} contains names of the +variables in \code{ANL} \item join_keys (\code{join_keys}) updated \code{join_keys} containing keys of \code{ANL} } } \description{ -Analyse selectors and guess merge consequences +Analyse selectors and concludes a merge parameters } \keyword{internal} diff --git a/man/dot-picker_icon.Rd b/man/dot-picker_icon.Rd new file mode 100644 index 00000000..c99c3a81 --- /dev/null +++ b/man/dot-picker_icon.Rd @@ -0,0 +1,18 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/0-module_picks.R +\name{.picker_icon} +\alias{.picker_icon} +\title{\code{pickerInput} choices icons} +\usage{ +.picker_icon(x) +} +\arguments{ +\item{x}{(\code{any}) object which class will determine icon} +} +\value{ +html-tag in form of \code{character(1)} +} +\description{ +Icons describing a class of the choice +} +\keyword{internal} diff --git a/man/dot-resolve.Rd b/man/dot-resolve.Rd index 4c042cfc..edf52397 100644 --- a/man/dot-resolve.Rd +++ b/man/dot-resolve.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/0-module_input.R +% Please edit documentation in R/0-module_picks.R \name{.resolve} \alias{.resolve} \title{Resolve downstream after selected changes} diff --git a/man/dot-update_rv.Rd b/man/dot-update_rv.Rd new file mode 100644 index 00000000..4fb50551 --- /dev/null +++ b/man/dot-update_rv.Rd @@ -0,0 +1,18 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/0-module_picks.R +\name{.update_rv} +\alias{.update_rv} +\title{Update reactive values with log} +\usage{ +.update_rv(rv, value, log) +} +\arguments{ +\item{rv}{(\code{reactiveVal})} + +\item{value}{(\code{vector})} + +\item{log}{(\code{character(1)}) message to \code{log_debug}} +} +\description{ +Update reactive values only if values differ to avoid unnecessary reactive trigger +} diff --git a/man/is.delayed.Rd b/man/is.delayed.Rd index f300d3db..b22639fa 100644 --- a/man/is.delayed.Rd +++ b/man/is.delayed.Rd @@ -15,8 +15,4 @@ A single logical value. \description{ Check that the specification is resolved against a given data source. } -\examples{ -is.delayed(1) -is.delayed(variables("df", "df")) -is.delayed(variables("df")) # Unknown selection -} +\keyword{internal} diff --git a/man/merge_srv.Rd b/man/merge_srv.Rd index 22ecdafb..cff900b6 100644 --- a/man/merge_srv.Rd +++ b/man/merge_srv.Rd @@ -2,26 +2,15 @@ % Please edit documentation in R/0-module_merge.R \name{merge_srv} \alias{merge_srv} -\alias{qenv_merge_selectors} -\alias{map_merged} \title{Merge Server Function for Dataset Integration} \usage{ merge_srv( id, data, selectors, - output_name = "merged", + output_name = "anl", join_fun = "dplyr::inner_join" ) - -qenv_merge_selectors( - x, - selectors, - output_name = "merged", - join_fun = "dplyr::left_join" -) - -map_merged(selectors, join_keys) } \arguments{ \item{id}{(\code{character(1)}) Module ID for the Shiny module namespace} @@ -38,7 +27,7 @@ The names of this list are used as identifiers for tracking which variables come }} \item{output_name}{(\code{character(1)}) Name of the merged dataset that will be created in the -returned \code{teal_data} object. Default is \code{"merged"}. This name will be used in the generated R code.} +returned \code{teal_data} object. Default is \code{"anl"}. This name will be used in the generated R code.} \item{join_fun}{(\code{character(1)}) The joining function to use for merging datasets. Must be a qualified function name (e.g., \code{"dplyr::left_join"}, \code{"dplyr::inner_join"}, \code{"dplyr::full_join"}). @@ -52,7 +41,7 @@ The merged dataset is named according to \code{output_name} parameter. The \code - The merged dataset with all selected variables - Complete R code to reproduce the merge operation - Updated join keys reflecting the merged dataset structure} -\item{\code{merge_vars}}{A \code{reactive} returning a named list mapping selector names to their selected +\item{\code{variables}}{A \code{reactive} returning a named list mapping selector names to their selected variables in the merged dataset. The structure is: \code{list(selector_name_1 = c("var1", "var2"), selector_name_2 = c("var3", "var4"), ...)}. Variable names reflect any renaming that occurred during the merge to avoid conflicts.} @@ -81,13 +70,13 @@ The \code{merge_srv} function performs the following steps: defined join keys \item \strong{Processes Selectors}: Evaluates each selector (whether static \code{picks} or reactive) to determine which datasets and variables are selected -\item \strong{Determines Merge Order}: Uses \code{\link[=qenv_merge_selectors]{qenv_merge_selectors()}} to analyze join keys and determine -the optimal order for merging datasets (topological sort based on relationships) +\item \strong{Determines Merge Order}: Uses topological sort based on the \code{join_keys} to determine +the optimal order for merging datasets. \item \strong{Handles Variable Conflicts}: Automatically renames variables when: \itemize{ \item Multiple selectors choose variables with the same name from different datasets \item Foreign key variables would conflict with existing variables -\item Renaming follows the pattern \code{variable_datasetname} +\item Renaming follows the pattern \verb{\{column-name\}_\{dataset-name\}} } \item \strong{Performs Merge}: Generates and executes merge code that: \itemize{ @@ -98,8 +87,7 @@ the optimal order for merging datasets (topological sort based on relationships) } \item \strong{Updates Join Keys}: Creates new join key relationships for the merged dataset ("anl") relative to remaining datasets in the \code{teal_data} object -\item \strong{Tracks Variables}: Uses \code{\link[=map_merged]{map_merged()}} to maintain a mapping of which variables in the -merged dataset came from which selector +\item \strong{Tracks Variables}: Keeps track of the variable names in the merged dataset } } @@ -123,7 +111,7 @@ merged_data <- merged$data() # teal_data object with merged dataset anl <- merged_data[["anl"]] # The actual merged data.frame/tibble # Get variable mapping -vars <- merged$merge_vars() +vars <- merged$variables() # Returns: list(selector1 = c("VAR1", "VAR2"), selector2 = c("VAR3", "VAR4_ADSL")) # Get reproducible code @@ -162,10 +150,10 @@ acts as the "left" side of the join, and subsequent datasets are joined one by o \section{Integration with Selectors}{ -\code{merge_srv} is designed to work with \code{\link[=module_input_srv]{module_input_srv()}} which creates selector objects: +\code{merge_srv} is designed to work with \code{\link[=picks_srv]{picks_srv()}} which creates selector objects: \if{html}{\out{
}}\preformatted{# Create selectors in server -selectors <- module_input_srv( +selectors <- picks_srv( spec = list( adsl = picks(...), adae = picks(...) @@ -199,8 +187,8 @@ join_keys(data) <- default_cdisc_join_keys[c("ADSL", "ADAE")] # Create Shiny app ui <- fluidPage( - module_input_ui("adsl", picks(datasets("ADSL"), variables())), - module_input_ui("adae", picks(datasets("ADAE"), variables())), + picks_ui("adsl", picks(datasets("ADSL"), variables())), + picks_ui("adae", picks(datasets("ADAE"), variables())), verbatimTextOutput("code"), verbatimTextOutput("vars") ) @@ -208,11 +196,11 @@ ui <- fluidPage( server <- function(input, output, session) { # Create selectors selectors <- list( - adsl = module_input_srv("adsl", + adsl = picks_srv("adsl", data = reactive(data), spec = picks(datasets("ADSL"), variables()) ), - adae = module_input_srv("adae", + adae = picks_srv("adae", data = reactive(data), spec = picks(datasets("ADAE"), variables()) ) @@ -233,7 +221,7 @@ server <- function(input, output, session) { }) output$vars <- renderPrint({ - merged$merge_vars() + merged$variables() }) } @@ -243,9 +231,7 @@ shinyApp(ui, server) } \seealso{ \itemize{ -\item \code{\link[=qenv_merge_selectors]{qenv_merge_selectors()}} for the underlying merge logic -\item \code{\link[=map_merged]{map_merged()}} for variable mapping functionality -\item \code{\link[=module_input_srv]{module_input_srv()}} for creating selectors +\item \code{\link[=picks_srv]{picks_srv()}} for creating selectors \item \code{\link[teal.data:join_keys]{teal.data::join_keys()}} for defining dataset relationships } } diff --git a/man/module_input_ui.Rd b/man/module_input_ui.Rd deleted file mode 100644 index 3bad7883..00000000 --- a/man/module_input_ui.Rd +++ /dev/null @@ -1,11 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/0-module_input.R -\name{module_input_ui} -\alias{module_input_ui} -\title{Module's interactive input} -\usage{ -module_input_ui(id, spec) -} -\description{ -Module's interactive input -} diff --git a/man/picks.Rd b/man/picks.Rd new file mode 100644 index 00000000..7e408852 --- /dev/null +++ b/man/picks.Rd @@ -0,0 +1,197 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/0-picks.R +\name{picks} +\alias{picks} +\alias{datasets} +\alias{variables} +\alias{values} +\alias{col_data} +\title{Choices/selected settings} +\usage{ +picks(...) + +datasets(choices = tidyselect::everything(), selected = 1, fixed = NULL, ...) + +variables( + choices = tidyselect::everything(), + selected = 1, + multiple = NULL, + fixed = NULL, + ordered = FALSE, + ... +) + +values( + choices = tidyselect::everything(), + selected = tidyselect::everything(), + multiple = TRUE, + fixed = NULL, + ... +) + +col_data(choices = tidyselect::everything(), selected = 1, multiple = FALSE) +} +\arguments{ +\item{...}{additional arguments delivered to \code{pickerInput}} + +\item{choices}{(\code{\link[tidyselect:language]{tidyselect::language}} or \code{character}) +Available values to choose.} + +\item{selected}{(\code{\link[tidyselect:language]{tidyselect::language}} or \code{character}) +Choices to be selected.} + +\item{fixed}{(\code{logical(1)}) selection will be fixed and not possible to change interactively.} + +\item{multiple}{(\code{logical(1)}) if more than one selection is possible.} + +\item{ordered}{(\code{logical(1)}) if the selected should follow the selection order. If \code{FALSE} +\code{selected} returned from \code{srv_module_input()} would be ordered according to order in \code{choices}.} +} +\description{ +Define choices and default selection for variables. \code{picks} allows app-developer to specify +\code{datasets}, \code{variables} and \code{values} to be selected by app-user during Shiny session. +Functions are based on the idea of \code{choices/selected} where app-developer provides \code{choices} +and what is \code{selected} by default. App-user though changes \code{selected} interactively in +\code{\link{picks_module}} +} +\section{\code{tidyselect} support}{ +Both \code{choices} and \code{selected} parameters support \code{tidyselect} syntax, enabling dynamic +and flexible variable selection patterns. This allows choices to be determined at runtime +based on data characteristics rather than hardcoded values. +\subsection{Using tidyselect for \code{choices}}{ + +When \code{choices} uses tidyselect, the available options are determined dynamically based on +the selected dataset's structure: +\itemize{ +\item \code{tidyselect::everything()} - All variables/datasets +\item \code{tidyselect::starts_with("prefix")} - Variables starting with a prefix +\item \code{tidyselect::ends_with("suffix")} - Variables ending with a suffix +\item \code{tidyselect::contains("pattern")} - Variables containing a pattern +\item \code{tidyselect::matches("regex")} - Variables matching a regular expression +\item \code{tidyselect::where(predicate)} - Variables/datasets satisfying a predicate function +\item \code{tidyselect::all_of(vars)} - All specified variables (error if missing) +\item \code{tidyselect::any_of(vars)} - Any specified variables (silent if missing) +\item Range selectors like \code{Sepal.Length:Petal.Width} - Variables between two positions +} +} + +\subsection{Using tidyselect for \code{selected}}{ + +The \code{selected} parameter can use: +\itemize{ +\item Numeric indices (e.g., \code{1}, \code{1:3}, \code{c(1, 3, 5)}) - Select by position +\item Character vectors (e.g., \code{"Species"}, \code{c("mpg", "cyl")}) - Select by name +\item \code{tidyselect::everything()} - Select all available choices +\item Other tidyselect helpers as needed +} + +\strong{Warning:} Using explicit character values for \code{selected} with dynamic \code{choices} may +cause issues if the selected values are not present in the dynamically determined choices. +Prefer using numeric indices (e.g., \code{1} for first variable) when \code{choices} is dynamic. +} +} + +\section{Structure and element dependencies}{ +The \code{picks()} function creates a hierarchical structure where elements depend on their +predecessors, enabling cascading reactive updates during Shiny sessions. +\subsection{Element hierarchy}{ + +A \code{picks} object must follow this order: +\enumerate{ +\item \strong{\code{datasets()}} - to select a dataset. Always the first element (required). +\item \strong{\code{variables()}} - To select columns from the chosen dataset. +\item \strong{\code{values()}} - To select specific values from the chosen variable(s). +} + +Each element's choices are evaluated within the context of its predecessor's selection. +} + +\subsection{How dependencies work}{ +\itemize{ +\item \strong{Single dataset}: When \code{datasets(choices = "iris")} specifies one dataset, the +\code{variables()} choices are evaluated against that dataset's columns. +\item \strong{Multiple datasets}: When \code{datasets(choices = c("iris", "mtcars"))} allows multiple +options, \code{variables()} choices are re-evaluated each time the user selects a different +dataset. This creates a reactive dependency where variable choices update automatically. +\item \strong{Dynamic datasets}: When using \code{datasets(choices = tidyselect::where(is.data.frame))}, +all available data frames are discovered at runtime, and variable choices adapt to +whichever dataset the user selects. +\item \strong{Variable to values}: Similarly, \code{values()} choices are evaluated based on the +selected variable(s), allowing users to filter specific levels or values. +} +} + +\subsection{Best practices}{ +\itemize{ +\item Always start with \code{datasets()} - this is enforced by validation +\item Use dynamic \code{choices} in \code{variables()} when working with multiple datasets to ensure +compatibility across different data structures +\item Prefer \code{tidyselect::everything()} or \code{tidyselect::where()} predicates for flexible +variable selection that works across datasets with different schemas +\item Use numeric indices for \code{selected} when \code{choices} are dynamic to avoid referencing +variables that may not exist in all datasets +} +} + +\subsection{Example: Three-level hierarchy}{ + +\if{html}{\out{
}}\preformatted{picks( + datasets(choices = c("iris", "mtcars"), selected = "iris"), + variables(choices = tidyselect::where(is.numeric), selected = 1), + values(choices = tidyselect::everything(), selected = 1:10) +) +}\if{html}{\out{
}} + +In this example: +\itemize{ +\item User first selects a dataset (iris or mtcars) +\item Variable choices update to show only numeric columns from selected dataset +\item After selecting a variable, value choices show all unique values from that column +} +} +} + +\examples{ +# Select columns from iris dataset using range selector +picks( + datasets(choices = "iris"), + variables(choices = Sepal.Length:Petal.Width, selected = 1) +) + +# Single variable selection from iris dataset +picks( + datasets(choices = "iris", selected = "iris"), + variables(choices = c("Sepal.Length", "Sepal.Width"), selected = "Sepal.Length", multiple = FALSE) +) + +# Dynamic selection: any variable from iris, first selected by default +picks( + datasets(choices = "iris", selected = "iris"), + variables(choices = tidyselect::everything(), selected = 1, multiple = FALSE) +) + +# Multiple dataset choices: variable choices will update when dataset changes +picks( + datasets(choices = c("iris", "mtcars"), selected = "iris"), + variables(choices = tidyselect::everything(), selected = 1, multiple = FALSE) +) + +# Select from any dataset, filter by numeric variables +picks( + datasets(choices = c("iris", "mtcars"), selected = 1), + variables(choices = tidyselect::where(is.numeric), selected = 1) +) + +# Fully dynamic: auto-discover datasets and variables +picks( + datasets(choices = tidyselect::where(is.data.frame), selected = 1), + variables(choices = tidyselect::everything(), selected = 1, multiple = FALSE) +) + +# Select categorical variables with length constraints +picks( + datasets(choices = tidyselect::everything(), selected = 1), + variables(choices = is_categorical(min.len = 2, max.len = 15), selected = 1:2) +) + +} diff --git a/man/picks_module.Rd b/man/picks_module.Rd new file mode 100644 index 00000000..12e59e9a --- /dev/null +++ b/man/picks_module.Rd @@ -0,0 +1,66 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/0-module_picks.R +\name{picks_module} +\alias{picks_module} +\alias{picks_ui} +\alias{picks_ui.list} +\alias{picks_ui.picks} +\alias{picks_srv} +\alias{picks_srv.list} +\alias{picks_srv.picks} +\title{Interactive picks} +\usage{ +picks_ui(id, spec, container = "badge_dropdown") + +\method{picks_ui}{list}(id, spec, container = "badge_dropdown") + +\method{picks_ui}{picks}(id, spec, container = "badge_dropdown") + +picks_srv(id = "", spec, data) + +\method{picks_srv}{list}(id, spec, data) + +\method{picks_srv}{picks}(id, spec, data) +} +\arguments{ +\item{id}{(\code{character(1)}) Shiny module ID} + +\item{spec}{(\code{picks} or \code{list}) Specification object created by \code{picks()} or a named list of such objects} + +\item{container}{(\code{character(1)} or \code{function}) UI container type. Default is \code{"badge_dropdown"}. +Can also be one of \code{htmltools::tags} functions} + +\item{data}{(\code{reactive}) Reactive expression returning the data object to be used for populating choices} +} +\value{ +\itemize{ +\item \code{picks_ui()}: UI elements for the input controls +\item \code{picks_srv()}: Server-side reactive logic returning the processed data +} +} +\description{ +\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} + +Creates UI and server components for interactive \code{\link[=picks]{picks()}} in Shiny modules. The module is based on +configuration provided via \code{\link[=picks]{picks()}} and its responsibility is to determine relevant input +values + +The module supports both single and combined specifications: +\itemize{ +\item Single \code{picks} objects for a single input +\item Named lists of \code{picks} objects for multiple inputs +} +} +\details{ +The module uses S3 method dispatch to handle different types of specifications: +\itemize{ +\item \code{.picks} methods handle single specification +\item \code{.list} methods handle multiple specifications +} + +The UI component (\code{picks_ui}) creates the visual elements, while the +server component (\code{picks_srv}) manages the reactive logic, +} +\seealso{ +\code{\link[=picks]{picks()}} for creating specification objects +} diff --git a/man/restoreValue.Rd b/man/restoreValue.Rd index 36fe9751..2b0ca13a 100644 --- a/man/restoreValue.Rd +++ b/man/restoreValue.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/0-module_input.R +% Please edit documentation in R/0-module_picks.R \name{restoreValue} \alias{restoreValue} \title{Restore value from bookmark.} diff --git a/man/tm_merge.Rd b/man/tm_merge.Rd index 892f54bc..182e3655 100644 --- a/man/tm_merge.Rd +++ b/man/tm_merge.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/0-module_merge.R +% Please edit documentation in R/0-tm_merge.R \name{tm_merge} \alias{tm_merge} \title{Merge module} diff --git a/man/types.Rd b/man/types.Rd deleted file mode 100644 index 1e92812e..00000000 --- a/man/types.Rd +++ /dev/null @@ -1,73 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/0-picks.R -\name{Types} -\alias{Types} -\alias{picks} -\alias{values} -\alias{mae_colData} -\title{Choices/selected settings} -\usage{ -picks(...) - -values( - choices = tidyselect::everything(), - selected = tidyselect::everything(), - multiple = TRUE, - fixed = !.is_tidyselect(choices) && length(choices) == 1, - ... -) - -mae_colData(choices = tidyselect::everything(), selected = 1, multiple = FALSE) -} -\arguments{ -\item{...}{additional arguments delivered to \code{pickerInput}} - -\item{choices}{<\code{\link[dplyr:dplyr_tidy_select]{tidy-select}} or \code{character}> -One unquoted expression to be used to picks the choices.} - -\item{selected}{<\code{\link[dplyr:dplyr_tidy_select]{tidy-select}} or \code{character}> -One unquoted expression to be used to picks from choices to be selected.} - -\item{multiple}{<\code{logical(1)}> if more than one selection is possible.} - -\item{fixed}{<\code{logical(1)}> selection will be fixed and not possible to change interactively.} - -\item{keep_order}{<\code{logical(1)}> if the selected should follow the selection order. If \code{FALSE} -\code{selected} returned from \code{srv_module_input()} would be ordered according to order in \code{choices}.} -} -\value{ -\code{picks} object containing specified settings -} -\description{ -Define choices and default selection of variables from datasets. -} -\section{Functions}{ -\itemize{ -\item \code{picks()}: specify a selector. - -\item \code{values()}: Specify variables. - -\item \code{mae_colData()}: Specify colData. - -}} -\examples{ - -# Initialize selector for `iris` to select columns between `Sepal.Length` and `Petal.Width` -# with first -picks( - datasets(choices = "iris"), - variables(choices = Sepal.Length:Petal.Width, selected = 1) -) -picks( - datasets(choices = c("iris", "mtcars"), selected = "iris"), - variables(choices = tidyselect::everything(), selected = 1) -) -picks( - datasets(choices = c("iris", "mtcars"), selected = 1), - variables(choices = tidyselect::where(is.numeric), selected = 1) -) -picks( - datasets(choices = tidyselect::everything(), selected = 1), - variables(choices = is_categorical(min.len = 2, max.len = 15), selected = 1:2) -) -} diff --git a/tests/testthat/0-to_picks.R b/tests/testthat/0-to_picks.R deleted file mode 100644 index 7dab4ca6..00000000 --- a/tests/testthat/0-to_picks.R +++ /dev/null @@ -1,111 +0,0 @@ -testthat::test_that("to_picks converts eager select_spec to variables without ordered, always_selected nor label", { - test <- select_spec( - choices = c("AVAL", "BMRKR1", "AGE"), - selected = "AVAL", - multiple = FALSE, - fixed = FALSE, - label = "Column", - ordered = TRUE, - always_selected = "AGE" - ) - - out <- select_spec_to_variables(test) - testthat::expect_s3_class(out, "variables") - testthat::expect_identical(out$choices, unclass(test$choices)) - testthat::expect_identical(out$selected, unclass(test$selected)) - testthat::expect_identical(attr(out, "multiple"), test$multiple) -}) - -testthat::test_that("to_picks converts delayed select_spec to variables preserving delayed_data and is resolvable", { - subset_fun <- function(data) names(Filter(is.factor, data)) - test <- select_spec( - choices = variable_choices("ADRS", subset = subset_fun), - selected = "AVISIT", - multiple = FALSE, - fixed = FALSE, - label = "Column", - ordered = TRUE, - always_selected = "AGE" - ) - - out <- suppressWarnings(select_spec_to_variables(test)) - testthat::expect_s3_class(out, "variables") - testthat::expect_s3_class(out$choices, "delayed_data") - testthat::expect_identical(out$selected, "AVISIT") - - testthat::expect_identical( - determine(out, data = rADRS)$x, - determine(variables(choices = subset_fun(rADRS), selected = "AVISIT"), data = rADRS)$x - ) -}) - -testthat::test_that("extract_filters pulls converts filter_spec to picks with value", { - des <- data_extract_spec( - dataname = "ADLB", - filter = list( - filter_spec( - vars = "PARAMCD", - choices = value_choices(data$ADLB, "PARAMCD", "PARAM"), - selected = levels(data$ADLB$PARAMCD)[1], - multiple = FALSE, - label = "Select lab:" - ), - filter_spec( - vars = "AVISIT", - choices = levels(data$ADLB$AVISIT), - selected = levels(data$ADLB$AVISIT)[1], - multiple = FALSE, - label = "Select visit:" - ) - ) - ) - - - extract_filters(des) -}) - - -testthat::test_that("to_picks", { - des <- list( - data_extract_spec( - dataname = "ADSL", - select = select_spec( - choices = variable_choices(data$ADSL), - selected = "AGE", - multiple = FALSE, - fixed = FALSE - ) - ), - data_extract_spec( - dataname = "ADLB", - select = select_spec( - choices = variable_choices(data$ADLB, c("AVAL", "CHG", "PCHG", "ANRIND", "BASE")), - selected = "AVAL", - multiple = FALSE, - fixed = FALSE - ), - filter = list( - filter_spec( - vars = "PARAMCD", - choices = value_choices(data$ADLB, "PARAMCD", "PARAM"), - selected = levels(data$ADLB$PARAMCD)[1], - multiple = FALSE, - label = "Select lab:" - ), - filter_spec( - vars = "AVISIT", - choices = levels(data$ADLB$AVISIT), - selected = levels(data$ADLB$AVISIT)[1], - multiple = FALSE, - label = "Select visit:" - ) - ) - ) - ) - - to_picks() -}) - -# can't convert list(data_extract_spec("ADSL", ...), data_extract_spec("ADTTE", ...)) reliably -# to picks as picks can't conditionally determine next step based on the dataset selection -# diff --git a/tests/testthat/test-0-picks.R b/tests/testthat/test-0-picks.R new file mode 100644 index 00000000..583532fd --- /dev/null +++ b/tests/testthat/test-0-picks.R @@ -0,0 +1,461 @@ +testthat::describe("picks() basic structure", { + it("returns an object of class 'picks' and 'list'", { + result <- picks(datasets()) + testthat::expect_s3_class(result, "picks") + testthat::expect_type(result, "list") + }) + + it("creates a picks object with single datasets element", { + result <- picks(datasets()) + testthat::expect_length(result, 1) + testthat::expect_named(result, "datasets") + }) + + it("creates a picks object with datasets and variables", { + result <- picks(datasets(), variables()) + testthat::expect_length(result, 2) + testthat::expect_named(result, c("datasets", "variables")) + }) + + it("creates a picks object with datasets, variables and values", { + result <- picks(datasets(), variables(), values()) + testthat::expect_length(result, 3) + testthat::expect_named(result, c("datasets", "variables", "values")) + }) + + it("ignores trailing empty arguments", { + result <- picks(datasets(), variables()) + testthat::expect_length(result, 2) + }) +}) + +testthat::describe("picks() assertions", { + it("fails when first element is not datasets", { + testthat::expect_error(picks(variables()), "datasets") + }) + + it("succeeds when first element is datasets", { + testthat::expect_no_error(picks(datasets())) + }) + + it("fails with empty input", { + testthat::expect_error(picks()) + }) + + it("fails when input is not of class 'type'", { + testthat::expect_error(picks(list(a = 1, b = 2))) + }) + + it("fails when mixing valid and invalid types", { + testthat::expect_error( + picks(datasets(), list(invalid = "test")) + ) + }) + + it("fails when values exists without variables", { + testthat::expect_error( + picks(datasets(), values()), + "requires variables\\(\\) before values\\(\\)" + ) + }) + + it("succeeds when values immediately follows variables", { + testthat::expect_no_error( + picks(datasets(), variables(), values()) + ) + }) + + it("fails when values doesn't immediately follow variables", { + testthat::expect_error( + picks(datasets(), values(), variables()) + ) + }) + + it("succeeds with only datasets and variables (no values)", { + testthat::expect_no_error( + picks(datasets(), variables()) + ) + }) +}) + +testthat::describe("picks() output is named:", { + it("names elements by their class", { + result <- picks(datasets(), variables()) + testthat::expect_named(result, c("datasets", "variables")) + }) +}) + +testthat::describe("picks() element access", { + it("allows accessing datasets element", { + result <- picks(datasets()) + testthat::expect_s3_class(result$datasets, "datasets") + }) + + it("allows accessing variables element", { + result <- picks(datasets(), variables()) + testthat::expect_s3_class(result$variables, "variables") + }) + + it("allows accessing values element", { + result <- picks(datasets(), variables(), values()) + testthat::expect_s3_class(result$values, "values") + }) + + it("preserves element attributes", { + result <- picks(datasets(), variables(multiple = TRUE, ordered = TRUE)) + testthat::expect_true(attr(result$variables, "multiple")) + testthat::expect_true(attr(result$variables, "ordered")) + }) +}) + +testthat::describe("datasets() basic asserts:", { + it("datasets(choices) argument accepts character, integer and tidyselect", { + testthat::expect_no_error(datasets(choices = "test")) + testthat::expect_no_error(datasets(choices = 1)) + testthat::expect_no_error(datasets(choices = tidyselect::everything())) + testthat::expect_no_error(datasets(choices = tidyselect::where(is.data.frame))) + testthat::expect_no_error(datasets(choices = c(test:test, test))) + testthat::expect_no_error(datasets(choices = tidyselect::starts_with("Petal") | tidyselect::ends_with("Width"))) + testthat::expect_no_error(datasets(choices = tidyselect::all_of(c("test", "test2")))) + }) + + it("datasets(choices) can't be empty", { + testthat::expect_error(datasets(choices = character(0))) + testthat::expect_error(datasets(choices = NULL)) + testthat::expect_error(datasets(choices = list())) + }) + + it("datasets(selected) can't be empty", { + testthat::expect_error(datasets(selected = character(0))) + testthat::expect_error(datasets(selected = NULL)) + testthat::expect_error(datasets(selected = list())) + }) + + it("datasets(selected) argument character, integer and tidyselect", { + testthat::expect_no_error(datasets(selected = 1)) + testthat::expect_no_error(datasets(selected = tidyselect::everything())) + testthat::expect_error(datasets(selected = NULL)) + }) + + it("fails when length(selected) > 1", { + testthat::expect_error(datasets(choices = c("iris", "mtcars"), selected = c("iris", "mtcars"))) + }) + + it("datasets(selected) must be a subset of choices", { + testthat::expect_error(datasets(choices = c("a", "b"), selected = "c"), "subset of `choices`") + }) + + it("datasets(selected) warns if choices are delayed and selected eager", { + testthat::expect_warning(datasets(choices = tidyselect::everything(), selected = "c"), "subset of `choices`") + testthat::expect_warning(datasets(choices = 1, selected = "c"), "subset of `choices`") + }) +}) + +testthat::describe("datasets() returns datasets", { + it("returns an object of class 'datasets' and 'type'", { + result <- datasets(choices = "iris") + testthat::expect_s3_class(result, "datasets") + }) + + it("returns a list with 'choices' and 'selected' elements", { + result <- datasets(choices = "iris") + testthat::expect_type(result, "list") + testthat::expect_named(result, c("choices", "selected")) + }) + + it("stores static character vector in $choices", { + result <- datasets(choices = c("iris", "mtcars")) + testthat::expect_equal(result$choices, c("iris", "mtcars")) + }) + + it("defaults selected to 1'st when not specified", { + result <- datasets(choices = c("iris", "mtcars")) + testthat::expect_s3_class(result$selected, "quosure") + testthat::expect_equal(rlang::quo_get_expr(result$selected), 1) + }) + + it("stores custom selected value", { + result <- datasets(choices = c("iris", "mtcars"), selected = "mtcars") + testthat::expect_equal(result$selected, "mtcars") + }) + + it("stores numeric selected value as quosure", { + result <- datasets(choices = c("iris", "mtcars"), selected = 2) + testthat::expect_s3_class(result$selected, "quosure") + testthat::expect_equal(rlang::quo_get_expr(result$selected), 2) + }) + + it("sets fixed to TRUE when single choice", { + testthat::expect_true(attr(datasets(choices = "test"), "fixed")) + }) +}) + +testthat::describe("datasets() returns quosures for delayed evaluation", { + it("stores tidyselect::everything() as a quosure in $choices", { + result <- datasets(choices = tidyselect::everything()) + testthat::expect_s3_class(result$choices, "quosure") + }) + + it("stores tidyselect::where() as a quosure in $choices", { + result <- datasets(choices = tidyselect::where(is.data.frame)) + testthat::expect_s3_class(result$choices, "quosure") + }) + + it("stores symbol range (a:b) as a quosure in $choices", { + result <- datasets(choices = c(a:b)) + testthat::expect_s3_class(result$choices, "quosure") + }) + + it("stores numeric range (1:5) as a quosure in $choices", { + result <- datasets(choices = 1:5) + testthat::expect_s3_class(result$choices, "quosure") + }) + + it("stores tidyselect::starts_with() as a quosure in $choices", { + result <- datasets(choices = tidyselect::starts_with("test")) + testthat::expect_s3_class(result$choices, "quosure") + }) + + it("stores tidyselect::ends_with() as a quosure in $choices", { + result <- datasets(choices = tidyselect::ends_with("test")) + testthat::expect_s3_class(result$choices, "quosure") + }) + + it("stores combined tidyselect expressions as a quosure in $choices", { + result <- datasets(choices = tidyselect::starts_with("a") | tidyselect::ends_with("b")) + testthat::expect_s3_class(result$choices, "quosure") + }) + + it("does not store static character vector as a quosure in $choices", { + result <- datasets(choices = c("a", "b", "c")) + testthat::expect_false(inherits(result$choices, "quosure")) + testthat::expect_type(result$choices, "character") + }) +}) + +testthat::describe("datasets() attributes", { + it("sets multiple attribute to FALSE (always single selection)", { + result <- datasets(choices = c("iris", "mtcars")) + testthat::expect_false(attr(result, "multiple")) + }) + + it("sets fixed to TRUE for single non-delayed choice", { + result <- datasets(choices = "iris") + testthat::expect_true(attr(result, "fixed")) + }) + + it("sets fixed to FALSE for multiple choices", { + result <- datasets(choices = c("iris", "mtcars")) + testthat::expect_false(attr(result, "fixed")) + }) + + it("sets fixed to FALSE for delayed choices (tidyselect)", { + result <- datasets(choices = tidyselect::everything()) + testthat::expect_false(attr(result, "fixed")) + }) + + it("allows explicit fixed = TRUE override", { + result <- datasets(choices = c("iris", "mtcars"), fixed = TRUE) + testthat::expect_true(attr(result, "fixed")) + }) + + it("allows explicit fixed = FALSE override", { + result <- datasets(choices = "iris", fixed = FALSE) + testthat::expect_false(attr(result, "fixed")) + }) + + it("passes additional arguments via ...", { + result <- datasets(choices = "iris", custom_attr = "test_value") + testthat::expect_equal(attr(result, "custom_attr"), "test_value") + }) +}) + +testthat::describe("datasets() validation and warnings", { + it("warns when selected is explicit and choices are delayed", { + testthat::expect_warning( + datasets(choices = tidyselect::everything(), selected = "iris"), + "Setting explicit `selected` while `choices` are delayed" + ) + }) + + it("does not warn when selected is numeric and choices are delayed", { + testthat::expect_no_warning( + datasets(choices = tidyselect::everything(), selected = 1) + ) + }) + + it("does not warn when both choices and selected are static", { + testthat::expect_no_warning( + datasets(choices = c("iris", "mtcars"), selected = "iris") + ) + }) +}) + +testthat::describe("datasets() integration with tidyselect helpers", { + it("accepts tidyselect::all_of()", { + testthat::expect_no_error( + datasets(choices = tidyselect::all_of(c("iris", "mtcars"))) + ) + }) + + it("accepts tidyselect::any_of()", { + testthat::expect_no_error( + datasets(choices = tidyselect::any_of(c("iris", "mtcars"))) + ) + }) + + it("stores tidyselect::starts_with() as a quosure", { + result <- datasets(choices = tidyselect::starts_with("ir")) + testthat::expect_s3_class(result$choices, "quosure") + }) + + it("stores tidyselect::ends_with() as a quosure", { + result <- datasets(choices = tidyselect::ends_with("s")) + testthat::expect_s3_class(result$choices, "quosure") + }) + + it("stores tidyselect::contains() as a quosure", { + result <- datasets(choices = tidyselect::contains("car")) + testthat::expect_s3_class(result$choices, "quosure") + }) + + it("stores tidyselect::matches() as a quosure", { + result <- datasets(choices = tidyselect::matches("^i")) + testthat::expect_s3_class(result$choices, "quosure") + }) +}) + +testthat::describe("variables() multiple attribute", { + it("sets multiple to FALSE for single selected value", { + result <- variables(choices = c("a", "b", "c"), selected = "a") + testthat::expect_false(attr(result, "multiple")) + }) + + it("sets multiple to TRUE for multiple selected values", { + result <- variables(choices = c("a", "b", "c"), selected = c("a", "b")) + testthat::expect_true(attr(result, "multiple")) + }) + + it("sets multiple to FALSE when explicitly specified", { + result <- variables(choices = c("a", "b", "c"), selected = "a", multiple = FALSE) + testthat::expect_false(attr(result, "multiple")) + }) + + it("sets multiple to TRUE when explicitly specified", { + result <- variables(choices = c("a", "b", "c"), selected = "a", multiple = TRUE) + testthat::expect_true(attr(result, "multiple")) + }) + + it("auto-detects multiple = TRUE from selected vector length", { + result <- variables(choices = c("a", "b", "c", "d"), selected = c("a", "b", "c")) + testthat::expect_true(attr(result, "multiple")) + }) + + it("auto-detects multiple = FALSE from single selected", { + result <- variables(choices = c("a", "b", "c"), selected = "b") + testthat::expect_false(attr(result, "multiple")) + }) + + it("defaults to NULL for tidyselect selected", { + result <- variables(choices = c("a", "b"), selected = tidyselect::everything()) + testthat::expect_false(attr(result, "multiple")) + }) + + it("explicit multiple overrides auto-detection", { + result <- variables(choices = c("a", "b", "c"), selected = c("a", "b"), multiple = FALSE) + testthat::expect_false(attr(result, "multiple")) + }) +}) + +testthat::describe("variables() ordered attribute", { + it("defaults to FALSE", { + result <- variables(choices = c("a", "b", "c")) + testthat::expect_false(attr(result, "ordered")) + }) + + it("sets ordered to TRUE when specified", { + result <- variables(choices = c("a", "b", "c"), ordered = TRUE) + testthat::expect_true(attr(result, "ordered")) + }) + + it("sets ordered to FALSE when explicitly specified", { + result <- variables(choices = c("a", "b", "c"), ordered = FALSE) + testthat::expect_false(attr(result, "ordered")) + }) +}) + +testthat::describe("variables() allow-clear attribute", { + it("sets allow-clear to FALSE for single non-NULL selected", { + result <- variables(choices = c("a", "b", "c"), selected = "a") + testthat::expect_false(attr(result, "allow-clear")) + }) + + it("sets allow-clear to TRUE for multiple selected", { + result <- variables(choices = c("a", "b", "c"), selected = c("a", "b")) + testthat::expect_true(attr(result, "allow-clear")) + }) + + it("sets allow-clear to TRUE when selected is NULL", { + result <- variables(choices = c("a", "b", "c"), selected = NULL) + testthat::expect_true(attr(result, "allow-clear")) + }) + + it("sets allow-clear to FALSE for tidyselect selected", { + result <- variables(choices = c("a", "b"), selected = tidyselect::everything()) + testthat::expect_false(attr(result, "allow-clear")) + }) + + it("sets allow-clear to FALSE for single numeric selected", { + result <- variables(choices = c("a", "b", "c"), selected = 1) + testthat::expect_false(attr(result, "allow-clear")) + }) + + it("sets allow-clear to FALSE for multiple numeric selected (tidyselect)", { + result <- variables(choices = c("a", "b", "c"), selected = c(1, 2)) + testthat::expect_false(attr(result, "allow-clear")) + }) +}) + +testthat::describe("variables() attribute interactions", { + it("multiple = TRUE and ordered = TRUE work together", { + result <- variables( + choices = c("a", "b", "c"), + selected = c("a", "c"), + multiple = TRUE, + ordered = TRUE + ) + testthat::expect_true(attr(result, "multiple")) + testthat::expect_true(attr(result, "ordered")) + }) + + it("multiple = FALSE and ordered = FALSE work together", { + result <- variables( + choices = c("a", "b", "c"), + selected = "a", + multiple = FALSE, + ordered = FALSE + ) + testthat::expect_false(attr(result, "multiple")) + testthat::expect_false(attr(result, "ordered")) + }) + + it("allow-clear depends on multiple when selected is character", { + result_single <- variables(choices = c("a", "b"), selected = "a", multiple = FALSE) + result_multi <- variables(choices = c("a", "b"), selected = "a", multiple = TRUE) + + testthat::expect_false(attr(result_single, "allow-clear")) + testthat::expect_true(attr(result_multi, "allow-clear")) + }) + + it("all three attributes can be set independently", { + result <- variables( + choices = c("a", "b", "c"), + selected = c("b", "c"), + multiple = TRUE, + ordered = TRUE + ) + testthat::expect_true(attr(result, "multiple")) + testthat::expect_true(attr(result, "ordered")) + testthat::expect_true(attr(result, "allow-clear")) + }) +}) diff --git a/tests/testthat/test-0-print.R b/tests/testthat/test-0-print.R new file mode 100644 index 00000000..19935d9c --- /dev/null +++ b/tests/testthat/test-0-print.R @@ -0,0 +1,72 @@ +testthat::describe("format.type() for datasets", { + it("formats datasets with character choices by printing them explicitly", { + ds <- datasets(choices = c("iris", "mtcars"), selected = "iris") + expected <- " \033[1m\033[0m\n choices: iris, mtcars\n selected: iris\n \033[3mmultiple=FALSE, ordered=FALSE, fixed=FALSE\033[0m\n" + testthat::expect_identical(format(ds), expected) + }) + + it("formats datasets with tidyselect choices by printing matched call's argument", { + ds <- datasets(choices = tidyselect::everything(), selected = 1) + result <- format(ds) + testthat::expect_match(result, "") + testthat::expect_match(result, "choices:.*everything\\(\\)") + testthat::expect_match(result, "selected:.*1") + }) +}) + +testthat::describe("print.type() for variables", { + it("prints variables with character choices by printing them explicitly", { + vars <- variables(choices = c("a", "b", "c"), selected = c("a", "b"), multiple = TRUE) + expected <- " \033[1m\033[0m\n choices: a, b, c\n selected: a, b\n \033[3mmultiple=TRUE, ordered=FALSE, fixed=FALSE, allow-clear=TRUE\033[0m\n" + testthat::expect_identical(format(vars), expected) + }) + + + it("formats variables with ordered attribute correctly", { + vars <- variables(choices = c("x", "y", "z"), selected = c("x", "y"), ordered = TRUE) + result <- format(vars) + testthat::expect_match(result, "ordered=TRUE") + }) +}) + +testthat::describe("format.type() for values", { + it("formats values with character choices by printing them explicitly with their attributes", { + vals <- values(choices = c("1", "2", "3"), selected = c("1", "2"), multiple = TRUE) + expected <- " \033[1m\033[0m\n choices: 1, 2, 3\n selected: 1, 2\n \033[3mmultiple=TRUE, ordered=FALSE, fixed=FALSE\033[0m\n" + testthat::expect_identical(format(vals), expected) + }) +}) + + +testthat::describe("format.picks() for picks collection", { + it("formats picks with datasets, variables and values by showing them all explicitly", { + p <- picks( + datasets(choices = "iris", selected = "iris"), + variables(choices = c("a", "b"), selected = "a", multiple = FALSE), + values(choices = c("1", "2"), selected = "1", multiple = FALSE) + ) + expected <- " \033[1m\033[0m\n \033[1m\033[0m:\n choices: iris\n selected: iris\n \033[3mmultiple=FALSE, ordered=FALSE, fixed=TRUE\033[0m\n \033[1m\033[0m:\n choices: a, b\n selected: a\n \033[3mmultiple=FALSE, ordered=FALSE, fixed=FALSE, allow-clear=FALSE\033[0m\n \033[1m\033[0m:\n choices: 1, 2\n selected: 1\n \033[3mmultiple=FALSE, ordered=FALSE, fixed=FALSE\033[0m\n" + testthat::expect_identical(format(p), expected) + }) +}) + +testthat::describe("print methods output correctly", { + it("print.type() outputs datasets to console with class name, choices and selected", { + ds <- datasets(choices = "iris", selected = "iris") + testthat::expect_output(print(ds), "") + testthat::expect_output(print(ds), "choices:") + testthat::expect_output(print(ds), "selected:") + }) + + it("print.picks() outputs picks to console with its class and elements", { + p <- picks(datasets(choices = "iris")) + testthat::expect_output(print(p), "") + testthat::expect_output(print(p), "") + }) + + it("print returns invisibly", { + ds <- datasets(choices = "iris", selected = "iris") + result <- print(ds) + testthat::expect_identical(result, ds) + }) +}) diff --git a/tests/testthat/test-Queue.R b/tests/testthat/test-Queue.R deleted file mode 100644 index fb508ebd..00000000 --- a/tests/testthat/test-Queue.R +++ /dev/null @@ -1,78 +0,0 @@ -testthat::test_that("Queue can be initialized", { - testthat::expect_true(is.environment(Queue$new())) - testthat::expect_identical(class(Queue$new()), c("Queue", "R6")) -}) - -testthat::test_that("size method returns number of elements in queue", { - queue <- Queue$new() - testthat::expect_identical(queue$size(), 0L) -}) - -testthat::test_that("push method adds elements to queue", { - queue <- Queue$new() - testthat::expect_equal(queue$size(), 0L) - testthat::expect_no_error(queue$push(7)) - testthat::expect_equal(queue$size(), 1L) -}) - -testthat::test_that("push method can add multiple elements", { - queue <- Queue$new() - testthat::expect_no_error(queue$push(c(1, "2"))) -}) - -testthat::test_that("get method returns elements of queue", { - queue <- Queue$new() - queue$push(letters) - testthat::expect_identical(queue$get(), letters) -}) - -testthat::test_that("pop method removes first element from queue", { - queue <- Queue$new() - queue$push(c(7, 8)) - testthat::expect_equal(queue$pop(), 7) - testthat::expect_equal(queue$get(), 8) -}) - -testthat::test_that("remove method removes specified element from queue", { - queue <- Queue$new() - queue$push(c(7, 8, 7, 8)) - testthat::expect_no_error(queue$remove(7)) - testthat::expect_equal(queue$get(), c(8, 7, 8)) - testthat::expect_no_error(queue$remove(7)) - testthat::expect_equal(queue$get(), c(8, 8)) - testthat::expect_no_error(queue$remove(7)) - testthat::expect_equal(queue$get(), c(8, 8)) -}) - -testthat::test_that("remove method can remove several elements", { - queue <- Queue$new() - queue$push(c(6, 7, 8, 6, 7, 8, 6, 7, 8, 6)) - testthat::expect_no_error(queue$remove(c(7, 7))) - testthat::expect_equal(queue$get(), c(6, 8, 6, 8, 6, 7, 8, 6)) -}) - -testthat::test_that("empty method removes all elements from queue", { - queue <- Queue$new() - queue$push(c(7, 8)) - testthat::expect_no_error(queue$empty()) - testthat::expect_equal(queue, Queue$new()) -}) - -testthat::test_that("print method- displays proper format", { - queue <- Queue$new() - queue$push(c(7, 8)) - testthat::expect_identical( - testthat::capture_output( - queue$print() - ), - testthat::capture_output( - cat( - "", - "Size: 2", - "Elements:", - "7 8", - sep = "\n" - ) - ) - ) -}) diff --git a/tests/testthat/test-delayed.R b/tests/testthat/test-delayed.R deleted file mode 100644 index 17c2ab8f..00000000 --- a/tests/testthat/test-delayed.R +++ /dev/null @@ -1,12 +0,0 @@ -test_that("is.delayed works", { - d <- datasets("a") - v <- variables("b") - expect_true(is.delayed(d)) - expect_true(is.delayed(datasets("a", "a"))) - expect_true(is.delayed(v)) - expect_true(is.delayed(variables("b", "b"))) - expect_true(is.delayed(c(d, v))) - expect_false(is.delayed(1)) - da <- datasets(is.data.frame) - expect_true(is.delayed(da)) -}) diff --git a/tests/testthat/test-merge_expr.R b/tests/testthat/test-merge_expr.R deleted file mode 100644 index 2e342ecd..00000000 --- a/tests/testthat/test-merge_expr.R +++ /dev/null @@ -1,15 +0,0 @@ -testthat::test_that("merge_expr", { - jk <- teal.data::join_keys() - merge_expr( - selectors = list( - x = spec( - datasets(choices = "test", selected = "test"), - variables(choices = letters, selected = letters) - ) - ), - output_name = "elo", - join_fun = "foo", - join_keys = jk, - TRUE - ) -}) diff --git a/tests/testthat/test-resolver.R b/tests/testthat/test-resolver.R deleted file mode 100644 index af07bdc5..00000000 --- a/tests/testthat/test-resolver.R +++ /dev/null @@ -1,186 +0,0 @@ -f <- function(x) { - head(x, 1) -} - -test_that("resolver datasets works", { - df_head <- datasets("df") - df_first <- datasets("df") - matrices <- datasets(where(is.matrix)) - df_mean <- datasets("df", where(mean)) - median_mean <- datasets(where(median), where(mean)) - td <- within(teal.data::teal_data(), { - df <- data.frame(a = LETTERS[1:5], b = factor(letters[1:5]), c = factor(letters[1:5])) - m <- cbind(b = 1:5, c = 10:14) - m2 <- cbind(a = LETTERS[1:2], b = LETTERS[4:5]) - }) - expect_no_error(resolver(df_head, td)) - expect_no_error(resolver(df_first, td)) - out <- resolver(matrices, td) - expect_length(out$datasets$selected, 1L) # Because we use 1 - expect_error(expect_warning(resolver(df_mean, td))) - expect_error(resolver(median_mean, td)) -}) - -test_that("resolver variables works", { - df <- datasets("df") - matrices <- datasets(where(is.matrix)) - data_frames <- datasets(where(is.data.frame)) - var_a <- variables("a") - factors <- variables(where(is.factor)) - factors_head <- variables(where(is.factor), where(function(x) { - head(x, 1) - })) - var_matrices_head <- variables(where(is.matrix), where(function(x) { - head(x, 1) - })) - td <- within(teal.data::teal_data(), { - df <- data.frame(a = LETTERS[1:5], b = factor(letters[1:5]), c = factor(letters[1:5])) - m <- cbind(b = 1:5, c = 10:14) - m2 <- cbind(a = LETTERS[1:2], b = LETTERS[4:5]) - }) - - expect_no_error(resolver(c(df, var_a), td)) - expect_no_error(resolver(c(df, factors), td)) - expect_error(resolver(c(df, factors_head), td)) - expect_error(resolver(c(df, var_matrices_head), td)) - - expect_error(resolver(c(matrices, var_a), td)) - expect_error(resolver(c(matrices, factors), td)) - expect_error(resolver(c(matrices, factors_head), td)) - expect_error(resolver(c(matrices, var_matrices_head), td)) - - expect_no_error(resolver(c(data_frames, var_a), td)) - expect_no_error(resolver(c(data_frames, factors), td)) - expect_error(resolver(c(data_frames, factors_head), td)) - expect_error(resolver(c(data_frames, var_matrices_head), td)) -}) - -test_that("resolver with missing type works", { - td <- within(teal.data::teal_data(), { - i <- iris - }) - - r <- expect_no_error(resolver(variables(where(is.numeric)), td)) - expect_true(r$variables$selected == "i") -}) - -test_that("resolver values works", { - df <- datasets("df") - matrices <- datasets(where(is.matrix)) - data_frames <- datasets(where(is.data.frame)) - var_a <- variables("a") - factors <- variables(is.factor) - factors_head <- variables(where(is.factor), where(function(x) { - head(x, 1) - })) - var_matrices_head <- variables(where(is.matrix), where(function(x) { - head(x, 1) - })) - val_A <- values("A") - td <- within(teal.data::teal_data(), { - df <- data.frame(a = LETTERS[1:5], b = factor(letters[1:5]), c = factor(letters[1:5])) - m <- cbind(b = 1:5, c = 10:14) - m2 <- cbind(a = LETTERS[1:2], b = LETTERS[4:5]) - }) - expect_no_error(resolver(c(df, var_a, val_A), td)) -}) - -test_that("names and variables are reported", { - td <- within(teal.data::teal_data(), { - df <- data.frame( - A = as.factor(letters[1:5]), - Ab = LETTERS[1:5], - Abc = c(LETTERS[1:4], letters[1]) - ) - df2 <- data.frame( - A = 1:5, - B = 1:5 - ) - m <- matrix() - }) - d_df <- datasets("df") - upper_variables <- variables(where(function(x) { - x == toupper(x) - })) - df_upper_variables <- c(d_df, upper_variables) - expect_error(resolver(df_upper_variables, td)) - # This should select A and Ab: - # A because the name is all capital letters and - # Ab values is all upper case. - # expect_length(out$variables$choices, 2) - v_all_upper <- variables(where(function(x) { - all(x == toupper(x)) - })) - df_all_upper_variables <- c(d_df, v_all_upper) - expect_no_error(out <- resolver(df_all_upper_variables, td)) - expect_no_error(out <- resolver(c(datasets("df2"), v_all_upper), td)) - expect_length(out$variables$choices, 2L) - expect_no_error(out <- resolver(datasets(where(function(x) { - is.data.frame(x) && all(colnames(x) == toupper(colnames(x))) - })), td)) - expect_length(out$datasets$choices, 1L) - expect_no_error(out <- resolver(datasets(where(function(x) { - is.data.frame(x) || any(colnames(x) == toupper(colnames(x))) - })), td)) - expect_length(out$datasets$choices, 2L) -}) - -test_that("update_spec resolves correctly", { - td <- within(teal.data::teal_data(), { - df <- data.frame( - A = as.factor(letters[1:5]), - Ab = LETTERS[1:5] - ) - df_n <- data.frame( - C = 1:5, - Ab = as.factor(letters[1:5]) - ) - }) - data_frames_factors <- c(datasets(where(is.data.frame)), variables(where(is.factor))) - expect_false(is.null(attr(data_frames_factors$datasets$choices, "original"))) - expect_false(is.null(attr(data_frames_factors$datasets$selected, "original"))) - expect_false(is.null(attr(data_frames_factors$variables$choices, "original"))) - expect_false(is.null(attr(data_frames_factors$variables$selected, "original"))) - - expect_no_error(resolver(data_frames_factors, td)) -}) - -test_that("OR specifications resolves correctly", { - td <- within(teal.data::teal_data(), { - df <- data.frame(A = 1:5, B = LETTERS[1:5]) - m <- cbind(A = 1:5, B = 5:10) - }) - var_a <- variables("A") - df_a <- c(datasets(where(is.data.frame)), var_a) - matrix_a <- c(datasets(where(is.matrix)), var_a) - df_or_m_var_a <- list(df_a, matrix_a) - out <- resolver(df_or_m_var_a, td) - expect_true(all(vapply(out, is.specification, logical(1L)))) -}) - -test_that("OR specifications fail correctly", { - td <- within(teal.data::teal_data(), { - df <- data.frame(A = 1:5, B = LETTERS[1:5]) - m <- cbind(A = 1:5, B = 5:10) - }) - var_a <- variables("A") - df_a <- c(datasets(where(is.data.frame)), var_a) - matrix_a <- c(datasets(where(is.matrix)), var_a) - df_or_m_var_a <- list(df_a, matrix_a) - out <- resolver(df_or_m_var_a, td) - expect_error(update_spec(out, "variables", "B")) -}) - -test_that("OR update_spec filters specifications", { - td <- within(teal.data::teal_data(), { - df <- data.frame(A = 1:5, B = LETTERS[1:5]) - m <- cbind(A = 1:5, B = 5:10) - }) - var_a <- variables("A") - df_a <- c(datasets(where(is.data.frame)), var_a) - matrix_a <- c(datasets(where(is.matrix)), var_a) - df_or_m_var_a <- list(df_a, matrix_a) - resolved <- resolver(df_or_m_var_a, td) - # The second option is not possible to have it as df - expect_error(update_spec(resolved, "datasets", "df")) -}) diff --git a/tests/testthat/test-types.R b/tests/testthat/test-types.R deleted file mode 100644 index 471d11f3..00000000 --- a/tests/testthat/test-types.R +++ /dev/null @@ -1,73 +0,0 @@ -testthat::describe("selected_choices() basic asserts:", { - it("selected_choices(choices) argument accepts character, integer and tidyselect", { - testthat::expect_no_error(datasets(choices = "test")) - testthat::expect_no_error(datasets(choices = 1)) - testthat::expect_no_error(datasets(choices = tidyselect::everything())) - testthat::expect_error(datasets(choices = character(0))) - testthat::expect_error(datasets(choices = NULL)) - testthat::expect_error(datasets(choices = list())) - }) - it("datasets(selected) argument accepts NULL, character, integer and tidyselect", { - testthat::expect_no_error(datasets(selected = "test")) - testthat::expect_no_error(datasets(selected = 1)) - testthat::expect_no_error(datasets(selected = tidyselect::everything())) - testthat::expect_no_error(datasets(selected = NULL)) - }) - it("datasets(selected) disallow values outside of the non-delayed choices", { - testthat::expect_error(datasets(choices = c("a", "b"), selected = "c") - testthat::expect_error(datasets(choices = c("a", "b"), selected = c("a","c")) - testthat::expect_no_error(datasets(choices = tidyselect::everything(), selected = "c") - testthat::expect_no_error(datasets(choices = 1, selected = "c") - }) - - it("datasets returns datasets object", { - testthat::expect_s3_class(datasets(choices = c("a", "b"), selected = "a"), "datasets") - testthat::expect_s3_class(datasets(choices = c("a", "b"), selected = "a"), "datasets") - }) -}) - -testthat::test_that("datasets", { - expect_no_error(dataset0 <- datasets("df", "df")) - expect_no_error(dataset1 <- datasets("df")) - expect_no_error(dataset2 <- datasets(where(is.matrix))) - expect_no_error(dataset3 <- datasets(where(is.data.frame))) -}) - -test_that("variables", { - expect_no_error(var0 <- variables("a", "a")) - expect_no_error(var1 <- variables("a")) - expect_no_error(var2 <- variables(where(is.factor))) - # Allowed to specify whatever we like, it is not until resolution that this raises errors - expect_no_error(var3 <- variables(where(is.factor), where(function(x) { - head(x, 1) - }))) - expect_no_error(var4 <- variables(where(is.matrix), where(function(x) { - head(x, 1) - }))) -}) - -test_that("raw combine of types", { - expect_equal(c(datasets("df")), datasets("df")) - expect_length(c(datasets("df"), variables("df")), 2L) - expect_length(c(datasets("df"), variables("df"), values("df")), 3L) -}) - -test_that("combine types", { - expect_no_error(c( - datasets(where(is.data.frame), selected = "df1"), - variables(where(is.numeric)) - )) -}) - -test_that("values", { - expect_no_error(val0 <- values("a", "a")) - expect_no_error(val1 <- values("a")) - expect_no_error(val2 <- values(where(is.factor))) - # Allowed to specify whatever we like, it is not until resolution that this raises errors - expect_no_error(val3 <- values(where(is.factor), function(x) { - head(x, 1) - })) - expect_no_error(val4 <- values(where(is.matrix), function(x) { - head(x, 1) - })) -}) From 3302ffb40f9d35f8ca337fe7481897cb6a248e92 Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Fri, 24 Oct 2025 12:39:51 +0200 Subject: [PATCH 137/142] WIP cleanup testing coverage --- NAMESPACE | 12 +- R/0-mae-methods.R | 25 + R/0-module_merge.R | 8 +- R/0-module_picks.R | 151 +++--- R/0-picks.R | 146 ++++-- R/0-print.R | 26 +- R/0-resolver.R | 315 +++++++------ R/0-tm_merge.R | 17 +- inst/refactor-notes.md | 16 +- man/dot-check_merge_keys.Rd | 8 + man/dot-determine_choices.Rd | 71 +++ man/dot-resolve.Rd | 10 +- man/is.delayed.Rd | 18 - man/merge_srv.Rd | 6 +- man/picks.Rd | 41 +- man/picks_module.Rd | 28 +- man/resolver.Rd | 27 +- man/tm_merge.Rd | 8 +- tests/testthat/test-0-module_picks.R | 682 +++++++++++++++++++++++++++ tests/testthat/test-0-picks.R | 163 ++++--- tests/testthat/test-0-print.R | 24 +- 21 files changed, 1347 insertions(+), 455 deletions(-) create mode 100644 R/0-mae-methods.R create mode 100644 man/dot-determine_choices.Rd delete mode 100644 man/is.delayed.Rd create mode 100644 tests/testthat/test-0-module_picks.R diff --git a/NAMESPACE b/NAMESPACE index 43c132cc..873f8346 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -17,18 +17,14 @@ S3method(data_extract_multiple_srv,list) S3method(data_extract_multiple_srv,reactive) S3method(data_extract_srv,FilteredData) S3method(data_extract_srv,list) -S3method(determine,colData) S3method(determine,datasets) -S3method(determine,default) +S3method(determine,mae_data) S3method(determine,values) S3method(determine,variables) S3method(filter_spec_internal,default) S3method(filter_spec_internal,delayed_data) +S3method(format,pick) S3method(format,picks) -S3method(format,type) -S3method(is.delayed,list) -S3method(is.delayed,picks) -S3method(is.delayed,type) S3method(merge_expression_module,list) S3method(merge_expression_module,reactive) S3method(merge_expression_srv,list) @@ -45,8 +41,8 @@ S3method(print,delayed_select_spec) S3method(print,delayed_value_choices) S3method(print,delayed_variable_choices) S3method(print,filter_spec) +S3method(print,pick) S3method(print,picks) -S3method(print,type) S3method(resolve,default) S3method(resolve,delayed_choices_selected) S3method(resolve,delayed_data_extract_spec) @@ -67,7 +63,6 @@ export(all_choices) export(check_no_multiple_selection) export(choices_labeled) export(choices_selected) -export(col_data) export(compose_and_enable_validators) export(data_extract_multiple_srv) export(data_extract_spec) @@ -92,6 +87,7 @@ export(is_single_dataset) export(last_choice) export(last_choices) export(list_extract_spec) +export(mae_data) export(merge_datasets) export(merge_expression_module) export(merge_expression_srv) diff --git a/R/0-mae-methods.R b/R/0-mae-methods.R new file mode 100644 index 00000000..12dab62c --- /dev/null +++ b/R/0-mae-methods.R @@ -0,0 +1,25 @@ +#' @rdname picks +#' @export +mae_data <- function(choices = tidyselect::everything(), selected = 1L, multiple = FALSE) { + out <- .selected_choices( + choices = if (.is_tidyselect(choices)) rlang::enquo(choices) else choices, + selected = if (.is_tidyselect(selected)) rlang::enquo(selected) else selected, + multiple = multiple + ) + class(out) <- c("mae_data", class(out)) + out +} + +#' @export +determine.mae_data <- function(x, data) { + if (!requireNamespace("SummarizedExperiment", quietly = TRUE)) { + stop("Requires SummarizedExperiment package from Bioconductor.") + } + data <- SummarizedExperiment::colData(data) + NextMethod("determine", x) +} + + +#' @keywords internal +#' @export +.picker_icon.MultiAssayExperiment <- function(x) "layer-group" diff --git a/R/0-module_merge.R b/R/0-module_merge.R index 17e19d80..a8fe8015 100644 --- a/R/0-module_merge.R +++ b/R/0-module_merge.R @@ -122,7 +122,7 @@ #' ```r #' # Create selectors in server #' selectors <- picks_srv( -#' spec = list( +#' picks = list( #' adsl = picks(...), #' adae = picks(...) #' ), @@ -169,11 +169,11 @@ #' selectors <- list( #' adsl = picks_srv("adsl", #' data = reactive(data), -#' spec = picks(datasets("ADSL"), variables()) +#' picks = picks(datasets("ADSL"), variables()) #' ), #' adae = picks_srv("adae", #' data = reactive(data), -#' spec = picks(datasets("ADAE"), variables()) +#' picks = picks(datasets("ADAE"), variables()) #' ) #' ) #' @@ -517,5 +517,5 @@ merge_srv <- function(id, TRUE } -#' @rdname .check_merge_keys +#' @rdname dot-check_merge_keys .assert_merge_keys <- checkmate::makeAssertionFunction(.check_merge_keys) diff --git a/R/0-module_picks.R b/R/0-module_picks.R index f51a2270..d145fd4c 100644 --- a/R/0-module_picks.R +++ b/R/0-module_picks.R @@ -8,14 +8,14 @@ #' values #' #' -#' The module supports both single and combined specifications: +#' The module supports both single and combined `picks`: #' - Single `picks` objects for a single input #' - Named lists of `picks` objects for multiple inputs #' #' @param id (`character(1)`) Shiny module ID -#' @param spec (`picks` or `list`) Specification object created by `picks()` or a named list of such objects -#' @param container (`character(1)` or `function`) UI container type. Default is `"badge_dropdown"`. -#' Can also be one of `htmltools::tags` functions +#' @param picks (`picks` or `list`) object created by `picks()` or a named list of such objects +#' @param container (`character(1)` or `function`) UI container type. Can be one of `htmltools::tags` +#' functions. By default, elements are wrapped in a package-specific dropdown. #' @param data (`reactive`) Reactive expression returning the data object to be used for populating choices #' #' @return @@ -23,47 +23,47 @@ #' - `picks_srv()`: Server-side reactive logic returning the processed data #' #' @details -#' The module uses S3 method dispatch to handle different types of specifications: -#' - `.picks` methods handle single specification -#' - `.list` methods handle multiple specifications +#' The module uses S3 method dispatch to handle different ways to provide `picks`: +#' - `.picks` methods handle single `picks`` object +#' - `.list` methods handle multiple `picks` objects #' #' The UI component (`picks_ui`) creates the visual elements, while the #' server component (`picks_srv`) manages the reactive logic, #' -#' @seealso [picks()] for creating specification objects +#' @seealso [picks()] for creating `picks`` objects #' #' @name picks_module NULL #' @rdname picks_module #' @export -picks_ui <- function(id, spec, container = "badge_dropdown") { +picks_ui <- function(id, picks, container = "badge_dropdown") { checkmate::assert_string(id) - UseMethod("picks_ui", spec) + UseMethod("picks_ui", picks) } #' @rdname picks_module #' @export -picks_ui.list <- function(id, spec, container = "badge_dropdown") { - checkmate::assert_list(spec, names = "named") +picks_ui.list <- function(id, picks, container) { + checkmate::assert_list(picks, names = "unique") ns <- shiny::NS(id) sapply( - Filter(length, names(spec)), + Filter(length, names(picks)), USE.NAMES = TRUE, - function(name) picks_ui(ns(name), spec[[name]], container = container) + function(name) picks_ui(ns(name), picks[[name]], container = container) ) } #' @rdname picks_module #' @export -picks_ui.picks <- function(id, spec, container = "badge_dropdown") { +picks_ui.picks <- function(id, picks, container) { ns <- shiny::NS(id) badge_label <- shiny::uiOutput(ns("summary"), container = htmltools::tags$span) - content <- lapply(spec, function(x) .selected_choices_ui(id = ns(is(x)))) + content <- lapply(picks, function(x) .selected_choices_ui(id = ns(is(x)))) htmltools::tags$div( # todo: badge to have css attribute to control the size - make CSS rule - can be controlled globally and module-ly - if (identical(container, "badge_dropdown")) { + if (missing(container)) { badge_dropdown(id = ns("inputs"), label = badge_label, htmltools::tagList(content)) } else { if (!any(sapply(htmltools::tags, identical, container))) { @@ -76,44 +76,41 @@ picks_ui.picks <- function(id, spec, container = "badge_dropdown") { #' @rdname picks_module #' @export -picks_srv <- function(id = "", spec, data) { +picks_srv <- function(id = "", picks, data) { checkmate::assert_string(id) checkmate::assert_class(data, "reactive") - UseMethod("picks_srv", spec) + UseMethod("picks_srv", picks) } #' @rdname picks_module #' @export -picks_srv.list <- function(id, spec, data) { +picks_srv.list <- function(id, picks, data) { + checkmate::assert_named(picks, type = "unique") sapply( - names(Filter(length, spec)), + names(Filter(length, picks)), USE.NAMES = TRUE, - function(name) picks_srv(name, spec[[name]], data) + function(name) picks_srv(name, picks[[name]], data) ) } #' @rdname picks_module #' @export -picks_srv.picks <- function(id, spec, data) { +picks_srv.picks <- function(id, picks, data) { moduleServer(id, function(input, output, session) { - data_r <- shiny::reactive(if (shiny::is.reactive(data)) data() else data) - spec_resolved <- shiny::reactiveVal( + picks_resolved <- shiny::reactiveVal( restoreValue( session$ns("picks"), - resolver(spec, shiny::isolate(data_r())) + resolver(picks, shiny::isolate(data())) ) ) session$onBookmark(function(state) { logger::log_debug("picks_srv@onBookmark: storing current picks") - state$values$picks <- spec_resolved() + state$values$picks <- picks_resolved() }) - # join_keys are needed to variables after merge - attr(spec_resolved, "join_keys") <- teal.data::join_keys(shiny::isolate(data_r())) - badge <- shiny::reactive({ lapply( - spec_resolved(), + picks_resolved(), function(x) { label <- if (length(x$selected)) { toString(x$selected) @@ -128,14 +125,14 @@ picks_srv.picks <- function(id, spec, data) { output$summary <- shiny::renderUI(tagList(badge())) Reduce( - function(data, slot_name) { - choices <- reactiveVal(isolate(spec_resolved())[[slot_name]]$choices) - selected <- reactiveVal(isolate(spec_resolved())[[slot_name]]$selected) - all_choices <- reactive(determine(x = spec[[slot_name]], data = data())$x$choices) + function(this_data, slot_name) { # this_data is a (drilled-down) data for current pick + choices <- reactiveVal(isolate(picks_resolved())[[slot_name]]$choices) + selected <- reactiveVal(isolate(picks_resolved())[[slot_name]]$selected) + all_choices <- reactive(determine(x = picks[[slot_name]], data = this_data())$x$choices) observeEvent(all_choices(), ignoreInit = TRUE, { - current_choices <- spec_resolved()[[slot_name]]$choices - current_selected <- spec_resolved()[[slot_name]]$selected + current_choices <- picks_resolved()[[slot_name]]$choices + current_selected <- picks_resolved()[[slot_name]]$selected new_selected <- if (is.numeric(current_selected) && is.numeric(all_choices())) { c( @@ -156,37 +153,45 @@ picks_srv.picks <- function(id, spec, data) { ) }) - observeEvent(spec_resolved()[[slot_name]], ignoreInit = TRUE, ignoreNULL = FALSE, { - .update_rv(choices, spec_resolved()[[slot_name]]$choices, log = "picks_srv@1 update input choices") - .update_rv(selected, spec_resolved()[[slot_name]]$selected, log = "picks_srv@1 update input selected") + observeEvent(picks_resolved()[[slot_name]], ignoreInit = TRUE, ignoreNULL = FALSE, { + .update_rv(choices, picks_resolved()[[slot_name]]$choices, log = "picks_srv@1 update input choices") + .update_rv(selected, picks_resolved()[[slot_name]]$selected, log = "picks_srv@1 update input selected") }) - args <- attributes(spec[[slot_name]]) + args <- attributes(picks[[slot_name]]) .selected_choices_srv( - id = is(spec[[slot_name]]), - type = is(spec[[slot_name]]), + id = slot_name, + pick_type = slot_name, choices = choices, selected = selected, args = args[!names(args) %in% c("names", "class")], - data = data + data = this_data ) # this works as follows: - # Each observer is observes input$selected of i-th element of spec ($datasets, $variables, ...) + # Each observer is observes input$selected of i-th element of picks ($datasets, $variables, ...) shiny::observeEvent( selected(), - ignoreInit = TRUE, # because spec_resolved is already resolved and `selected()` is being set + ignoreInit = TRUE, # because picks_resolved is already resolved and `selected()` is being set ignoreNULL = FALSE, # because input$selected can be empty - .resolve(selected(), slot_name = slot_name, spec_resolved = spec_resolved, old_spec = spec, data = data_r()) + { + .resolve( + selected(), + slot_name = slot_name, + picks_resolved = picks_resolved, + old_picks = picks, + data = data() # data() object needed as we resolve the WHOLE picks INSTEAD OF one picks element. + ) + } ) - reactive(.extract(x = isolate(spec_resolved()[[slot_name]]), data())) + reactive(.extract(x = picks_resolved()[[slot_name]], this_data())) }, - x = names(spec), - init = data_r + x = names(picks), + init = data ) - spec_resolved + picks_resolved }) } @@ -195,7 +200,7 @@ picks_srv.picks <- function(id, spec, data) { uiOutput(ns("selected_container")) } -.selected_choices_srv <- function(id, type, choices, selected, data, args) { +.selected_choices_srv <- function(id, pick_type, choices, selected, data, args) { checkmate::assert_string(id) checkmate::assert_class(choices, "reactiveVal") checkmate::assert_class(selected, "reactiveVal") @@ -204,7 +209,7 @@ picks_srv.picks <- function(id, spec, data) { shiny::moduleServer(id, function(input, output, session) { is_numeric <- reactive(is.numeric(choices())) choices_opt_content <- reactive({ - if (type != "values") { + if (pick_type != "values") { sapply( choices(), function(choice) { @@ -223,12 +228,12 @@ picks_srv.picks <- function(id, spec, data) { }) output$selected_container <- renderUI({ - logger::log_debug(".selected_choices_srv@1 rerender {type} input") + logger::log_debug(".selected_choices_srv@1 rerender {pick_type} input") if (isTRUE(args$fixed) || length(choices()) <= 1) { } else if (is_numeric()) { .selected_choices_ui_numeric( session$ns("range"), - label = sprintf("Select %s range:", type), + label = sprintf("Select %s range:", pick_type), choices = choices(), selected = selected(), args = args @@ -236,7 +241,7 @@ picks_srv.picks <- function(id, spec, data) { } else { .selected_choices_ui_categorical( session$ns("selected"), - label = sprintf("Select %s:", type), + label = sprintf("Select %s:", pick_type), choices = choices(), selected = selected(), multiple = args$multiple, @@ -320,38 +325,38 @@ picks_srv.picks <- function(id, spec, data) { #' #' @description #' When i-th select input changes then -#' - spec_resolved containing current state is being unresolved but only after the i-th element as +#' - picks_resolved containing current state is being unresolved but only after the i-th element as #' values are sequentially dependent. For example if variables (i=2) is selected we don't want #' to unresolve (restart) dataset. #' - new value (selected) is replacing old value in current slot (i) #' - we call resolve which resolves only "unresolved" (delayed) values -#' - new spec is replacing reactiveValue +#' - new picks is replacing reactiveValue #' Thanks to this design reactive values are triggered only once #' @param selected (`vector`) rather `character`, or `factor`. `numeric(2)` for `values()` based on numeric column. #' @param slot_idx (`integer`) -#' @param spec_resolved (`reactiveVal`) -#' @param old_spec (`picks`) +#' @param picks_resolved (`reactiveVal`) +#' @param old_picks (`picks`) #' @param data (`any` asserted further in `resolver`) #' @keywords internal -.resolve <- function(selected, slot_name, spec_resolved, old_spec, data) { +.resolve <- function(selected, slot_name, picks_resolved, old_picks, data) { checkmate::assert_vector(selected, null.ok = TRUE) checkmate::assert_string(slot_name) - checkmate::assert_class(spec_resolved, "reactiveVal") - checkmate::assert_class(old_spec, "picks") - if (isTRUE(all.equal(selected, spec_resolved()[[slot_name]]$selected, tolerance = 1e-15))) { + checkmate::assert_class(picks_resolved, "reactiveVal") + checkmate::assert_class(old_picks, "picks") + if (isTRUE(all.equal(selected, picks_resolved()[[slot_name]]$selected, tolerance = 1e-15))) { return(NULL) } logger::log_info("picks_server@1 selected has changed. Resolving downstream...") - new_spec_unresolved <- old_spec + new_picks_unresolved <- old_picks # ↓ everything after `slot_idx` is to resolve - slot_idx <- which(names(old_spec) == slot_name) - new_spec_unresolved[seq_len(slot_idx - 1)] <- spec_resolved()[seq_len(slot_idx - 1)] - new_spec_unresolved[[slot_idx]]$selected <- selected + slot_idx <- which(names(old_picks) == slot_name) + new_picks_unresolved[seq_len(slot_idx - 1)] <- picks_resolved()[seq_len(slot_idx - 1)] + new_picks_unresolved[[slot_idx]]$selected <- selected resolver_warnings <- character(0) - new_spec_resolved <- withCallingHandlers( - resolver(new_spec_unresolved, data), + new_picks_resolved <- withCallingHandlers( + resolver(new_picks_unresolved, data), warning = function(w) { resolver_warnings <<- paste(conditionMessage(w), collapse = " ") } @@ -360,7 +365,7 @@ picks_srv.picks <- function(id, spec, data) { showNotification(resolver_warnings, type = "error") } - spec_resolved(new_spec_resolved) + picks_resolved(new_picks_resolved) } #' Restore value from bookmark. @@ -450,10 +455,6 @@ restoreValue <- function(value, default) { # nolint: object_name. #' @export .picker_icon.data.frame <- function(x) "table" -#' @keywords internal -#' @export -.picker_icon.MultiAssayExperiment <- function(x) "layer-group" - #' @keywords internal #' @export .picker_icon.default <- function(x) "circle-question" diff --git a/R/0-picks.R b/R/0-picks.R index 7820542e..72752595 100644 --- a/R/0-picks.R +++ b/R/0-picks.R @@ -5,10 +5,10 @@ #' Functions are based on the idea of `choices/selected` where app-developer provides `choices` #' and what is `selected` by default. App-user though changes `selected` interactively in #' [`picks_module`] -#' -#' @param choices ([`tidyselect::language`] or `character`) +#' # todo: add note that values accepts predicates only +#' @param choices (`tidyselect::language` or `character`) #' Available values to choose. -#' @param selected ([`tidyselect::language`] or `character`) +#' @param selected (`tidyselect::language` or `character`) #' Choices to be selected. #' @param multiple (`logical(1)`) if more than one selection is possible. #' @param fixed (`logical(1)`) selection will be fixed and not possible to change interactively. @@ -153,13 +153,13 @@ #' @export picks <- function(...) { picks <- rlang::dots_list(..., .ignore_empty = "trailing") - checkmate::assert_list(picks, types = "type") + checkmate::assert_list(picks, types = "pick") if (!inherits(picks[[1]], "datasets")) { stop("picks() requires datasets() as the first element", call. = FALSE) } # Check if values exists and is preceded by variables - element_classes <- vapply(picks, FUN = is, FUN.VALUE = character(1)) + element_classes <- vapply(picks, FUN = methods::is, FUN.VALUE = character(1)) values_idx <- which(element_classes == "values") if (length(values_idx) > 0) { @@ -172,6 +172,24 @@ picks <- function(...) { } } + previous_has_dynamic_choices <- c( + FALSE, + vapply(head(picks, -1), FUN.VALUE = logical(1), FUN = function(x) { + inherits(x$choices, "quosure") || length(x$choices) > 1 + }) + ) + has_eager_choices <- vapply(picks, function(x) is.character(x$choices), logical(1)) + + if (any(previous_has_dynamic_choices & has_eager_choices)) { + idx_wrong <- which(previous_has_dynamic_choices & has_eager_choices)[1] + warning( + element_classes[idx_wrong], " has eager choices (character) while ", + element_classes[idx_wrong - 1], " has dynamic choices. ", + "It is not guaranteed that explicitly defined choices will be a subset of data selected in a previous element.", + call. = FALSE + ) + } + names(picks) <- element_classes structure(picks, class = c("picks", "list")) } @@ -179,24 +197,27 @@ picks <- function(...) { #' @rdname picks #' @export datasets <- function(choices = tidyselect::everything(), - selected = 1, + selected = 1L, fixed = NULL, ...) { - if (is.null(fixed)) { - fixed <- !.is_tidyselect(choices) && length(choices) == 1 - } + checkmate::assert( + .check_tidyselect(choices), + .check_predicate(choices), + checkmate::check_character(choices, min.len = 1) + ) + checkmate::assert( + .check_tidyselect(selected), + .check_predicate(selected), + checkmate::check_character(selected, len = 1, null.ok = TRUE) + ) - selected_q <- if (.is_tidyselect(selected)) { - rlang::enquo(selected) - } else if (is.character(selected) && length(selected) == 1) { - selected - } else { - stop("datasets(selected) should either be `character(>0)` or `tidyselect-select-helper`") + if (is.null(fixed)) { + fixed <- !.is_tidyselect(choices) && !.is_predicate(choices) && length(choices) == 1 } out <- .selected_choices( choices = if (.is_tidyselect(choices)) rlang::enquo(choices) else choices, - selected = selected_q, + selected = if (.is_tidyselect(selected)) rlang::enquo(selected) else selected, multiple = FALSE, fixed = fixed, ... @@ -208,16 +229,26 @@ datasets <- function(choices = tidyselect::everything(), #' @rdname picks #' @export variables <- function(choices = tidyselect::everything(), - selected = 1, + selected = 1L, multiple = NULL, fixed = NULL, ordered = FALSE, ...) { + checkmate::assert( + .check_tidyselect(choices), + .check_predicate(choices), + checkmate::check_character(choices, min.len = 1) + ) + checkmate::assert( + .check_tidyselect(selected), + .check_predicate(selected), + checkmate::check_character(selected, min.len = 1, null.ok = TRUE) + ) if (is.null(multiple)) { - multiple <- !.is_tidyselect(selected) && length(selected) > 1 + multiple <- !(.is_tidyselect(selected) || .is_predicate(selected)) && length(selected) > 1 } if (is.null(fixed)) { - fixed <- !.is_tidyselect(choices) && length(choices) == 1 + fixed <- !(.is_tidyselect(choices) || .is_predicate(choices)) && length(choices) == 1 } out <- .selected_choices( @@ -226,7 +257,7 @@ variables <- function(choices = tidyselect::everything(), multiple = multiple, fixed = fixed, ordered = ordered, - `allow-clear` = !.is_tidyselect(selected) && (is.null(selected) || multiple), + `allow-clear` = !.is_tidyselect(selected) && !.is_predicate(selected) && (is.null(selected) || multiple), ... ) class(out) <- c("variables", class(out)) @@ -235,17 +266,34 @@ variables <- function(choices = tidyselect::everything(), #' @rdname picks #' @export -values <- function(choices = tidyselect::everything(), - selected = tidyselect::everything(), +values <- function(choices = function(x) !is.na(x), + selected = function(x) !is.na(x), multiple = TRUE, fixed = NULL, ...) { + checkmate::assert( + .check_predicate(choices), + checkmate::check_character(choices, min.len = 1, unique = TRUE), + checkmate::check_numeric(choices, len = 2, sorted = TRUE, finite = TRUE), + checkmate::check_date(choices, len = 2), # should be sorted but determine + checkmate::check_posixct(choices, len = 2) + ) + checkmate::assert( + .check_predicate(selected), + checkmate::check_null(selected), + checkmate::check_character(selected, min.len = 1, unique = TRUE), + checkmate::check_numeric(selected, len = 2, sorted = TRUE, finite = TRUE), + checkmate::check_date(selected, len = 2), + checkmate::check_posixct(selected, len = 2) + ) + if (is.null(fixed)) { - fixed <- !.is_tidyselect(choices) && length(choices) == 1 + fixed <- !.is_predicate(choices) && length(choices) == 1 } + out <- .selected_choices( - choices = if (.is_tidyselect(choices)) rlang::enquo(choices) else choices, - selected = if (.is_tidyselect(selected)) rlang::enquo(selected) else selected, + choices = choices, + selected = selected, multiple = multiple, fixed = fixed, ... @@ -255,18 +303,6 @@ values <- function(choices = tidyselect::everything(), } -#' @rdname picks -#' @export -col_data <- function(choices = tidyselect::everything(), selected = 1, multiple = FALSE) { - out <- .selected_choices( - choices = if (.is_tidyselect(choices)) rlang::enquo(choices) else choices, - selected = if (.is_tidyselect(selected)) rlang::enquo(selected) else selected, - multiple = multiple - ) - class(out) <- c("col_data", class(out)) - out -} - .selected_choices <- function(choices, @@ -275,12 +311,8 @@ col_data <- function(choices = tidyselect::everything(), selected = 1, multiple ordered = FALSE, fixed = FALSE, ...) { - is_choices_delayed <- rlang::is_quosure(choices) - is_choices_eager <- is.character(choices) && length(choices) + is_choices_delayed <- rlang::is_quosure(choices) || .is_predicate(choices) is_selected_eager <- is.character(selected) - if (!(is_choices_delayed || is_choices_eager)) { - stop("`choices` should either be `character(>0)` or `tidyselect-select-helper`") - } if (is_choices_delayed && is_selected_eager) { warning( deparse(sys.call(-1)), @@ -305,7 +337,7 @@ col_data <- function(choices = tidyselect::everything(), selected = 1, multiple ordered = ordered, fixed = fixed, ..., - class = "type" + class = "pick" ) } @@ -324,6 +356,30 @@ col_data <- function(choices = tidyselect::everything(), selected = 1, multiple inherits(out, "error") && grepl("must be used within a \\*selecting\\* function", out$message) || # e.g. everything inherits(out, "error") && grepl("object .+ not found", out$message) || # e.g. var:var2 inherits(out, "error") && grepl("operations are possible", out$message) || # e.g. where() | where() - is.function(out) || # e.g. where(is.numeric) - checkmate::test_integerish(out, min.len = 1) # e.g. 1:5 + checkmate::test_integer(out, min.len = 1) # e.g. 1L:5L +} + +.is_predicate <- function(x) { + !.is_tidyselect(x) && + ( + checkmate::test_function(x, nargs = 1) || + checkmate::test_function(x) && identical(names(formals(x)), "...") + + ) +} + +.check_tidyselect <- function(x) { + if (!.is_tidyselect(x)) { + "choices/selected has not been created using tidyselect-helper" + } else { + TRUE + } +} + +.check_predicate <- function(x) { + if (!.is_predicate(x)) { + "choices/selected has not been created using predicate function (single arg function returning TRUE or FALSE)" + } else { + TRUE + } } diff --git a/R/0-print.R b/R/0-print.R index da17a668..584d4299 100644 --- a/R/0-print.R +++ b/R/0-print.R @@ -1,5 +1,5 @@ #' @export -print.type <- function(x, ...) { +print.pick <- function(x, ...) { cat(format(x, indent = 0)) invisible(x) } @@ -21,28 +21,28 @@ format.picks <- function(x, indent = 0) { for (i in seq_along(x)) { element_name <- names(x)[i] out <- paste0(out, .indent(sprintf(" %s:\n", .bold(sprintf("<%s>", element_name))), indent)) - out <- paste0(out, .format_type_content(x[[i]], indent + 4)) - out <- paste0(out, .format_type_attributes(x[[i]], indent + 4)) + out <- paste0(out, .format_pick_content(x[[i]], indent + 4)) + out <- paste0(out, .format_pick_attributes(x[[i]], indent + 4)) } out } #' @export -format.type <- function(x, indent = 0) { - element_class <- setdiff(class(x), "type")[1] +format.pick <- function(x, indent = 0) { + element_class <- setdiff(class(x), "pick")[1] out <- .indent(sprintf("%s\n", .bold(sprintf("<%s>", element_class))), indent) - out <- paste0(out, .format_type_content(x, indent + 2)) - out <- paste0(out, .format_type_attributes(x, indent + 2)) + out <- paste0(out, .format_pick_content(x, indent + 2)) + out <- paste0(out, .format_pick_attributes(x, indent + 2)) out } -.format_type_content <- function(x, indent = 0) { - out <- .indent(sprintf("%s %s\n", "choices:", .format_type_value(x$choices)), indent) - out <- paste0(out, .indent(sprintf("%s %s\n", "selected:", .format_type_value(x$selected)), indent)) +.format_pick_content <- function(x, indent = 0) { + out <- .indent(sprintf("%s %s\n", "choices:", .format_pick_value(x$choices)), indent) + out <- paste0(out, .indent(sprintf("%s %s\n", "selected:", .format_pick_value(x$selected)), indent)) out } -.format_type_attributes <- function(x, indent = 0) { +.format_pick_attributes <- function(x, indent = 0) { attrs <- attributes(x) attrs_to_show <- attrs[!names(attrs) %in% c("class", "names")] if (length(attrs_to_show) > 0) { @@ -56,8 +56,8 @@ format.type <- function(x, indent = 0) { } } -.format_type_value <- function(x) { - choices_str <- if (rlang::is_quosure(x)) { +.format_pick_value <- function(x) { + choices_str <- if (rlang::is_quosure(x) || is.function(x)) { rlang::as_label(x) } else if (length(x) == 0) { "~" diff --git a/R/0-resolver.R b/R/0-resolver.R index f8cdbf1c..b9a97219 100644 --- a/R/0-resolver.R +++ b/R/0-resolver.R @@ -1,75 +1,39 @@ -#' Resolve the specification +#' Resolve `picks` #' -#' Given the specification of some data to extract find if they are available or not. -#' The specification for selecting a variable shouldn't depend on the data of said variable. -#' @param spec A object extraction specification. -#' @param data The qenv where the specification is evaluated. +#' Resolve iterates through each `picks` element and determines values . +#' @param picks ([picks()]) settings for picks. +#' @param data ([teal_data()] `environment` or `list`) any data collection supporting object extraction with `[[`. +#' Used to determine values of unresolved `picks`. #' -#' @returns A specification but resolved: the names and selection is the name of the objects (if possible). +#' @returns resolved `picks`. #' @export #' #' @examples -#' dataset1 <- datasets(where(is.data.frame)) -#' dataset2 <- datasets(where(is.matrix)) -#' spec <- c(dataset1, variables("a", "a")) -#' td <- within(teal.data::teal_data(), { +#' # todo: fix example to use environment or a list +#' x1 <- datasets(where(is.data.frame)) +#' x2 <- picks(x1, variables("a", "a")) +#' data <- within(teal.data::teal_data(), { #' df <- data.frame(a = as.factor(LETTERS[1:5]), b = letters[1:5]) #' df2 <- data.frame(a = LETTERS[1:5], b = 1:5) #' m <- matrix() #' }) -#' resolver(list(spec, dataset2), td) -#' resolver(dataset2, td) -#' resolver(spec, td) -#' spec <- c(dataset1, variables("a", where(is.character))) -#' resolver(spec, td) +#' resolver(x = x1, data = data) +#' resolver(x = x2, data = data) resolver <- function(x, data) { checkmate::assert_class(x, "picks") - checkmate::assert_environment(data) - if (is.delayed(x)) { - data_i <- data - for (i in seq_along(x)) { - x[[i]] <- if (is.null(data_i)) { - # remove subsequent elements if nothing selected in the previous one - NULL - } else { - determined_i <- determine(x[[i]], data = data_i) - data_i <- determined_i$data - determined_i$x - } - } + checkmate::assert( + is.environment(data), + checkmate::check_list(data, names = "unique") + ) + data_i <- data + for (i in seq_along(x)) { + determined_i <- determine(x[[i]], data = data_i) + data_i <- determined_i$data + x[[i]] <- determined_i$x } x } -#' Is the specification resolved? -#' -#' Check that the specification is resolved against a given data source. -#' @param x Object to be evaluated. -#' @returns A single logical value. -#' @keywords internal -is.delayed <- function(x) { - UseMethod("is.delayed") -} - -# Handling a list of transformers e1 | e2 -#' @export -#' @method is.delayed list -is.delayed.list <- function(x) { - any(vapply(x, is.delayed, logical(1L))) -} - -#' @export -#' @method is.delayed picks -is.delayed.picks <- function(x) { - any(vapply(x, is.delayed, logical(1L))) -} - -#' @export -#' @method is.delayed type -is.delayed.type <- function(x) { - !is.character(x$choices) || !is.character(x$selected) -} - #' A method that should take a type and resolve it. #' @@ -80,35 +44,19 @@ is.delayed.type <- function(x) { #' @return A list with two elements, the `type` resolved and the data extracted. #' @keywords internal determine <- function(x, data, ...) { - UseMethod("determine") -} - -#' @export -determine.default <- function(x, data, ...) { - stop("There is not a specific method to picks choices.") -} - -#' @export -determine.colData <- function(x, data) { - if (!requireNamespace("SummarizedExperiment", quietly = TRUE)) { - stop("Requires SummarizedExperiment package from Bioconductor.") + if (is.null(data)) { # this happens when $selected=NULL + return(list(x = .nullify_pick(x))) } - data <- as.data.frame(colData(data)) - NextMethod("determine", x) + UseMethod("determine") } #' @export determine.datasets <- function(x, data) { - checkmate::assert_environment(data) - if (is.null(data)) { - return(list(x = x, data = NULL)) - } else if (!inherits(data, "qenv")) { - stop("Please use qenv() or teal_data() objects.") - } - - x$choices <- .determine_choices(x$choices, data = data) + checkmate::assert(is.environment(data), is.list(data)) + data <- as.list(data) + x$choices <- .determine_choices(x = x$choices, data = data) x$selected <- .determine_selected( - x$selected, + x = x$selected, data = data[intersect(x$choices, names(data))], multiple = attr(x, "multiple") ) @@ -118,13 +66,9 @@ determine.datasets <- function(x, data) { #' @export determine.variables <- function(x, data) { checkmate::assert_multi_class(data, c("data.frame", "tbl_df", "data.table", "DataFrame")) - - if (is.null(data)) { - return(list(x = x, data = NULL)) - } - if (ncol(data) <= 0L) { - stop("Can't pull variable: No variables is available.") + warning("Selected dataset has no columns", call. = FALSE) + return(list(x = .nullify_pick(x))) } x$choices <- .determine_choices(x$choices, data = data) @@ -133,93 +77,178 @@ determine.variables <- function(x, data) { data = data[intersect(x$choices, colnames(data))], multiple = attr(x, "multiple") ) - list(x = x, data = .extract(x, data)) } #' @export determine.values <- function(x, data) { - if (is.null(data) || ncol(data) == 0) { - return(list(x = NULL)) - } data <- if (ncol(data) > 1) { # todo: to limit number of possible columns to concat apply(data, 1, toString) } else { data[[1]] } - if (is.character(data) || is.factor(data)) { - # todo: what to do with NA choices? - d <- unique(data) - x$choices <- .determine_choices(x$choices, data = setNames(d, d)) # .determine_* uses names - x$selected <- if (length(x$choices)) { - .determine_selected(x$selected, data = setNames(x$choices, x$choices), multiple = attr(x, "multiple")) - } - list(x = x) # nothing more after this (no need to pass data further) - } else if (is.numeric(data) || inherits(data, c("Date", "POSIXct"))) { - if (all(is.na(data))) { - return(list(x = NULL)) - } - x$choices <- range(data, na.rm = TRUE) - x$selected <- if (is.numeric(x$selected) || inherits(data, c("Date", "POSIXct"))) x$selected else x$choices - list(x = x) + # todo: what to do with NA choices? + x$choices <- .determine_choices(x$choices, data = data) # .determine_* uses names + x$selected <- if (length(x$choices)) { + .determine_selected(x$selected, data = setNames(x$choices, x$choices), multiple = attr(x, "multiple")) } + list(x = x) # no picks element possible after picks(..., values) (no need to pass data further) } + +#' Evaluate delayed choices +#' +#' @param data (`list`, `data.frame`, `vector`) +#' @param x (`character`, `quosure`, `function(x)`) to determine `data` elements to extract. +#' +#' @details +#' +#' ## Various ways to evaluate choices/selected. +#' +#' Function resolves `x` to determine `choices` or `selected`. `x` is matched in multiple ways with +#' `data` to return valid choices: +#' - `x (character)`: values are matched with names of data and only intersection is returned. +#' - `x (tidyselect-helper)`: using [tidyselect::eval_select] +#' - `x (function)`: function is executed on each element of `data` to determine where function returns TRUE +#' +#' Mechnism is robust in a sense that it never fails (`tryCatch`) and returns `NULL` if no-match found. `NULL` +#' in [determine()] is handled gracefully, by setting `NULL` to all following components of `picks`. +#' +#' In the examples below you can replace `.determine_delayed` with `.determine_choices` or `.determine_selected`. +#' +#' - `character`: refers to the object name in `data`, for example +#' ``` +#' .determine_delayed(data = iris, x = "Species") +#' .determine_delayed(data = iris, x = c("Species", "inexisting")) +#' .determine_delayed(data = list2env(list(iris = iris, mtcars = mtcars)), x = "iris") +#' ``` +#' - `quosure`: delayed (quoted) `tidyselect-helper` to be evaluated through `tidyselect::eval_select`. For example +#' ``` +#' .determine_delayed(data = iris, x = rlang::quo(tidyselect::starts_with("Sepal"))) +#' .determine_delayed(data = iris, x = rlang::quo(1:2)) +#' .determine_delayed(data = iris, x = rlang::quo(Petal.Length:Sepal.Length)) +#' ``` +#' - `function(x)`: predicate function returning a logical flag. Evaluated for each `data` element. For example +#' ``` +#' +#' .determine_delayed(data = iris, x = is.numeric) +#' .determine_delayed(data = letters, x = function(x) x > "c") +#' .determine_delayed(data = list2env(list(iris = iris, mtcars = mtcars, a = "a")), x = is.data.frame) +#' ``` +#' +#' @return `character` containing names/levels of `data` elements which match `x`, with two differences: +#' - `.determine_choices` returns vector named after data labels +#' - `.determine_selected` cuts vector to scalar when `multiple = FALSE` +#' +#' @keywords internal .determine_choices <- function(x, data) { - if (is.character(x) && length(x)) { - return(x) + out <- .determine_delayed(data = data, x = x) + if (!is.null(names(data)) && !is.atomic(data) && # only named non-atomic can have label + is.character(out) && is.null(names(out))) { # don't rename if names provided by app dev + labels <- vapply( + out, + FUN = function(choice) c(attr(data[[choice]], "label"), choice)[1], + FUN.VALUE = character(1) + ) + setNames(out, labels) + } else { + out } +} - idx <- .eval_select(data, x) - choices <- unique(names(data)[idx]) - if (length(choices) == 0) { - stop("Can't determine choices: ", rlang::as_label(x)) +#' @rdname dot-determine_choices +.determine_selected <- function(x, data, multiple = FALSE) { + if (!is.null(x) && length(data)) { + out <- .determine_delayed(data = data, x = x) + if (!isTRUE(multiple) && length(out) > 1) { + warning( + "`multiple` has been set to `FALSE`, while selected contains multiple values, forcing to select first:", + rlang::as_label(x) + ) + out <- out[1] + } + out + } +} + +#' @rdname dot-determine_choices +.determine_delayed <- function(x, data) { + if (length(dim(data)) == 2L) { # for example matrix + data <- as.data.frame(data) } - labels <- vapply( - choices, - FUN = function(choice) c(attr(data[[choice]], "label"), choice)[1], - FUN.VALUE = character(1) + out <- tryCatch( # app developer might provide failing function + if (inherits(data, c("numeric", "Date", "POSIXct"))) { + data_range <- .possible_choices(data) + this_range <- if (inherits(x, c("numeric", "Date", "POSIXct")) && length(x) == 2) { + x + } else if (is.function(x)) { + idx_match <- unique(which(vapply(data, x, logical(1)))) + .possible_choices(data[idx_match]) + } else { + data_range + } + mins <- c(this_range[1], data_range[1]) + maxs <- c(this_range[2], data_range[2]) + mins <- mins[is.finite(mins)] + maxs <- maxs[is.finite(maxs)] + if (length(mins) && length(maxs)) { + c(max(mins), min(maxs)) + } + } else { + if (is.character(x) && length(x)) { + # don't need to evaluated eager choices - just make sure choices are subset of possible + x[which(x %in% .possible_choices(data))] + } else if (is.function(x)) { + idx_match <- unique(which(vapply(data, x, logical(1)))) + .possible_choices(data[idx_match]) + } else if (rlang::is_quosure(x)) { + # app developer might provide failing function + idx_match <- unique(tidyselect::eval_select(expr = x, data)) + .possible_choices(data[idx_match]) + } + }, + error = function(e) NULL # not returning error to avoid design complication to handle errors ) - setNames(choices, labels) + + if (length(out) == 0) { + warning( + "None of the `choices/selected`: ", rlang::as_label(x), "\n", + "are subset of: ", toString(.possible_choices(data), width = 30), "\n", + "Emptying choices..." + ) + return(NULL) + } + # unique() for idx containing duplicated values + if (is.atomic(out) && length(out)) out # this function should return atomic vector of length > 1 or NULL } -.determine_selected <- function(x, data, multiple) { - if (!is.null(x) && length(data)) { - res <- try(.eval_select(data, x), silent = TRUE) - x <- if (inherits(res, "try-error")) { - warning("`selected` outside of possible `choices`. Emptying `selecting` field.", call. = FALSE) - NULL - } else { - unique(names(res)) - } - if (!isTRUE(multiple)) { - x <- x[1] - } +#' @rdname dot-determine_choices +.possible_choices <- function(data) { + if (is.factor(data)) { + levels(data) + } else if (inherits(data, c("numeric", "Date", "POSIXct"))) { + suppressWarnings(range(data, na.rm = TRUE)) # we don't need to warn as we handle this case (inf) + } else if (is.character(data)) { + unique(data) + } else { + names(data) } - x } .extract <- function(x, data) { - if (length(x$selected) == 1 && inherits(x, "datasets")) { + if (length(x$selected) == 0) { + NULL # this nullifies following pick-elements. See determine (generic) + } else if (length(x$selected) == 1 && inherits(x, "datasets")) { data[[x$selected]] } else if (all(x$selected %in% names(data))) { data[x$selected] } } -.eval_select <- function(data, ...) { - if (is.environment(data)) { - # To keep the "order" of the names in the extraction: avoids suprises - data <- as.list(data)[names(data)] - } else if (length(dim(data)) == 2L) { - data <- as.data.frame(data) - } - - if (is.null(names(data))) { - stop("Can't extract the data.") - } - pos <- tidyselect::eval_select(expr = ..., data) - pos +.nullify_pick <- function(x) { + x$choices <- NULL + x$selected <- NULL + x } diff --git a/R/0-tm_merge.R b/R/0-tm_merge.R index a06a5bef..911127b0 100644 --- a/R/0-tm_merge.R +++ b/R/0-tm_merge.R @@ -1,22 +1,23 @@ #' Merge module #' +#' @param picks (`list` of `picks`) #' Example module -tm_merge <- function(label = "merge-module", inputs, transformators = list()) { +tm_merge <- function(label = "merge-module", picks, transformators = list()) { # todo: move to vignette module( label = label, - ui = function(id, inputs) { + ui = function(id, picks) { ns <- NS(id) tags$div( tags$div( class = "row g-2", - lapply(names(inputs), function(id) { + lapply(names(picks), function(id) { tags$div( class = "col-auto", tags$strong(tags$label(id)), teal.transform::picks_ui( id = ns(id), - spec = inputs[[id]] + picks = picks[[id]] ) ) }) @@ -29,9 +30,9 @@ tm_merge <- function(label = "merge-module", inputs, transformators = list()) { ) ) }, - server = function(id, data, inputs) { + server = function(id, data, picks) { moduleServer(id, function(input, output, session) { - selectors <- picks_srv(id, spec = inputs, data = data) + selectors <- picks_srv(id, picks = picks, data = data) merged <- merge_srv("merge", data = data, selectors = selectors) @@ -56,8 +57,8 @@ tm_merge <- function(label = "merge-module", inputs, transformators = list()) { output$join_keys <- renderPrint(teal.data::join_keys(merged$data())) }) }, - ui_args = list(inputs = inputs), - server_args = list(inputs = inputs), + ui_args = list(picks = picks), + server_args = list(picks = picks), transformators = transformators ) } diff --git a/inst/refactor-notes.md b/inst/refactor-notes.md index 77190254..9296bc5a 100644 --- a/inst/refactor-notes.md +++ b/inst/refactor-notes.md @@ -456,9 +456,9 @@ On the `ui` part it is necessary to call `picks_ui` for each `picks` object. ui_example <- function(id, x, y, facet) { ns <- NS(id) div( - picks_ui(id = ns("x"), spec = x), - picks_ui(id = ns("y"), spec = y), - picks_ui(id = ns("facet"), spec = facet), + picks_ui(id = ns("x"), picks = x), + picks_ui(id = ns("y"), picks = y), + picks_ui(id = ns("facet"), picks = facet), plotOutput(ns("plot")) ) } @@ -495,7 +495,7 @@ To create a merged-dataset using information from app-user selection one needs t ```r srv_example <- function(id, data, x, y, facet) { moduleServer(id, function(input, output, session) { - selectors <- picks_srv(data = data, spec = list(x = x, y = y, facet = facet)) + selectors <- picks_srv(data = data, picks = list(x = x, y = y, facet = facet)) merged <- merge_srv("merge", data = data, selectors = selectors) @@ -669,16 +669,16 @@ tm_example <- function(x, y, facet) { ui_example <- function(id, x, y, facet) { ns <- NS(id) div( - picks_ui(id = ns("x"), spec = x), - picks_ui(id = ns("y"), spec = y), - picks_ui(id = ns("facet"), spec = facet), + picks_ui(id = ns("x"), picks = x), + picks_ui(id = ns("y"), picks = y), + picks_ui(id = ns("facet"), picks = facet), plotOutput(ns("plot")) ) } srv_example <- function(id, data, x, y, facet) { moduleServer(id, function(input, output, session) { - selectors <- picks_srv(data = data, spec = list(x = x, y = y, facet = facet)) + selectors <- picks_srv(data = data, picks = list(x = x, y = y, facet = facet)) merged <- merge_srv("merge", data = data, selectors = selectors) diff --git a/man/dot-check_merge_keys.Rd b/man/dot-check_merge_keys.Rd index 04b4203b..ba5b5e06 100644 --- a/man/dot-check_merge_keys.Rd +++ b/man/dot-check_merge_keys.Rd @@ -2,9 +2,17 @@ % Please edit documentation in R/0-module_merge.R \name{.check_merge_keys} \alias{.check_merge_keys} +\alias{.assert_merge_keys} \title{Check if datasets can be merged in topological order} \usage{ .check_merge_keys(datanames, join_keys) + +.assert_merge_keys( + datanames, + join_keys, + .var.name = checkmate::vname(datanames), + add = NULL +) } \arguments{ \item{datanames}{(\code{character}) Vector of dataset names to be merged} diff --git a/man/dot-determine_choices.Rd b/man/dot-determine_choices.Rd new file mode 100644 index 00000000..f15e8464 --- /dev/null +++ b/man/dot-determine_choices.Rd @@ -0,0 +1,71 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/0-resolver.R +\name{.determine_choices} +\alias{.determine_choices} +\alias{.determine_selected} +\alias{.determine_delayed} +\alias{.possible_choices} +\title{Evaluate delayed choices} +\usage{ +.determine_choices(x, data) + +.determine_selected(x, data, multiple = FALSE) + +.determine_delayed(x, data) + +.possible_choices(data) +} +\arguments{ +\item{x}{(\code{character}, \code{quosure}, \verb{function(x)}) to determine \code{data} elements to extract.} + +\item{data}{(\code{list}, \code{data.frame}, \code{vector})} +} +\value{ +\code{character} containing names/levels of \code{data} elements which match \code{x}, with two differences: +\itemize{ +\item \code{.determine_choices} returns vector named after data labels +\item \code{.determine_selected} cuts vector to scalar when \code{multiple = FALSE} +} +} +\description{ +Evaluate delayed choices +} +\details{ +\subsection{Various ways to evaluate choices/selected.}{ + +Function resolves \code{x} to determine \code{choices} or \code{selected}. \code{x} is matched in multiple ways with +\code{data} to return valid choices: +\itemize{ +\item \code{x (character)}: values are matched with names of data and only intersection is returned. +\item \code{x (tidyselect-helper)}: using \link[tidyselect:eval_select]{tidyselect::eval_select} +\item \verb{x (function)}: function is executed on each element of \code{data} to determine where function returns TRUE +} + +Mechnism is robust in a sense that it never fails (\code{tryCatch}) and returns \code{NULL} if no-match found. \code{NULL} +in \code{\link[=determine]{determine()}} is handled gracefully, by setting \code{NULL} to all following components of \code{picks}. + +In the examples below you can replace \code{.determine_delayed} with \code{.determine_choices} or \code{.determine_selected}. +\itemize{ +\item \code{character}: refers to the object name in \code{data}, for example + +\if{html}{\out{
}}\preformatted{.determine_delayed(data = iris, x = "Species") +.determine_delayed(data = iris, x = c("Species", "inexisting")) +.determine_delayed(data = list2env(list(iris = iris, mtcars = mtcars)), x = "iris") +}\if{html}{\out{
}} +\item \code{quosure}: delayed (quoted) \code{tidyselect-helper} to be evaluated through \code{tidyselect::eval_select}. For example + +\if{html}{\out{
}}\preformatted{.determine_delayed(data = iris, x = rlang::quo(tidyselect::starts_with("Sepal"))) +.determine_delayed(data = iris, x = rlang::quo(1:2)) +.determine_delayed(data = iris, x = rlang::quo(Petal.Length:Sepal.Length)) +}\if{html}{\out{
}} +\item \verb{function(x)}: predicate function returning a logical flag. Evaluated for each \code{data} element. For example + +\if{html}{\out{
}}\preformatted{ +.determine_delayed(data = iris, x = is.numeric) +.determine_delayed(data = letters, x = function(x) x > "c") +.determine_delayed(data = list2env(list(iris = iris, mtcars = mtcars, a = "a")), x = is.data.frame) +}\if{html}{\out{
}} +} +} +} +\keyword{internal} diff --git a/man/dot-resolve.Rd b/man/dot-resolve.Rd index edf52397..260d77fc 100644 --- a/man/dot-resolve.Rd +++ b/man/dot-resolve.Rd @@ -4,14 +4,14 @@ \alias{.resolve} \title{Resolve downstream after selected changes} \usage{ -.resolve(selected, slot_name, spec_resolved, old_spec, data) +.resolve(selected, slot_name, picks_resolved, old_picks, data) } \arguments{ \item{selected}{(\code{vector}) rather \code{character}, or \code{factor}. \code{numeric(2)} for \code{values()} based on numeric column.} -\item{spec_resolved}{(\code{reactiveVal})} +\item{picks_resolved}{(\code{reactiveVal})} -\item{old_spec}{(\code{picks})} +\item{old_picks}{(\code{picks})} \item{data}{(\code{any} asserted further in \code{resolver})} @@ -21,12 +21,12 @@ @description When i-th select input changes then \itemize{ -\item spec_resolved containing current state is being unresolved but only after the i-th element as +\item picks_resolved containing current state is being unresolved but only after the i-th element as values are sequentially dependent. For example if variables (i=2) is selected we don't want to unresolve (restart) dataset. \item new value (selected) is replacing old value in current slot (i) \item we call resolve which resolves only "unresolved" (delayed) values -\item new spec is replacing reactiveValue +\item new picks is replacing reactiveValue Thanks to this design reactive values are triggered only once } } diff --git a/man/is.delayed.Rd b/man/is.delayed.Rd deleted file mode 100644 index b22639fa..00000000 --- a/man/is.delayed.Rd +++ /dev/null @@ -1,18 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/0-delayed.R -\name{is.delayed} -\alias{is.delayed} -\title{Is the specification resolved?} -\usage{ -is.delayed(x) -} -\arguments{ -\item{x}{Object to be evaluated.} -} -\value{ -A single logical value. -} -\description{ -Check that the specification is resolved against a given data source. -} -\keyword{internal} diff --git a/man/merge_srv.Rd b/man/merge_srv.Rd index cff900b6..012f8d86 100644 --- a/man/merge_srv.Rd +++ b/man/merge_srv.Rd @@ -154,7 +154,7 @@ acts as the "left" side of the join, and subsequent datasets are joined one by o \if{html}{\out{
}}\preformatted{# Create selectors in server selectors <- picks_srv( - spec = list( + picks = list( adsl = picks(...), adae = picks(...) ), @@ -198,11 +198,11 @@ server <- function(input, output, session) { selectors <- list( adsl = picks_srv("adsl", data = reactive(data), - spec = picks(datasets("ADSL"), variables()) + picks = picks(datasets("ADSL"), variables()) ), adae = picks_srv("adae", data = reactive(data), - spec = picks(datasets("ADAE"), variables()) + picks = picks(datasets("ADAE"), variables()) ) ) diff --git a/man/picks.Rd b/man/picks.Rd index 7e408852..eca13ef3 100644 --- a/man/picks.Rd +++ b/man/picks.Rd @@ -1,20 +1,22 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/0-picks.R -\name{picks} +% Please edit documentation in R/0-mae-methods.R, R/0-picks.R +\name{mae_data} +\alias{mae_data} \alias{picks} \alias{datasets} \alias{variables} \alias{values} -\alias{col_data} \title{Choices/selected settings} \usage{ +mae_data(choices = tidyselect::everything(), selected = 1L, multiple = FALSE) + picks(...) -datasets(choices = tidyselect::everything(), selected = 1, fixed = NULL, ...) +datasets(choices = tidyselect::everything(), selected = 1L, fixed = NULL, ...) variables( choices = tidyselect::everything(), - selected = 1, + selected = 1L, multiple = NULL, fixed = NULL, ordered = FALSE, @@ -22,37 +24,36 @@ variables( ) values( - choices = tidyselect::everything(), - selected = tidyselect::everything(), + choices = function(x) !is.na(x), + selected = function(x) !is.na(x), multiple = TRUE, fixed = NULL, ... ) - -col_data(choices = tidyselect::everything(), selected = 1, multiple = FALSE) } \arguments{ -\item{...}{additional arguments delivered to \code{pickerInput}} - -\item{choices}{(\code{\link[tidyselect:language]{tidyselect::language}} or \code{character}) +\item{choices}{(\code{tidyselect::language} or \code{character}) Available values to choose.} -\item{selected}{(\code{\link[tidyselect:language]{tidyselect::language}} or \code{character}) +\item{selected}{(\code{tidyselect::language} or \code{character}) Choices to be selected.} -\item{fixed}{(\code{logical(1)}) selection will be fixed and not possible to change interactively.} - \item{multiple}{(\code{logical(1)}) if more than one selection is possible.} +\item{...}{additional arguments delivered to \code{pickerInput}} + +\item{fixed}{(\code{logical(1)}) selection will be fixed and not possible to change interactively.} + \item{ordered}{(\code{logical(1)}) if the selected should follow the selection order. If \code{FALSE} \code{selected} returned from \code{srv_module_input()} would be ordered according to order in \code{choices}.} } \description{ -Define choices and default selection for variables. \code{picks} allows app-developer to specify -\code{datasets}, \code{variables} and \code{values} to be selected by app-user during Shiny session. -Functions are based on the idea of \code{choices/selected} where app-developer provides \code{choices} -and what is \code{selected} by default. App-user though changes \code{selected} interactively in -\code{\link{picks_module}} +Define choices and default selection for variables. `picks` allows app-developer to specify +`datasets`, `variables` and `values` to be selected by app-user during Shiny session. +Functions are based on the idea of `choices/selected` where app-developer provides `choices` +and what is `selected` by default. App-user though changes `selected` interactively in +[`picks_module`] +# todo: add note that values accepts predicates only } \section{\code{tidyselect} support}{ Both \code{choices} and \code{selected} parameters support \code{tidyselect} syntax, enabling dynamic diff --git a/man/picks_module.Rd b/man/picks_module.Rd index 12e59e9a..4791e6cf 100644 --- a/man/picks_module.Rd +++ b/man/picks_module.Rd @@ -10,25 +10,25 @@ \alias{picks_srv.picks} \title{Interactive picks} \usage{ -picks_ui(id, spec, container = "badge_dropdown") +picks_ui(id, picks, container = "badge_dropdown") -\method{picks_ui}{list}(id, spec, container = "badge_dropdown") +\method{picks_ui}{list}(id, picks, container) -\method{picks_ui}{picks}(id, spec, container = "badge_dropdown") +\method{picks_ui}{picks}(id, picks, container) -picks_srv(id = "", spec, data) +picks_srv(id = "", picks, data) -\method{picks_srv}{list}(id, spec, data) +\method{picks_srv}{list}(id, picks, data) -\method{picks_srv}{picks}(id, spec, data) +\method{picks_srv}{picks}(id, picks, data) } \arguments{ \item{id}{(\code{character(1)}) Shiny module ID} -\item{spec}{(\code{picks} or \code{list}) Specification object created by \code{picks()} or a named list of such objects} +\item{picks}{(\code{picks} or \code{list}) object created by \code{picks()} or a named list of such objects} -\item{container}{(\code{character(1)} or \code{function}) UI container type. Default is \code{"badge_dropdown"}. -Can also be one of \code{htmltools::tags} functions} +\item{container}{(\code{character(1)} or \code{function}) UI container type. Can be one of \code{htmltools::tags} +functions. By default, elements are wrapped in a package-specific dropdown.} \item{data}{(\code{reactive}) Reactive expression returning the data object to be used for populating choices} } @@ -45,22 +45,22 @@ Creates UI and server components for interactive \code{\link[=picks]{picks()}} i configuration provided via \code{\link[=picks]{picks()}} and its responsibility is to determine relevant input values -The module supports both single and combined specifications: +The module supports both single and combined \code{picks}: \itemize{ \item Single \code{picks} objects for a single input \item Named lists of \code{picks} objects for multiple inputs } } \details{ -The module uses S3 method dispatch to handle different types of specifications: +The module uses S3 method dispatch to handle different ways to provide \code{picks}: \itemize{ -\item \code{.picks} methods handle single specification -\item \code{.list} methods handle multiple specifications +\item \code{.picks} methods handle single `picks`` object +\item \code{.list} methods handle multiple \code{picks} objects } The UI component (\code{picks_ui}) creates the visual elements, while the server component (\code{picks_srv}) manages the reactive logic, } \seealso{ -\code{\link[=picks]{picks()}} for creating specification objects +\code{\link[=picks]{picks()}} for creating `picks`` objects } diff --git a/man/resolver.Rd b/man/resolver.Rd index e16a08b3..068c57ab 100644 --- a/man/resolver.Rd +++ b/man/resolver.Rd @@ -2,34 +2,31 @@ % Please edit documentation in R/0-resolver.R \name{resolver} \alias{resolver} -\title{Resolve the specification} +\title{Resolve \code{picks}} \usage{ resolver(x, data) } \arguments{ -\item{data}{The qenv where the specification is evaluated.} +\item{data}{(\code{\link[teal.data:teal_data]{teal.data::teal_data()}} \code{environment} or \code{list}) any data collection supporting object extraction with \code{[[}. +Used to determine values of unresolved \code{picks}.} -\item{spec}{A object extraction specification.} +\item{picks}{(\code{\link[=picks]{picks()}}) settings for picks.} } \value{ -A specification but resolved: the names and selection is the name of the objects (if possible). +resolved \code{picks}. } \description{ -Given the specification of some data to extract find if they are available or not. -The specification for selecting a variable shouldn't depend on the data of said variable. +Resolve iterates through each \code{picks} element and determines values . } \examples{ -dataset1 <- datasets(where(is.data.frame)) -dataset2 <- datasets(where(is.matrix)) -spec <- c(dataset1, variables("a", "a")) -td <- within(teal.data::teal_data(), { +# todo: fix example to use environment or a list +x1 <- datasets(where(is.data.frame)) +x2 <- picks(x1, variables("a", "a")) +data <- within(teal.data::teal_data(), { df <- data.frame(a = as.factor(LETTERS[1:5]), b = letters[1:5]) df2 <- data.frame(a = LETTERS[1:5], b = 1:5) m <- matrix() }) -resolver(list(spec, dataset2), td) -resolver(dataset2, td) -resolver(spec, td) -spec <- c(dataset1, variables("a", where(is.character))) -resolver(spec, td) +resolver(x = x1, data = data) +resolver(x = x2, data = data) } diff --git a/man/tm_merge.Rd b/man/tm_merge.Rd index 182e3655..ddf12cf6 100644 --- a/man/tm_merge.Rd +++ b/man/tm_merge.Rd @@ -4,8 +4,12 @@ \alias{tm_merge} \title{Merge module} \usage{ -tm_merge(label = "merge-module", inputs, transformators = list()) +tm_merge(label = "merge-module", picks, transformators = list()) +} +\arguments{ +\item{picks}{(\code{list} of \code{picks}) +Example module} } \description{ -Example module +Merge module } diff --git a/tests/testthat/test-0-module_picks.R b/tests/testthat/test-0-module_picks.R new file mode 100644 index 00000000..704cf0f0 --- /dev/null +++ b/tests/testthat/test-0-module_picks.R @@ -0,0 +1,682 @@ +testthat::describe("picks_srv accepts picks", { + it("as single picks object", { + test_data <- list(iris = iris, mtcars = mtcars) + test_picks <- picks(datasets(choices = c("iris", "mtcars"), selected = "iris")) + shiny::withReactiveDomain( + domain = shiny::MockShinySession$new(), + expr = testthat::expect_no_error( + picks_srv(id = "test", picks = test_picks, data = shiny::reactive(test_data)) + ) + ) + }) + + it("as list of picks objects", { + test_data <- list(iris = iris, mtcars = mtcars) + test_picks_list <- list( + pick1 = picks(datasets(choices = c("iris", "mtcars"), selected = "iris")), + pick2 = picks(datasets(choices = c("iris", "mtcars"), selected = "mtcars")) + ) + shiny::withReactiveDomain( + domain = shiny::MockShinySession$new(), + expr = testthat::expect_no_error( + picks_srv(id = "test", picks = test_picks_list, data = shiny::reactive(test_data)) + ) + ) + }) + + it("accepts empty list", { + test_data <- list(iris = iris) + shiny::withReactiveDomain( + domain = shiny::MockShinySession$new(), + expr = testthat::expect_no_error( + picks_srv(id = "test", picks = list(), data = shiny::reactive(test_data)) + ) + ) + }) + + it("doesn't accept list of non-picks", { + test_data <- list(iris = iris) + shiny::withReactiveDomain( + domain = shiny::MockShinySession$new(), + expr = testthat::expect_error( + picks_srv(id = "test", picks = list(a = 1, b = 2), data = shiny::reactive(test_data)) + ) + ) + }) + + it("doesn't accept NULL picks", { + test_data <- list(iris = iris) + + shiny::withReactiveDomain( + domain = shiny::MockShinySession$new(), + expr = testthat::expect_error( + picks_srv(id = "test", picks = NULL, data = shiny::reactive(test_data)) + ) + ) + }) + + it("doesn't accept unnamed list of picks", { + test_picks_list <- list( + picks(datasets(choices = "iris")), + picks(datasets(choices = "iris")) + ) + + shiny::withReactiveDomain( + domain = shiny::MockShinySession$new(), + expr = testthat::expect_error( + picks_srv(id = "test", picks = test_picks_list, data = shiny::reactive(test_data)) + ) + ) + }) + + it("doesn't accept list of picks with duplicated names", { + test_picks_list <- list( + a = picks(datasets(choices = "iris")), + a = picks(datasets(choices = "iris")) + ) + + shiny::withReactiveDomain( + domain = shiny::MockShinySession$new(), + expr = testthat::expect_error( + picks_srv(id = "test", picks = test_picks_list, data = shiny::reactive(test_data)) + ) + ) + }) +}) + +testthat::describe("picks_srv accepts data", { + it("as reactive (named) list", { + test_data <- list(iris = iris) + test_picks <- picks(datasets(choices = "iris")) + + shiny::withReactiveDomain( + domain = shiny::MockShinySession$new(), + expr = testthat::expect_no_error( + picks_srv(id = "test", picks = test_picks, data = shiny::reactive(test_data)) + ) + ) + }) + + it("as reactive environment", { + test_data <- list2env(list(iris = iris)) + test_picks <- picks(datasets(choices = "iris")) + + shiny::withReactiveDomain( + domain = shiny::MockShinySession$new(), + expr = testthat::expect_no_error( + picks_srv(id = "test", picks = test_picks, data = shiny::reactive(test_data)) + ) + ) + }) + + it("doesn't accept non-reactive list/environment/teal_data", { + test_picks <- picks(datasets(choices = "iris")) + + shiny::withReactiveDomain( + domain = shiny::MockShinySession$new(), + expr = { + testthat::expect_error( + picks_srv(id = "test", picks = test_picks, data = iris), + "reactive" + ) + testthat::expect_error( + picks_srv(id = "test", picks = test_picks, data = list(iris = iris)), + "reactive" + ) + testthat::expect_error( + picks_srv(id = "test", picks = test_picks, data = teal.data::teal_data(iris = iris)), + "reactive" + ) + } + ) + }) + + it("doesn't accept reactive non-named-list or non-environment", { + test_picks <- picks(datasets(choices = "iris")) + + shiny::withReactiveDomain( + domain = shiny::MockShinySession$new(), + expr = { + testthat::expect_error( + picks_srv(id = "test", picks = test_picks, data = reactive(iris)) + ) + testthat::expect_error( + picks_srv(id = "test", picks = test_picks, data = reactive(letters)) + ) + testthat::expect_error( + picks_srv(id = "test", picks = test_picks, data = reactive(list(iris))) + ) + } + ) + }) +}) + +testthat::describe("picks_srv return a named list of reactive picks", { + testthat::it("each list element is reactiveVal", { + test_picks_list <- list( + pick1 = picks(datasets(choices = c("iris", "mtcars"), selected = "iris")), + pick2 = picks(datasets(choices = c("iris", "mtcars"), selected = "mtcars")) + ) + shiny::withReactiveDomain( + domain = shiny::MockShinySession$new(), + expr = checkmate::expect_list( + picks_srv(id = "test", picks = test_picks_list, data = shiny::reactive(list(iris = iris, mtcars = mtcars))), + types = "reactiveVal", + names = "unique" + ) + ) + }) + + testthat::it("list is named as pick argument", { + test_picks_list <- list( + pick1 = picks(datasets(choices = c("iris", "mtcars"), selected = "iris")), + pick2 = picks(datasets(choices = c("iris", "mtcars"), selected = "mtcars")) + ) + shiny::withReactiveDomain( + domain = shiny::MockShinySession$new(), + expr = testthat::expect_named( + picks_srv(id = "test", picks = test_picks_list, data = shiny::reactive(list(iris = iris, mtcars = mtcars))), + c("pick1", "pick2") + ) + ) + }) + + testthat::it("each list element is reactiveVal containing picks", { + test_picks_list <- list( + pick1 = picks(datasets(choices = c("iris", "mtcars"), selected = "iris")), + pick2 = picks(datasets(choices = c("iris", "mtcars"), selected = "mtcars")) + ) + shiny::withReactiveDomain( + domain = shiny::MockShinySession$new(), + expr = { + out <- picks_srv( + id = "test", picks = test_picks_list, data = shiny::reactive(list(iris = iris, mtcars = mtcars)) + ) + checkmate::expect_list(out, "reactiveVal") + lapply(out, function(x) checkmate::assert_class(shiny::isolate(x()), "picks")) + } + ) + }) +}) + +testthat::describe("picks_srv resolves datasets", { + it("provided non-delayed datasets are adjusted to possible datanames", { + test_picks <- picks( + datasets(choices = c(mtcars = "mtcars", notexisting = "notexisting"), selected = "mtcars") + ) + shiny::testServer( + picks_srv, + args = list(id = "test", picks = test_picks, data = shiny::reactive(list(mtcars = mtcars))), + expr = { + test_picks$datasets$choices <- c(mtcars = "mtcars") + testthat::expect_identical(picks_resolved(), test_picks) + } + ) + }) + + it("datasets() are resolved on init", { + test_picks <- picks( + datasets(choices = tidyselect::everything(), selected = tidyselect::last_col()) + ) + shiny::testServer( + picks_srv, + args = list(id = "id", picks = test_picks, data = shiny::reactive(list(iris = iris, mtcars = mtcars, a = "a"))), + expr = { + testthat::expect_identical( + picks_resolved(), + picks( + datasets(choices = c(iris = "iris", mtcars = "mtcars", a = "a"), selected = "a") + ) + ) + } + ) + }) + + it("datasets() are resolved on init", { + # tidyselect::where is based on the columns values - unlike other functions which utilized column-names vector + test_picks <- picks(datasets(choices = is.data.frame, selected = 1L)) + shiny::testServer( + picks_srv, + args = list(id = "id", picks = test_picks, data = shiny::reactive(list(iris = iris, mtcars = mtcars, a = "a"))), + expr = { + testthat::expect_identical( + picks_resolved(), + picks( + datasets(choices = c(iris = "iris", mtcars = "mtcars"), selected = "iris") + ) + ) + } + ) + }) +}) + +testthat::describe("picks_srv resolves variables", { + it("variables() are adjusted to possible column names", { + test_picks <- picks( + datasets(choices = c(mtcars = "mtcars"), selected = "mtcars"), + variables(choices = c(mpg = "mpg", cyl = "cyl", inexisting = "inexisting"), selected = c("mpg", "inexisting")) + ) + shiny::testServer( + picks_srv, + args = list(id = "test", picks = test_picks, data = shiny::reactive(list(mtcars = mtcars))), + expr = { + test_picks$variables$choices <- c(mpg = "mpg", cyl = "cyl") + test_picks$variables$selected <- "mpg" + testthat::expect_identical(picks_resolved(), test_picks) + } + ) + }) + + it("variables() are resolved on init", { + test_picks <- picks( + datasets(choices = "mtcars", selected = "mtcars"), + variables(choices = tidyselect::everything(), selected = 1L) + ) + shiny::testServer( + picks_srv, + args = list(id = "test", picks = test_picks, data = shiny::reactive(list(iris = iris, mtcars = mtcars))), + expr = { + testthat::expect_identical( + picks_resolved(), + picks( + datasets(choices = c(mtcars = "mtcars"), selected = "mtcars"), + variables(choices = setNames(colnames(mtcars), colnames(mtcars)), selected = "mpg") + ) + ) + } + ) + }) + + it("variables() are resolved on init", { + # tidyselect::where is based on the columns values - unlike other functions which utilized column-names vector + test_picks <- picks( + datasets(choices = "mtcars", selected = "mtcars"), + variables(choices = function(x) mean(x) > 20, selected = 1L) + ) + shiny::testServer( + picks_srv, + args = list(id = "test", picks = test_picks, data = shiny::reactive(list(iris = iris, mtcars = mtcars))), + expr = { + testthat::expect_identical( + picks_resolved(), + picks( + datasets(choices = c(mtcars = "mtcars"), selected = "mtcars"), + variables(choices = c(mpg = "mpg", disp = "disp", hp = "hp"), selected = "mpg") + ) + ) + } + ) + }) + + it("variables() are nullified with warning when selected dataset has no columns", { + # tidyselect::where is based on the columns values - unlike other functions which utilized column-names vector + test_picks <- picks( + datasets(choices = c(test = "test"), selected = "test"), + variables(choices = "doesn't matter", selected = "doesn't matter") + ) + testthat::expect_warning( + shiny::testServer( + picks_srv, + args = list(id = "test", picks = test_picks, data = shiny::reactive(list(test = data.frame()))), + expr = { + test_picks$variables$choices <- NULL + test_picks$variables$selected <- NULL + testthat::expect_identical(picks_resolved(), test_picks) + } + ), + "Selected dataset has no columns" + ) + }) +}) + +testthat::describe("picks_srv resolves values", { + it("values() are resolved on init", { + test_picks <- picks( + datasets(choices = "mtcars", selected = "mtcars"), + variables(choices = "mpg", selected = "mpg"), + values(choices = function(x) x > 20) + ) + shiny::testServer( + picks_srv, + args = list(id = "test", picks = test_picks, data = shiny::reactive(list(iris = iris, mtcars = mtcars))), + expr = { + testthat::expect_identical( + picks_resolved(), + picks( + datasets(choices = c(mtcars = "mtcars"), selected = "mtcars"), + variables(choices = c(mpg = "mpg"), selected = "mpg"), + values( + choices = range(mtcars$mpg[mtcars$mpg > 20]), + selected = range(mtcars$mpg[mtcars$mpg > 20]) + ) + ) + ) + } + ) + }) + + it("values() are adjusted to possible levels", { + test_picks <- picks( + datasets(choices = c(iris = "iris"), selected = "iris"), + variables(choices = c(Species = "Species"), selected = "Species"), + values( + choices = c(setosa = "setosa", versicolor = "versicolor", inexisting = "inexisting"), + selected = c("setosa", "versicolor", "inexisting") + ) + ) + shiny::testServer( + picks_srv, + args = list(id = "test", picks = test_picks, data = shiny::reactive(list(iris = iris))), + expr = { + test_picks$values$choices <- c(setosa = "setosa", versicolor = "versicolor") + test_picks$values$selected <- c("setosa", "versicolor") + testthat::expect_identical(picks_resolved(), test_picks) + } + ) + }) + + it("values() are adjusted to possible range", { + test_picks <- picks( + datasets(choices = c(iris = "iris"), selected = "iris"), + variables(choices = c(Sepal.Length = "Sepal.Length"), selected = "Sepal.Length"), + values( + choices = c(min(iris$Sepal.Length) - 1, max(iris$Sepal.Length) + 1), + selected = c(min(iris$Sepal.Length) - 1, max(iris$Sepal.Length) + 1) + ) + ) + shiny::testServer( + picks_srv, + args = list(id = "test", picks = test_picks, data = shiny::reactive(list(iris = iris))), + expr = { + test_picks$values$choices <- range(iris$Sepal.Length) + test_picks$values$selected <- range(iris$Sepal.Length) + testthat::expect_identical(picks_resolved(), test_picks) + } + ) + }) + + it("values() are preserved when related data lacks finite values", { + test_picks <- picks( + datasets(choices = c(iris = "iris"), selected = "iris"), + variables(choices = c(Sepal.Length = "Sepal.Length"), selected = "Sepal.Length"), + values(choices = c(1, 10), selected = c(1, 10)) + ) + iris$Sepal.Length <- NA_real_ + shiny::testServer( + picks_srv, + args = list(id = "id", picks = test_picks, data = shiny::reactive(list(iris = iris))), + expr = { + testthat::expect_identical(picks_resolved(), test_picks) + } + ) + }) + + it("values() are emptied (with warning) when data returns infinite", { + test_picks <- picks( + datasets(choices = c(iris = "iris"), selected = "iris"), + variables(choices = c(Sepal.Length = "Sepal.Length"), selected = "Sepal.Length"), + values(function(x) !is.finite(x)) + ) + iris$Sepal.Length[1] <- Inf + + testthat::expect_warning( + shiny::testServer( + picks_srv, + args = list(id = "id", picks = test_picks, data = shiny::reactive(list(iris = iris))), + expr = { + test_picks$values$choices <- NULL + test_picks$values$selected <- NULL + testthat::expect_identical(picks_resolved(), test_picks) + } + ), + "Emptying choices..." + ) + }) + + it("values() are set to delayed range when data-range returns infinite", { + test_picks <- picks( + datasets(choices = c(iris = "iris"), selected = "iris"), + variables(choices = c(Sepal.Length = "Sepal.Length"), selected = "Sepal.Length"), + values(function(x) is.finite(x)) + ) + iris$Sepal.Length[1] <- Inf + shiny::testServer( + picks_srv, + args = list(id = "id", picks = test_picks, data = shiny::reactive(list(iris = iris))), + expr = { + test_picks$values$choices <- range(iris$Sepal.Length[-1]) + test_picks$values$selected <- range(iris$Sepal.Length[-1]) + testthat::expect_identical(picks_resolved(), test_picks) + } + ) + }) + + it("values() are set to data-range when predicate doesn't match anything", { + test_picks <- picks( + datasets(choices = c(iris = "iris"), selected = "iris"), + variables(choices = c(Sepal.Length = "Sepal.Length"), selected = "Sepal.Length"), + values(function(x) FALSE) + ) + shiny::testServer( + picks_srv, + args = list(id = "id", picks = test_picks, data = shiny::reactive(list(iris = iris))), + expr = { + test_picks$values$choices <- range(iris$Sepal.Length) + test_picks$values$selected <- range(iris$Sepal.Length) + testthat::expect_identical(picks_resolved(), test_picks) + } + ) + }) + + it("values() are set to data-range when column is numeric", { + test_picks <- picks( + datasets(choices = c(iris = "iris"), selected = "iris"), + variables(choices = c(Sepal.Length = "Sepal.Length"), selected = "Sepal.Length"), + values(c("5.1", "4.9")) + ) + shiny::testServer( + picks_srv, + args = list(id = "id", picks = test_picks, data = shiny::reactive(list(iris = iris))), + expr = { + test_picks$values$choices <- range(iris$Sepal.Length) + test_picks$values$selected <- range(iris$Sepal.Length) + testthat::expect_identical(picks_resolved(), test_picks) + } + ) + }) + + it("values() are emptied with warning when column is not numeric", { + test_picks <- picks( + datasets(choices = c(iris = "iris"), selected = "iris"), + variables(choices = c(Species = "Species"), selected = "Species"), + values(choices = c(1, 10), selected = c(1, 10)) + ) + + testthat::expect_warning( + shiny::testServer( + picks_srv, + args = list(id = "id", picks = test_picks, data = shiny::reactive(list(iris = iris))), + expr = { + test_picks$values$choices <- NULL + test_picks$values$selected <- NULL + testthat::expect_identical(picks_resolved(), test_picks) + } + ) + ) + }) + + it("values() on multiple columns are resolved to be concatenated choices", { + test_picks <- picks( + datasets(choices = c(mtcars = "mtcars"), selected = "mtcars"), + variables(choices = c(vs = "mpg", cyl = "cyl"), selected = c("mpg", "cyl")), + values() + ) + shiny::testServer( + picks_srv, + args = list(id = "id", picks = test_picks, data = shiny::reactive(list(mtcars = mtcars))), + expr = { + test_picks$values$choices <- unique(paste(mtcars$mpg, mtcars$cyl, sep = ", ")) + test_picks$values$selected <- unique(paste(mtcars$mpg, mtcars$cyl, sep = ", ")) + testthat::expect_identical(picks_resolved(), test_picks) + } + ) + }) +}) + +testthat::describe("picks_srv resolves picks", { + it("non-delayed-picks are returned unchanged", { + test_picks <- picks( + datasets(choices = c(mtcars = "mtcars"), selected = "mtcars"), + variables(choices = setNames(colnames(mtcars), colnames(mtcars)), selected = "mpg") + ) + shiny::testServer( + picks_srv, + args = list(id = "test", picks = test_picks, data = shiny::reactive(list(mtcars = mtcars))), + expr = { + testthat::expect_identical(picks_resolved(), test_picks) + } + ) + }) + + it("named non-delayed-picks preserve names", { + test_picks <- picks( + datasets(choices = c(dataset = "iris"), selected = "iris"), + variables(choices = setNames(colnames(iris), letters[1:5]), selected = "Species") + ) + shiny::testServer( + picks_srv, + args = list(id = "test", picks = test_picks, data = shiny::reactive(list(iris = iris))), + expr = { + testthat::expect_identical(picks_resolved(), test_picks) + } + ) + }) + + it("non-delayed-picks with values are returned unchanged if within a possible choices", { + test_picks <- picks( + datasets(choices = c(mtcars = "mtcars"), selected = "mtcars"), + variables(choices = setNames(colnames(mtcars), colnames(mtcars)), selected = "mpg"), + values(choices = c(10.4, 33.9), selected = c(10.4, 33.9)) + ) + shiny::testServer( + picks_srv, + args = list(id = "test", picks = test_picks, data = shiny::reactive(list(mtcars = mtcars))), + expr = { + testthat::expect_identical(picks_resolved(), test_picks) + } + ) + }) + + it("pick elements are resolved sequentially", { + test_picks <- picks( + datasets(choices = tidyselect::where(is.data.frame), selected = 1L), + variables(choices = tidyselect::everything(), selected = 1L), + values(choices = function(x) x > 5) + ) + shiny::testServer( + picks_srv, + args = list(id = "id", picks = test_picks, data = shiny::reactive(list(iris = iris, mtcars = mtcars))), + expr = { + suppressWarnings( + picks_expected <- picks( + datasets(choices = c(iris = "iris", mtcars = "mtcars"), selected = "iris"), + variables(choices = setNames(colnames(iris), colnames(iris)), selected = "Sepal.Length"), + values( + choices = range(iris$Sepal.Length[iris$Sepal.Length > 5]), + selected = range(iris$Sepal.Length[iris$Sepal.Length > 5]) + ) + ) + ) + testthat::expect_identical(picks_resolved(), picks_expected) + } + ) + }) + + it("pick elements are nullified if $selected=NULL", { + test_picks <- picks( + datasets(choices = c(iris = "iris"), selected = "iris"), + variables(choices = setNames(colnames(iris), colnames(iris)), selected = NULL), + values(choices = function(x) x > 5) + ) + shiny::testServer( + picks_srv, + args = list(id = "id", picks = test_picks, data = shiny::reactive(list(iris = iris, mtcars = mtcars))), + expr = { + test_picks$variables$selected <- NULL + test_picks$values$choices <- NULL + test_picks$values$selected <- NULL + testthat::expect_identical(picks_resolved(), test_picks) + } + ) + }) + + it("picks with multiple=FALSE defaults to single value even if multiple values provided", { + test_picks <- picks( + datasets(choices = c(iris = "iris"), selected = "iris"), + variables(choices = setNames(colnames(iris), colnames(iris)), selected = colnames(iris), multiple = FALSE) + ) + testthat::expect_warning( + shiny::testServer( + picks_srv, + args = list(id = "id", picks = test_picks, data = shiny::reactive(list(iris = iris))), + expr = { + test_picks$variables$selected <- test_picks$variables$selected[1] + testthat::expect_identical(picks_resolved(), test_picks) + } + ), + "`multiple` has been set to `FALSE`" + ) + }) +}) + + +testthat::describe("picks_srv resolves picks interactively", { + it("change of dataset-input resolves variables", { + test_picks <- picks( + datasets(choices = c(mtcars = "mtcars", iris = "iris"), selected = "mtcars"), + variables(choices = tidyselect::everything(), selected = 1L) + ) + shiny::testServer( + picks_srv, + args = list(id = "test", picks = test_picks, data = shiny::reactive(list(mtcars = mtcars, iris = iris))), + expr = { + session$setInputs(`datasets-selected` = "iris") + session$setInputs(`datasets-selected_open` = FALSE) # close dropdown to trigger + test_picks$datasets$selected <- "iris" + test_picks$variables$choices <- setNames(colnames(iris), colnames(iris)) + test_picks$variables$selected <- "Sepal.Length" + testthat::expect_identical(picks_resolved(), test_picks) + } + ) + }) + + it("current datasets-choices/selected are produced in picker inputs", { + test_picks <- picks( + datasets(choices = c("mtcars", "iris"), selected = "iris") + ) + shiny::testServer( + picks_srv, + args = list(id = "test", picks = test_picks, data = shiny::reactive(list(mtcars = mtcars, iris = iris))), + expr = { + html <- rvest::read_html(as.character(session$output[["datasets-selected_container"]]$html)) + choices_value <- rvest::html_attr(rvest::html_nodes(html, "option"), "value") + selected_value <- rvest::html_attr(rvest::html_nodes(html, "option[selected='selected']"), "value") + testthat::expect_identical(choices_value, c("mtcars", "iris")) + testthat::expect_identical(selected_value, "iris") + } + ) + }) + + + it("custom label is displayed in a picker input", { + }) + + it("switching dataset-input changes variables-input", { + }) + + it("changing picks_resolved changes picker input", { + }) + + it("changing data changes picker input", { + }) +}) diff --git a/tests/testthat/test-0-picks.R b/tests/testthat/test-0-picks.R index 583532fd..253a2765 100644 --- a/tests/testthat/test-0-picks.R +++ b/tests/testthat/test-0-picks.R @@ -1,34 +1,3 @@ -testthat::describe("picks() basic structure", { - it("returns an object of class 'picks' and 'list'", { - result <- picks(datasets()) - testthat::expect_s3_class(result, "picks") - testthat::expect_type(result, "list") - }) - - it("creates a picks object with single datasets element", { - result <- picks(datasets()) - testthat::expect_length(result, 1) - testthat::expect_named(result, "datasets") - }) - - it("creates a picks object with datasets and variables", { - result <- picks(datasets(), variables()) - testthat::expect_length(result, 2) - testthat::expect_named(result, c("datasets", "variables")) - }) - - it("creates a picks object with datasets, variables and values", { - result <- picks(datasets(), variables(), values()) - testthat::expect_length(result, 3) - testthat::expect_named(result, c("datasets", "variables", "values")) - }) - - it("ignores trailing empty arguments", { - result <- picks(datasets(), variables()) - testthat::expect_length(result, 2) - }) -}) - testthat::describe("picks() assertions", { it("fails when first element is not datasets", { testthat::expect_error(picks(variables()), "datasets") @@ -76,47 +45,60 @@ testthat::describe("picks() assertions", { picks(datasets(), variables()) ) }) -}) -testthat::describe("picks() output is named:", { - it("names elements by their class", { - result <- picks(datasets(), variables()) - testthat::expect_named(result, c("datasets", "variables")) + it("warns when element with dynamic choices is followed by element with eager choices", { + testthat::expect_warning( + picks( + datasets(c("iris", "mtcars")), + variables(c("Species")) + ), + "eager" + ) }) }) -testthat::describe("picks() element access", { - it("allows accessing datasets element", { +testthat::describe("picks() basic structure", { + it("returns an object of class 'picks' and 'list'", { + result <- picks(datasets()) + testthat::expect_s3_class(result, "picks") + testthat::expect_type(result, "list") + }) + + it("creates a picks object with single datasets element", { result <- picks(datasets()) - testthat::expect_s3_class(result$datasets, "datasets") + checkmate::expect_list(result, len = 1, types = "datasets") }) - it("allows accessing variables element", { + it("creates a picks object with datasets and variables", { result <- picks(datasets(), variables()) - testthat::expect_s3_class(result$variables, "variables") + checkmate::expect_list(result, len = 2, types = c("datasets", "variables")) + testthat::expect_named(result, c("datasets", "variables")) }) - it("allows accessing values element", { + it("creates a picks object with datasets, variables and values", { result <- picks(datasets(), variables(), values()) - testthat::expect_s3_class(result$values, "values") + checkmate::expect_list(result, len = 3, types = c("datasets", "variables", "values")) + testthat::expect_named(result, c("datasets", "variables", "values")) }) - it("preserves element attributes", { - result <- picks(datasets(), variables(multiple = TRUE, ordered = TRUE)) - testthat::expect_true(attr(result$variables, "multiple")) - testthat::expect_true(attr(result$variables, "ordered")) + it("ignores trailing empty arguments", { + result <- picks(datasets(), variables(), ) + checkmate::expect_list(result, len = 2, types = c("datasets", "variables")) }) }) testthat::describe("datasets() basic asserts:", { - it("datasets(choices) argument accepts character, integer and tidyselect", { + it("datasets(choices) argument accepts character, integer, predicate function and tidyselect", { testthat::expect_no_error(datasets(choices = "test")) - testthat::expect_no_error(datasets(choices = 1)) + testthat::expect_no_error(datasets(choices = 1L)) testthat::expect_no_error(datasets(choices = tidyselect::everything())) testthat::expect_no_error(datasets(choices = tidyselect::where(is.data.frame))) testthat::expect_no_error(datasets(choices = c(test:test, test))) testthat::expect_no_error(datasets(choices = tidyselect::starts_with("Petal") | tidyselect::ends_with("Width"))) testthat::expect_no_error(datasets(choices = tidyselect::all_of(c("test", "test2")))) + testthat::expect_error(datasets(choices = c(1.2))) # double + testthat::expect_error(datasets(choices = c(1.0))) # integerish + testthat::expect_error(datasets(choices = as.Date(1))) # Date }) it("datasets(choices) can't be empty", { @@ -125,29 +107,22 @@ testthat::describe("datasets() basic asserts:", { testthat::expect_error(datasets(choices = list())) }) - it("datasets(selected) can't be empty", { - testthat::expect_error(datasets(selected = character(0))) - testthat::expect_error(datasets(selected = NULL)) - testthat::expect_error(datasets(selected = list())) - }) - - it("datasets(selected) argument character, integer and tidyselect", { - testthat::expect_no_error(datasets(selected = 1)) + it("datasets(selected) argument character(1), integer(1), predicate and tidyselect or empty", { + testthat::expect_no_error(datasets(selected = 1L)) testthat::expect_no_error(datasets(selected = tidyselect::everything())) - testthat::expect_error(datasets(selected = NULL)) - }) - - it("fails when length(selected) > 1", { + testthat::expect_no_error(datasets(selected = function(x) TRUE)) + testthat::expect_no_error(datasets(selected = NULL)) testthat::expect_error(datasets(choices = c("iris", "mtcars"), selected = c("iris", "mtcars"))) }) + it("datasets(selected) must be a subset of choices", { testthat::expect_error(datasets(choices = c("a", "b"), selected = "c"), "subset of `choices`") }) it("datasets(selected) warns if choices are delayed and selected eager", { testthat::expect_warning(datasets(choices = tidyselect::everything(), selected = "c"), "subset of `choices`") - testthat::expect_warning(datasets(choices = 1, selected = "c"), "subset of `choices`") + testthat::expect_warning(datasets(choices = 1L, selected = "c"), "subset of `choices`") }) }) @@ -179,10 +154,10 @@ testthat::describe("datasets() returns datasets", { testthat::expect_equal(result$selected, "mtcars") }) - it("stores numeric selected value as quosure", { - result <- datasets(choices = c("iris", "mtcars"), selected = 2) + it("stores integer selected value as quosure", { + result <- datasets(choices = c("iris", "mtcars"), selected = 2L) testthat::expect_s3_class(result$selected, "quosure") - testthat::expect_equal(rlang::quo_get_expr(result$selected), 2) + testthat::expect_equal(rlang::quo_get_expr(result$selected), 2L) }) it("sets fixed to TRUE when single choice", { @@ -196,9 +171,9 @@ testthat::describe("datasets() returns quosures for delayed evaluation", { testthat::expect_s3_class(result$choices, "quosure") }) - it("stores tidyselect::where() as a quosure in $choices", { + it("stores tidyselect::where() as a predicate function in $choices", { result <- datasets(choices = tidyselect::where(is.data.frame)) - testthat::expect_s3_class(result$choices, "quosure") + testthat::expect_true(is.function(result$choices)) }) it("stores symbol range (a:b) as a quosure in $choices", { @@ -207,7 +182,7 @@ testthat::describe("datasets() returns quosures for delayed evaluation", { }) it("stores numeric range (1:5) as a quosure in $choices", { - result <- datasets(choices = 1:5) + result <- datasets(choices = seq(1, 5)) testthat::expect_s3_class(result$choices, "quosure") }) @@ -280,7 +255,7 @@ testthat::describe("datasets() validation and warnings", { it("does not warn when selected is numeric and choices are delayed", { testthat::expect_no_warning( - datasets(choices = tidyselect::everything(), selected = 1) + datasets(choices = tidyselect::everything(), selected = 1L) ) }) @@ -406,12 +381,12 @@ testthat::describe("variables() allow-clear attribute", { }) it("sets allow-clear to FALSE for single numeric selected", { - result <- variables(choices = c("a", "b", "c"), selected = 1) + result <- variables(choices = c("a", "b", "c"), selected = 1L) testthat::expect_false(attr(result, "allow-clear")) }) it("sets allow-clear to FALSE for multiple numeric selected (tidyselect)", { - result <- variables(choices = c("a", "b", "c"), selected = c(1, 2)) + result <- variables(choices = c("a", "b", "c"), selected = c(1L, 2L)) testthat::expect_false(attr(result, "allow-clear")) }) }) @@ -459,3 +434,49 @@ testthat::describe("variables() attribute interactions", { testthat::expect_true(attr(result, "allow-clear")) }) }) + +testthat::describe("values() assertions", { + it("values() succeeds by default", { + testthat::expect_no_error(values()) + }) + + it("values(choices) accepts predicate functions, character, numeric(2), date(2) and posixct(2). No tidyselect", { + testthat::expect_no_error(values(choices = "test")) + testthat::expect_no_error(values(choices = c("test", "test2"))) + testthat::expect_error(values(choices = c("test", "test"))) + testthat::expect_no_error(values(choices = c(1, 2))) + testthat::expect_error(values(choices = 1)) + testthat::expect_error(values(choices = c(1, 2, 3))) + testthat::expect_error(values(choices = c(-Inf, Inf))) + testthat::expect_no_error(values(choices = as.Date(1:2))) + testthat::expect_error(values(choices = as.Date(1))) + testthat::expect_error(values(choices = as.Date(1:3))) + testthat::expect_no_error(values(choices = as.POSIXct(1:2))) + testthat::expect_error(values(choices = as.POSIXct(1))) + testthat::expect_error(values(choices = as.POSIXct(1:3))) + testthat::expect_no_error(values(choices = tidyselect::where(~ .x > 1))) # this is predicate, not tidyselect + testthat::expect_no_error(values(choices = function(x) !is.na(x))) + testthat::expect_no_error(values(choices = function(x, ...) !is.na(x))) + testthat::expect_error(values(choices = function(x, y, ...) x > y)) + testthat::expect_error(values(choices = tidyselect::everything())) + testthat::expect_error(values(choices = c(test:test, test))) + }) +}) + +testthat::describe("values() attributes", { + it("multiple set to TRUE by default", { + testthat::expect_true(attr(values(), "multiple")) + }) + + it("fixed=TRUE when single choice is provided", { + testthat::expect_true(attr(values(choices = "test"), "fixed")) + }) + + it("fixed=FALSE when choices is a predicate", { + testthat::expect_false(attr(values(choices = function(x) TRUE), "fixed")) + }) + + it("fixed=FALSE when choices length > 1", { + testthat::expect_false(attr(values(choices = c("test", "test2")), "fixed")) + }) +}) diff --git a/tests/testthat/test-0-print.R b/tests/testthat/test-0-print.R index 19935d9c..1f375fac 100644 --- a/tests/testthat/test-0-print.R +++ b/tests/testthat/test-0-print.R @@ -6,7 +6,7 @@ testthat::describe("format.type() for datasets", { }) it("formats datasets with tidyselect choices by printing matched call's argument", { - ds <- datasets(choices = tidyselect::everything(), selected = 1) + ds <- datasets(choices = tidyselect::everything(), selected = 1L) result <- format(ds) testthat::expect_match(result, "") testthat::expect_match(result, "choices:.*everything\\(\\)") @@ -42,10 +42,28 @@ testthat::describe("format.picks() for picks collection", { it("formats picks with datasets, variables and values by showing them all explicitly", { p <- picks( datasets(choices = "iris", selected = "iris"), - variables(choices = c("a", "b"), selected = "a", multiple = FALSE), + variables(choices = "a", selected = "a", multiple = FALSE), values(choices = c("1", "2"), selected = "1", multiple = FALSE) ) - expected <- " \033[1m\033[0m\n \033[1m\033[0m:\n choices: iris\n selected: iris\n \033[3mmultiple=FALSE, ordered=FALSE, fixed=TRUE\033[0m\n \033[1m\033[0m:\n choices: a, b\n selected: a\n \033[3mmultiple=FALSE, ordered=FALSE, fixed=FALSE, allow-clear=FALSE\033[0m\n \033[1m\033[0m:\n choices: 1, 2\n selected: 1\n \033[3mmultiple=FALSE, ordered=FALSE, fixed=FALSE\033[0m\n" + expected <- paste( + c( + " \033[1m\033[0m", + " \033[1m\033[0m:", + " choices: iris", + " selected: iris", + " \033[3mmultiple=FALSE, ordered=FALSE, fixed=TRUE\033[0m", + " \033[1m\033[0m:", + " choices: a", + " selected: a", + " \033[3mmultiple=FALSE, ordered=FALSE, fixed=TRUE, allow-clear=FALSE\033[0m", + " \033[1m\033[0m:", + " choices: 1, 2", + " selected: 1", + " \033[3mmultiple=FALSE, ordered=FALSE, fixed=FALSE\033[0m\n" + ), + collapse = "\n" + ) + testthat::expect_identical(format(p), expected) }) }) From c3f8e424abfe1e0e7bf3d59fe61efb7f4bf11d99 Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Wed, 29 Oct 2025 15:08:31 +0100 Subject: [PATCH 138/142] WIP --- DESCRIPTION | 1 + NAMESPACE | 6 +- R/0-as_picks.R | 235 +++++++ R/0-call_utils.R | 168 +---- R/0-datanames.R | 76 --- R/0-mae-methods.R | 2 +- R/0-module_merge.R | 83 ++- R/0-module_picks.R | 30 +- R/0-picks.R | 59 +- R/0-resolver.R | 16 +- R/0-tidyselect-helpers.R | 12 +- R/0-to_picks.R | 54 -- inst/refactor-notes.md | 142 ++++ man/as.picks.Rd | 89 +++ man/call_extract_array.Rd | 27 - man/call_extract_list.Rd | 22 - man/call_extract_matrix.Rd | 24 - man/call_with_colon.Rd | 24 - man/datanames.Rd | 77 --- man/dot-check_merge_keys.Rd | 26 - man/dot-is.delayed.Rd | 21 + man/dot-validate_join_keys.Rd | 23 + tests/testthat/test-0-as_picks.R | 51 ++ tests/testthat/test-0-module_merge.R | 981 +++++++++++++++++++++++++++ tests/testthat/test-0-module_picks.R | 388 ++++++++++- 25 files changed, 2075 insertions(+), 562 deletions(-) create mode 100644 R/0-as_picks.R delete mode 100644 R/0-datanames.R delete mode 100644 R/0-to_picks.R create mode 100644 man/as.picks.Rd delete mode 100644 man/call_extract_array.Rd delete mode 100644 man/call_extract_list.Rd delete mode 100644 man/call_extract_matrix.Rd delete mode 100644 man/call_with_colon.Rd delete mode 100644 man/datanames.Rd delete mode 100644 man/dot-check_merge_keys.Rd create mode 100644 man/dot-is.delayed.Rd create mode 100644 man/dot-validate_join_keys.Rd create mode 100644 tests/testthat/test-0-as_picks.R create mode 100644 tests/testthat/test-0-module_merge.R diff --git a/DESCRIPTION b/DESCRIPTION index f1f60a1d..892567fe 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -31,6 +31,7 @@ Imports: shinyjs (>= 2.1.0), shinyvalidate (>= 0.1.3), stats, + teal, teal.data (>= 0.8.0), teal.logger (>= 0.4.0), teal.widgets (>= 0.5.0), diff --git a/NAMESPACE b/NAMESPACE index 873f8346..3b441943 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,5 +1,8 @@ # Generated by roxygen2: do not edit by hand +S3method(.is.delayed,default) +S3method(.is.delayed,list) +S3method(.is.delayed,pick) S3method(.picker_icon,Date) S3method(.picker_icon,MultiAssayExperiment) S3method(.picker_icon,POSIXct) @@ -60,6 +63,7 @@ S3method(variable_choices,data.frame) export("%>%") export(add_no_selected_choices) export(all_choices) +export(as.picks) export(check_no_multiple_selection) export(choices_labeled) export(choices_selected) @@ -68,7 +72,6 @@ export(data_extract_multiple_srv) export(data_extract_spec) export(data_extract_srv) export(data_extract_ui) -export(datanames) export(datanames_input) export(datasets) export(filter_spec) @@ -103,6 +106,7 @@ export(select_spec) export(select_spec.default) export(select_spec.delayed_data) export(split_by_sep) +export(teal_transform_filter) export(value_choices) export(values) export(variable_choices) diff --git a/R/0-as_picks.R b/R/0-as_picks.R new file mode 100644 index 00000000..a0c3425f --- /dev/null +++ b/R/0-as_picks.R @@ -0,0 +1,235 @@ +#' Convert data_extract_spec to picks +#' +#' Helper functions to ease transition between [data_extract_spec()] and [picks()]. +#' @param x (`data_extract_spec`, `select_spec`, `filter_spec`) object to convert to [`picks`] +#' +#' @details +#' With introduction of [`picks`], [`data_extract_spec`] will no longer serve a primary tool to +#' define variable choices and default selection in teal-modules and eventually [`data_extract_spec`] +#' will be deprecated. +#' To ease the transition to the new tool, we provide `as.picks` method which can handle 1:1 +#' conversion from [`data_extract_spec`] to [`picks`]. Unfortunately, when [`data_extract_spec`] +#' contains [`filter_spec`] then `as.picks` is unable to provide reliable [`picks`] equivalent. +#' +#' @examples +#' # convert des with eager select_spec +#' as.picks( +#' data_extract_spec( +#' dataname = "iris", +#' select_spec( +#' choices = c("Sepal.Length", "Sepal.Width", "Species"), +#' selected = c("Sepal.Length", "Species"), +#' multiple = TRUE, +#' ordered = TRUE +#' ) +#' ) +#' ) +#' +#' # convert des with delayed select_spec +#' as.picks( +#' data_extract_spec( +#' dataname = "iris", +#' select_spec( +#' choices = variable_choices("iris"), +#' selected = first_choice(), +#' multiple = TRUE, +#' ordered = TRUE +#' ) +#' ) +#' ) +#' +#' as.picks( +#' data_extract_spec( +#' dataname = "iris", +#' select_spec( +#' choices = variable_choices("iris", subset = function(data) names(Filter(is.numeric, data))), +#' selected = first_choice(), +#' multiple = TRUE, +#' ordered = TRUE +#' ) +#' ) +#' ) +#' +#' @export +as.picks <- function(x, ...) { + if (inherits(x, c("picks", "pick"))) { + x + } else if (checkmate::test_list(x, c("data_extract_spec", "filter_spec"))) { + Filter(length, lapply(x, as.picks, ...)) + } else if (inherits(x, "data_extract_spec")) { + args <- Filter( + length, + list( + datasets(choices = x$dataname, fixed = TRUE), + as.picks(x$select), + as.picks(x$filter, dataname = x$dataname) + # filter_spec as they are not necessary linked with `select` (selected variables) + # as filter_spec can be specified on the variable(s) different than select_spec for example: + # for example: #pseudocode select = select_spec(AVAL); filter = filter_spec(PARAMCD)) + ) + ) + do.call(picks, args) + } else if (inherits(x, "select_spec")) { + .select_spec_to_variables(x) + } else if (inherits(x, "filter_spec")) { + dataname <- list(...)$dataname + # warning + warning( + "`filter_spec` are not convertible to picks - please use `transformers` argument", + "and create `teal_transform_module` containing necessary filter. See `?teal_transform_filter`" + ) + + NULL + } +} + +#' @rdname as.picks +#' @examples +#' # teal_transform_module build on teal.transform +#' +#' teal_transform_filter( +#' data_extract_spec( +#' dataname = "iris", +#' filter = filter_spec( +#' vars = "Species", +#' choices = c("setosa", "versicolor", "virginica"), +#' selected = c("setosa", "versicolor") +#' ) +#' ) +#' ) +#' +#' teal_transform_filter( +#' picks( +#' datasets(choices = "iris", select = "iris"), +#' variables(choices = "Species", "Species"), +#' values( +#' choices = c("setosa", "versicolor", "virginica"), +#' selected = c("setosa", "versicolor") +#' ) +#' ) +#' ) +#' +#' @export +teal_transform_filter <- function(x, label = "Filter") { + checkmate::assert_multi_class(x, c("data_extract_spec", "picks")) + if (inherits(x, "data_extract_spec")) { + lapply(as.picks.filter(x), teal_transform_filter, label = label) + } else { + checkmate::assert_true("values" %in% names(x)) + teal::teal_transform_module( + label = label, + ui <- function(id) { + ns <- NS(id) + picks_ui(ns("transformer"), picks = x, container = div) + }, + server <- function(id, data) { + moduleServer(id, function(input, output, session) { + selector <- picks_srv("transformer", picks = x, data = data) + reactive({ + req(data(), selector()) + # todo: make sure filter call is not executed when setequal(selected, all_possible_choices) + filter_call <- .make_filter_call( + datasets = selector()$datasets$selected, + variables = selector()$variables$selected, + values = selector()$values$selected + ) + teal.code::eval_code(data(), filter_call) + }) + }) + } + ) + } +} + +as.picks.filter <- function(x, dataname) { + if (inherits(x, "filter_spec")) { + if (inherits(x$choices, "delayed_data")) { + warning( + "filter_spec(choices) doesn't support delayed_data when using with teal_transform_filter. ", + "Setting to all possible choices..." + ) + x$choices <- function(x) TRUE + } + if (inherits(x$selected, "delayed_data")) { + warning( + "filter_spec(selected) doesn't support delayed_data when using with teal_transform_filter. ", + "Setting to all possible choices..." + ) + x$selected <- function(x) TRUE + } + picks( + datasets(choices = dataname, selected = dataname), + variables(choices = x$vars_choices, selected = x$vars_selected, multiple = FALSE), # can't be multiple + values(choices = x$choices, selected = x$selected, multiple = x$multiple) + ) + } else if (checkmate::test_list(x, "filter_spec")) { + lapply(x, as.picks.filter, dataname = dataname) + } else if (inherits(x, "data_extract_spec")) { + as.picks.filter(x$filter, dataname = x$dataname) + } else if (checkmate::test_list(x, c("data_extract_spec", "list", "NULL"))) { + unlist( + lapply(Filter(length, x), as.picks.filter), + recursive = FALSE + ) + } +} + +.make_filter_call <- function(datasets, variables, values) { + checkmate::assert_character(datasets) + checkmate::assert_character(variables) + checkmate::assert_character(values) + substitute( + dataname <- dplyr::filter(dataname, varname %in% values), + list( + dataname = as.name(datasets), + varname = if (length(variables) == 1) { + as.name(variables) + } else { + as.call( + c( + quote(paste), + lapply(variables, as.name), + list(sep = ", ") + ) + ) + }, + values = values + ) + ) +} + +.select_spec_to_variables <- function(x) { + if (length(x)) { + variables( + choices = if (inherits(x$choices, "delayed_data")) { + out <- x$choices$subset + if (is.null(out)) { + function(x) TRUE # same effect as tidyselect::everything + } else { + class(out) <- "des-delayed" + out + } + } else { + x$choices + }, + selected = if (inherits(x$selected, "delayed_choices")) { + out <- x$selected + class(out) <- "des-delayed" + out + } else if (inherits(x$selected, "delayed_data")) { + out <- x$selected$subset + if (is.null(out)) { + 1L + } else { + class(out) <- "des-delayed" + out + } + } else { + unname(x$selected) + }, + ordered = x$ordered, + multiple = x$multiple, + fixed = x$fixed + ) + } +} diff --git a/R/0-call_utils.R b/R/0-call_utils.R index 238ab855..5c1b6412 100644 --- a/R/0-call_utils.R +++ b/R/0-call_utils.R @@ -162,8 +162,8 @@ call_condition_range_posixct <- function(varname, range, timezone = Sys.timezone range[1] <- trunc(range[1], units = c("secs")) range[2] <- trunc(range[2] + 1, units = c("secs")) - range <- format( - range, + range <- format.POSIXct( + unname(range), format = "%Y-%m-%d %H:%M:%S", tz = timezone ) @@ -198,154 +198,6 @@ call_condition_range_date <- function(varname, range) { ) } -#' Get call to subset and select array -#' -#' @param dataname (`character(1)` or `name`). -#' @param row (`name` or `call` or `logical` or `integer` or `character`) optional -#' name of the `row` or condition. -#' @param column (`name` or `call` or `logical` or `integer` or `character`) optional -#' name of the `column` or condition. -#' @param aisle (`name` or `call` or `logical` or `integer` or `character`) optional -#' name of the `row` or condition. -#' -#' @return [Extract()] `call` for 3-dimensional array in `x[i, j, k]` notation. -#' -#' @keywords internal -#' -call_extract_array <- function(dataname = ".", row = NULL, column = NULL, aisle = NULL) { - checkmate::assert( - checkmate::check_string(dataname), - checkmate::check_class(dataname, "call"), - checkmate::check_class(dataname, "name") - ) - stopifnot(is.null(row) || is.call(row) || is.character(row) || is.logical(row) || is.integer(row) || is.name(row)) - stopifnot(is.null(column) || is.call(column) || is.vector(column) || is.name(column)) - stopifnot(is.null(aisle) || is.call(aisle) || is.vector(aisle) || is.name(aisle)) - - if (is.language(dataname)) { - dataname <- paste(trimws(deparse(dataname, width.cutoff = 500L)), collapse = "\n") - } - - row <- if (is.null(row)) { - "" - } else { - paste(trimws(deparse(row, width.cutoff = 500L)), collapse = "\n") - } - column <- if (is.null(column)) { - "" - } else { - paste(trimws(deparse(column, width.cutoff = 500L)), collapse = "\n") - } - aisle <- if (is.null(aisle)) { - "" - } else { - paste(trimws(deparse(aisle, width.cutoff = 500L)), collapse = "\n") - } - - parse( - text = sprintf("%s[%s, %s, %s]", dataname, row, column, aisle), - keep.source = FALSE - )[[1]] -} - -#' Get call to subset and select matrix -#' -#' @param dataname (`character(1)` or `name`). -#' @param row (`name` or `call` or `logical` or `integer` or `character`) optional -#' name of the `row` or condition. -#' @param column (`name` or `call` or `logical` or `integer` or `character`) optional -#' name of the `column` or condition. -#' -#' @return [Extract()] `call` for matrix in `x[i, j]` notation. -#' -#' @keywords internal -#' -call_extract_matrix <- function(dataname = ".", row = NULL, column = NULL) { - checkmate::assert( - checkmate::check_string(dataname), - checkmate::check_class(dataname, "call"), - checkmate::check_class(dataname, "name") - ) - stopifnot(is.null(row) || is.call(row) || is.character(row) || is.logical(row) || is.integer(row) || is.name(row)) - stopifnot(is.null(column) || is.call(column) || is.vector(column) || is.name(column)) - - if (is.language(dataname)) { - dataname <- paste(trimws(deparse(dataname, width.cutoff = 500L)), collapse = "\n") - } - - row <- if (is.null(row)) { - "" - } else { - paste(trimws(deparse(row, width.cutoff = 500L)), collapse = "\n") - } - column <- if (is.null(column)) { - "" - } else { - paste(trimws(deparse(column, width.cutoff = 500L)), collapse = "\n") - } - - parse( - text = sprintf("%s[%s, %s]", dataname, row, column), - keep.source = FALSE - )[[1]] -} - - -#' Compose extract call with `$` operator -#' -#' @param dataname (`character(1)` or `name`) name of the object. -#' @param varname (`character(1)` or `name`) name of the slot in data. -#' @param dollar (`logical(1)`) whether returned call should use `$` or `[[` operator. -#' -#' @return [Extract()] `call` in `$` or `[[` notation (depending on parameters). -#' -#' @keywords internal -#' -call_extract_list <- function(dataname, varname, dollar = TRUE) { - checkmate::assert_flag(dollar) - checkmate::assert( - checkmate::check_string(varname), - checkmate::check_class(varname, "name"), - checkmate::assert( - combine = "and", - checkmate::check_class(varname, "call"), - checkmate::check_false(dollar) - ) - ) - - dataname <- call_check_parse_varname(dataname) - - if (dollar) { - call("$", dataname, varname) - } else { - call("[[", dataname, varname) - } -} - -#' Create a call using a function in a given namespace -#' -#' The dot arguments in `...` need to be quoted because they will be evaluated otherwise. -#' -#' @param name `character` function name, possibly using namespace colon `::`, also -#' works with `:::` (sometimes needed, but strongly discouraged). -#' @param ... arguments to pass to function with name `name`. -#' @param unlist_args `list` extra arguments passed in a single list, -#' avoids the use of `do.call` with this function. -#' -#' @return `call`. -#' -#' @keywords internal -#' -call_with_colon <- function(name, ..., unlist_args = list()) { - checkmate::assert_string(name) - checkmate::assert_list(unlist_args) - as.call(c( - parse(text = name, keep.source = FALSE)[[1]], - c(list(...), unlist_args) - )) -} - - #' Combine calls by operator #' #' Combine list of calls by specific operator. @@ -368,7 +220,6 @@ calls_combine_by <- function(operator, calls) { ) ) ) - Reduce( x = calls, f = function(x, y) call(operator, x, y) @@ -394,7 +245,13 @@ calls_combine_by <- function(operator, calls) { predicates <- lapply(unname(A), function(x) { if (is.numeric(x$values)) { call_condition_range(varname = x$variables, range = x$values) - } else { + } else if (inherits(x$values, "Date")) { + call_condition_range_date(varname = x$variables, range = x$values) + } else if (inherits(x$values, "POSIXct")) { + call_condition_range_posixct(varname = x$variables, range = x$values) + } else if (is.logical(x$values)) { + call_condition_logical(varname = x$variables, choice = x$values) + } else if (length(x$variables)) { variable <- if (length(x$variables) > 1) { as.call( c( @@ -411,5 +268,10 @@ calls_combine_by <- function(operator, calls) { call_condition_choice(varname = variable, choices = x$values) } }) - as.call(c(list(str2lang("dplyr::filter")), predicates)) + as.call( + c( + list(str2lang("dplyr::filter")), + Filter(length, predicates) + ) + ) } diff --git a/R/0-datanames.R b/R/0-datanames.R deleted file mode 100644 index dea1e1eb..00000000 --- a/R/0-datanames.R +++ /dev/null @@ -1,76 +0,0 @@ -#' Extract dataset names from picks objects -#' -#' `datanames()` extracts the names of all datasets referenced in one or more `picks` objects. -#' This is useful for determining which datasets need to be available in the data environment -#' before a module can function properly. -#' -#' @param x (`picks` object, a list of `picks`) -#' -#' @return A character vector of unique dataset names. Only returns names when dataset choices -#' are specified as character vectors (static choices). Returns `NULL` or empty vector when -#' datasets are specified using `tidyselect` expressions (dynamic choices), since the actual -#' dataset names cannot be determined until runtime. -#' -#' @details -#' The function examines the `datasets()` component of each `picks` object and extracts -#' dataset names only when they are explicitly specified as character vectors. This allows -#' modules to declare their data dependencies upfront. -#' -#' ## Behavior with different choice types -#' -#' - **Static choices**: When `datasets(choices = c("iris", "mtcars"))` uses character vectors, -#' `datanames()` returns `c("iris", "mtcars")`. -#' -#' - **Dynamic choices**: When `datasets(choices = tidyselect::everything())` or other -#' tidyselect expressions are used, `datanames()` cannot determine the dataset names in -#' advance and returns an empty result. -#' -#' - **Mixed lists**: When processing multiple `picks` objects, only the statically defined -#' dataset names are extracted and combined. -#' -#' @examples -#' # Single picks object with one dataset -#' p1 <- picks( -#' datasets(choices = "iris", selected = "iris"), -#' variables(choices = tidyselect::everything(), selected = 1) -#' ) -#' datanames(p1) # Returns "iris" -#' -#' # Single picks object with multiple datasets -#' p2 <- picks( -#' datasets(choices = c("iris", "mtcars"), selected = "iris"), -#' variables(choices = tidyselect::where(is.numeric), selected = 1) -#' ) -#' datanames(p2) # Returns c("iris", "mtcars") -#' -#' # List of picks objects -#' p3 <- picks( -#' datasets(choices = c("chickwts", "PlantGrowth"), selected = 1), -#' variables(choices = tidyselect::everything(), selected = 1) -#' ) -#' datanames(list(p1, p2, p3)) # Returns c("iris", "mtcars", "chickwts", "PlantGrowth") -#' -#' # Dynamic choices - cannot determine dataset names -#' p4 <- picks( -#' datasets(choices = tidyselect::where(is.data.frame), selected = 1), -#' variables(choices = tidyselect::everything(), selected = 1) -#' ) -#' datanames(p4) # Returns NULL or empty vector -#' -#' # List with NULL values (filtered out automatically) -#' datanames(list(p1, NULL, p2)) # Returns c("iris", "mtcars") -#' -#' # Duplicate dataset names are removed -#' datanames(list(p1, p1, p2)) # Returns c("iris", "mtcars") - no duplicates -#' -#' @seealso [picks()], [datasets()] -#' @export -datanames <- function(x) { - if (inherits(x, "picks")) { - x <- list(x) - } - checkmate::assert_list(x, c("picks", "NULL")) - unique(unlist(lapply(x, function(x) { - if (is.character(x$datasets$choices)) x$datasets$choices - }))) -} diff --git a/R/0-mae-methods.R b/R/0-mae-methods.R index 12dab62c..351ed224 100644 --- a/R/0-mae-methods.R +++ b/R/0-mae-methods.R @@ -1,7 +1,7 @@ #' @rdname picks #' @export mae_data <- function(choices = tidyselect::everything(), selected = 1L, multiple = FALSE) { - out <- .selected_choices( + out <- .pick( choices = if (.is_tidyselect(choices)) rlang::enquo(choices) else choices, selected = if (.is_tidyselect(selected)) rlang::enquo(selected) else selected, multiple = multiple diff --git a/R/0-module_merge.R b/R/0-module_merge.R index a8fe8015..ae8f0c2f 100644 --- a/R/0-module_merge.R +++ b/R/0-module_merge.R @@ -209,6 +209,9 @@ merge_srv <- function(id, output_name = "anl", join_fun = "dplyr::inner_join") { checkmate::assert_list(selectors, "reactive", names = "named") + checkmate::assert_class(data, "reactive") + checkmate::assert_string(output_name) + checkmate::assert_string(join_fun) moduleServer(id, function(input, output, session) { # selectors is a list of reactive picks. selectors_unwrapped <- reactive({ @@ -235,6 +238,7 @@ merge_srv <- function(id, ) } ) + list(data = data_r, variables = variables_selected) }) } @@ -251,14 +255,11 @@ merge_srv <- function(id, checkmate::assert_string(join_fun) # Early validation of merge keys between datasets - datanames <- unique(unlist(lapply(selectors, function(selector) selector$datasets$selected))) - .assert_merge_keys(datanames, teal.data::join_keys(x)) - merge_summary <- .merge_summary_list(selectors, join_keys = teal.data::join_keys(x)) expr <- .merge_expr(merge_summary = merge_summary, output_name = output_name, join_fun = join_fun) - merged_q <- eval_code(x, expr) + merged_q <- teal.code::eval_code(x, expr) teal.data::join_keys(merged_q) <- merge_summary$join_keys merged_q } @@ -286,7 +287,9 @@ merge_srv <- function(id, for (i in seq_along(datanames)) { dataname <- datanames[i] this_mapping <- Filter(function(x) x$datasets == dataname, mapping) - this_filter_mapping <- Filter(x = this_mapping, function(x) "values" %in% names(x)) + this_filter_mapping <- Filter( + x = this_mapping, function(x) !is.null(x$values) && !is.null(x$variables) + ) this_foreign_keys <- .fk(join_keys, dataname) this_primary_keys <- join_keys[dataname, dataname] this_variables <- c( @@ -296,10 +299,8 @@ merge_srv <- function(id, this_variables <- this_variables[!duplicated(unname(this_variables))] # because unique drops names this_call <- .call_dplyr_select(dataname = dataname, variables = this_variables) - if (length(this_filter_mapping)) { - # todo: make sure filter call is not executed when setequal(selected, all_possible_choices) - this_call <- calls_combine_by("%>%", c(this_call, .call_dplyr_filter(this_filter_mapping))) - } + # todo: make sure filter call is not executed when setequal(selected, all_possible_choices) + this_call <- calls_combine_by("%>%", c(this_call, .call_dplyr_filter(this_filter_mapping))) if (i > 1) { anl_vs_this <- setdiff(anl_primary_keys, this_primary_keys) @@ -338,10 +339,19 @@ merge_srv <- function(id, .merge_summary_list <- function(selectors, join_keys) { checkmate::assert_list(selectors, "picks") checkmate::assert_class(join_keys, "join_keys") + + .validate_is_eager(selectors) + .validate_join_keys(selectors, join_keys) + mapping <- lapply( # what has been selected in each selector selectors, - function(selector) lapply(selector, function(x) stats::setNames(x$selected, x$selected)) + function(selector) { + lapply(selector, function(x) { + stats::setNames(x$selected, x$selected) + }) + } ) + mapped_datanames <- unlist(lapply(mapping, `[[`, "datasets"), use.names = FALSE) mapping_by_dataset <- split(mapping, mapped_datanames) @@ -392,7 +402,7 @@ merge_srv <- function(id, suffix = dataname ) names(new_keys) <- new_key_names - join_key(dataset_1 = "anl", dataset_2 = dataset_2, keys = new_keys) + teal.data::join_key(dataset_1 = "anl", dataset_2 = dataset_2, keys = new_keys) } } ) @@ -451,11 +461,17 @@ merge_srv <- function(id, #' Determines the topological order from join_keys, then checks that each dataset #' can be joined with at least one of the previously accumulated datasets. #' -#' @param datanames (`character`) Vector of dataset names to be merged +#' @inheritParams merge_srv #' @param join_keys (`join_keys`) The join keys object #' #' @keywords internal -.check_merge_keys <- function(datanames, join_keys) { +.validate_join_keys <- function(selectors, join_keys) { + validate(need( + inherits(join_keys, "join_keys"), + "Provided data doesn't have join_keys specified" + )) + + datanames <- unique(unlist(lapply(selectors, function(selector) selector$datasets$selected))) # No validation needed for single dataset if (length(datanames) <= 1) { return(TRUE) @@ -470,20 +486,18 @@ merge_srv <- function(id, # Check if any dataset has no keys defined at all if (length(ordered_datasets) != length(datanames)) { datasets_without_keys <- setdiff(datanames, ordered_datasets) - return( - sprintf( - "Cannot merge datasets. The following dataset%s no join keys defined: %s.\n\nPlease define join keys using teal.data::join_keys().", - if (length(datasets_without_keys) == 1) " has" else "s have", - paste(sprintf("'%s'", datasets_without_keys), collapse = ", ") + validate( + need( + FALSE, + sprintf( + "Cannot merge datasets. The following dataset%s no join keys defined: %s.\n\nPlease define join keys using teal.data::join_keys().", + if (length(datasets_without_keys) == 1) " has" else "s have", + paste(sprintf("'%s'", datasets_without_keys), collapse = ", ") + ) ) ) } - # First dataset doesn't need validation - if (length(ordered_datasets) <= 1) { - return(TRUE) - } - # Iteratively check if each dataset can join with accumulated datasets accumulated <- ordered_datasets[1] @@ -500,12 +514,15 @@ merge_srv <- function(id, } if (!can_join) { - return( - sprintf( - "Cannot merge dataset '%s'. No join keys found between '%s' and any of the accumulated datasets: %s.\n\nPlease define join keys using teal.data::join_keys().", - current_dataset, - current_dataset, - paste(sprintf("'%s'", accumulated), collapse = ", ") + validate( + need( + FALSE, + sprintf( + "Cannot merge dataset '%s'. No join keys found between '%s' and any of the accumulated datasets: %s.\n\nPlease define join keys using teal.data::join_keys().", + current_dataset, + current_dataset, + paste(sprintf("'%s'", accumulated), collapse = ", ") + ) ) ) } @@ -517,5 +534,9 @@ merge_srv <- function(id, TRUE } -#' @rdname dot-check_merge_keys -.assert_merge_keys <- checkmate::makeAssertionFunction(.check_merge_keys) +.validate_is_eager <- function(x) { + validate(need( + !.is.delayed(x), + "selected values have not been resolved correctly. Please report this issue to an app-developer." + )) +} diff --git a/R/0-module_picks.R b/R/0-module_picks.R index d145fd4c..ec42d229 100644 --- a/R/0-module_picks.R +++ b/R/0-module_picks.R @@ -60,7 +60,7 @@ picks_ui.picks <- function(id, picks, container) { ns <- shiny::NS(id) badge_label <- shiny::uiOutput(ns("summary"), container = htmltools::tags$span) - content <- lapply(picks, function(x) .selected_choices_ui(id = ns(is(x)))) + content <- lapply(picks, function(x) .pick_ui(id = ns(is(x)))) htmltools::tags$div( # todo: badge to have css attribute to control the size - make CSS rule - can be controlled globally and module-ly if (missing(container)) { @@ -133,7 +133,6 @@ picks_srv.picks <- function(id, picks, data) { observeEvent(all_choices(), ignoreInit = TRUE, { current_choices <- picks_resolved()[[slot_name]]$choices current_selected <- picks_resolved()[[slot_name]]$selected - new_selected <- if (is.numeric(current_selected) && is.numeric(all_choices())) { c( max(current_selected[1], all_choices()[1], na.rm = TRUE), @@ -159,7 +158,7 @@ picks_srv.picks <- function(id, picks, data) { }) args <- attributes(picks[[slot_name]]) - .selected_choices_srv( + .pick_srv( id = slot_name, pick_type = slot_name, choices = choices, @@ -195,12 +194,12 @@ picks_srv.picks <- function(id, picks, data) { }) } -.selected_choices_ui <- function(id) { +.pick_ui <- function(id) { ns <- shiny::NS(id) uiOutput(ns("selected_container")) } -.selected_choices_srv <- function(id, pick_type, choices, selected, data, args) { +.pick_srv <- function(id, pick_type, choices, selected, data, args) { checkmate::assert_string(id) checkmate::assert_class(choices, "reactiveVal") checkmate::assert_class(selected, "reactiveVal") @@ -228,10 +227,12 @@ picks_srv.picks <- function(id, picks, data) { }) output$selected_container <- renderUI({ - logger::log_debug(".selected_choices_srv@1 rerender {pick_type} input") + logger::log_debug(".pick_srv@1 rerender {pick_type} input") + .validate_is_eager(choices()) + .validate_is_eager(selected()) if (isTRUE(args$fixed) || length(choices()) <= 1) { } else if (is_numeric()) { - .selected_choices_ui_numeric( + .pick_ui_numeric( session$ns("range"), label = sprintf("Select %s range:", pick_type), choices = choices(), @@ -239,7 +240,8 @@ picks_srv.picks <- function(id, picks, data) { args = args ) } else { - .selected_choices_ui_categorical( + # todo: create .pick_ui_categorical for date/datetime etc. + .pick_ui_categorical( session$ns("selected"), label = sprintf("Select %s:", pick_type), choices = choices(), @@ -254,10 +256,7 @@ picks_srv.picks <- function(id, picks, data) { # for numeric range_debounced <- reactive(input$range) |> debounce(1000) shiny::observeEvent(range_debounced(), { - if (length(input$range) != 2) { - return(NULL) - } - .update_rv(selected, input$range, log = ".selected_choices_srv@2 update selected after input changed") + .update_rv(selected, input$range, log = ".pick_srv@2 update selected after input changed") }) # for non-numeric @@ -268,14 +267,15 @@ picks_srv.picks <- function(id, picks, data) { if (args$ordered) { new_selected <- c(intersect(selected(), new_selected), setdiff(new_selected, selected())) } - .update_rv(selected, new_selected, log = ".selected_choices_srv@1 update selected after input changed") + .update_rv(selected, new_selected, log = ".pick_srv@1 update selected after input changed") } }) selected }) } -.selected_choices_ui_numeric <- function(id, label, choices, selected, args) { + +.pick_ui_numeric <- function(id, label, choices, selected, args) { shinyWidgets::numericRangeInput( inputId = id, label = label, @@ -285,7 +285,7 @@ picks_srv.picks <- function(id, picks, data) { ) } -.selected_choices_ui_categorical <- function(id, label, choices, selected, multiple, choicesOpt, args) { +.pick_ui_categorical <- function(id, label, choices, selected, multiple, choicesOpt, args) { htmltools::div( style = "max-width: 500px;", shinyWidgets::pickerInput( diff --git a/R/0-picks.R b/R/0-picks.R index 72752595..382834de 100644 --- a/R/0-picks.R +++ b/R/0-picks.R @@ -174,11 +174,9 @@ picks <- function(...) { previous_has_dynamic_choices <- c( FALSE, - vapply(head(picks, -1), FUN.VALUE = logical(1), FUN = function(x) { - inherits(x$choices, "quosure") || length(x$choices) > 1 - }) + vapply(head(picks, -1), FUN.VALUE = logical(1), FUN = .is.delayed) ) - has_eager_choices <- vapply(picks, function(x) is.character(x$choices), logical(1)) + has_eager_choices <- vapply(picks, function(x) !.is.delayed(x$choices), logical(1)) if (any(previous_has_dynamic_choices & has_eager_choices)) { idx_wrong <- which(previous_has_dynamic_choices & has_eager_choices)[1] @@ -215,7 +213,7 @@ datasets <- function(choices = tidyselect::everything(), fixed <- !.is_tidyselect(choices) && !.is_predicate(choices) && length(choices) == 1 } - out <- .selected_choices( + out <- .pick( choices = if (.is_tidyselect(choices)) rlang::enquo(choices) else choices, selected = if (.is_tidyselect(selected)) rlang::enquo(selected) else selected, multiple = FALSE, @@ -251,7 +249,7 @@ variables <- function(choices = tidyselect::everything(), fixed <- !(.is_tidyselect(choices) || .is_predicate(choices)) && length(choices) == 1 } - out <- .selected_choices( + out <- .pick( choices = if (.is_tidyselect(choices)) rlang::enquo(choices) else choices, selected = if (.is_tidyselect(selected)) rlang::enquo(selected) else selected, multiple = multiple, @@ -274,6 +272,7 @@ values <- function(choices = function(x) !is.na(x), checkmate::assert( .check_predicate(choices), checkmate::check_character(choices, min.len = 1, unique = TRUE), + checkmate::check_logical(choices, min.len = 1, unique = TRUE), checkmate::check_numeric(choices, len = 2, sorted = TRUE, finite = TRUE), checkmate::check_date(choices, len = 2), # should be sorted but determine checkmate::check_posixct(choices, len = 2) @@ -282,6 +281,7 @@ values <- function(choices = function(x) !is.na(x), .check_predicate(selected), checkmate::check_null(selected), checkmate::check_character(selected, min.len = 1, unique = TRUE), + checkmate::check_logical(selected, min.len = 1, unique = TRUE), checkmate::check_numeric(selected, len = 2, sorted = TRUE, finite = TRUE), checkmate::check_date(selected, len = 2), checkmate::check_posixct(selected, len = 2) @@ -291,7 +291,7 @@ values <- function(choices = function(x) !is.na(x), fixed <- !.is_predicate(choices) && length(choices) == 1 } - out <- .selected_choices( + out <- .pick( choices = choices, selected = selected, multiple = multiple, @@ -302,15 +302,12 @@ values <- function(choices = function(x) !is.na(x), out } - - - -.selected_choices <- function(choices, - selected, - multiple = length(selected) > 1, - ordered = FALSE, - fixed = FALSE, - ...) { +.pick <- function(choices, + selected, + multiple = length(selected) > 1, + ordered = FALSE, + fixed = FALSE, + ...) { is_choices_delayed <- rlang::is_quosure(choices) || .is_predicate(choices) is_selected_eager <- is.character(selected) if (is_choices_delayed && is_selected_eager) { @@ -383,3 +380,33 @@ values <- function(choices = function(x) !is.na(x), TRUE } } + + +#' Is picks delayed +#' +#' Determine whether list of picks/picks or pick are delayed. +#' When [pick()] is created it could be either: +#' - `quosure` when `tidyselect` helper used (delayed) +#' - `function` when predicate function provided (delayed) +#' - `atomic` when vector of choices/selcted provided (eager) +#' @param x (`list`, `list of picks`, `picks`, `pick`, `$choices`, `$selected`) +#' @keywords internal +.is.delayed <- function(x) { + UseMethod(".is.delayed") +} + +#' @export +.is.delayed.list <- function(x) { + any(vapply(x, .is.delayed, logical(1))) +} + +#' @export +.is.delayed.pick <- function(x) { + .is.delayed(x$choices) | .is.delayed(x$selected) +} + +#' @export +.is.delayed.default <- function(x) { + rlang::is_quosure(x) | + is.function(x) +} diff --git a/R/0-resolver.R b/R/0-resolver.R index b9a97219..1da5cbb1 100644 --- a/R/0-resolver.R +++ b/R/0-resolver.R @@ -179,13 +179,13 @@ determine.values <- function(x, data) { } out <- tryCatch( # app developer might provide failing function - if (inherits(data, c("numeric", "Date", "POSIXct"))) { - data_range <- .possible_choices(data) - this_range <- if (inherits(x, c("numeric", "Date", "POSIXct")) && length(x) == 2) { + if (inherits(data, c("integer", "numeric", "Date", "POSIXct"))) { + data_range <- range(data, na.rm = TRUE) + this_range <- if (inherits(x, c("integer", "numeric", "Date", "POSIXct")) && length(x) == 2) { x } else if (is.function(x)) { idx_match <- unique(which(vapply(data, x, logical(1)))) - .possible_choices(data[idx_match]) + range(data[idx_match], na.rm = TRUE) } else { data_range } @@ -201,8 +201,12 @@ determine.values <- function(x, data) { # don't need to evaluated eager choices - just make sure choices are subset of possible x[which(x %in% .possible_choices(data))] } else if (is.function(x)) { - idx_match <- unique(which(vapply(data, x, logical(1)))) - .possible_choices(data[idx_match]) + if (inherits(x, "des-delayed")) { + x(data) + } else { + idx_match <- unique(which(vapply(data, x, logical(1)))) + .possible_choices(data[idx_match]) + } } else if (rlang::is_quosure(x)) { # app developer might provide failing function idx_match <- unique(tidyselect::eval_select(expr = x, data)) diff --git a/R/0-tidyselect-helpers.R b/R/0-tidyselect-helpers.R index 8b01d85e..2d2565a2 100644 --- a/R/0-tidyselect-helpers.R +++ b/R/0-tidyselect-helpers.R @@ -24,23 +24,23 @@ is_categorical <- function(max.len, min.len) { # todo: consider making a function which can exit earlier when max.len > length(unique(x)) < min.len # without a need to compute unique on the whole vector. if (missing(max.len) && missing(min.len)) { - where(function(x) is.factor(x) || is.character(x)) + function(x) is.factor(x) || is.character(x) } else if (!missing(max.len) && missing(min.len)) { checkmate::assert_int(max.len, lower = 0) - where(function(x) (is.factor(x) || is.character(x)) && length(unique(x)) <= max.len) + function(x) (is.factor(x) || is.character(x)) && length(unique(x)) <= max.len } else if (!missing(min.len) && missing(max.len)) { checkmate::assert_int(min.len, lower = 0) - where(function(x) (is.factor(x) || is.character(x)) && length(unique(x)) >= min.len) + function(x) (is.factor(x) || is.character(x)) && length(unique(x)) >= min.len } else { checkmate::assert_int(min.len, lower = 0) checkmate::assert_int(max.len, lower = 0) checkmate::assert_true(max.len >= min.len) - where(function(x) { + function(x) { (is.factor(x) || is.character(x)) && { n <- length(unique(x)) n >= min.len && n <= max.len } - }) + } } } @@ -49,5 +49,5 @@ is_categorical <- function(max.len, min.len) { no_more_choices_than <- function(max.len) { # todo: consider making a function which can exit earlier when max.len > length(unique(x)) < min.len # without a need to compute unique on the whole vector. - where(function(x) length(unique(x)) <= max.len) + function(x) length(unique(x)) <= max.len } diff --git a/R/0-to_picks.R b/R/0-to_picks.R deleted file mode 100644 index af3fd7d9..00000000 --- a/R/0-to_picks.R +++ /dev/null @@ -1,54 +0,0 @@ -to_picks <- function(x, dataname) { - if (checkmate::test_list(x, "data_extract_spec")) { - - } -} - -des_to_picks <- function(x) { - if (inherits(x, "picks")) { - x - } else if (length(x)) { - args <- Filter( - length, - list( - datasets(choices = x$dataname, fixed = TRUE), - select_spec_to_variables(x$select) - # don't use filter_spec as they are not necessary linked with `select` (selected variables) - # as filter_spec can be speciefied on the variable(s) different than select_spec for example: - # for example: #pseudocode select = select_spec(AVAL); filter = filter_spec(PARAMCD)) - ) - ) - do.call(picks, args) - } -} - -select_spec_to_variables <- function(x) { - if (length(x)) { - variables( - choices = x$choices, - selected = x$selected, - # ordered = x$ordered, - multiple = x$multiple, - fixed = x$fixed - ) - } -} - -extract_filters <- function(elem, dataname) { - if (inherits(elem, "filter_spec")) { - picks( - datasets(choices = dataname, selected = dataname), - variables(choices = elem$vars_choices, selected = elem$vars_selected, multiple = FALSE), # can't be multiple - values(choices = elem$choices, selected = elem$selected, multiple = elem$multiple) - ) - } else if (checkmate::test_list(elem, "filter_spec")) { - lapply(elem, extract_filters, dataname = dataname) - } else if (inherits(elem, "data_extract_spec")) { - extract_filters(elem$filter, dataname = elem$dataname) - } else if (checkmate::test_list(elem, c("data_extract_spec", "list", "NULL"))) { - unlist( - lapply(Filter(length, elem), extract_filters), - recursive = FALSE - ) - } -} diff --git a/inst/refactor-notes.md b/inst/refactor-notes.md index 9296bc5a..44868eae 100644 --- a/inst/refactor-notes.md +++ b/inst/refactor-notes.md @@ -785,3 +785,145 @@ shinyApp(app$ui, app$server, enableBookmarking = "server") ``` + +## Conversion from to data-extract-spec + +### Select specific variable(s) from a specific dataset + +``` +data_extract_spec( + data = "iris" + select = select_spec( + choices = c("Sepal.Length", "Species"), + selected = "Species" + ) +) + +# to +picks( + datasets("iris", "iris"), + variables( + choices = c("Sepal.Length", "Species"), + selected = "Species" + ) +) + +``` + + +### Select specific variable(s) from a selected dataset + +``` +list( + data_extract_spec( + data = "iris" + select = select_spec( + choices = c("Sepal.Length", "Species"), + selected = "Species" + ) + ), + data_extract_spec( + data = "mtcars" + select = select_spec( + choices = c("mpg", "cyl"), + selected = "mpg" + ) + ) +) + +# to +picks( + datasets(c("iris", "mtcars"), "iris"), + variables( + choices = c("Sepal.Length", "Species", "mpg", "cyl"), + selected = c("Species", "mpg") + ) +) +``` + +### Select unknown variable(s) from a selected dataset + +``` +list( + data_extract_spec( + data = "iris" + select = select_spec( + choices = variable_choices("iris"), + selected = first_choice() + ) + ), + data_extract_spec( + data = "mtcars" + select = select_spec( + choices = variable_choices("mtcars"), + selected = first_choice() + ) + ) +) + +# to +picks( + datasets(c("iris", "mtcars"), "iris"), + variables( + choices = tidyselect::everything(), + selected = 1L + ) +) + +``` +### filtering by any variable + +`picks` provides no equivalent to `filter_spec` feature. To achieve this, please create a `teal_transform_module` with +a filtering mechanism. + +``` +list( + data_extract_spec( + data = "iris" + select = select_spec( + choices = c("Sepal.Length", "Species"), + selected = first_choice() + ), + filter = filter_spec( + vars = "Species", + choices = c("setosa", "versicolor", "virginica"), + selected = "setosa" + ) + ) +) + +# to picks and transformators +picks( + datasets("iris", "iris"), + variables( + choices = c("Sepal.Length", "Species"), + selected = 1L + ) +) + +# Apply filtering through teal_transform_module +transformators = teal_transform_module( + ui = function(id) { + ns <- NS(id) + selectInput( + ns("species"), + label = "Select species", + choices = c("setosa", "versicolor", "virginica"), + selected = "setosa" + ) + }, + server = function(id, data) { + moduleServer(id, function(input, output, session) { + reactive({ + req(input$species) + within( + data(), { + iris <- iris %>% dplyr::filter(Species %in% !!filter_values) + }, + filter_values = input$species) + }) + }) + } +) + +``` diff --git a/man/as.picks.Rd b/man/as.picks.Rd new file mode 100644 index 00000000..5b5e5cef --- /dev/null +++ b/man/as.picks.Rd @@ -0,0 +1,89 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/0-as_picks.R +\name{as.picks} +\alias{as.picks} +\alias{teal_transform_filter} +\title{Convert data_extract_spec to picks} +\usage{ +as.picks(x, ...) + +teal_transform_filter(x, label = "Filter") +} +\arguments{ +\item{x}{(\code{data_extract_spec}, \code{select_spec}, \code{filter_spec}) object to convert to \code{\link{picks}}} +} +\description{ +Helper functions to ease transition between \code{\link[=data_extract_spec]{data_extract_spec()}} and \code{\link[=picks]{picks()}}. +} +\details{ +With introduction of \code{\link{picks}}, \code{\link{data_extract_spec}} will no longer serve a primary tool to +define variable choices and default selection in teal-modules and eventually \code{\link{data_extract_spec}} +will be deprecated. +To ease the transition to the new tool, we provide \code{as.picks} method which can handle 1:1 +conversion from \code{\link{data_extract_spec}} to \code{\link{picks}}. Unfortunately, when \code{\link{data_extract_spec}} +contains \code{\link{filter_spec}} then \code{as.picks} is unable to provide reliable \code{\link{picks}} equivalent. +} +\examples{ +# convert des with eager select_spec +as.picks( + data_extract_spec( + dataname = "iris", + select_spec( + choices = c("Sepal.Length", "Sepal.Width", "Species"), + selected = c("Sepal.Length", "Species"), + multiple = TRUE, + ordered = TRUE + ) + ) +) + +# convert des with delayed select_spec +as.picks( + data_extract_spec( + dataname = "iris", + select_spec( + choices = variable_choices("iris"), + selected = first_choice(), + multiple = TRUE, + ordered = TRUE + ) + ) +) + +as.picks( + data_extract_spec( + dataname = "iris", + select_spec( + choices = variable_choices("iris", subset = function(data) names(Filter(is.numeric, data))), + selected = first_choice(), + multiple = TRUE, + ordered = TRUE + ) + ) +) + +# teal_transform_module build on teal.transform + +teal_transform_filter( + data_extract_spec( + dataname = "iris", + filter = filter_spec( + vars = "Species", + choices = c("setosa", "versicolor", "virginica"), + selected = c("setosa", "versicolor") + ) + ) +) + +teal_transform_filter( + picks( + datasets(choices = "iris", select = "iris"), + variables(choices = "Species", "Species"), + values( + choices = c("setosa", "versicolor", "virginica"), + selected = c("setosa", "versicolor") + ) + ) +) + +} diff --git a/man/call_extract_array.Rd b/man/call_extract_array.Rd deleted file mode 100644 index 1baa383a..00000000 --- a/man/call_extract_array.Rd +++ /dev/null @@ -1,27 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/0-call_utils.R -\name{call_extract_array} -\alias{call_extract_array} -\title{Get call to subset and select array} -\usage{ -call_extract_array(dataname = ".", row = NULL, column = NULL, aisle = NULL) -} -\arguments{ -\item{dataname}{(\code{character(1)} or \code{name}).} - -\item{row}{(\code{name} or \code{call} or \code{logical} or \code{integer} or \code{character}) optional -name of the \code{row} or condition.} - -\item{column}{(\code{name} or \code{call} or \code{logical} or \code{integer} or \code{character}) optional -name of the \code{column} or condition.} - -\item{aisle}{(\code{name} or \code{call} or \code{logical} or \code{integer} or \code{character}) optional -name of the \code{row} or condition.} -} -\value{ -\code{\link[=Extract]{Extract()}} \code{call} for 3-dimensional array in \code{x[i, j, k]} notation. -} -\description{ -Get call to subset and select array -} -\keyword{internal} diff --git a/man/call_extract_list.Rd b/man/call_extract_list.Rd deleted file mode 100644 index f910e6f0..00000000 --- a/man/call_extract_list.Rd +++ /dev/null @@ -1,22 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/0-call_utils.R -\name{call_extract_list} -\alias{call_extract_list} -\title{Compose extract call with \code{$} operator} -\usage{ -call_extract_list(dataname, varname, dollar = TRUE) -} -\arguments{ -\item{dataname}{(\code{character(1)} or \code{name}) name of the object.} - -\item{varname}{(\code{character(1)} or \code{name}) name of the slot in data.} - -\item{dollar}{(\code{logical(1)}) whether returned call should use \code{$} or \code{[[} operator.} -} -\value{ -\code{\link[=Extract]{Extract()}} \code{call} in \code{$} or \code{[[} notation (depending on parameters). -} -\description{ -Compose extract call with \code{$} operator -} -\keyword{internal} diff --git a/man/call_extract_matrix.Rd b/man/call_extract_matrix.Rd deleted file mode 100644 index 2d676e2f..00000000 --- a/man/call_extract_matrix.Rd +++ /dev/null @@ -1,24 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/0-call_utils.R -\name{call_extract_matrix} -\alias{call_extract_matrix} -\title{Get call to subset and select matrix} -\usage{ -call_extract_matrix(dataname = ".", row = NULL, column = NULL) -} -\arguments{ -\item{dataname}{(\code{character(1)} or \code{name}).} - -\item{row}{(\code{name} or \code{call} or \code{logical} or \code{integer} or \code{character}) optional -name of the \code{row} or condition.} - -\item{column}{(\code{name} or \code{call} or \code{logical} or \code{integer} or \code{character}) optional -name of the \code{column} or condition.} -} -\value{ -\code{\link[=Extract]{Extract()}} \code{call} for matrix in \code{x[i, j]} notation. -} -\description{ -Get call to subset and select matrix -} -\keyword{internal} diff --git a/man/call_with_colon.Rd b/man/call_with_colon.Rd deleted file mode 100644 index 9f2296a5..00000000 --- a/man/call_with_colon.Rd +++ /dev/null @@ -1,24 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/0-call_utils.R -\name{call_with_colon} -\alias{call_with_colon} -\title{Create a call using a function in a given namespace} -\usage{ -call_with_colon(name, ..., unlist_args = list()) -} -\arguments{ -\item{name}{\code{character} function name, possibly using namespace colon \code{::}, also -works with \code{:::} (sometimes needed, but strongly discouraged).} - -\item{...}{arguments to pass to function with name \code{name}.} - -\item{unlist_args}{\code{list} extra arguments passed in a single list, -avoids the use of \code{do.call} with this function.} -} -\value{ -\code{call}. -} -\description{ -The dot arguments in \code{...} need to be quoted because they will be evaluated otherwise. -} -\keyword{internal} diff --git a/man/datanames.Rd b/man/datanames.Rd deleted file mode 100644 index 0441408d..00000000 --- a/man/datanames.Rd +++ /dev/null @@ -1,77 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/0-datanames.R -\name{datanames} -\alias{datanames} -\title{Extract dataset names from picks objects} -\usage{ -datanames(x) -} -\arguments{ -\item{x}{(\code{picks} object, a list of \code{picks})} -} -\value{ -A character vector of unique dataset names. Only returns names when dataset choices -are specified as character vectors (static choices). Returns \code{NULL} or empty vector when -datasets are specified using \code{tidyselect} expressions (dynamic choices), since the actual -dataset names cannot be determined until runtime. -} -\description{ -\code{datanames()} extracts the names of all datasets referenced in one or more \code{picks} objects. -This is useful for determining which datasets need to be available in the data environment -before a module can function properly. -} -\details{ -The function examines the \code{datasets()} component of each \code{picks} object and extracts -dataset names only when they are explicitly specified as character vectors. This allows -modules to declare their data dependencies upfront. -\subsection{Behavior with different choice types}{ -\itemize{ -\item \strong{Static choices}: When \code{datasets(choices = c("iris", "mtcars"))} uses character vectors, -\code{datanames()} returns \code{c("iris", "mtcars")}. -\item \strong{Dynamic choices}: When \code{datasets(choices = tidyselect::everything())} or other -tidyselect expressions are used, \code{datanames()} cannot determine the dataset names in -advance and returns an empty result. -\item \strong{Mixed lists}: When processing multiple \code{picks} objects, only the statically defined -dataset names are extracted and combined. -} -} -} -\examples{ -# Single picks object with one dataset -p1 <- picks( - datasets(choices = "iris", selected = "iris"), - variables(choices = tidyselect::everything(), selected = 1) -) -datanames(p1) # Returns "iris" - -# Single picks object with multiple datasets -p2 <- picks( - datasets(choices = c("iris", "mtcars"), selected = "iris"), - variables(choices = tidyselect::where(is.numeric), selected = 1) -) -datanames(p2) # Returns c("iris", "mtcars") - -# List of picks objects -p3 <- picks( - datasets(choices = c("chickwts", "PlantGrowth"), selected = 1), - variables(choices = tidyselect::everything(), selected = 1) -) -datanames(list(p1, p2, p3)) # Returns c("iris", "mtcars", "chickwts", "PlantGrowth") - -# Dynamic choices - cannot determine dataset names -p4 <- picks( - datasets(choices = tidyselect::where(is.data.frame), selected = 1), - variables(choices = tidyselect::everything(), selected = 1) -) -datanames(p4) # Returns NULL or empty vector - -# List with NULL values (filtered out automatically) -datanames(list(p1, NULL, p2)) # Returns c("iris", "mtcars") - -# Duplicate dataset names are removed -datanames(list(p1, p1, p2)) # Returns c("iris", "mtcars") - no duplicates - -} -\seealso{ -\code{\link[=picks]{picks()}}, \code{\link[=datasets]{datasets()}} -} diff --git a/man/dot-check_merge_keys.Rd b/man/dot-check_merge_keys.Rd deleted file mode 100644 index ba5b5e06..00000000 --- a/man/dot-check_merge_keys.Rd +++ /dev/null @@ -1,26 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/0-module_merge.R -\name{.check_merge_keys} -\alias{.check_merge_keys} -\alias{.assert_merge_keys} -\title{Check if datasets can be merged in topological order} -\usage{ -.check_merge_keys(datanames, join_keys) - -.assert_merge_keys( - datanames, - join_keys, - .var.name = checkmate::vname(datanames), - add = NULL -) -} -\arguments{ -\item{datanames}{(\code{character}) Vector of dataset names to be merged} - -\item{join_keys}{(\code{join_keys}) The join keys object} -} -\description{ -Determines the topological order from join_keys, then checks that each dataset -can be joined with at least one of the previously accumulated datasets. -} -\keyword{internal} diff --git a/man/dot-is.delayed.Rd b/man/dot-is.delayed.Rd new file mode 100644 index 00000000..22d01ade --- /dev/null +++ b/man/dot-is.delayed.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/0-picks.R +\name{.is.delayed} +\alias{.is.delayed} +\title{Is picks delayed} +\usage{ +.is.delayed(x) +} +\arguments{ +\item{x}{(\code{list}, \verb{list of picks}, \code{picks}, \code{pick}, \verb{$choices}, \verb{$selected})} +} +\description{ +Determine whether list of picks/picks or pick are delayed. +When \code{\link[dplyr:pick]{dplyr::pick()}} is created it could be either: +\itemize{ +\item \code{quosure} when \code{tidyselect} helper used (delayed) +\item \code{function} when predicate function provided (delayed) +\item \code{atomic} when vector of choices/selcted provided (eager) +} +} +\keyword{internal} diff --git a/man/dot-validate_join_keys.Rd b/man/dot-validate_join_keys.Rd new file mode 100644 index 00000000..3ec70c69 --- /dev/null +++ b/man/dot-validate_join_keys.Rd @@ -0,0 +1,23 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/0-module_merge.R +\name{.validate_join_keys} +\alias{.validate_join_keys} +\title{Check if datasets can be merged in topological order} +\usage{ +.validate_join_keys(selectors, join_keys) +} +\arguments{ +\item{selectors}{(\verb{named list}) A named list of selector objects. Each element can be: +\itemize{ +\item A \code{picks} object defining dataset and variable selections +\item A \code{reactive} expression returning a \code{picks} object +The names of this list are used as identifiers for tracking which variables come from which selector. +}} + +\item{join_keys}{(\code{join_keys}) The join keys object} +} +\description{ +Determines the topological order from join_keys, then checks that each dataset +can be joined with at least one of the previously accumulated datasets. +} +\keyword{internal} diff --git a/tests/testthat/test-0-as_picks.R b/tests/testthat/test-0-as_picks.R new file mode 100644 index 00000000..de4fc478 --- /dev/null +++ b/tests/testthat/test-0-as_picks.R @@ -0,0 +1,51 @@ +testthat::describe("as.picks turns select_spec to variables", { + testthat::it("eager select_spec is convertible to variables", { + testthat::expect_identical( + as.picks(select_spec(choices = c("a", "b", "c"), selected = "a", multiple = TRUE, ordered = TRUE)), + variables(choices = c(a = "a", b = "b", c = "c"), selected = "a", multiple = TRUE, ordered = TRUE) + ) + }) + + testthat::it("select_spec with selected=NULL is convertible to variables", { + testthat::expect_identical( + as.picks(select_spec(choices = c("a", "b", "c"), selected = NULL)), + variables(choices = c(a = "a", b = "b", c = "c"), selected = NULL) + ) + }) + + testthat::it("select_spec with multiple selected convertible to variables", { + testthat::expect_identical( + as.picks(select_spec(choices = c("a", "b", "c"), selected = c("a", "b"))), + variables(choices = c(a = "a", b = "b", c = "c"), selected = c("a", "b")) + ) + }) + + testthat::it("delayed select_spec is convertible to variables", { + choices <- variable_choices("anything", function(data) names(Filter(is.factor, data))) + selected <- first_choice() + test <- as.picks(select_spec(choices = choices, selected = selected)) + + expected_choices <- choices$subset + expected_selected <- selected(choices)$subset + class(expected_choices) <- "des-delayed" + class(expected_selected) <- "des-delayed" + testthat::expect_equal( + test, + variables(choices = expected_choices, expected_selected) + ) + }) +}) + + +testthat::describe("as.picks doesn't convert filter_spec to picks", { + testthat::it("throws warning with teal_tranform_filter instruction for eager filter_spec", { + testthat::expect_warning( + as.picks( + data_extract_spec( + dataname = "iris", + filter = filter_spec(vars = "Species", choices = levels(iris$Species), selected = levels(iris$Species)), + ) + ) + ) + }) +}) diff --git a/tests/testthat/test-0-module_merge.R b/tests/testthat/test-0-module_merge.R new file mode 100644 index 00000000..efb327ee --- /dev/null +++ b/tests/testthat/test-0-module_merge.R @@ -0,0 +1,981 @@ +testthat::describe("merge_srv accepts selectors argument", { + it("accepts named list of shiny::reactive picks", { + data <- teal.data::teal_data() + data <- within(data, { + adsl <- data.frame(studyid = "A", usubjid = c("1", "2"), age = c(30, 40)) + adae <- data.frame(studyid = "A", usubjid = c("1", "2"), AVAL = c(1.5, 2.5)) + }) + teal.data::join_keys(data) <- teal.data::join_keys( + teal.data::join_key("adsl", "adsl", c("studyid", "usubjid")), + teal.data::join_key("adae", "adae", c("studyid", "usubjid", "paramcd", "avisit")), + teal.data::join_key("adsl", "adae", c("studyid", "usubjid")) + ) + + selectors <- list( + a = shiny::reactive(picks(datasets("adsl", "adsl"), variables("age", "age"))), + b = shiny::reactive(picks(datasets("adae", "adae"), variables("AVAL", "AVAL"))) + ) + + shiny::withReactiveDomain( + domain = shiny::MockShinySession$new(), + expr = testthat::expect_no_error( + merge_srv( + id = "test", + data = shiny::reactive(data), + selectors = selectors + ) + ) + ) + }) + + it("doesn't accept non-reactive list elements", { + data <- teal.data::teal_data() + data <- within(data, { + adsl <- data.frame(studyid = "A", usubjid = c("1", "2"), age = c(30, 40)) + }) + teal.data::join_keys(data) <- teal.data::join_keys( + teal.data::join_key("adsl", "adsl", c("studyid", "usubjid")) + ) + + selectors <- list( + a = picks( + datasets(choices = "adsl", selected = "adsl"), + variables(choices = "age", selected = "age") + ) + ) + + shiny::withReactiveDomain( + domain = shiny::MockShinySession$new(), + expr = testthat::expect_error( + merge_srv( + id = "test", + data = shiny::reactive(data), + selectors = selectors + ), + "reactive" + ) + ) + }) + + it("doesn't accept unnamed list of selectors", { + data <- teal.data::teal_data() + data <- within(data, { + adsl <- data.frame(studyid = "A", usubjid = c("1", "2"), age = c(30, 40)) + }) + teal.data::join_keys(data) <- teal.data::join_keys( + teal.data::join_key("adsl", "adsl", c("studyid", "usubjid")) + ) + + selectors <- list( + shiny::reactive(picks(datasets("adsl", "adsl"), variables("age", "age"))) + ) + + shiny::withReactiveDomain( + domain = shiny::MockShinySession$new(), + expr = testthat::expect_error( + merge_srv( + id = "test", + data = shiny::reactive(data), + selectors = selectors + ) + ) + ) + }) + + it("accepts empty list of selectors", { + data <- teal.data::teal_data() + data <- within(data, { + adsl <- data.frame(studyid = "A", usubjid = c("1", "2"), age = c(30, 40)) + }) + teal.data::join_keys(data) <- teal.data::join_keys( + teal.data::join_key("adsl", "adsl", c("studyid", "usubjid")) + ) + + selectors <- list() + + shiny::withReactiveDomain( + domain = shiny::MockShinySession$new(), + expr = testthat::expect_no_error( + merge_srv( + id = "test", + data = shiny::reactive(data), + selectors = selectors + ) + ) + ) + }) +}) + +testthat::describe("merge_srv accepts data argument", { + it("accepts shiny::reactive teal_data", { + data <- teal.data::teal_data() + data <- within(data, { + adsl <- data.frame(studyid = "A", usubjid = c("1", "2"), age = c(30, 40)) + }) + teal.data::join_keys(data) <- teal.data::join_keys( + teal.data::join_key("adsl", "adsl", c("studyid", "usubjid")) + ) + + selectors <- list( + a = shiny::reactive(picks(datasets("adsl", "adsl"), variables("age", "age"))) + ) + + shiny::withReactiveDomain( + domain = shiny::MockShinySession$new(), + expr = testthat::expect_no_error( + merge_srv( + id = "test", + data = shiny::reactive(data), + selectors = selectors + ) + ) + ) + }) + + it("doesn't accept non-reactive teal_data", { + data <- teal.data::teal_data() + data <- within(data, { + adsl <- data.frame(studyid = "A", usubjid = c("1", "2"), age = c(30, 40)) + }) + teal.data::join_keys(data) <- teal.data::join_keys( + teal.data::join_key("adsl", "adsl", c("studyid", "usubjid")) + ) + + selectors <- list( + adsl = shiny::reactive(picks(datasets("adsl", "adsl"), variables("age", "age"))) + ) + + shiny::withReactiveDomain( + domain = shiny::MockShinySession$new(), + expr = testthat::expect_error( + merge_srv( + id = "test", + data = data, + selectors = selectors + ) + ) + ) + }) +}) + +testthat::describe("merge_srv returns list with data (teal_data with anl) and variables (selected anl variables)", { + it("returns list with two reactives: variables and data", { + shiny::reactiveConsole(TRUE) + on.exit(reactiveConsole(FALSE)) + data <- teal.data::teal_data() + data <- within(data, { + adsl <- data.frame(studyid = "A", usubjid = c("1", "2"), age = c(30, 40)) + }) + teal.data::join_keys(data) <- teal.data::join_keys( + teal.data::join_key("adsl", "adsl", c("studyid", "usubjid")) + ) + + selectors <- list(a = shiny::reactive(picks(datasets("adsl", "adsl"), variables("age", "age")))) + out <- shiny::withReactiveDomain( + domain = shiny::MockShinySession$new(), + expr = merge_srv(id = "test", data = shiny::reactive(data), selectors = selectors, output_name = "anl") + ) + testthat::expect_named(out, c("data", "variables")) + checkmate::expect_class(out$variables, "reactive") + checkmate::expect_class(out$data, "reactive") + }) + + it("$data returns reactive containing teal_data with object `output_name`", { + shiny::reactiveConsole(TRUE) + on.exit(reactiveConsole(FALSE)) + data <- teal.data::teal_data() + data <- within(data, { + adsl <- data.frame(studyid = "A", usubjid = c("1", "2"), age = c(30, 40)) + }) + teal.data::join_keys(data) <- teal.data::join_keys( + teal.data::join_key("adsl", "adsl", c("studyid", "usubjid")) + ) + + selectors <- list(a = shiny::reactive(picks(datasets("adsl", "adsl"), variables("age", "age")))) + out <- shiny::withReactiveDomain( + domain = shiny::MockShinySession$new(), + expr = merge_srv(id = "test", data = shiny::reactive(data), selectors = selectors, output_name = "abcd") + ) + checkmate::expect_class(out$data(), "teal_data") + testthat::expect_named(out$data(), c("abcd", "adsl")) + }) + + it("$data() returns teal_data with merged anl using join_fun", { + shiny::reactiveConsole(TRUE) + on.exit(reactiveConsole(FALSE)) + data <- within(teal.data::teal_data(), { + customers <- tibble::tribble( + ~id, ~name, ~age, ~status, + 1, "Alice Johnson", 30, "active", + 2, "Bob Smith", 25, "active", + 3, "Charlie Brown", 35, "inactive" + ) + + orders <- tibble::tribble( + ~id, ~customer_id, ~date, ~status, ~total_amount, + 101, 1, as.Date("2024-01-15"), "shipped", 100, + 102, 2, as.Date("2024-02-01"), "pending", 200, + 103, 3, as.Date("2024-02-10"), "delivered", 300 + ) + }) + teal.data::join_keys(data) <- teal.data::join_keys( + teal.data::join_key("customers", keys = "id"), + teal.data::join_key("orders", keys = c("id")), + teal.data::join_key("customers", "orders", keys = c(id = "customer_id")) + ) + + selectors <- list( + a = shiny::reactive(picks(datasets("customers", "customers"), variables("name", "name"))), + b = shiny::reactive(picks(datasets("orders", "orders"), variables("date", "date"))) + ) + out <- shiny::withReactiveDomain( + domain = shiny::MockShinySession$new(), + expr = merge_srv(id = "test", data = shiny::reactive(data), selectors = selectors, join_fun = "dplyr::left_join") + ) + + testthat::expect_equal( + out$data(), + within(data, { + anl <- dplyr::select(customers, id, name) %>% + dplyr::left_join(y = dplyr::select(orders, customer_id, date), by = c(id = "customer_id")) + }) + ) + }) + + it("$variables returns reactive list named after selectors", { + shiny::reactiveConsole(TRUE) + on.exit(reactiveConsole(FALSE)) + data <- teal.data::teal_data() + data <- within(data, { + adsl <- data.frame(studyid = "A", usubjid = c("1", "2"), age = c(30, 40)) + }) + teal.data::join_keys(data) <- teal.data::join_keys( + teal.data::join_key("adsl", "adsl", c("studyid", "usubjid")) + ) + + selectors <- list( + a = shiny::reactive(picks(datasets("adsl", "adsl"), variables("age", "age"))), + b = shiny::reactive(picks(datasets("adsl", "adsl"), variables("age", "age"))) + ) + + out <- shiny::withReactiveDomain( + domain = shiny::MockShinySession$new(), + expr = merge_srv(id = "test", data = shiny::reactive(data), selectors = selectors, output_name = "abcd") + ) + checkmate::expect_list(out$variables()) + testthat::expect_named(out$variables(), c("a", "b")) + }) + + it("anl contains selected colnames with original names if variables are selected from a single dataset", { + shiny::reactiveConsole(TRUE) + on.exit(shiny::reactiveConsole(FALSE)) + data <- teal.data::teal_data() + data <- within(data, { + iris <- iris + }) + + selectors <- list( + a = shiny::reactive(picks( + datasets(choices = "iris", selected = "iris"), + variables(choices = colnames(iris), selected = "Species") + )), + b = shiny::reactive(picks( + datasets(choices = "iris", selected = "iris"), + variables(choices = colnames(iris), selected = c("Sepal.Length", "Sepal.Width")) + )) + ) + + out <- shiny::withReactiveDomain( + domain = shiny::MockShinySession$new(), + expr = merge_srv(id = "test", data = shiny::reactive(data), selectors = selectors, output_name = "anl") + ) + + testthat::expect_equal( + out$data(), + within(data, anl <- dplyr::select(iris, Species, Sepal.Length, Sepal.Width)) + ) + testthat::expect_identical(out$variables(), list(a = "Species", b = c("Sepal.Length", "Sepal.Width"))) + testthat::expect_in(unique(unlist(out$variables())), colnames(out$data()$anl)) + }) + + it("anl contains selected colnames with original names if selected from a multiple datasets and not duplicated", { + shiny::reactiveConsole(TRUE) + on.exit(reactiveConsole(FALSE)) + data <- within(teal.data::teal_data(), { + customers <- tibble::tribble( + ~id, ~name, ~age, ~status, + 1, "Alice Johnson", 30, "active", + 2, "Bob Smith", 25, "active", + 3, "Charlie Brown", 35, "inactive" + ) + + orders <- tibble::tribble( + ~id, ~customer_id, ~date, ~status, ~total_amount, + 101, 1, as.Date("2024-01-15"), "shipped", 100, + 102, 2, as.Date("2024-02-01"), "pending", 200, + 103, 3, as.Date("2024-02-10"), "delivered", 300 + ) + }) + teal.data::join_keys(data) <- teal.data::join_keys( + teal.data::join_key("customers", keys = "id"), + teal.data::join_key("orders", keys = c("id")), + teal.data::join_key("customers", "orders", keys = c(id = "customer_id")) + ) + + selectors <- list( + a = shiny::reactive(picks( + datasets(choices = "customers", selected = "customers"), + variables(choices = colnames(data$customers), selected = c("name", "age")) + )), + b = shiny::reactive(picks( + datasets(choices = "orders", selected = "orders"), + variables(choices = colnames(data$orders), selected = c("date", "total_amount")) + )) + ) + + out <- shiny::withReactiveDomain( + domain = shiny::MockShinySession$new(), + expr = merge_srv(id = "test", data = shiny::reactive(data), selectors = selectors) + ) + + testthat::expect_equal( + out$data(), + within(data, { + anl <- dplyr::select(customers, id, name, age) %>% + dplyr::inner_join( + y = dplyr::select(orders, customer_id, date, total_amount), + by = c(id = "customer_id"), + suffix = c("", "_orders") + ) + }) + ) + testthat::expect_identical(out$variables(), list(a = c("name", "age"), b = c("date", "total_amount"))) + testthat::expect_in(unique(unlist(out$variables())), colnames(out$data()$anl)) + }) + + it("anl contains selected colnames with suffixes names if duplicated across datasets", { + shiny::reactiveConsole(TRUE) + on.exit(reactiveConsole(FALSE)) + data <- within(teal.data::teal_data(), { + customers <- tibble::tribble( + ~id, ~name, ~age, ~status, + 1, "Alice Johnson", 30, "active", + 2, "Bob Smith", 25, "active", + 3, "Charlie Brown", 35, "inactive" + ) + + orders <- tibble::tribble( + ~id, ~customer_id, ~date, ~status, ~total_amount, + 101, 1, as.Date("2024-01-15"), "shipped", 100, + 102, 2, as.Date("2024-02-01"), "pending", 200, + 103, 3, as.Date("2024-02-10"), "delivered", 300 + ) + }) + teal.data::join_keys(data) <- teal.data::join_keys( + teal.data::join_key("customers", keys = "id"), + teal.data::join_key("orders", keys = c("id")), + teal.data::join_key("customers", "orders", keys = c(id = "customer_id")) + ) + + selectors <- list( + a = shiny::reactive(picks( + datasets(choices = "customers", selected = "customers"), + variables(choices = colnames(data$customers), selected = c("name", "status")) + )), + b = shiny::reactive(picks( + datasets(choices = "orders", selected = "orders"), + variables(choices = colnames(data$orders), selected = c("date", "status")) + )) + ) + + out <- shiny::withReactiveDomain( + domain = shiny::MockShinySession$new(), + expr = merge_srv(id = "test", data = shiny::reactive(data), selectors = selectors) + ) + testthat::expect_equal( + out$data(), + within(data, { + anl <- dplyr::select(customers, id, name, status) %>% + dplyr::inner_join( + y = dplyr::select(orders, customer_id, date, status), + by = c(id = "customer_id"), + suffix = c("", "_orders") + ) + }) + ) + testthat::expect_identical(out$variables(), list(a = c("name", "status"), b = c("date", "status_orders"))) + testthat::expect_in(unique(unlist(out$variables())), colnames(out$data()$anl)) + }) + + it("anl contains colnames with original names when duplicated for the same dataset", { + shiny::reactiveConsole(TRUE) + on.exit(reactiveConsole(FALSE)) + data <- within(teal.data::teal_data(), { + customers <- tibble::tribble( + ~id, ~name, ~age, ~status, + 1, "Alice Johnson", 30, "active", + 2, "Bob Smith", 25, "active", + 3, "Charlie Brown", 35, "inactive" + ) + }) + + selectors <- list( + a = shiny::reactive(picks( + datasets(choices = "customers", selected = "customers"), + variables(choices = colnames(data$customers), selected = c("id", "status")) + )), + b = shiny::reactive(picks( + datasets(choices = "customers", selected = "customers"), + variables(choices = colnames(data$customers), selected = c("id", "status")) + )), + c = shiny::reactive(picks( + datasets(choices = "customers", selected = "customers"), + variables(choices = colnames(data$customers), selected = c("name", "id")) + )) + ) + + out <- shiny::withReactiveDomain( + domain = shiny::MockShinySession$new(), + expr = merge_srv(id = "test", data = shiny::reactive(data), selectors = selectors) + ) + + testthat::expect_equal( + out$data(), + within(data, { + anl <- dplyr::select(customers, id, status, name) + }) + ) + testthat::expect_identical( + out$variables(), + list(a = c("id", "status"), b = c("id", "status"), c = c("name", "id")) + ) + testthat::expect_in(unique(unlist(out$variables())), colnames(out$data()$anl)) + }) + + it("anl can merge deep join tree by pair keys and finds correct merge order", { + shiny::reactiveConsole(TRUE) + on.exit(reactiveConsole(FALSE)) + data <- within(teal.data::teal_data(), { + customers <- tibble::tribble( + ~id, ~name, ~age, ~status, + 1, "Alice Johnson", 30, "active", + 2, "Bob Smith", 25, "active", + 3, "Charlie Brown", 35, "inactive" + ) + + orders <- tibble::tribble( + ~id, ~customer_id, ~date, ~status, ~total_amount, + 101, 1, as.Date("2024-01-15"), "shipped", 100, + 102, 2, as.Date("2024-02-01"), "pending", 200, + 103, 3, as.Date("2024-02-10"), "delivered", 300 + ) + + order_items <- tibble::tribble( + ~id, ~order_id, ~product, ~quantity, ~price, + 1001, 101, "Widget A", 2, 25, + 1002, 101, "Widget B", 1, 50, + 1003, 102, "Widget C", 3, 66.67, + 1004, 103, "Widget A", 5, 60 + ) + + shipments <- tibble::tribble( + ~id, ~item_id, ~tracking_number, ~carrier, ~shipped_date, + 5001, 1001, "TRK123456", "FedEx", as.Date("2024-01-16"), + 5002, 1002, "TRK123457", "UPS", as.Date("2024-01-16"), + 5003, 1003, "TRK123458", "FedEx", as.Date("2024-02-02"), + 5004, 1004, "TRK123459", "DHL", as.Date("2024-02-11") + ) + }) + teal.data::join_keys(data) <- teal.data::join_keys( + teal.data::join_key("customers", keys = "id"), + teal.data::join_key("orders", keys = "id"), + teal.data::join_key("order_items", keys = "id"), + teal.data::join_key("shipments", keys = "id"), + teal.data::join_key("customers", "orders", keys = c(id = "customer_id")), + teal.data::join_key("orders", "order_items", keys = c(id = "order_id")), + teal.data::join_key("order_items", "shipments", keys = c(id = "item_id")) + ) + + selectors <- list( + a = shiny::reactive(picks( + datasets(choices = "shipments", selected = "shipments"), + variables(choices = colnames(data$shipments), selected = c("tracking_number", "carrier")) + )), + b = shiny::reactive(picks( + datasets(choices = "customers", selected = "customers"), + variables(choices = colnames(data$customers), selected = c("name", "age")) + )), + c = shiny::reactive(picks( + datasets(choices = "order_items", selected = "order_items"), + variables(choices = colnames(data$order_items), selected = c("product", "quantity")) + )), + d = shiny::reactive(picks( + datasets(choices = "orders", selected = "orders"), + variables(choices = colnames(data$orders), selected = c("date", "total_amount")) + )) + ) + + out <- shiny::withReactiveDomain( + domain = shiny::MockShinySession$new(), + expr = merge_srv(id = "test", data = shiny::reactive(data), selectors = selectors) + ) + + testthat::expect_equal( + out$data(), + within(data, { + anl <- dplyr::select(customers, id, name, age) %>% + dplyr::inner_join( + y = dplyr::select(orders, customer_id, id, date, total_amount), + by = c(id = "customer_id"), + suffix = c("", "_orders") + ) %>% + dplyr::inner_join( + y = dplyr::select(order_items, order_id, id, product, quantity), + by = c(id_orders = "order_id"), + suffix = c("", "_order_items") + ) %>% + dplyr::inner_join( + y = dplyr::select(shipments, item_id, tracking_number, carrier), + by = c(id_order_items = "item_id"), + suffix = c("", "_shipments") + ) + }) + ) + testthat::expect_identical( + out$variables(), + list( + b = c("name", "age"), + d = c("date", "total_amount"), + c = c("product", "quantity"), + a = c("tracking_number", "carrier") + ) + ) + testthat::expect_in(unique(unlist(out$variables())), colnames(out$data()$anl)) + }) + + it("selected join_keys across multiple datasets refers to the same column in anl c( O.O )ɔ", { + # ie. when `*_join(a, b, by = c(id = "id_parent"))` the second column won't be included as it is + # referring to the same column + shiny::reactiveConsole(TRUE) + on.exit(reactiveConsole(FALSE)) + data <- within(teal.data::teal_data(), { + customers <- tibble::tribble( + ~id, ~name, ~age, ~status, + 1, "Alice Johnson", 30, "active", + 2, "Bob Smith", 25, "active", + 3, "Charlie Brown", 35, "inactive" + ) + + orders <- tibble::tribble( + ~id, ~customer_id, ~date, ~status, ~total_amount, + 101, 1, as.Date("2024-01-15"), "shipped", 100, + 102, 2, as.Date("2024-02-01"), "pending", 200, + 103, 3, as.Date("2024-02-10"), "delivered", 300 + ) + + order_items <- tibble::tribble( + ~id, ~order_id, ~product, ~quantity, ~price, + 1001, 101, "Widget A", 2, 25, + 1002, 101, "Widget B", 1, 50, + 1003, 102, "Widget C", 3, 66.67, + 1004, 103, "Widget A", 5, 60 + ) + + shipments <- tibble::tribble( + ~id, ~item_id, ~tracking_number, ~carrier, ~shipped_date, + 5001, 1001, "TRK123456", "FedEx", as.Date("2024-01-16"), + 5002, 1002, "TRK123457", "UPS", as.Date("2024-01-16"), + 5003, 1003, "TRK123458", "FedEx", as.Date("2024-02-02"), + 5004, 1004, "TRK123459", "DHL", as.Date("2024-02-11") + ) + }) + teal.data::join_keys(data) <- teal.data::join_keys( + teal.data::join_key("customers", keys = "id"), + teal.data::join_key("orders", keys = "id"), + teal.data::join_key("order_items", keys = "id"), + teal.data::join_key("customers", "orders", keys = c(id = "customer_id")), + teal.data::join_key("orders", "order_items", keys = c(id = "order_id")) + ) + + selectors <- list( + a = shiny::reactive(picks( + datasets(choices = "customers", selected = "customers"), + variables(choices = colnames(data$customers), selected = "id") + )), + b = shiny::reactive(picks( + datasets(choices = "orders", selected = "orders"), + variables(choices = colnames(data$orders), selected = c("id", "customer_id")) + )), + c = shiny::reactive(picks( + datasets(choices = "order_items", selected = "order_items"), + variables(choices = colnames(data$order_items), selected = "order_id", ) + )) + ) + + out <- shiny::withReactiveDomain( + domain = shiny::MockShinySession$new(), + expr = merge_srv(id = "test", data = shiny::reactive(data), selectors = selectors) + ) + + testthat::expect_equal( + out$data(), + within(data, { + anl <- dplyr::select(customers, id) %>% + dplyr::inner_join( + y = dplyr::select(orders, customer_id, id), + by = c(id = "customer_id"), + suffix = c("", "_orders") + ) %>% + dplyr::inner_join( + y = dplyr::select(order_items, order_id), + by = c(id_orders = "order_id"), + suffix = c("", "_order_items") + ) + }) + ) + testthat::expect_identical( + out$variables(), + list(a = "id", b = c("id_orders", "id"), c = "id_orders") # + ) + testthat::expect_in(unique(unlist(out$variables())), colnames(out$data()$anl)) + }) + + it("join_keys are updated to contains anl <-> anl-components", { + shiny::reactiveConsole(TRUE) + on.exit(reactiveConsole(FALSE)) + data <- within(teal.data::teal_data(), { + customers <- tibble::tribble( + ~id, ~name, ~age, ~status, + 1, "Alice Johnson", 30, "active", + 2, "Bob Smith", 25, "active", + 3, "Charlie Brown", 35, "inactive" + ) + + orders <- tibble::tribble( + ~id, ~customer_id, ~date, ~status, ~total_amount, + 101, 1, as.Date("2024-01-15"), "shipped", 100, + 102, 2, as.Date("2024-02-01"), "pending", 200, + 103, 3, as.Date("2024-02-10"), "delivered", 300 + ) + + order_items <- tibble::tribble( + ~id, ~order_id, ~product, ~quantity, ~price, + 1001, 101, "Widget A", 2, 25, + 1002, 101, "Widget B", 1, 50, + 1003, 102, "Widget C", 3, 66.67, + 1004, 103, "Widget A", 5, 60 + ) + + shipments <- tibble::tribble( + ~id, ~item_id, ~tracking_number, ~carrier, ~shipped_date, + 5001, 1001, "TRK123456", "FedEx", as.Date("2024-01-16"), + 5002, 1002, "TRK123457", "UPS", as.Date("2024-01-16"), + 5003, 1003, "TRK123458", "FedEx", as.Date("2024-02-02"), + 5004, 1004, "TRK123459", "DHL", as.Date("2024-02-11") + ) + }) + teal.data::join_keys(data) <- teal.data::join_keys( + teal.data::join_key("customers", keys = "id"), + teal.data::join_key("orders", keys = "id"), + teal.data::join_key("order_items", keys = "id"), + teal.data::join_key("shipments", keys = "id"), + teal.data::join_key("customers", "orders", keys = c(id = "customer_id")), + teal.data::join_key("orders", "order_items", keys = c(id = "order_id")), + teal.data::join_key("order_items", "shipments", keys = c(id = "item_id")) + ) + + selectors <- list( + a = shiny::reactive(picks( + datasets(choices = "shipments", selected = "shipments"), + variables(choices = colnames(data$shipments), selected = c("tracking_number", "carrier")) + )), + b = shiny::reactive(picks( + datasets(choices = "customers", selected = "customers"), + variables(choices = colnames(data$customers), selected = c("name", "age")) + )), + c = shiny::reactive(picks( + datasets(choices = "order_items", selected = "order_items"), + variables(choices = colnames(data$order_items), selected = c("product", "quantity")) + )), + d = shiny::reactive(picks( + datasets(choices = "orders", selected = "orders"), + variables(choices = colnames(data$orders), selected = c("date", "total_amount")) + )) + ) + + out <- shiny::withReactiveDomain( + domain = shiny::MockShinySession$new(), + expr = merge_srv(id = "test", data = shiny::reactive(data), selectors = selectors) + ) + + testthat::expect_identical( + teal.data::join_keys(out$data())$anl, + list( + shipments = c(id_order_items = "item_id"), + order_items = c(id_orders = "order_id"), + orders = c(id = "customer_id") + ) + ) + }) + + it("anl is filtered by factor variable when values is selected", { + shiny::reactiveConsole(TRUE) + on.exit(shiny::reactiveConsole(FALSE)) + data <- teal.data::teal_data() + data <- within(data, { + test_data <- data.frame( + factor_var = factor(c("A", "B", "C", "A", "B"), levels = c("A", "B", "C")), + id = 1:5 + ) + }) + + selectors <- list( + a = shiny::reactive(picks( + datasets(choices = "test_data", selected = "test_data"), + variables(choices = colnames(data$test_data), selected = "factor_var"), + values(choices = c("A", "B", "C"), selected = c("A", "B")) + )) + ) + + out <- shiny::withReactiveDomain( + domain = shiny::MockShinySession$new(), + expr = merge_srv(id = "test", data = shiny::reactive(data), selectors = selectors, output_name = "anl") + ) + + testthat::expect_equal( + out$data(), + within(data, { + anl <- dplyr::select(test_data, factor_var) %>% + dplyr::filter(factor_var %in% c("A", "B")) + }) + ) + }) + + it("anl is filtered by numeric variable when values is selected", { + shiny::reactiveConsole(TRUE) + on.exit(shiny::reactiveConsole(FALSE)) + data <- teal.data::teal_data() + data <- within(data, { + test_data <- data.frame( + numeric_var = c(1.5, 2.5, 3.5, 4.5, 5.5), + id = 1:5 + ) + }) + + selectors <- list( + a = shiny::reactive(picks( + datasets(choices = "test_data", selected = "test_data"), + variables(choices = colnames(data$test_data), selected = "numeric_var"), + values(choices = range(data$test_data$numeric_var), selected = c(2.0, 4.0)) + )) + ) + + out <- shiny::withReactiveDomain( + domain = shiny::MockShinySession$new(), + expr = merge_srv(id = "test", data = shiny::reactive(data), selectors = selectors, output_name = "anl") + ) + + testthat::expect_equal( + out$data(), + within(data, { + anl <- dplyr::select(test_data, numeric_var) %>% + dplyr::filter(numeric_var >= 2.0 & numeric_var <= 4.0) + }) + ) + }) + + it("anl is filtered by date variable when values is selected", { + shiny::reactiveConsole(TRUE) + on.exit(shiny::reactiveConsole(FALSE)) + data <- teal.data::teal_data() + data <- within(data, { + test_data <- data.frame( + date_var = as.Date(c("2024-01-01", "2024-02-01", "2024-03-01", "2024-04-01", "2024-05-01")), + id = 1:5 + ) + }) + + selectors <- list( + a = shiny::reactive(picks( + datasets(choices = "test_data", selected = "test_data"), + variables(choices = colnames(data$test_data), selected = "date_var"), + values(choices = range(data$test_data$date_var), selected = as.Date(c("2024-01-15", "2024-03-15"))) + )) + ) + + out <- shiny::withReactiveDomain( + domain = shiny::MockShinySession$new(), + expr = merge_srv(id = "test", data = shiny::reactive(data), selectors = selectors, output_name = "anl") + ) + + testthat::expect_equal( + out$data(), + within(data, { + anl <- dplyr::select(test_data, date_var) %>% + dplyr::filter(date_var >= as.Date("2024-01-15") & date_var <= as.Date("2024-03-15")) + }) + ) + }) + + it("anl is filtered by POSIXct variable when values is selected", { + shiny::reactiveConsole(TRUE) + on.exit(shiny::reactiveConsole(FALSE)) + data <- teal.data::teal_data() + data <- within(data, { + test_data <- data.frame( + posixct_var = as.POSIXct(c("2024-01-01 10:00:00", "2024-02-01 11:00:00", "2024-03-01 12:00:00", "2024-04-01 13:00:00", "2024-05-01 14:00:00")), + id = 1:5 + ) + }) + + selectors <- list( + a = shiny::reactive(picks( + datasets(choices = "test_data", selected = "test_data"), + variables(choices = colnames(data$test_data), selected = "posixct_var"), + values(choices = range(data$test_data$posixct_var), selected = as.POSIXct(c("2024-01-15 00:00:00", "2024-04-15 00:00:00"))) + )) + ) + + out <- shiny::withReactiveDomain( + domain = shiny::MockShinySession$new(), + expr = merge_srv(id = "test", data = shiny::reactive(data), selectors = selectors, output_name = "anl") + ) + + testthat::expect_equal( + out$data(), + within(data, { + anl <- dplyr::select(test_data, posixct_var) %>% + dplyr::filter( + posixct_var >= as.POSIXct("2024-01-15 00:00:00") & + posixct_var <= as.POSIXct("2024-04-15 00:00:00") + ) + }) + ) + }) + + it("anl is filtered by logical variable when values is selected", { + shiny::reactiveConsole(TRUE) + on.exit(shiny::reactiveConsole(FALSE)) + data <- teal.data::teal_data() + data <- within(data, { + test_data <- data.frame( + logical_var = c(TRUE, FALSE, TRUE, FALSE, TRUE), + id = 1:5 + ) + }) + + selectors <- list( + a = shiny::reactive(picks( + datasets(choices = "test_data", selected = "test_data"), + variables(choices = colnames(data$test_data), selected = "logical_var"), + values(choices = c(TRUE, FALSE), selected = TRUE) + )) + ) + + out <- shiny::withReactiveDomain( + domain = shiny::MockShinySession$new(), + expr = merge_srv(id = "test", data = shiny::reactive(data), selectors = selectors, output_name = "anl") + ) + + testthat::expect_equal( + out$data(), + within(data, { + anl <- dplyr::select(test_data, logical_var) %>% + dplyr::filter(logical_var) + }) + ) + }) + + it("fails when selected from multiple datasets and no join-keys/primary-keys", { + shiny::reactiveConsole(TRUE) + on.exit(shiny::reactiveConsole(FALSE)) + data <- teal.data::teal_data() + data <- within(data, { + iris <- iris + mtcars <- mtcars + }) + + selectors <- list( + a = shiny::reactive(picks( + datasets(choices = "mtcars", selected = "mtcars"), + variables(choices = colnames(mtcars), selected = "mpg") + )), + b = shiny::reactive(picks( + datasets(choices = "iris", selected = "iris"), + variables(choices = colnames(iris), selected = c("Sepal.Length", "Sepal.Width")) + )) + ) + + out <- shiny::withReactiveDomain( + domain = shiny::MockShinySession$new(), + expr = merge_srv(id = "test", data = shiny::reactive(data), selectors = selectors) + ) + testthat::expect_error(out$variables(), regexp = "no join keys defined", class = "validation") + testthat::expect_error(out$data(), regexp = "no join keys defined", class = "validation") + }) + + it("fails when selected from multiple datasets and no join-keys between selected datasets", { + shiny::reactiveConsole(TRUE) + on.exit(reactiveConsole(FALSE)) + data <- within(teal.data::teal_data(), { + customers <- tibble::tribble( + ~id, ~name, ~age, ~status, + 1, "Alice Johnson", 30, "active", + 2, "Bob Smith", 25, "active", + 3, "Charlie Brown", 35, "inactive" + ) + + orders <- tibble::tribble( + ~id, ~customer_id, ~date, ~status, ~total_amount, + 101, 1, as.Date("2024-01-15"), "shipped", 100, + 102, 2, as.Date("2024-02-01"), "pending", 200, + 103, 3, as.Date("2024-02-10"), "delivered", 300 + ) + }) + + teal.data::join_keys(data) <- teal.data::join_keys( + teal.data::join_key("customers", keys = "id"), + teal.data::join_key("orders", keys = c("id")) + ) + + + selectors <- list( + a = shiny::reactive(picks( + datasets(choices = "customers", selected = "customers"), + variables(choices = colnames(data$customers), selected = c("name", "status")) + )), + b = shiny::reactive(picks( + datasets(choices = "orders", selected = "orders"), + variables(choices = colnames(data$orders), selected = c("date", "status")) + )) + ) + + out <- shiny::withReactiveDomain( + domain = shiny::MockShinySession$new(), + expr = merge_srv(id = "test", data = shiny::reactive(data), selectors = selectors) + ) + testthat::expect_error(out$variables(), regexp = "No join keys found between", class = "validation") + testthat::expect_error(out$data(), regexp = "No join keys found between", class = "validation") + }) + + it("fails when unresolved picks are passed to the module", { + shiny::reactiveConsole(TRUE) + on.exit(shiny::reactiveConsole(FALSE)) + data <- teal.data::teal_data() + data <- within(data, { + iris <- iris + }) + + selectors <- list( + a = shiny::reactive(picks(datasets(choices = "iris", selected = "iris"), variables(selected = 1L))), + b = shiny::reactive(picks(datasets(choices = "iris", selected = "iris"), variables(selected = 1L))) + ) + + out <- shiny::withReactiveDomain( + domain = shiny::MockShinySession$new(), + expr = merge_srv(id = "test", data = shiny::reactive(data), selectors = selectors) + ) + testthat::expect_error(out$variables(), regexp = "have not been resolved correctly", class = "validation") + testthat::expect_error(out$data(), regexp = "have not been resolved correctly", class = "validation") + }) +}) diff --git a/tests/testthat/test-0-module_picks.R b/tests/testthat/test-0-module_picks.R index 704cf0f0..3276971d 100644 --- a/tests/testthat/test-0-module_picks.R +++ b/tests/testthat/test-0-module_picks.R @@ -627,6 +627,55 @@ testthat::describe("picks_srv resolves picks", { "`multiple` has been set to `FALSE`" ) }) + + it("picks converted from des with variable_choices are resolved", { + test_picks <- as.picks( + data_extract_spec( + dataname = "iris", + select_spec(choices = variable_choices("iris"), selected = first_choice()) + ) + ) + shiny::testServer( + picks_srv, + args = list(id = "id", picks = test_picks, data = shiny::reactive(list(iris = iris, mtcars = mtcars))), + expr = { + suppressWarnings( + picks_expected <- picks( + datasets(choices = c(iris = "iris"), selected = "iris"), + variables(choices = setNames(colnames(iris), colnames(iris)), selected = "Sepal.Length") + ) + ) + testthat::expect_identical(picks_resolved(), picks_expected) + } + ) + }) + + it("picks converted from variable_choices(fun) are resolved", { + test_picks <- as.picks( + data_extract_spec( + dataname = "iris", + select_spec( + choices = variable_choices("iris", function(data) { + names(Filter(is.numeric, data)) + }), + selected = first_choice() + ) + ) + ) + shiny::testServer( + picks_srv, + args = list(id = "id", picks = test_picks, data = shiny::reactive(list(iris = iris, mtcars = mtcars))), + expr = { + suppressWarnings( + picks_expected <- picks( + datasets(choices = c(iris = "iris"), selected = "iris"), + variables(choices = setNames(colnames(iris)[-5], colnames(iris)[-5]), selected = "Sepal.Length") + ) + ) + testthat::expect_identical(picks_resolved(), picks_expected) + } + ) + }) }) @@ -667,16 +716,349 @@ testthat::describe("picks_srv resolves picks interactively", { ) }) + it("custom choices label set in picks is displayed in a picker input", { + test_picks <- picks( + datasets(choices = c(`mtcars dataset` = "mtcars", `iris dataset` = "iris"), selected = "iris") + ) + shiny::testServer( + picks_srv, + args = list(id = "test", picks = test_picks, data = shiny::reactive(list(mtcars = mtcars, iris = iris))), + expr = { + html <- rvest::read_html(as.character(session$output[["datasets-selected_container"]]$html)) + choices_label <- rvest::html_text(rvest::html_nodes(html, "option")) + testthat::expect_identical(choices_label, c("mtcars dataset", "iris dataset")) + } + ) + }) - it("custom label is displayed in a picker input", { + it("custom choices label set in data is displayed in a picker input", { + test_picks <- picks( + datasets(choices = c("mtcars", "iris"), selected = "iris") + ) + attr(mtcars, "label") <- "mtcars dataset" + attr(iris, "label") <- "iris dataset" + shiny::testServer( + picks_srv, + args = list(id = "test", picks = test_picks, data = shiny::reactive(list(mtcars = mtcars, iris = iris))), + expr = { + html <- rvest::read_html(as.character(session$output[["datasets-selected_container"]]$html)) + choices_label <- rvest::html_text(rvest::html_nodes(html, "option")) + testthat::expect_identical(choices_label, c("mtcars dataset", "iris dataset")) + } + ) + }) + + it("custom choices label set in picks has priority over data label is displayed in a picker input", { + test_picks <- picks( + datasets(choices = c(`mtcars picks` = "mtcars", `iris picks` = "iris"), selected = "iris") + ) + attr(mtcars, "label") <- "mtcars label" + attr(iris, "label") <- "iris label" + shiny::testServer( + picks_srv, + args = list(id = "test", picks = test_picks, data = shiny::reactive(list(mtcars = mtcars, iris = iris))), + expr = { + html <- rvest::read_html(as.character(session$output[["datasets-selected_container"]]$html)) + choices_label <- rvest::html_text(rvest::html_nodes(html, "option")) + testthat::expect_identical(choices_label, c("mtcars picks", "iris picks")) + } + ) + }) + + it("picker input choices produces class-specific-icons for variable", { + test_dataset <- data.frame( + col_numeric = c(1.5, 2.5, 3.5), + col_integer = 1L:3L, + col_logical = c(TRUE, FALSE, TRUE), + col_character = c("a", "b", "c"), + col_factor = factor(c("x", "y", "z")), + col_date = as.Date(c("2024-01-01", "2024-01-02", "2024-01-03")), + col_datetime = as.POSIXct(c("2024-01-01 12:00:00", "2024-01-02 12:00:00", "2024-01-03 12:00:00")) + ) + + test_picks <- picks( + datasets(choices = "test", selected = "test"), + variables(choices = tidyselect::everything(), selected = 1L) + ) + shiny::testServer( + picks_srv, + args = list(id = "test", picks = test_picks, data = shiny::reactive(list(test = test_dataset))), + expr = { + html <- rvest::read_html(as.character(session$output[["variables-selected_container"]]$html)) + icons <- gsub( + "^.+fa-((\\w|-)+).+$", "\\1", + rvest::html_attr(rvest::html_nodes(html, "option"), "data-content") + ) + + testthat::expect_identical( + icons, c("arrow-up-1-9", "arrow-up-1-9", "pause", "font", "chart-bar", "calendar", "calendar") + ) + } + ) + }) + + it("picker input choices produces class-specific-icons for datasets", { + skip("todo") }) it("switching dataset-input changes variables-input", { + test_picks <- picks( + datasets(choices = c("mtcars", "iris"), selected = "iris"), + variables(choices = tidyselect::everything(), selected = 1L) + ) + shiny::testServer( + picks_srv, + args = list(id = "test", picks = test_picks, data = shiny::reactive(list(mtcars = mtcars, iris = iris))), + expr = { + html <- rvest::read_html(as.character(session$output[["variables-selected_container"]]$html)) + testthat::expect_identical( + rvest::html_attr(rvest::html_nodes(html, "option[selected='selected']"), "value"), "Sepal.Length" + ) + session$setInputs(`datasets-selected` = "mtcars") + session$setInputs(`datasets-selected_open` = FALSE) + html <- rvest::read_html(as.character(session$output[["variables-selected_container"]]$html)) + testthat::expect_identical( + rvest::html_attr(rvest::html_nodes(html, "option[selected='selected']"), "value"), "mpg" + ) + } + ) }) - it("changing picks_resolved changes picker input", { + it("Setting numeric variable resolves values to be a slider input with variable range", { + test_picks <- picks( + datasets(choices = "iris", selected = "iris"), + variables(choices = "Sepal.Length", selected = "Sepal.Length"), + values(choices = function(x) !is.na(x), selected = function(x) !is.na(x)) + ) + shiny::testServer( + picks_srv, + args = list(id = "test", picks = test_picks, data = shiny::reactive(list(mtcars = mtcars, iris = iris))), + expr = { + html <- rvest::read_html(as.character(session$output[["values-selected_container"]]$html)) + testthat::expect_identical( + rvest::html_attr(rvest::html_nodes(html, "input[type='number']"), "value"), + as.character(range(iris$Sepal.Length)) + ) + } + ) }) - it("changing data changes picker input", { + it("switching variables-input changes values-input", { + test_picks <- picks( + datasets(choices = "iris", selected = "iris"), + variables(choices = c("Sepal.Length", "Species"), selected = "Species"), + values(choices = function(x) !is.na(x), selected = function(x) !is.na(x)) + ) + shiny::testServer( + picks_srv, + args = list(id = "test", picks = test_picks, data = shiny::reactive(list(mtcars = mtcars, iris = iris))), + expr = { + html <- rvest::read_html(as.character(session$output[["values-selected_container"]]$html)) + testthat::expect_identical( + rvest::html_attr(rvest::html_nodes(html, "option[selected='selected']"), "value"), + c("setosa", "versicolor", "virginica") + ) + session$setInputs(`variables-selected` = "Sepal.Length") + session$setInputs(`variables-selected_open` = FALSE) + html <- rvest::read_html(as.character(session$output[["values-selected_container"]]$html)) + testthat::expect_identical( + rvest::html_attr(rvest::html_nodes(html, "input[type='number']"), "value"), + as.character(range(iris$Sepal.Length)) + ) + } + ) + }) + + it("changing picks_resolved doesn't change picker input", { + test_picks <- picks( + datasets(choices = c("iris", "mtcars"), selected = "iris") + ) + shiny::testServer( + picks_srv, + args = list(id = "test", picks = test_picks, data = shiny::reactive(list(mtcars = mtcars, iris = iris))), + expr = { + current_picks <- picks_resolved() + current_picks$datasets$selected <- "mtcars" + picks_resolved(current_picks) + html <- rvest::read_html(as.character(session$output[["datasets-selected_container"]]$html)) + testthat::expect_identical( + rvest::html_attr(rvest::html_nodes(html, "option[selected='selected']"), "value"), + "iris" + ) + } + ) + }) + + it("adding a dataset to data adds new choice to dataset choices", { + skip("todo: tests can't trigger data()") + test_picks <- picks( + datasets(choices = tidyselect::everything(), selected = 1L), + variables(choices = tidyselect::everything(), selected = 1L) + ) + reactive_data <- reactiveVal( + list( + iris = iris, + mtcars = mtcars + ) + ) + shiny::testServer( + picks_srv, + args = list(id = "test", picks = test_picks, data = reactive_data), + expr = { + html <- rvest::read_html(as.character(session$output[["datasets-selected_container"]]$html)) + testthat::expect_identical(rvest::html_attr(rvest::html_nodes(html, "option"), "value"), c("iris", "mtcars")) + reactive_data( + list( + a = data.frame(a = 1:10, b = letters[1:10]), + iris = iris, + mtcars = mtcars + ) + ) + + html <- rvest::read_html(as.character(session$output[["datasets-selected_container"]]$html)) + testthat::expect_identical( + rvest::html_attr(rvest::html_nodes(html, "option"), "value"), + c("a", "iris", "mtcars") + ) + } + ) + }) + + it("adding a column to data adds new choice to variables-choices", { + skip("todo: tests can't trigger data()") + test_picks <- picks( + datasets(choices = tidyselect::everything(), selected = 1L), + variables(choices = tidyselect::everything(), selected = 1L) + ) + reactive_data <- reactiveVal( + list( + iris = iris, + mtcars = mtcars + ) + ) + shiny::testServer( + picks_srv, + args = list(id = "test", picks = test_picks, data = reactive_data), + expr = { + reactive_data( + list( + iris = transform(iris, new = 1:150), + mtcars = mtcars + ) + ) + session$flushReact() + html <- rvest::read_html(as.character(session$output[["variables-selected_container"]]$html)) + testthat::expect_identical( + rvest::html_attr(rvest::html_nodes(html, "option"), "value"), + c("a", "mtcars") + ) + testthat::expect_identical( + rvest::html_attr(rvest::html_nodes(html, "option[selected = 'selected']"), "value"), + "iris" + ) + } + ) }) + + it("removing a (selected) dataset from data removes choice from dataset choices and from selection with warning", { + test_picks <- picks( + datasets(choices = tidyselect::everything(), selected = 1L), + variables(choices = tidyselect::everything(), selected = 1L) + ) + reactive_data <- reactiveVal( + list( + iris = iris, + mtcars = mtcars + ) + ) + shiny::testServer( + picks_srv, + args = list(id = "test", picks = test_picks, data = reactive_data), + expr = { + html <- rvest::read_html(as.character(session$output[["datasets-selected_container"]]$html)) + testthat::expect_identical(rvest::html_attr(rvest::html_nodes(html, "option"), "value"), c("iris", "mtcars")) + testthat::expect_identical( + rvest::html_attr(rvest::html_nodes(html, "option[selected = 'selected']"), "value"), + "iris" + ) + reactive_data( + list( + a = data.frame(a = 1:10, b = letters[1:10]), + mtcars = mtcars + ) + ) + + testthat::expect_warning(session$flushReact()) + html <- rvest::read_html(as.character(session$output[["datasets-selected_container"]]$html)) + testthat::expect_identical(rvest::html_attr(rvest::html_nodes(html, "option"), "value"), c("a", "mtcars")) + testthat::expect_length( + rvest::html_attr(rvest::html_nodes(html, "option[selected = 'selected']"), "value"), + 0 + ) + } + ) + }) + + it("removing a (selected) variable from data removes choice from dataset choices and from selection", { + test_picks <- picks( + datasets(choices = tidyselect::everything(), selected = 1L), + variables(choices = tidyselect::everything(), selected = tidyselect::starts_with("Sepal"), multiple = TRUE) + ) + reactive_data <- reactiveVal( + list( + iris = iris, + mtcars = mtcars + ) + ) + shiny::testServer( + picks_srv, + args = list(id = "test", picks = test_picks, data = reactive_data), + expr = { + html <- rvest::read_html(as.character(session$output[["variables-selected_container"]]$html)) + testthat::expect_identical( + rvest::html_attr(rvest::html_nodes(html, "option[selected = 'selected']"), "value"), + c("Sepal.Length", "Sepal.Width") + ) + reactive_data( + list( + iris = iris[-1], + mtcars = mtcars + ) + ) + session$flushReact() + html <- rvest::read_html(as.character(session$output[["variables-selected_container"]]$html)) + testthat::expect_identical(rvest::html_attr(rvest::html_nodes(html, "option"), "value"), colnames(iris)[-1]) + testthat::expect_identical( + rvest::html_attr(rvest::html_nodes(html, "option[selected = 'selected']"), "value"), + "Sepal.Width" + ) + } + ) + }) + + it("variables(ordered=TRUE) returns input following a selection-order instead of choices-order", { + test_picks <- picks( + datasets(choices = "iris", selected = "iris"), + variables(choices = tidyselect::everything(), selected = 3L, multiple = TRUE, ordered = TRUE) + ) + shiny::testServer( + picks_srv, + args = list(id = "test", picks = test_picks, data = shiny::reactive(list(mtcars = mtcars, iris = iris))), + expr = { + session$setInputs(`variables-selected` = colnames(iris)[c(1L, 3L)]) + session$setInputs(`variables-selected_open` = FALSE) # close dropdown to trigger + session$setInputs(`variables-selected` = colnames(iris)[c(1L, 2L, 3L)]) + session$setInputs(`variables-selected_open` = FALSE) # close dropdown to trigger + session$setInputs(`variables-selected` = colnames(iris)[c(1L, 2L, 3L, 4L)]) + session$setInputs(`variables-selected_open` = FALSE) # close dropdown to trigger + testthat::expect_identical(picks_resolved()$variables$selected, colnames(iris)[c(3L, 1L, 2L, 4L)]) + } + ) + }) + + it("changing numeric range in slider input updates picks_resolved") + it("changing integer range in slider input updates picks_resolved") + it("changing date range in slider input updates picks_resolved") + it("changing date range in slider input updates picks_resolved") + it("setting picks_resolved$selected outside of range adjust to the available range") }) From a5564852666a23a613142c9d3fb3844a798b9c6a Mon Sep 17 00:00:00 2001 From: github-actions <41898282+github-actions[bot]@users.noreply.github.com> Date: Thu, 30 Oct 2025 14:51:54 +0000 Subject: [PATCH 139/142] [skip style] [skip vbump] Restyle files --- R/0-module_merge.R | 1 - R/0-module_picks.R | 3 +-- R/0-picks.R | 1 - 3 files changed, 1 insertion(+), 4 deletions(-) diff --git a/R/0-module_merge.R b/R/0-module_merge.R index ae8f0c2f..c5070e56 100644 --- a/R/0-module_merge.R +++ b/R/0-module_merge.R @@ -244,7 +244,6 @@ merge_srv <- function(id, } - #' @keywords internal .qenv_merge <- function(x, selectors, diff --git a/R/0-module_picks.R b/R/0-module_picks.R index ec42d229..dd5670e1 100644 --- a/R/0-module_picks.R +++ b/R/0-module_picks.R @@ -230,8 +230,7 @@ picks_srv.picks <- function(id, picks, data) { logger::log_debug(".pick_srv@1 rerender {pick_type} input") .validate_is_eager(choices()) .validate_is_eager(selected()) - if (isTRUE(args$fixed) || length(choices()) <= 1) { - } else if (is_numeric()) { + if (isTRUE(args$fixed) || length(choices()) <= 1) {} else if (is_numeric()) { .pick_ui_numeric( session$ns("range"), label = sprintf("Select %s range:", pick_type), diff --git a/R/0-picks.R b/R/0-picks.R index 382834de..4a3a6e79 100644 --- a/R/0-picks.R +++ b/R/0-picks.R @@ -361,7 +361,6 @@ values <- function(choices = function(x) !is.na(x), ( checkmate::test_function(x, nargs = 1) || checkmate::test_function(x) && identical(names(formals(x)), "...") - ) } From 394cbeaaa71cac64def931328b134f061d1d112c Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Thu, 30 Oct 2025 15:56:02 +0100 Subject: [PATCH 140/142] r cmd check --- DESCRIPTION | 8 +- NAMESPACE | 12 +- R/0-as_picks.R | 22 ++- R/0-badge_dropdown.R | 16 +- R/0-call_utils.R | 4 +- R/0-mae-methods.R | 25 --- R/0-module_merge.R | 32 ++-- R/0-module_picks.R | 20 ++- R/0-picks.R | 162 ++++++++++++----- R/0-print.R | 9 +- R/0-resolver.R | 37 ++-- R/0-tidyselect-helpers.R | 24 +-- R/0-tm_merge.R | 53 ++++-- R/choices_selected.R | 4 +- R/data_extract_filter_module.R | 3 +- R/get_merge_call.R | 18 +- inst/WORDLIST | 4 + inst/refactor-notes.md | 161 ++++++++++++++--- man/as.picks.Rd | 4 +- man/badge_dropdown.Rd | 10 +- man/choices_selected.Rd | 4 +- man/determine.Rd | 2 +- man/dot-determine_choices.Rd | 4 +- man/{dot-is.delayed.Rd => dot-is_delayed.Rd} | 8 +- man/dot-is_tidyselect.Rd | 2 +- man/dot-resolve.Rd | 6 +- man/merge_srv.Rd | 23 +-- man/picks.Rd | 172 ++++++++++++++----- man/picks_module.Rd | 2 +- man/resolver.Rd | 21 +-- man/tidyselectors.Rd | 15 +- man/tm_merge.Rd | 45 ++++- tests/testthat/test-0-module_merge.R | 10 +- tests/testthat/test-0-print.R | 6 +- 34 files changed, 626 insertions(+), 322 deletions(-) delete mode 100644 R/0-mae-methods.R rename man/{dot-is.delayed.Rd => dot-is_delayed.Rd} (81%) diff --git a/DESCRIPTION b/DESCRIPTION index 892567fe..1f5b7de0 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -21,6 +21,7 @@ BugReports: https://github.com/insightsengineering/teal.transform/issues Depends: R (>= 3.6) Imports: + bsicons, checkmate (>= 2.1.0), dplyr (>= 1.1.0), htmltools, @@ -30,20 +31,25 @@ Imports: shiny (>= 1.6.0), shinyjs (>= 2.1.0), shinyvalidate (>= 0.1.3), + shinyWidgets, stats, teal, + teal.code, teal.data (>= 0.8.0), teal.logger (>= 0.4.0), teal.widgets (>= 0.5.0), tidyr (>= 1.0.0), tidyselect (>= 1.2.1), - utils + utils, + yaml Suggests: bslib (>= 0.8.0), knitr (>= 1.42), rmarkdown (>= 2.23), + rvest, roxy.shinylive (>= 1.0.0), testthat (>= 3.1.5), + tibble, withr (>= 2.0.0) VignetteBuilder: knitr, diff --git a/NAMESPACE b/NAMESPACE index 3b441943..dd6ca8d6 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,10 +1,9 @@ # Generated by roxygen2: do not edit by hand -S3method(.is.delayed,default) -S3method(.is.delayed,list) -S3method(.is.delayed,pick) +S3method(.is_delayed,default) +S3method(.is_delayed,list) +S3method(.is_delayed,pick) S3method(.picker_icon,Date) -S3method(.picker_icon,MultiAssayExperiment) S3method(.picker_icon,POSIXct) S3method(.picker_icon,POSIXlt) S3method(.picker_icon,character) @@ -21,7 +20,6 @@ S3method(data_extract_multiple_srv,reactive) S3method(data_extract_srv,FilteredData) S3method(data_extract_srv,list) S3method(determine,datasets) -S3method(determine,mae_data) S3method(determine,values) S3method(determine,variables) S3method(filter_spec_internal,default) @@ -77,7 +75,6 @@ export(datasets) export(filter_spec) export(first_choice) export(first_choices) -export(format) export(format_data_extract) export(get_anl_relabel_call) export(get_dataset_prefixed_col_names) @@ -90,12 +87,10 @@ export(is_single_dataset) export(last_choice) export(last_choices) export(list_extract_spec) -export(mae_data) export(merge_datasets) export(merge_expression_module) export(merge_expression_srv) export(merge_srv) -export(no_more_choices_than) export(no_selected_as_NULL) export(picks) export(picks_srv) @@ -107,6 +102,7 @@ export(select_spec.default) export(select_spec.delayed_data) export(split_by_sep) export(teal_transform_filter) +export(tm_merge) export(value_choices) export(values) export(variable_choices) diff --git a/R/0-as_picks.R b/R/0-as_picks.R index a0c3425f..df605106 100644 --- a/R/0-as_picks.R +++ b/R/0-as_picks.R @@ -1,8 +1,8 @@ #' Convert data_extract_spec to picks #' #' Helper functions to ease transition between [data_extract_spec()] and [picks()]. +#' @inheritParams teal::teal_transform_module #' @param x (`data_extract_spec`, `select_spec`, `filter_spec`) object to convert to [`picks`] -#' #' @details #' With introduction of [`picks`], [`data_extract_spec`] will no longer serve a primary tool to #' define variable choices and default selection in teal-modules and eventually [`data_extract_spec`] @@ -51,18 +51,18 @@ #' ) #' #' @export -as.picks <- function(x, ...) { +as.picks <- function(x) { # nolint if (inherits(x, c("picks", "pick"))) { x } else if (checkmate::test_list(x, c("data_extract_spec", "filter_spec"))) { - Filter(length, lapply(x, as.picks, ...)) + Filter(length, lapply(x, as.picks)) } else if (inherits(x, "data_extract_spec")) { args <- Filter( length, list( datasets(choices = x$dataname, fixed = TRUE), as.picks(x$select), - as.picks(x$filter, dataname = x$dataname) + as.picks(x$filter) # filter_spec as they are not necessary linked with `select` (selected variables) # as filter_spec can be specified on the variable(s) different than select_spec for example: # for example: #pseudocode select = select_spec(AVAL); filter = filter_spec(PARAMCD)) @@ -72,7 +72,6 @@ as.picks <- function(x, ...) { } else if (inherits(x, "select_spec")) { .select_spec_to_variables(x) } else if (inherits(x, "filter_spec")) { - dataname <- list(...)$dataname # warning warning( "`filter_spec` are not convertible to picks - please use `transformers` argument", @@ -113,7 +112,7 @@ as.picks <- function(x, ...) { teal_transform_filter <- function(x, label = "Filter") { checkmate::assert_multi_class(x, c("data_extract_spec", "picks")) if (inherits(x, "data_extract_spec")) { - lapply(as.picks.filter(x), teal_transform_filter, label = label) + lapply(.as.picks.filter(x), teal_transform_filter, label = label) } else { checkmate::assert_true("values" %in% names(x)) teal::teal_transform_module( @@ -123,11 +122,10 @@ teal_transform_filter <- function(x, label = "Filter") { picks_ui(ns("transformer"), picks = x, container = div) }, server <- function(id, data) { - moduleServer(id, function(input, output, session) { + shiny::moduleServer(id, function(input, output, session) { selector <- picks_srv("transformer", picks = x, data = data) reactive({ req(data(), selector()) - # todo: make sure filter call is not executed when setequal(selected, all_possible_choices) filter_call <- .make_filter_call( datasets = selector()$datasets$selected, variables = selector()$variables$selected, @@ -141,7 +139,7 @@ teal_transform_filter <- function(x, label = "Filter") { } } -as.picks.filter <- function(x, dataname) { +.as.picks.filter <- function(x, dataname) { # nolint if (inherits(x, "filter_spec")) { if (inherits(x$choices, "delayed_data")) { warning( @@ -163,12 +161,12 @@ as.picks.filter <- function(x, dataname) { values(choices = x$choices, selected = x$selected, multiple = x$multiple) ) } else if (checkmate::test_list(x, "filter_spec")) { - lapply(x, as.picks.filter, dataname = dataname) + lapply(x, .as.picks.filter, dataname = dataname) } else if (inherits(x, "data_extract_spec")) { - as.picks.filter(x$filter, dataname = x$dataname) + .as.picks.filter(x$filter, dataname = x$dataname) } else if (checkmate::test_list(x, c("data_extract_spec", "list", "NULL"))) { unlist( - lapply(Filter(length, x), as.picks.filter), + lapply(Filter(length, x), .as.picks.filter), recursive = FALSE ) } diff --git a/R/0-badge_dropdown.R b/R/0-badge_dropdown.R index 0b42c58d..dc6885d2 100644 --- a/R/0-badge_dropdown.R +++ b/R/0-badge_dropdown.R @@ -1,13 +1,13 @@ -#' Dropdown badge +#' Drop-down badge #' -#' Dropdown button in a form of a badge with `bg-primary` as default style -#' Clicking badge shows a dropdown containing any `HTML` element. Folded dropdown +#' Drop-down button in a form of a badge with `bg-primary` as default style +#' Clicking badge shows a drop-down containing any `HTML` element. Folded drop-down #' doesn't trigger display output which means that items rendered using `render*` -#' will be recomputed only when dropdown is show. +#' will be recomputed only when drop-down is show. #' #' @param id (`character(1)`) shiny module's id #' @param label (`shiny.tag`) Label displayed on a badge. -#' @param ... (`shiny.tag`) Content of a dropdown. +#' @param content (`shiny.tag`) Content of a drop-down. #' @keywords internal badge_dropdown <- function(id, label, content) { ns <- shiny::NS(id) @@ -28,7 +28,11 @@ badge_dropdown <- function(id, label, content) { htmltools::tags$div( content, id = ns("inputs_container"), - style = "visibility: hidden; opacity: 0; pointer-events: none; position: absolute; background: white; border: 1px solid #ccc; border-radius: 4px; box-shadow: 0 2px 10px rgba(0,0,0,0.1); padding: 10px; z-index: 1000; min-width: 200px; transition: opacity 0.2s ease;", + style = paste( + "visibility: hidden; opacity: 0; pointer-events: none; position: absolute; background: white;", + "border: 1px solid #ccc; border-radius: 4px; box-shadow: 0 2px 10px rgba(0,0,0,0.1);", + "padding: 10px; z-index: 1000; min-width: 200px; transition: opacity 0.2s ease;" + ) ) ) ) diff --git a/R/0-call_utils.R b/R/0-call_utils.R index 5c1b6412..65a2347a 100644 --- a/R/0-call_utils.R +++ b/R/0-call_utils.R @@ -241,8 +241,8 @@ calls_combine_by <- function(operator, calls) { ) } -.call_dplyr_filter <- function(A) { - predicates <- lapply(unname(A), function(x) { +.call_dplyr_filter <- function(x) { + predicates <- lapply(unname(x), function(x) { if (is.numeric(x$values)) { call_condition_range(varname = x$variables, range = x$values) } else if (inherits(x$values, "Date")) { diff --git a/R/0-mae-methods.R b/R/0-mae-methods.R deleted file mode 100644 index 351ed224..00000000 --- a/R/0-mae-methods.R +++ /dev/null @@ -1,25 +0,0 @@ -#' @rdname picks -#' @export -mae_data <- function(choices = tidyselect::everything(), selected = 1L, multiple = FALSE) { - out <- .pick( - choices = if (.is_tidyselect(choices)) rlang::enquo(choices) else choices, - selected = if (.is_tidyselect(selected)) rlang::enquo(selected) else selected, - multiple = multiple - ) - class(out) <- c("mae_data", class(out)) - out -} - -#' @export -determine.mae_data <- function(x, data) { - if (!requireNamespace("SummarizedExperiment", quietly = TRUE)) { - stop("Requires SummarizedExperiment package from Bioconductor.") - } - data <- SummarizedExperiment::colData(data) - NextMethod("determine", x) -} - - -#' @keywords internal -#' @export -.picker_icon.MultiAssayExperiment <- function(x) "layer-group" diff --git a/R/0-module_merge.R b/R/0-module_merge.R index c5070e56..664edca8 100644 --- a/R/0-module_merge.R +++ b/R/0-module_merge.R @@ -27,17 +27,15 @@ #' Default is `"dplyr::inner_join"`. The function must accept `by` and `suffix` parameters. #' #' @return A `list` with two reactive elements: -#' \describe{ -#' \item{`data`}{A `reactive` returning a [teal.data::teal_data] object containing the merged dataset. +#' - `data`A `reactive` returning a [teal.data::teal_data] object containing the merged dataset. #' The merged dataset is named according to `output_name` parameter. The `teal_data` object includes: #' - The merged dataset with all selected variables #' - Complete R code to reproduce the merge operation -#' - Updated join keys reflecting the merged dataset structure} -#' \item{`variables`}{A `reactive` returning a named list mapping selector names to their selected +#' - Updated join keys reflecting the merged dataset structure +#' - `variables` A `reactive` returning a named list mapping selector names to their selected #' variables in the merged dataset. The structure is: #' `list(selector_name_1 = c("var1", "var2"), selector_name_2 = c("var3", "var4"), ...)`. -#' Variable names reflect any renaming that occurred during the merge to avoid conflicts.} -#' } +#' Variable names reflect any renaming that occurred during the merge to avoid conflicts. #' #' @section How It Works: #' @@ -63,7 +61,7 @@ #' - Joins datasets using specified join function and join keys #' - Maintains reproducibility through generated R code #' -#' 6. **Updates Join Keys**: Creates new join key relationships for the merged dataset ("anl") +#' 6. **Updates Join Keys**: Creates new join key relationships for the merged dataset (`"anl"`) #' relative to remaining datasets in the `teal_data` object #' #' 7. **Tracks Variables**: Keeps track of the variable names in the merged dataset @@ -142,7 +140,6 @@ #' - [teal.data::join_keys()] for defining dataset relationships #' #' @examples -#' \dontrun{ #' # Complete example with CDISC data #' library(teal.transform) #' library(teal.data) @@ -195,14 +192,11 @@ #' merged$variables() #' }) #' } -#' -#' shinyApp(ui, server) +#' if (interactive()) { +#' shinyApp(ui, server) #' } #' #' @export -# todo: merge_ui to display error message somewhere (at least) -# - if this dataset has no join_keys to anl (anl_datasets) then error saying -# can't merge {dataset} with merged dataset composed of {anl_datasets} merge_srv <- function(id, data, selectors, @@ -298,14 +292,13 @@ merge_srv <- function(id, this_variables <- this_variables[!duplicated(unname(this_variables))] # because unique drops names this_call <- .call_dplyr_select(dataname = dataname, variables = this_variables) - # todo: make sure filter call is not executed when setequal(selected, all_possible_choices) this_call <- calls_combine_by("%>%", c(this_call, .call_dplyr_filter(this_filter_mapping))) if (i > 1) { anl_vs_this <- setdiff(anl_primary_keys, this_primary_keys) this_vs_anl <- setdiff(this_primary_keys, anl_primary_keys) if (length(anl_vs_this) && length(this_vs_anl)) { - # validate(need(FALSE, "cartesian join")) # todo: add more info + warning("cartesian join - happens when primary keys A is not a subset of B and B is not a subset of A") } this_call <- as.call( list( @@ -489,7 +482,7 @@ merge_srv <- function(id, need( FALSE, sprintf( - "Cannot merge datasets. The following dataset%s no join keys defined: %s.\n\nPlease define join keys using teal.data::join_keys().", + "Cannot merge datasets. The following dataset%s no join keys defined: %s.\n\nPlease define `join_keys`.", if (length(datasets_without_keys) == 1) " has" else "s have", paste(sprintf("'%s'", datasets_without_keys), collapse = ", ") ) @@ -517,7 +510,10 @@ merge_srv <- function(id, need( FALSE, sprintf( - "Cannot merge dataset '%s'. No join keys found between '%s' and any of the accumulated datasets: %s.\n\nPlease define join keys using teal.data::join_keys().", + paste( + "Cannot merge dataset '%s'. No join keys found between '%s' and any of the accumulated datasets:", + "%s.\n\nPlease define join keys using teal.data::join_keys()." + ), current_dataset, current_dataset, paste(sprintf("'%s'", accumulated), collapse = ", ") @@ -535,7 +531,7 @@ merge_srv <- function(id, .validate_is_eager <- function(x) { validate(need( - !.is.delayed(x), + !.is_delayed(x), "selected values have not been resolved correctly. Please report this issue to an app-developer." )) } diff --git a/R/0-module_picks.R b/R/0-module_picks.R index dd5670e1..2b4b29a1 100644 --- a/R/0-module_picks.R +++ b/R/0-module_picks.R @@ -15,7 +15,7 @@ #' @param id (`character(1)`) Shiny module ID #' @param picks (`picks` or `list`) object created by `picks()` or a named list of such objects #' @param container (`character(1)` or `function`) UI container type. Can be one of `htmltools::tags` -#' functions. By default, elements are wrapped in a package-specific dropdown. +#' functions. By default, elements are wrapped in a package-specific drop-down. #' @param data (`reactive`) Reactive expression returning the data object to be used for populating choices #' #' @return @@ -60,9 +60,8 @@ picks_ui.picks <- function(id, picks, container) { ns <- shiny::NS(id) badge_label <- shiny::uiOutput(ns("summary"), container = htmltools::tags$span) - content <- lapply(picks, function(x) .pick_ui(id = ns(is(x)))) + content <- lapply(picks, function(x) .pick_ui(id = ns(methods::is(x)))) htmltools::tags$div( - # todo: badge to have css attribute to control the size - make CSS rule - can be controlled globally and module-ly if (missing(container)) { badge_dropdown(id = ns("inputs"), label = badge_label, htmltools::tagList(content)) } else { @@ -112,7 +111,11 @@ picks_srv.picks <- function(id, picks, data) { lapply( picks_resolved(), function(x) { - label <- if (length(x$selected)) { + label <- if (inherits(x, "values")) { + if (!setequal(x$choices, x$selected)) { + bsicons::bs_icon("funnel") + } + } else if (length(x$selected)) { toString(x$selected) } else { "~" @@ -239,7 +242,6 @@ picks_srv.picks <- function(id, picks, data) { args = args ) } else { - # todo: create .pick_ui_categorical for date/datetime etc. .pick_ui_categorical( session$ns("selected"), label = sprintf("Select %s:", pick_type), @@ -279,12 +281,12 @@ picks_srv.picks <- function(id, picks, data) { inputId = id, label = label, min = unname(choices[1]), - max = unname(tail(choices, 1)), + max = unname(utils::tail(choices, 1)), value = unname(selected) ) } -.pick_ui_categorical <- function(id, label, choices, selected, multiple, choicesOpt, args) { +.pick_ui_categorical <- function(id, label, choices, selected, multiple, choicesOpt, args) { # nolint htmltools::div( style = "max-width: 500px;", shinyWidgets::pickerInput( @@ -329,10 +331,10 @@ picks_srv.picks <- function(id, picks, data) { #' to unresolve (restart) dataset. #' - new value (selected) is replacing old value in current slot (i) #' - we call resolve which resolves only "unresolved" (delayed) values -#' - new picks is replacing reactiveValue +#' - new picks is replacing `reactiveValue` #' Thanks to this design reactive values are triggered only once #' @param selected (`vector`) rather `character`, or `factor`. `numeric(2)` for `values()` based on numeric column. -#' @param slot_idx (`integer`) +#' @param slot_name (`character(1)`) one of `c("datasets", "variables", "values")` #' @param picks_resolved (`reactiveVal`) #' @param old_picks (`picks`) #' @param data (`any` asserted further in `resolver`) diff --git a/R/0-picks.R b/R/0-picks.R index 4a3a6e79..229c04d9 100644 --- a/R/0-picks.R +++ b/R/0-picks.R @@ -3,9 +3,8 @@ #' Define choices and default selection for variables. `picks` allows app-developer to specify #' `datasets`, `variables` and `values` to be selected by app-user during Shiny session. #' Functions are based on the idea of `choices/selected` where app-developer provides `choices` -#' and what is `selected` by default. App-user though changes `selected` interactively in -#' [`picks_module`] -#' # todo: add note that values accepts predicates only +#' and what is `selected` by default. App-user changes `selected` interactively (see [`picks_module`]). +#' #' @param choices (`tidyselect::language` or `character`) #' Available values to choose. #' @param selected (`tidyselect::language` or `character`) @@ -21,12 +20,12 @@ #' #' Both `choices` and `selected` parameters support `tidyselect` syntax, enabling dynamic #' and flexible variable selection patterns. This allows choices to be determined at runtime -#' based on data characteristics rather than hardcoded values. +#' based on data characteristics rather than hard-coded values. #' -#' ## Using tidyselect for `choices` +#' ## Using `tidyselect` for `choices` and `selected` #' -#' When `choices` uses tidyselect, the available options are determined dynamically based on -#' the selected dataset's structure: +#' When `choices` uses `tidyselect`, the available options are determined dynamically based on actually +#' selected data: #' #' - `tidyselect::everything()` - All variables/datasets #' - `tidyselect::starts_with("prefix")` - Variables starting with a prefix @@ -37,15 +36,11 @@ #' - `tidyselect::all_of(vars)` - All specified variables (error if missing) #' - `tidyselect::any_of(vars)` - Any specified variables (silent if missing) #' - Range selectors like `Sepal.Length:Petal.Width` - Variables between two positions +#' - Integer indices (e.g., `1L`, `1L:3L`, `c(1L, 3L, 5L)`) - Select by position. Be careful, must be integer! #' -#' ## Using tidyselect for `selected` -#' -#' The `selected` parameter can use: -#' -#' - Numeric indices (e.g., `1`, `1:3`, `c(1, 3, 5)`) - Select by position -#' - Character vectors (e.g., `"Species"`, `c("mpg", "cyl")`) - Select by name -#' - `tidyselect::everything()` - Select all available choices -#' - Other tidyselect helpers as needed +#' The `selected` parameter can use the same syntax but it will be applied to the subset defined in choices. This +#' means that `choices = is.numeric, selected = is.factor` or `choices = c("a", "b", "c"), selected = c("d", "e")` +#' will imply en empty `selected`. #' #' **Warning:** Using explicit character values for `selected` with dynamic `choices` may #' cause issues if the selected values are not present in the dynamically determined choices. @@ -68,19 +63,20 @@ #' #' ## How dependencies work #' -#' - **Single dataset**: When `datasets(choices = "iris")` specifies one dataset, the -#' `variables()` choices are evaluated against that dataset's columns. +#' - **Fixed dataset**: When `datasets(choices = "iris")` specifies one dataset, the +#' `variables()` choices are evaluated against that dataset columns. #' -#' - **Multiple datasets**: When `datasets(choices = c("iris", "mtcars"))` allows multiple +#' - **Multiple dataset choices**: When `datasets(choices = c("iris", "mtcars"))` allows multiple #' options, `variables()` choices are re-evaluated each time the user selects a different #' dataset. This creates a reactive dependency where variable choices update automatically. #' -#' - **Dynamic datasets**: When using `datasets(choices = tidyselect::where(is.data.frame))`, +#' - **Dynamic dataset choices**: When using `datasets(choices = tidyselect::where(is.data.frame))`, #' all available data frames are discovered at runtime, and variable choices adapt to #' whichever dataset the user selects. #' #' - **Variable to values**: Similarly, `values()` choices are evaluated based on the -#' selected variable(s), allowing users to filter specific levels or values. +#' selected variable(s), allowing users to filter specific levels or values. When multiple +#' variables are selected, then values will be a concatenation of the columns. #' #' ## Best practices #' @@ -92,18 +88,98 @@ #' - Use numeric indices for `selected` when `choices` are dynamic to avoid referencing #' variables that may not exist in all datasets #' +#' ## Important: `values()` requires type-aware configuration +#' +#' ### Why `values()` is different from `datasets()` and `variables()` +#' +#' `datasets()` and `variables()` operate on named lists of objects, meaning they work with character-based +#' identifiers. This allows you to use text-based selectors like `starts_with("S")` or `contains("prefix")` +#' consistently for both datasets and variable names. +#' +#' `values()` is fundamentally different because it operates on the **actual data content** within a +#' selected variable (column). The type of data in the column determines what kind of filtering makes sense: +#' +#' - **`numeric` columns** (e.g., `age`, `height`, `price`) contain numbers +#' - **`character`/`factor` columns** (e.g., `country`, `category`, `status`) contain categorical values +#' - **`Date`/`POSIXct` columns** contain temporal data +#' - **`logical` columns** contain TRUE/FALSE values +#' +#' ### Type-specific UI controls +#' +#' The `values()` function automatically renders different UI controls based on data type: +#' +#' - **`numeric` data**: Creates a `sliderInput` for range selection +#' - `choices` must be a numeric vector of length 2: `c(min, max)` +#' - `selected` must be a numeric vector of length 2: `c(selected_min, selected_max)` +#' +#' - **Categorical data** (`character`/`factor`): Creates a `pickerInput` for discrete selection +#' - `choices` can be a character vector or predicate function +#' - `selected` can be specific values or a predicate function +#' +#' - **`Date`/`POSIXct` data**: Creates date/datetime range selectors +#' - `choices` must be a Date or `POSIXct` vector of length 2 +#' +#' - **`logical` data**: Creates a checkbox or picker for TRUE/FALSE selection +#' +#' ### Developer responsibility +#' +#' **App developers must ensure `values()` configuration matches the variable type:** +#' +#' 1. **Know your data**: Understand what type of variable(s) users might select +#' 2. **Configure appropriately**: Set `choices` and `selected` to match expected data types +#' 3. **Use predicates for flexibility**: When variable type is dynamic, use predicate functions +#' like `function(x) !is.na(x)` (the default) to handle multiple types safely +#' +#' ### Examples of correct usage +#' +#' ```r +#' # For a numeric variable (e.g., age) +#' picks( +#' datasets(choices = "demographic"), +#' variables(choices = "age", multiple = FALSE), +#' values(choices = c(0, 100), selected = c(18, 65)) +#' ) +#' +#' # For a categorical variable (e.g., country) +#' picks( +#' datasets(choices = "demographic"), +#' variables(choices = "country", multiple = FALSE), +#' values(choices = c("USA", "Canada", "Mexico"), selected = "USA") +#' ) +#' +#' # Safe approach when variable type is unknown - use predicates +#' picks( +#' datasets(choices = "demographic"), +#' variables(choices = tidyselect::everything(), selected = 1L), +#' values(choices = function(x) !is.na(x), selected = function(x) !is.na(x)) +#' ) +#' ``` +#' +#' ### Common mistakes to avoid +#' +#' ```r +#' # WRONG: Using string selectors for numeric data +#' values(choices = starts_with("5")) # Doesn't make sense for numeric data! +#' +#' # WRONG: Providing categorical choices for a numeric variable +#' values(choices = c("low", "medium", "high")) # Won't work if variable is numeric! +#' +#' # WRONG: Providing numeric range for categorical variable +#' values(choices = c(0, 100)) # Won't work if variable is factor/character! +#' ``` +#' #' ## Example: Three-level hierarchy #' #' ```r #' picks( #' datasets(choices = c("iris", "mtcars"), selected = "iris"), -#' variables(choices = tidyselect::where(is.numeric), selected = 1), -#' values(choices = tidyselect::everything(), selected = 1:10) +#' variables(choices = tidyselect::where(is.numeric), selected = 1L), +#' values(choices = tidyselect::everything(), selected = seq_len(10)) #' ) #' ``` #' #' In this example: -#' - User first selects a dataset (iris or mtcars) +#' - User first selects a dataset (`iris` or `mtcars`) #' - Variable choices update to show only numeric columns from selected dataset #' - After selecting a variable, value choices show all unique values from that column #' @@ -111,7 +187,7 @@ #' # Select columns from iris dataset using range selector #' picks( #' datasets(choices = "iris"), -#' variables(choices = Sepal.Length:Petal.Width, selected = 1) +#' variables(choices = Sepal.Length:Petal.Width, selected = 1L) #' ) #' #' # Single variable selection from iris dataset @@ -123,31 +199,31 @@ #' # Dynamic selection: any variable from iris, first selected by default #' picks( #' datasets(choices = "iris", selected = "iris"), -#' variables(choices = tidyselect::everything(), selected = 1, multiple = FALSE) +#' variables(choices = tidyselect::everything(), selected = 1L, multiple = FALSE) #' ) #' #' # Multiple dataset choices: variable choices will update when dataset changes #' picks( #' datasets(choices = c("iris", "mtcars"), selected = "iris"), -#' variables(choices = tidyselect::everything(), selected = 1, multiple = FALSE) +#' variables(choices = tidyselect::everything(), selected = 1L, multiple = FALSE) #' ) #' #' # Select from any dataset, filter by numeric variables #' picks( -#' datasets(choices = c("iris", "mtcars"), selected = 1), -#' variables(choices = tidyselect::where(is.numeric), selected = 1) +#' datasets(choices = c("iris", "mtcars"), selected = 1L), +#' variables(choices = tidyselect::where(is.numeric), selected = 1L) #' ) #' #' # Fully dynamic: auto-discover datasets and variables #' picks( -#' datasets(choices = tidyselect::where(is.data.frame), selected = 1), -#' variables(choices = tidyselect::everything(), selected = 1, multiple = FALSE) +#' datasets(choices = tidyselect::where(is.data.frame), selected = 1L), +#' variables(choices = tidyselect::everything(), selected = 1L, multiple = FALSE) #' ) #' #' # Select categorical variables with length constraints #' picks( -#' datasets(choices = tidyselect::everything(), selected = 1), -#' variables(choices = is_categorical(min.len = 2, max.len = 15), selected = 1:2) +#' datasets(choices = tidyselect::everything(), selected = 1L), +#' variables(choices = is_categorical(min.len = 2, max.len = 15), selected = seq_len(2)) #' ) #' #' @export @@ -174,9 +250,9 @@ picks <- function(...) { previous_has_dynamic_choices <- c( FALSE, - vapply(head(picks, -1), FUN.VALUE = logical(1), FUN = .is.delayed) + vapply(utils::head(picks, -1), FUN.VALUE = logical(1), FUN = .is_delayed) ) - has_eager_choices <- vapply(picks, function(x) !.is.delayed(x$choices), logical(1)) + has_eager_choices <- vapply(picks, function(x) !.is_delayed(x$choices), logical(1)) if (any(previous_has_dynamic_choices & has_eager_choices)) { idx_wrong <- which(previous_has_dynamic_choices & has_eager_choices)[1] @@ -338,7 +414,7 @@ values <- function(choices = function(x) !is.na(x), ) } -#' Is an object created using tidyselect +#' Is an object created using `tidyselect` #' #' @description #' `choices` and `selected` can be provided using `tidyselect`, (e.g. [tidyselect::everything()] @@ -387,25 +463,25 @@ values <- function(choices = function(x) !is.na(x), #' When [pick()] is created it could be either: #' - `quosure` when `tidyselect` helper used (delayed) #' - `function` when predicate function provided (delayed) -#' - `atomic` when vector of choices/selcted provided (eager) +#' - `atomic` when vector of choices/selected provided (eager) #' @param x (`list`, `list of picks`, `picks`, `pick`, `$choices`, `$selected`) #' @keywords internal -.is.delayed <- function(x) { - UseMethod(".is.delayed") +.is_delayed <- function(x) { + UseMethod(".is_delayed") } #' @export -.is.delayed.list <- function(x) { - any(vapply(x, .is.delayed, logical(1))) +.is_delayed.list <- function(x) { + any(vapply(x, .is_delayed, logical(1))) } #' @export -.is.delayed.pick <- function(x) { - .is.delayed(x$choices) | .is.delayed(x$selected) +.is_delayed.pick <- function(x) { + .is_delayed(x$choices) | .is_delayed(x$selected) } #' @export -.is.delayed.default <- function(x) { +.is_delayed.default <- function(x) { rlang::is_quosure(x) | is.function(x) } diff --git a/R/0-print.R b/R/0-print.R index 584d4299..2bb09f07 100644 --- a/R/0-print.R +++ b/R/0-print.R @@ -11,12 +11,7 @@ print.picks <- function(x, ...) { } #' @export -format <- function(x, indent = 0) { - UseMethod("format") -} - -#' @export -format.picks <- function(x, indent = 0) { +format.picks <- function(x, indent = 0, ...) { out <- .indent(sprintf("%s\n", .bold("")), indent) for (i in seq_along(x)) { element_name <- names(x)[i] @@ -28,7 +23,7 @@ format.picks <- function(x, indent = 0) { } #' @export -format.pick <- function(x, indent = 0) { +format.pick <- function(x, indent = 0, ...) { element_class <- setdiff(class(x), "pick")[1] out <- .indent(sprintf("%s\n", .bold(sprintf("<%s>", element_class))), indent) out <- paste0(out, .format_pick_content(x, indent + 2)) diff --git a/R/0-resolver.R b/R/0-resolver.R index 1da5cbb1..034d6521 100644 --- a/R/0-resolver.R +++ b/R/0-resolver.R @@ -1,7 +1,7 @@ #' Resolve `picks` #' #' Resolve iterates through each `picks` element and determines values . -#' @param picks ([picks()]) settings for picks. +#' @param x ([picks()]) settings for picks. #' @param data ([teal_data()] `environment` or `list`) any data collection supporting object extraction with `[[`. #' Used to determine values of unresolved `picks`. #' @@ -9,16 +9,13 @@ #' @export #' #' @examples -#' # todo: fix example to use environment or a list -#' x1 <- datasets(where(is.data.frame)) -#' x2 <- picks(x1, variables("a", "a")) -#' data <- within(teal.data::teal_data(), { -#' df <- data.frame(a = as.factor(LETTERS[1:5]), b = letters[1:5]) -#' df2 <- data.frame(a = LETTERS[1:5], b = 1:5) -#' m <- matrix() -#' }) -#' resolver(x = x1, data = data) -#' resolver(x = x2, data = data) +#' x <- picks(datasets(tidyselect::where(is.data.frame)), variables("a", "a")) +#' data <- list( +#' df1 = data.frame(a = as.factor(LETTERS[1:5]), b = letters[1:5]), +#' df2 = data.frame(a = LETTERS[1:5], b = 1:5), +#' m = matrix() +#' ) +#' resolver(x = x, data = data) resolver <- function(x, data) { checkmate::assert_class(x, "picks") checkmate::assert( @@ -34,7 +31,6 @@ resolver <- function(x, data) { x } - #' A method that should take a type and resolve it. #' #' Generic that makes the minimal check on spec. @@ -43,7 +39,7 @@ resolver <- function(x, data) { #' @param data The minimal data required. #' @return A list with two elements, the `type` resolved and the data extracted. #' @keywords internal -determine <- function(x, data, ...) { +determine <- function(x, data) { if (is.null(data)) { # this happens when $selected=NULL return(list(x = .nullify_pick(x))) } @@ -82,16 +78,15 @@ determine.variables <- function(x, data) { #' @export determine.values <- function(x, data) { - data <- if (ncol(data) > 1) { # todo: to limit number of possible columns to concat + data <- if (ncol(data) > 1) { apply(data, 1, toString) } else { data[[1]] } - # todo: what to do with NA choices? x$choices <- .determine_choices(x$choices, data = data) # .determine_* uses names x$selected <- if (length(x$choices)) { - .determine_selected(x$selected, data = setNames(x$choices, x$choices), multiple = attr(x, "multiple")) + .determine_selected(x$selected, data = stats::setNames(x$choices, x$choices), multiple = attr(x, "multiple")) } list(x = x) # no picks element possible after picks(..., values) (no need to pass data further) } @@ -101,6 +96,7 @@ determine.values <- function(x, data) { #' #' @param data (`list`, `data.frame`, `vector`) #' @param x (`character`, `quosure`, `function(x)`) to determine `data` elements to extract. +#' @param multiple (`logical(1)`) whether multiple selection is possible. #' #' @details #' @@ -112,7 +108,7 @@ determine.values <- function(x, data) { #' - `x (tidyselect-helper)`: using [tidyselect::eval_select] #' - `x (function)`: function is executed on each element of `data` to determine where function returns TRUE #' -#' Mechnism is robust in a sense that it never fails (`tryCatch`) and returns `NULL` if no-match found. `NULL` +#' Mechanism is robust in a sense that it never fails (`tryCatch`) and returns `NULL` if no-match found. `NULL` #' in [determine()] is handled gracefully, by setting `NULL` to all following components of `picks`. #' #' In the examples below you can replace `.determine_delayed` with `.determine_choices` or `.determine_selected`. @@ -144,14 +140,15 @@ determine.values <- function(x, data) { #' @keywords internal .determine_choices <- function(x, data) { out <- .determine_delayed(data = data, x = x) - if (!is.null(names(data)) && !is.atomic(data) && # only named non-atomic can have label - is.character(out) && is.null(names(out))) { # don't rename if names provided by app dev + if (!is.null(names(data)) && !is.atomic(data) && is.character(out) && is.null(names(out))) { + # only named non-atomic can have label + # don't rename if names provided by app dev labels <- vapply( out, FUN = function(choice) c(attr(data[[choice]], "label"), choice)[1], FUN.VALUE = character(1) ) - setNames(out, labels) + stats::setNames(out, labels) } else { out } diff --git a/R/0-tidyselect-helpers.R b/R/0-tidyselect-helpers.R index 2d2565a2..a9b94b4c 100644 --- a/R/0-tidyselect-helpers.R +++ b/R/0-tidyselect-helpers.R @@ -2,25 +2,15 @@ #' #' #' @examples -#' # select keys (primary and foreign) -#' variables(choices = is_key()) -#' #' # select factor column but exclude foreign keys -#' variables(choices = where(~ is.factor(.x) & !is_foreign_key())) +#' variables(choices = is_categorical(min.len = 2, max.len = 10)) +#' #' @name tidyselectors - -# developer notes: -# in determine join_keys are handed over and in determine.variables attributes are assigned to -# the data columns. It is internally controlled process and it is designed like this because: -# - tidyselect functions don't accept arguments from outside so we can't add join_keys of selected dataset -# during eval_select. -# - having predicates to be utilized by `tidyselect::where` is `tidyselect` compatible and more predictable - #' @rdname tidyselectors #' @param min.len (`integer(1)`) minimal number of unique values #' @param max.len (`integer(1)`) maximal number of unique values #' @export -is_categorical <- function(max.len, min.len) { +is_categorical <- function(min.len, max.len) { # todo: consider making a function which can exit earlier when max.len > length(unique(x)) < min.len # without a need to compute unique on the whole vector. if (missing(max.len) && missing(min.len)) { @@ -43,11 +33,3 @@ is_categorical <- function(max.len, min.len) { } } } - -#' @rdname tidyselectors -#' @export -no_more_choices_than <- function(max.len) { - # todo: consider making a function which can exit earlier when max.len > length(unique(x)) < min.len - # without a need to compute unique on the whole vector. - function(x) length(unique(x)) <= max.len -} diff --git a/R/0-tm_merge.R b/R/0-tm_merge.R index 911127b0..632f3152 100644 --- a/R/0-tm_merge.R +++ b/R/0-tm_merge.R @@ -1,13 +1,48 @@ #' Merge module #' +#' Example [`teal::module`] containing interactive inputs and displaying results of merge. +#' +#' @inheritParams teal::module #' @param picks (`list` of `picks`) -#' Example module +#' @examples +#' library(teal) +#' +#' data <- within(teal.data::teal_data(), { +#' iris <- iris +#' mtcars <- mtcars +#' }) +#' +#' app <- init( +#' data = data, +#' modules = modules( +#' modules( +#' label = "Testing modules", +#' tm_merge( +#' label = "non adam", +#' picks = list( +#' a = picks( +#' datasets("iris", "iris"), +#' variables( +#' choices = c("Sepal.Length", "Species"), +#' selected = +#' ), +#' values() +#' ) +#' ) +#' ) +#' ) +#' ) +#' ) +#' if (interactive()) { +#' shinyApp(app$ui, app$server, enableBookmarking = "server") +#' } +#' +#' @export tm_merge <- function(label = "merge-module", picks, transformators = list()) { - # todo: move to vignette - module( + teal::module( label = label, ui = function(id, picks) { - ns <- NS(id) + ns <- shiny::NS(id) tags$div( tags$div( class = "row g-2", @@ -23,7 +58,7 @@ tm_merge <- function(label = "merge-module", picks, transformators = list()) { }) ), shiny::div( - reactable::reactableOutput(ns("table_merged")), + shiny::tableOutput(ns("table_merged")), shiny::verbatimTextOutput(ns("join_keys")), shiny::verbatimTextOutput(ns("mapped")), shiny::verbatimTextOutput(ns("src")) @@ -38,18 +73,16 @@ tm_merge <- function(label = "merge-module", picks, transformators = list()) { table_q <- reactive({ req(merged$data()) - within(merged$data(), reactable::reactable(anl), selectors = selectors) + within(merged$data(), anl, selectors = selectors) }) - output$table_merged <- reactable::renderReactable({ + output$table_merged <- shiny::tableOutput({ req(table_q()) teal.code::get_outputs(table_q())[[1]] }) output$src <- renderPrint({ - styler::style_text( - teal.code::get_code(req(table_q())) - ) + cat(teal.code::get_code(req(table_q()))) }) output$mapped <- renderText(yaml::as.yaml(merged$variables())) diff --git a/R/choices_selected.R b/R/choices_selected.R index 197a58c8..771f3e53 100644 --- a/R/choices_selected.R +++ b/R/choices_selected.R @@ -95,11 +95,11 @@ no_select_keyword <- "-- no selection --" #' choices_selected(choices = letters, selected = all_choices()) #' #' choices_selected( -#' choices = setNames(LETTERS[1:5], paste("Letter", LETTERS[1:5])), +#' choices = stats::setNames(LETTERS[1:5], paste("Letter", LETTERS[1:5])), #' selected = "E" #' ) #' choices_selected( -#' choices = setNames(LETTERS[1:5], paste("Letter", LETTERS[1:5])), +#' choices = stats::setNames(LETTERS[1:5], paste("Letter", LETTERS[1:5])), #' selected = last_choice() #' ) #' diff --git a/R/data_extract_filter_module.R b/R/data_extract_filter_module.R index d87a6d85..00bcea1c 100644 --- a/R/data_extract_filter_module.R +++ b/R/data_extract_filter_module.R @@ -70,7 +70,7 @@ data_extract_filter_srv <- function(id, datasets, filter) { # when the filter is initialized with a delayed spec, the choices and selected are NULL # here delayed are resolved and the values are set up # Begin by resolving delayed choices. - if (inherits(filter$selected, "delayed_choices")) { + if (inherits(filter$selected, "delayed_choices")) { filter$selected <- filter$selected(filter$choices) } teal.widgets::updateOptionalSelectInput( @@ -106,7 +106,6 @@ data_extract_filter_srv <- function(id, datasets, filter) { } else { choices[1] } - } else { choices <- character(0) selected <- character(0) diff --git a/R/get_merge_call.R b/R/get_merge_call.R index b319299b..5646f37a 100644 --- a/R/get_merge_call.R +++ b/R/get_merge_call.R @@ -383,16 +383,14 @@ get_anl_relabel_call <- function(columns_source, datasets, anl_name = "ANL") { column_labels <- labels[intersect(colnames(data_used()), column_names)] # NULL for no labels at all, character(0) for no labels for a given columns - return( - if (rlang::is_empty(column_labels)) { - column_labels - } else { - stats::setNames( - column_labels, - selector[names(column_labels)] - ) - } - ) + if (rlang::is_empty(column_labels)) { + column_labels + } else { + stats::setNames( + column_labels, + selector[names(column_labels)] + ) + } } ) ) diff --git a/inst/WORDLIST b/inst/WORDLIST index f6b2e6ca..5b22b1f8 100644 --- a/inst/WORDLIST +++ b/inst/WORDLIST @@ -1,3 +1,4 @@ +Analyse CDISC cloneable colData @@ -8,5 +9,8 @@ preselected qenv repo reproducibility +schemas Shinylive +th UI +unresolve diff --git a/inst/refactor-notes.md b/inst/refactor-notes.md index 44868eae..0dfe3342 100644 --- a/inst/refactor-notes.md +++ b/inst/refactor-notes.md @@ -1,15 +1,33 @@ ---- -title: "Refactor Notes" -author: "Development Team" -date: "`r Sys.Date()`" -output: html_document ---- +# Table of Contents + +- [Table of Contents](#table-of-contents) +- [Motivation](#motivation) + - [Merging relational data](#merging-relational-data) + - [Handling ambiguous variables](#handling-ambiguous-variables) + - [Merging interactively](#merging-interactively) +- [Configure possible selection](#configure-possible-selection) + - [picks and choices/selected](#picks-and-choicesselected) + - [Relationship between `picks` elements](#relationship-between-picks-elements) + - [Example settings](#example-settings) + - [Strict variables picks](#strict-variables-picks) + - [Dynamic variables choices](#dynamic-variables-choices) + - [Dynamic variables from multiple datasets](#dynamic-variables-from-multiple-datasets) + - [Dynamic everything](#dynamic-everything) + - [Implementation in `teal_module`](#implementation-in-teal_module) + - [App example](#app-example) + - [Select specific variable(s) from a specific dataset](#select-specific-variables-from-a-specific-dataset) + - [Select specific variable(s) from a selected dataset](#select-specific-variables-from-a-selected-dataset) + - [Select unknown variable(s) from a selected dataset](#select-unknown-variables-from-a-selected-dataset) + - [filtering by any variable](#filtering-by-any-variable) + - [Conversion from to data-extract-spec](#conversion-from-to-data-extract-spec) + - [Issues with `data_extract_spec`](#issues-with-data_extract_spec) + - [Bad encapsulation](#bad-encapsulation) + - [Hard to extend](#hard-to-extend) # Motivation ## Merging relational data - Consider following tables `orders`, `order_items`, `products`, `customers` connected with join keys following sql convention `{child}.{$parent}_id = {$parent+"s"}.id`, for example `orders.customer_id = customers.id`. `teal.data` setup would look like this: @@ -220,13 +238,15 @@ Developing system which can interactively handle merge is a challenging task not but also due to additional layers which need to control described operation. These layers include: 1. Providing an API for app-developer to enable and set specific merge configuration. -2. Providing robust, easy to use merge-modules which can handle weirdest app-developer needs (1) and provide meaningful information to the app-user about consequences of the data/variable selections. +2. Handling reactive relationship between all inputs (dataset -> variable -> value) and avoid unnecessary triggers. +3. Providing robust, easy to use merge-modules which can handle weirdest app-developer needs (1) and provide meaningful information to the app-user about consequences of the data/variable selections. -# 1. Configure possible selection +# Configure possible selection ## picks and choices/selected -We came with an idea of `picks` which allows app-developer to specify `datasets`, `variables` and `values` to be selected by app-user during an app run. Each of them is based on the idea of `choices/selected` where app-developer +We came with an idea of `picks` which allows app-developer to specify `datasets`, `variables` and `values` to be +selected by app-user during an app run. Each of them is based on the idea of `choices/selected` where app-developer provides `choices` and what is `selected` by default. App-user though changes `selected` interactively. ```mermaid @@ -267,12 +287,12 @@ graph TB New design bases on an idea that a module can consume its arguments referring to any variable in any dataset. Consider following example, where: - a module uses `x`, `y` and `facet` arguments to create an interactive inputs, - user can select a variable from any dataset for `x`, `y`, `facet` -- visualization will be build on a merged dataset containing these three variables +- visualization will be build on a merged dataset containing these three variables. ```r # pseudocode tm_example <- function(x, y, facet) { - ui = function(id, x, y, facet) ...., # creates placeholders for inputs + ui = function(id, x, y, facet) ...., # inputs will be here server = function(id, x, y, facet) { moduleServer(id, function(input, output, session) { output$plot <- renderPlot({ @@ -292,7 +312,7 @@ tm_example <- function(x, y, facet) { To provide choices and default selection for `x`, `y` and `facet` we propose following api:
-Proposed API using picks() for variable selection +Proposed API using picks() for variable selection ```r # pseudocode @@ -315,9 +335,9 @@ tm_example(
Where each function creates an object which holds the information consumed by the framework. `choices` and `selected` can be either: -- explicit character denoting the name of the objects -- Natural number denoting index of column - `tidyselect` selection_helpers (`?tidyselect::language`) +- Integer denoting index of column(s) +- explicit character denoting the name of the objects/columns/level ## Relationship between `picks` elements @@ -357,8 +377,6 @@ graph TB style VAR_Choices stroke-width:3px ``` - - ## Example settings Please read carefully the code and see the description to understand how `picks` work. @@ -427,6 +445,7 @@ picks( + ## Implementation in `teal_module` `teal_module` will accept `x`, `y` and `facet` and hand-over them to both `ui` and `server`. @@ -523,7 +542,7 @@ srv_example <- function(id, data, x, y, facet) { -## App example +### App example
Complete working app example with relational data and dynamic merging @@ -786,8 +805,6 @@ shinyApp(app$ui, app$server, enableBookmarking = "server")
-## Conversion from to data-extract-spec - ### Select specific variable(s) from a specific dataset ``` @@ -927,3 +944,107 @@ transformators = teal_transform_module( ) ``` + +## Conversion from to data-extract-spec + +`picks` will completelly replace `data_extract_spec` (des) and will be the only tool to select-and-merge +in `teal` framework. So far des will be supported as soft deprecated. `help("as.picks")` +contains the information how to convert des into picks but in a limited scope. +- `data_extract_spec` (or a list of des) containing only `select_spec` are convertible 1:1 to the `picks` +- `filter_spec` is not convertible to `picks` as it variables used in filter can be different than variables selected in `select_spec`, thus hierarchical form of `picks` can't handle this case. +- `filter_spec` can be converted to `teal_transform_module` and used in `transformators` argument instead and we recommend to do so. `teal.transform::teal_transform_filter` provides a simplified way to create such `transformator`. + + +### Issues with `data_extract_spec` + +API of `data_extract_spec` is bad encapsulation, hard to extend, confusing and easy to break. + +#### Bad encapsulation + +In `filter_spec` one can specify `choices = value_choices(dataname, subset = function(data))`, this is vulnerable +for multiple failures: + +- `value_choices("dataname")` can be completelly different than `data_extract_spec(dataname)`, guess what happens? ;] +- `subset = function(data)` is a function of a dataset, it means that even if `vars = "Species"` has been provideed one still have to do `levels(data$Species)` instead of `levels(column)` + +As you can see, there are few places where scope of the classes is not well separated which leads to: + +- repeating same information on multiple levels of the hierarchy `data_extract_spec(dataname)` and `value_choices(dataname)`, `vars = "Species"`, `levels(data$Species)` +- Repeating the same information also requires to be cautious to have both places correctly specified, otherwise error will occur + +```r +data_extract_spec( + dataname = "iris", + select = select_spec( + choices = variable_choices(subset = function(data) names(data)) + selected = "Sepal.Length" + ), + filter = filter_spec( + vars = "Species", + choices = value_choices("iris, subset = function(data) levels(data$Species)), + selected = first_choice() + ) +) +``` + +Conclusion: + +- `value_choices(data)` shouldn't have an argument `data` as it is "given" by the `data_extract_spec`. Same applies to `variable_choices(data)`. +- `value_choices(subset = function(data))` should be a function of column which is set in `filter_spec(vars)` + +#### Hard to extend + +Recently one user asked to make `data_extract_spec(datanames)` delayed, so that it will adjust automatically to the existing datasets when resolved. Problem is API allow to have des for multiple datasets only when one knows their names. It is just done by making a list-of-des. Following code will produce dropdown with "iris" and "mtcars" and app-user will be able to switch between datasets (switching between des) + +```r +# pseudocode +list( + data_extract_spec(dataname = "iris", ...), + data_extract_spec(dataname = "mtcars", ...) +) +``` + +Proposition was that `dataname = dataset_choices()`, similar to the `filter_spec(vars = variable_choices())`. Let's consider how would it look like: + +```r +data_extract_spec( + dataname = dataset_choices(choices = all_datasets(), selected = first_choice()), + select = select_spec( + choices = variable_choices(dataname = ??, choices = function(x) names(data)) + ) + filter = filter_spec( + vars = variable_choices(dataname = ??, choices = function(x) names(data)), # how to obtain delayed `dataname` + choices = value_choices(dataname = ??, choices = function(x) data$?? |> levels()) # how to obtain delayed `vars` + ) +) +``` + +To achive this, package would have to be seriously refactored, to be able to do following: + +```r +data_extract_spec( + dataname = dataset_choices(choices = all_datasets(), selected = first_choice()), + select = select_spec( + choices = variable_choices(choices = function(x) names(data)) + ), + filter = filter_spec( + vars = variable_choices(choices = function(data) names(data)), + choices = value_choices(choices = function(column) column |> levels()) + ) +) +``` + +Let's just use above example and change function names: + +``` +picks( + datanames(choices = all_datasets(), selected = first_choice()), + variables( + choices = variable_choices(choices = function(x) names(data)) + ), + values( + vars = variable_choices(choices = function(data) names(data)), + choices = value_choices(choices = function(column) column |> levels()) + ) +) +``` diff --git a/man/as.picks.Rd b/man/as.picks.Rd index 5b5e5cef..8102f105 100644 --- a/man/as.picks.Rd +++ b/man/as.picks.Rd @@ -5,12 +5,14 @@ \alias{teal_transform_filter} \title{Convert data_extract_spec to picks} \usage{ -as.picks(x, ...) +as.picks(x) teal_transform_filter(x, label = "Filter") } \arguments{ \item{x}{(\code{data_extract_spec}, \code{select_spec}, \code{filter_spec}) object to convert to \code{\link{picks}}} + +\item{label}{(\code{character(1)}) Label of the module.} } \description{ Helper functions to ease transition between \code{\link[=data_extract_spec]{data_extract_spec()}} and \code{\link[=picks]{picks()}}. diff --git a/man/badge_dropdown.Rd b/man/badge_dropdown.Rd index 97df8808..fb6c66e0 100644 --- a/man/badge_dropdown.Rd +++ b/man/badge_dropdown.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/0-badge_dropdown.R \name{badge_dropdown} \alias{badge_dropdown} -\title{Dropdown badge} +\title{Drop-down badge} \usage{ badge_dropdown(id, label, content) } @@ -11,12 +11,12 @@ badge_dropdown(id, label, content) \item{label}{(\code{shiny.tag}) Label displayed on a badge.} -\item{...}{(\code{shiny.tag}) Content of a dropdown.} +\item{content}{(\code{shiny.tag}) Content of a drop-down.} } \description{ -Dropdown button in a form of a badge with \code{bg-primary} as default style -Clicking badge shows a dropdown containing any \code{HTML} element. Folded dropdown +Drop-down button in a form of a badge with \code{bg-primary} as default style +Clicking badge shows a drop-down containing any \code{HTML} element. Folded drop-down doesn't trigger display output which means that items rendered using \verb{render*} -will be recomputed only when dropdown is show. +will be recomputed only when drop-down is show. } \keyword{internal} diff --git a/man/choices_selected.Rd b/man/choices_selected.Rd index 028bdd54..fa645d20 100644 --- a/man/choices_selected.Rd +++ b/man/choices_selected.Rd @@ -119,11 +119,11 @@ choices_selected(choices = letters, selected = letters) choices_selected(choices = letters, selected = all_choices()) choices_selected( - choices = setNames(LETTERS[1:5], paste("Letter", LETTERS[1:5])), + choices = stats::setNames(LETTERS[1:5], paste("Letter", LETTERS[1:5])), selected = "E" ) choices_selected( - choices = setNames(LETTERS[1:5], paste("Letter", LETTERS[1:5])), + choices = stats::setNames(LETTERS[1:5], paste("Letter", LETTERS[1:5])), selected = last_choice() ) diff --git a/man/determine.Rd b/man/determine.Rd index 97f71e1e..24a6dcc4 100644 --- a/man/determine.Rd +++ b/man/determine.Rd @@ -4,7 +4,7 @@ \alias{determine} \title{A method that should take a type and resolve it.} \usage{ -determine(x, data, ...) +determine(x, data) } \arguments{ \item{x}{The specification to resolve.} diff --git a/man/dot-determine_choices.Rd b/man/dot-determine_choices.Rd index f15e8464..fb2c22bb 100644 --- a/man/dot-determine_choices.Rd +++ b/man/dot-determine_choices.Rd @@ -19,6 +19,8 @@ \item{x}{(\code{character}, \code{quosure}, \verb{function(x)}) to determine \code{data} elements to extract.} \item{data}{(\code{list}, \code{data.frame}, \code{vector})} + +\item{multiple}{(\code{logical(1)}) whether multiple selection is possible.} } \value{ \code{character} containing names/levels of \code{data} elements which match \code{x}, with two differences: @@ -41,7 +43,7 @@ Function resolves \code{x} to determine \code{choices} or \code{selected}. \code \item \verb{x (function)}: function is executed on each element of \code{data} to determine where function returns TRUE } -Mechnism is robust in a sense that it never fails (\code{tryCatch}) and returns \code{NULL} if no-match found. \code{NULL} +Mechanism is robust in a sense that it never fails (\code{tryCatch}) and returns \code{NULL} if no-match found. \code{NULL} in \code{\link[=determine]{determine()}} is handled gracefully, by setting \code{NULL} to all following components of \code{picks}. In the examples below you can replace \code{.determine_delayed} with \code{.determine_choices} or \code{.determine_selected}. diff --git a/man/dot-is.delayed.Rd b/man/dot-is_delayed.Rd similarity index 81% rename from man/dot-is.delayed.Rd rename to man/dot-is_delayed.Rd index 22d01ade..2c561496 100644 --- a/man/dot-is.delayed.Rd +++ b/man/dot-is_delayed.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/0-picks.R -\name{.is.delayed} -\alias{.is.delayed} +\name{.is_delayed} +\alias{.is_delayed} \title{Is picks delayed} \usage{ -.is.delayed(x) +.is_delayed(x) } \arguments{ \item{x}{(\code{list}, \verb{list of picks}, \code{picks}, \code{pick}, \verb{$choices}, \verb{$selected})} @@ -15,7 +15,7 @@ When \code{\link[dplyr:pick]{dplyr::pick()}} is created it could be either: \itemize{ \item \code{quosure} when \code{tidyselect} helper used (delayed) \item \code{function} when predicate function provided (delayed) -\item \code{atomic} when vector of choices/selcted provided (eager) +\item \code{atomic} when vector of choices/selected provided (eager) } } \keyword{internal} diff --git a/man/dot-is_tidyselect.Rd b/man/dot-is_tidyselect.Rd index 7fa9bb48..49cfccc6 100644 --- a/man/dot-is_tidyselect.Rd +++ b/man/dot-is_tidyselect.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/0-picks.R \name{.is_tidyselect} \alias{.is_tidyselect} -\title{Is an object created using tidyselect} +\title{Is an object created using \code{tidyselect}} \usage{ .is_tidyselect(x) } diff --git a/man/dot-resolve.Rd b/man/dot-resolve.Rd index 260d77fc..0083e011 100644 --- a/man/dot-resolve.Rd +++ b/man/dot-resolve.Rd @@ -9,13 +9,13 @@ \arguments{ \item{selected}{(\code{vector}) rather \code{character}, or \code{factor}. \code{numeric(2)} for \code{values()} based on numeric column.} +\item{slot_name}{(\code{character(1)}) one of \code{c("datasets", "variables", "values")}} + \item{picks_resolved}{(\code{reactiveVal})} \item{old_picks}{(\code{picks})} \item{data}{(\code{any} asserted further in \code{resolver})} - -\item{slot_idx}{(\code{integer})} } \description{ @description @@ -26,7 +26,7 @@ values are sequentially dependent. For example if variables (i=2) is selected we to unresolve (restart) dataset. \item new value (selected) is replacing old value in current slot (i) \item we call resolve which resolves only "unresolved" (delayed) values -\item new picks is replacing reactiveValue +\item new picks is replacing \code{reactiveValue} Thanks to this design reactive values are triggered only once } } diff --git a/man/merge_srv.Rd b/man/merge_srv.Rd index 012f8d86..d19318e8 100644 --- a/man/merge_srv.Rd +++ b/man/merge_srv.Rd @@ -35,16 +35,18 @@ Default is \code{"dplyr::inner_join"}. The function must accept \code{by} and \c } \value{ A \code{list} with two reactive elements: -\describe{ -\item{\code{data}}{A \code{reactive} returning a \link[teal.data:teal_data]{teal.data::teal_data} object containing the merged dataset. +\itemize{ +\item \code{data}A \code{reactive} returning a \link[teal.data:teal_data]{teal.data::teal_data} object containing the merged dataset. The merged dataset is named according to \code{output_name} parameter. The \code{teal_data} object includes: -- The merged dataset with all selected variables -- Complete R code to reproduce the merge operation -- Updated join keys reflecting the merged dataset structure} -\item{\code{variables}}{A \code{reactive} returning a named list mapping selector names to their selected +\itemize{ +\item The merged dataset with all selected variables +\item Complete R code to reproduce the merge operation +\item Updated join keys reflecting the merged dataset structure +} +\item \code{variables} A \code{reactive} returning a named list mapping selector names to their selected variables in the merged dataset. The structure is: \code{list(selector_name_1 = c("var1", "var2"), selector_name_2 = c("var3", "var4"), ...)}. -Variable names reflect any renaming that occurred during the merge to avoid conflicts.} +Variable names reflect any renaming that occurred during the merge to avoid conflicts. } } \description{ @@ -85,7 +87,7 @@ the optimal order for merging datasets. \item Joins datasets using specified join function and join keys \item Maintains reproducibility through generated R code } -\item \strong{Updates Join Keys}: Creates new join key relationships for the merged dataset ("anl") +\item \strong{Updates Join Keys}: Creates new join key relationships for the merged dataset (\code{"anl"}) relative to remaining datasets in the \code{teal_data} object \item \strong{Tracks Variables}: Keeps track of the variable names in the merged dataset } @@ -171,7 +173,6 @@ merged <- merge_srv( } \examples{ -\dontrun{ # Complete example with CDISC data library(teal.transform) library(teal.data) @@ -224,8 +225,8 @@ server <- function(input, output, session) { merged$variables() }) } - -shinyApp(ui, server) +if (interactive()) { + shinyApp(ui, server) } } diff --git a/man/picks.Rd b/man/picks.Rd index eca13ef3..c7751d18 100644 --- a/man/picks.Rd +++ b/man/picks.Rd @@ -1,15 +1,12 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/0-mae-methods.R, R/0-picks.R -\name{mae_data} -\alias{mae_data} +% Please edit documentation in R/0-picks.R +\name{picks} \alias{picks} \alias{datasets} \alias{variables} \alias{values} \title{Choices/selected settings} \usage{ -mae_data(choices = tidyselect::everything(), selected = 1L, multiple = FALSE) - picks(...) datasets(choices = tidyselect::everything(), selected = 1L, fixed = NULL, ...) @@ -32,37 +29,35 @@ values( ) } \arguments{ +\item{...}{additional arguments delivered to \code{pickerInput}} + \item{choices}{(\code{tidyselect::language} or \code{character}) Available values to choose.} \item{selected}{(\code{tidyselect::language} or \code{character}) Choices to be selected.} -\item{multiple}{(\code{logical(1)}) if more than one selection is possible.} - -\item{...}{additional arguments delivered to \code{pickerInput}} - \item{fixed}{(\code{logical(1)}) selection will be fixed and not possible to change interactively.} +\item{multiple}{(\code{logical(1)}) if more than one selection is possible.} + \item{ordered}{(\code{logical(1)}) if the selected should follow the selection order. If \code{FALSE} \code{selected} returned from \code{srv_module_input()} would be ordered according to order in \code{choices}.} } \description{ -Define choices and default selection for variables. `picks` allows app-developer to specify -`datasets`, `variables` and `values` to be selected by app-user during Shiny session. -Functions are based on the idea of `choices/selected` where app-developer provides `choices` -and what is `selected` by default. App-user though changes `selected` interactively in -[`picks_module`] -# todo: add note that values accepts predicates only +Define choices and default selection for variables. \code{picks} allows app-developer to specify +\code{datasets}, \code{variables} and \code{values} to be selected by app-user during Shiny session. +Functions are based on the idea of \code{choices/selected} where app-developer provides \code{choices} +and what is \code{selected} by default. App-user changes \code{selected} interactively (see \code{\link{picks_module}}). } \section{\code{tidyselect} support}{ Both \code{choices} and \code{selected} parameters support \code{tidyselect} syntax, enabling dynamic and flexible variable selection patterns. This allows choices to be determined at runtime -based on data characteristics rather than hardcoded values. -\subsection{Using tidyselect for \code{choices}}{ +based on data characteristics rather than hard-coded values. +\subsection{Using \code{tidyselect} for \code{choices} and \code{selected}}{ -When \code{choices} uses tidyselect, the available options are determined dynamically based on -the selected dataset's structure: +When \code{choices} uses \code{tidyselect}, the available options are determined dynamically based on actually +selected data: \itemize{ \item \code{tidyselect::everything()} - All variables/datasets \item \code{tidyselect::starts_with("prefix")} - Variables starting with a prefix @@ -73,18 +68,12 @@ the selected dataset's structure: \item \code{tidyselect::all_of(vars)} - All specified variables (error if missing) \item \code{tidyselect::any_of(vars)} - Any specified variables (silent if missing) \item Range selectors like \code{Sepal.Length:Petal.Width} - Variables between two positions -} +\item Integer indices (e.g., \code{1L}, \code{1L:3L}, \code{c(1L, 3L, 5L)}) - Select by position. Be careful, must be integer! } -\subsection{Using tidyselect for \code{selected}}{ - -The \code{selected} parameter can use: -\itemize{ -\item Numeric indices (e.g., \code{1}, \code{1:3}, \code{c(1, 3, 5)}) - Select by position -\item Character vectors (e.g., \code{"Species"}, \code{c("mpg", "cyl")}) - Select by name -\item \code{tidyselect::everything()} - Select all available choices -\item Other tidyselect helpers as needed -} +The \code{selected} parameter can use the same syntax but it will be applied to the subset defined in choices. This +means that \verb{choices = is.numeric, selected = is.factor} or \verb{choices = c("a", "b", "c"), selected = c("d", "e")} +will imply en empty \code{selected}. \strong{Warning:} Using explicit character values for \code{selected} with dynamic \code{choices} may cause issues if the selected values are not present in the dynamically determined choices. @@ -109,16 +98,17 @@ Each element's choices are evaluated within the context of its predecessor's sel \subsection{How dependencies work}{ \itemize{ -\item \strong{Single dataset}: When \code{datasets(choices = "iris")} specifies one dataset, the -\code{variables()} choices are evaluated against that dataset's columns. -\item \strong{Multiple datasets}: When \code{datasets(choices = c("iris", "mtcars"))} allows multiple +\item \strong{Fixed dataset}: When \code{datasets(choices = "iris")} specifies one dataset, the +\code{variables()} choices are evaluated against that dataset columns. +\item \strong{Multiple dataset choices}: When \code{datasets(choices = c("iris", "mtcars"))} allows multiple options, \code{variables()} choices are re-evaluated each time the user selects a different dataset. This creates a reactive dependency where variable choices update automatically. -\item \strong{Dynamic datasets}: When using \code{datasets(choices = tidyselect::where(is.data.frame))}, +\item \strong{Dynamic dataset choices}: When using \code{datasets(choices = tidyselect::where(is.data.frame))}, all available data frames are discovered at runtime, and variable choices adapt to whichever dataset the user selects. \item \strong{Variable to values}: Similarly, \code{values()} choices are evaluated based on the -selected variable(s), allowing users to filter specific levels or values. +selected variable(s), allowing users to filter specific levels or values. When multiple +variables are selected, then values will be a concatenation of the columns. } } @@ -134,18 +124,108 @@ variables that may not exist in all datasets } } +\subsection{Important: \code{values()} requires type-aware configuration}{ +\subsection{Why \code{values()} is different from \code{datasets()} and \code{variables()}}{ + +\code{datasets()} and \code{variables()} operate on named lists of objects, meaning they work with character-based +identifiers. This allows you to use text-based selectors like \code{starts_with("S")} or \code{contains("prefix")} +consistently for both datasets and variable names. + +\code{values()} is fundamentally different because it operates on the \strong{actual data content} within a +selected variable (column). The type of data in the column determines what kind of filtering makes sense: +\itemize{ +\item \strong{\code{numeric} columns} (e.g., \code{age}, \code{height}, \code{price}) contain numbers +\item \strong{\code{character}/\code{factor} columns} (e.g., \code{country}, \code{category}, \code{status}) contain categorical values +\item \strong{\code{Date}/\code{POSIXct} columns} contain temporal data +\item \strong{\code{logical} columns} contain TRUE/FALSE values +} +} + +\subsection{Type-specific UI controls}{ + +The \code{values()} function automatically renders different UI controls based on data type: +\itemize{ +\item \strong{\code{numeric} data}: Creates a \code{sliderInput} for range selection +\itemize{ +\item \code{choices} must be a numeric vector of length 2: \code{c(min, max)} +\item \code{selected} must be a numeric vector of length 2: \code{c(selected_min, selected_max)} +} +\item \strong{Categorical data} (\code{character}/\code{factor}): Creates a \code{pickerInput} for discrete selection +\itemize{ +\item \code{choices} can be a character vector or predicate function +\item \code{selected} can be specific values or a predicate function +} +\item \strong{\code{Date}/\code{POSIXct} data}: Creates date/datetime range selectors +\itemize{ +\item \code{choices} must be a Date or \code{POSIXct} vector of length 2 +} +\item \strong{\code{logical} data}: Creates a checkbox or picker for TRUE/FALSE selection +} +} + +\subsection{Developer responsibility}{ + +\strong{App developers must ensure \code{values()} configuration matches the variable type:} +\enumerate{ +\item \strong{Know your data}: Understand what type of variable(s) users might select +\item \strong{Configure appropriately}: Set \code{choices} and \code{selected} to match expected data types +\item \strong{Use predicates for flexibility}: When variable type is dynamic, use predicate functions +like \code{function(x) !is.na(x)} (the default) to handle multiple types safely +} +} + +\subsection{Examples of correct usage}{ + +\if{html}{\out{
}}\preformatted{# For a numeric variable (e.g., age) +picks( + datasets(choices = "demographic"), + variables(choices = "age", multiple = FALSE), + values(choices = c(0, 100), selected = c(18, 65)) +) + +# For a categorical variable (e.g., country) +picks( + datasets(choices = "demographic"), + variables(choices = "country", multiple = FALSE), + values(choices = c("USA", "Canada", "Mexico"), selected = "USA") +) + +# Safe approach when variable type is unknown - use predicates +picks( + datasets(choices = "demographic"), + variables(choices = tidyselect::everything(), selected = 1L), + values(choices = function(x) !is.na(x), selected = function(x) !is.na(x)) +) +}\if{html}{\out{
}} +} + +\subsection{Common mistakes to avoid}{ + +\if{html}{\out{
}}\preformatted{# WRONG: Using string selectors for numeric data +values(choices = starts_with("5")) # Doesn't make sense for numeric data! + +# WRONG: Providing categorical choices for a numeric variable +values(choices = c("low", "medium", "high")) # Won't work if variable is numeric! + +# WRONG: Providing numeric range for categorical variable +values(choices = c(0, 100)) # Won't work if variable is factor/character! +}\if{html}{\out{
}} +} + +} + \subsection{Example: Three-level hierarchy}{ \if{html}{\out{
}}\preformatted{picks( datasets(choices = c("iris", "mtcars"), selected = "iris"), - variables(choices = tidyselect::where(is.numeric), selected = 1), - values(choices = tidyselect::everything(), selected = 1:10) + variables(choices = tidyselect::where(is.numeric), selected = 1L), + values(choices = tidyselect::everything(), selected = seq_len(10)) ) }\if{html}{\out{
}} In this example: \itemize{ -\item User first selects a dataset (iris or mtcars) +\item User first selects a dataset (\code{iris} or \code{mtcars}) \item Variable choices update to show only numeric columns from selected dataset \item After selecting a variable, value choices show all unique values from that column } @@ -156,7 +236,7 @@ In this example: # Select columns from iris dataset using range selector picks( datasets(choices = "iris"), - variables(choices = Sepal.Length:Petal.Width, selected = 1) + variables(choices = Sepal.Length:Petal.Width, selected = 1L) ) # Single variable selection from iris dataset @@ -168,31 +248,31 @@ picks( # Dynamic selection: any variable from iris, first selected by default picks( datasets(choices = "iris", selected = "iris"), - variables(choices = tidyselect::everything(), selected = 1, multiple = FALSE) + variables(choices = tidyselect::everything(), selected = 1L, multiple = FALSE) ) # Multiple dataset choices: variable choices will update when dataset changes picks( datasets(choices = c("iris", "mtcars"), selected = "iris"), - variables(choices = tidyselect::everything(), selected = 1, multiple = FALSE) + variables(choices = tidyselect::everything(), selected = 1L, multiple = FALSE) ) # Select from any dataset, filter by numeric variables picks( - datasets(choices = c("iris", "mtcars"), selected = 1), - variables(choices = tidyselect::where(is.numeric), selected = 1) + datasets(choices = c("iris", "mtcars"), selected = 1L), + variables(choices = tidyselect::where(is.numeric), selected = 1L) ) # Fully dynamic: auto-discover datasets and variables picks( - datasets(choices = tidyselect::where(is.data.frame), selected = 1), - variables(choices = tidyselect::everything(), selected = 1, multiple = FALSE) + datasets(choices = tidyselect::where(is.data.frame), selected = 1L), + variables(choices = tidyselect::everything(), selected = 1L, multiple = FALSE) ) # Select categorical variables with length constraints picks( - datasets(choices = tidyselect::everything(), selected = 1), - variables(choices = is_categorical(min.len = 2, max.len = 15), selected = 1:2) + datasets(choices = tidyselect::everything(), selected = 1L), + variables(choices = is_categorical(min.len = 2, max.len = 15), selected = seq_len(2)) ) } diff --git a/man/picks_module.Rd b/man/picks_module.Rd index 4791e6cf..aea3c789 100644 --- a/man/picks_module.Rd +++ b/man/picks_module.Rd @@ -28,7 +28,7 @@ picks_srv(id = "", picks, data) \item{picks}{(\code{picks} or \code{list}) object created by \code{picks()} or a named list of such objects} \item{container}{(\code{character(1)} or \code{function}) UI container type. Can be one of \code{htmltools::tags} -functions. By default, elements are wrapped in a package-specific dropdown.} +functions. By default, elements are wrapped in a package-specific drop-down.} \item{data}{(\code{reactive}) Reactive expression returning the data object to be used for populating choices} } diff --git a/man/resolver.Rd b/man/resolver.Rd index 068c57ab..564b53c2 100644 --- a/man/resolver.Rd +++ b/man/resolver.Rd @@ -7,10 +7,10 @@ resolver(x, data) } \arguments{ +\item{x}{(\code{\link[=picks]{picks()}}) settings for picks.} + \item{data}{(\code{\link[teal.data:teal_data]{teal.data::teal_data()}} \code{environment} or \code{list}) any data collection supporting object extraction with \code{[[}. Used to determine values of unresolved \code{picks}.} - -\item{picks}{(\code{\link[=picks]{picks()}}) settings for picks.} } \value{ resolved \code{picks}. @@ -19,14 +19,11 @@ resolved \code{picks}. Resolve iterates through each \code{picks} element and determines values . } \examples{ -# todo: fix example to use environment or a list -x1 <- datasets(where(is.data.frame)) -x2 <- picks(x1, variables("a", "a")) -data <- within(teal.data::teal_data(), { - df <- data.frame(a = as.factor(LETTERS[1:5]), b = letters[1:5]) - df2 <- data.frame(a = LETTERS[1:5], b = 1:5) - m <- matrix() -}) -resolver(x = x1, data = data) -resolver(x = x2, data = data) +x <- picks(datasets(tidyselect::where(is.data.frame)), variables("a", "a")) +data <- list( + df1 = data.frame(a = as.factor(LETTERS[1:5]), b = letters[1:5]), + df2 = data.frame(a = LETTERS[1:5], b = 1:5), + m = matrix() +) +resolver(x = x, data = data) } diff --git a/man/tidyselectors.Rd b/man/tidyselectors.Rd index 9b552d4f..7dc889d3 100644 --- a/man/tidyselectors.Rd +++ b/man/tidyselectors.Rd @@ -3,25 +3,20 @@ \name{tidyselectors} \alias{tidyselectors} \alias{is_categorical} -\alias{no_more_choices_than} \title{\code{tidyselect} helpers} \usage{ -is_categorical(max.len, min.len) - -no_more_choices_than(max.len) +is_categorical(min.len, max.len) } \arguments{ -\item{max.len}{(\code{integer(1)}) maximal number of unique values} - \item{min.len}{(\code{integer(1)}) minimal number of unique values} + +\item{max.len}{(\code{integer(1)}) maximal number of unique values} } \description{ \code{tidyselect} helpers } \examples{ -# select keys (primary and foreign) -variables(choices = is_key()) - # select factor column but exclude foreign keys -variables(choices = where(~ is.factor(.x) & !is_foreign_key())) +variables(choices = is_categorical(min.len = 2, max.len = 10)) + } diff --git a/man/tm_merge.Rd b/man/tm_merge.Rd index ddf12cf6..1d735486 100644 --- a/man/tm_merge.Rd +++ b/man/tm_merge.Rd @@ -7,9 +7,48 @@ tm_merge(label = "merge-module", picks, transformators = list()) } \arguments{ -\item{picks}{(\code{list} of \code{picks}) -Example module} +\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. +For \code{modules()} defaults to \code{"root"}. See \code{Details}.} + +\item{picks}{(\code{list} of \code{picks})} + +\item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. +To learn more check \code{vignette("transform-input-data", package = "teal")}.} } \description{ -Merge module +Example \code{\link[teal:teal_modules]{teal::module}} containing interactive inputs and displaying results of merge. +} +\examples{ +library(teal) + +data <- within(teal.data::teal_data(), { + iris <- iris + mtcars <- mtcars +}) + +app <- init( + data = data, + modules = modules( + modules( + label = "Testing modules", + tm_merge( + label = "non adam", + picks = list( + a = picks( + datasets("iris", "iris"), + variables( + choices = c("Sepal.Length", "Species"), + selected = + ), + values() + ) + ) + ) + ) + ) +) +if (interactive()) { + shinyApp(app$ui, app$server, enableBookmarking = "server") +} + } diff --git a/tests/testthat/test-0-module_merge.R b/tests/testthat/test-0-module_merge.R index efb327ee..0a94c19f 100644 --- a/tests/testthat/test-0-module_merge.R +++ b/tests/testthat/test-0-module_merge.R @@ -823,7 +823,10 @@ testthat::describe("merge_srv returns list with data (teal_data with anl) and va data <- teal.data::teal_data() data <- within(data, { test_data <- data.frame( - posixct_var = as.POSIXct(c("2024-01-01 10:00:00", "2024-02-01 11:00:00", "2024-03-01 12:00:00", "2024-04-01 13:00:00", "2024-05-01 14:00:00")), + posixct_var = as.POSIXct(c( + "2024-01-01 10:00:00", "2024-02-01 11:00:00", "2024-03-01 12:00:00", + "2024-04-01 13:00:00", "2024-05-01 14:00:00" + )), id = 1:5 ) }) @@ -832,7 +835,10 @@ testthat::describe("merge_srv returns list with data (teal_data with anl) and va a = shiny::reactive(picks( datasets(choices = "test_data", selected = "test_data"), variables(choices = colnames(data$test_data), selected = "posixct_var"), - values(choices = range(data$test_data$posixct_var), selected = as.POSIXct(c("2024-01-15 00:00:00", "2024-04-15 00:00:00"))) + values( + choices = range(data$test_data$posixct_var), + selected = as.POSIXct(c("2024-01-15 00:00:00", "2024-04-15 00:00:00")) + ) )) ) diff --git a/tests/testthat/test-0-print.R b/tests/testthat/test-0-print.R index 1f375fac..9569b151 100644 --- a/tests/testthat/test-0-print.R +++ b/tests/testthat/test-0-print.R @@ -1,7 +1,7 @@ testthat::describe("format.type() for datasets", { it("formats datasets with character choices by printing them explicitly", { ds <- datasets(choices = c("iris", "mtcars"), selected = "iris") - expected <- " \033[1m\033[0m\n choices: iris, mtcars\n selected: iris\n \033[3mmultiple=FALSE, ordered=FALSE, fixed=FALSE\033[0m\n" + expected <- " \033[1m\033[0m\n choices: iris, mtcars\n selected: iris\n \033[3mmultiple=FALSE, ordered=FALSE, fixed=FALSE\033[0m\n" # nolint testthat::expect_identical(format(ds), expected) }) @@ -17,7 +17,7 @@ testthat::describe("format.type() for datasets", { testthat::describe("print.type() for variables", { it("prints variables with character choices by printing them explicitly", { vars <- variables(choices = c("a", "b", "c"), selected = c("a", "b"), multiple = TRUE) - expected <- " \033[1m\033[0m\n choices: a, b, c\n selected: a, b\n \033[3mmultiple=TRUE, ordered=FALSE, fixed=FALSE, allow-clear=TRUE\033[0m\n" + expected <- " \033[1m\033[0m\n choices: a, b, c\n selected: a, b\n \033[3mmultiple=TRUE, ordered=FALSE, fixed=FALSE, allow-clear=TRUE\033[0m\n" # nolint testthat::expect_identical(format(vars), expected) }) @@ -32,7 +32,7 @@ testthat::describe("print.type() for variables", { testthat::describe("format.type() for values", { it("formats values with character choices by printing them explicitly with their attributes", { vals <- values(choices = c("1", "2", "3"), selected = c("1", "2"), multiple = TRUE) - expected <- " \033[1m\033[0m\n choices: 1, 2, 3\n selected: 1, 2\n \033[3mmultiple=TRUE, ordered=FALSE, fixed=FALSE\033[0m\n" + expected <- " \033[1m\033[0m\n choices: 1, 2, 3\n selected: 1, 2\n \033[3mmultiple=TRUE, ordered=FALSE, fixed=FALSE\033[0m\n" # nolint testthat::expect_identical(format(vals), expected) }) }) From 566a18c7a3bdebb2499b1f66a7c9f8a5e3c982f9 Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Thu, 30 Oct 2025 16:01:53 +0100 Subject: [PATCH 141/142] remove refactor notes --- inst/refactor-notes.md | 1050 ---------------------------------------- 1 file changed, 1050 deletions(-) delete mode 100644 inst/refactor-notes.md diff --git a/inst/refactor-notes.md b/inst/refactor-notes.md deleted file mode 100644 index 0dfe3342..00000000 --- a/inst/refactor-notes.md +++ /dev/null @@ -1,1050 +0,0 @@ -# Table of Contents - -- [Table of Contents](#table-of-contents) -- [Motivation](#motivation) - - [Merging relational data](#merging-relational-data) - - [Handling ambiguous variables](#handling-ambiguous-variables) - - [Merging interactively](#merging-interactively) -- [Configure possible selection](#configure-possible-selection) - - [picks and choices/selected](#picks-and-choicesselected) - - [Relationship between `picks` elements](#relationship-between-picks-elements) - - [Example settings](#example-settings) - - [Strict variables picks](#strict-variables-picks) - - [Dynamic variables choices](#dynamic-variables-choices) - - [Dynamic variables from multiple datasets](#dynamic-variables-from-multiple-datasets) - - [Dynamic everything](#dynamic-everything) - - [Implementation in `teal_module`](#implementation-in-teal_module) - - [App example](#app-example) - - [Select specific variable(s) from a specific dataset](#select-specific-variables-from-a-specific-dataset) - - [Select specific variable(s) from a selected dataset](#select-specific-variables-from-a-selected-dataset) - - [Select unknown variable(s) from a selected dataset](#select-unknown-variables-from-a-selected-dataset) - - [filtering by any variable](#filtering-by-any-variable) - - [Conversion from to data-extract-spec](#conversion-from-to-data-extract-spec) - - [Issues with `data_extract_spec`](#issues-with-data_extract_spec) - - [Bad encapsulation](#bad-encapsulation) - - [Hard to extend](#hard-to-extend) - -# Motivation - -## Merging relational data - -Consider following tables `orders`, `order_items`, `products`, `customers` connected with join keys -following sql convention `{child}.{$parent}_id = {$parent+"s"}.id`, for example -`orders.customer_id = customers.id`. `teal.data` setup would look like this: - -
-Sample data setup with relational tables and join keys - -```r -library(teal.data) -data <- within(teal_data(), { - customers <- tibble::tribble( - ~id, ~name, ~age, ~country, - 1, "Alice Johnson", 30, "USA", - 2, "Bob Smith", 25, "Canada", - 3, "Charlie Brown", 35, "UK", - 4, "David Wilson", 28, "Australia", - 5, "Emma Davis", 32, "USA", - 6, "Frank Miller", 27, "Canada", - 7, "Grace Taylor", 29, "UK", - 8, "Henry Clark", 33, "Australia", - 9, "Isabella Martinez", 26, "USA", - 10, "Jack Thompson", 31, "Canada" - ) - - orders <- tibble::tribble( - ~id, ~customer_id, ~order_date, ~total_amount, - 101, 1, as.Date("2024-01-15"), 250.00, - 102, 1, as.Date("2024-02-01"), 150.00, - 103, 2, as.Date("2024-02-10"), 125.00, - 104, 3, as.Date("2024-02-15"), 200.00, - 105, 4, as.Date("2024-02-20"), 175.00, - 106, 5, as.Date("2024-03-01"), 300.00, - 107, 6, as.Date("2024-03-05"), 50.00, - 108, 7, as.Date("2024-03-10"), 225.00, - 109, 8, as.Date("2024-03-12"), 100.00, - 110, 9, as.Date("2024-03-15"), 275.00, - 111, 10, as.Date("2024-03-18"), 125.00, - 112, 2, as.Date("2024-03-20"), 150.00 - ) - - order_items <- tibble::tribble( - ~id, ~order_id, ~product_id, ~quantity, ~unit_price, ~total_price, - 201, 101, 1, 2, 100.00, 200.00, - 202, 101, 2, 1, 50.00, 50.00, - 203, 102, 2, 3, 50.00, 150.00, - 204, 103, 2, 1, 50.00, 50.00, - 205, 103, 3, 1, 75.00, 75.00, - 206, 104, 1, 2, 100.00, 200.00, - 207, 105, 3, 2, 75.00, 150.00, - 208, 105, 2, 1, 50.00, 50.00, - 209, 106, 1, 3, 100.00, 300.00, - 210, 107, 2, 1, 50.00, 50.00, - 211, 108, 1, 1, 100.00, 100.00, - 212, 108, 3, 2, 75.00, 150.00, - 213, 109, 2, 2, 50.00, 100.00, - 214, 110, 1, 2, 100.00, 200.00, - 215, 110, 3, 1, 75.00, 75.00, - 216, 111, 2, 2, 50.00, 100.00, - 217, 111, 1, 1, 100.00, 100.00, - 218, 112, 3, 2, 75.00, 150.00 - ) - - order_files <- tibble::tribble( - ~id, ~order_id, ~file_name, ~file_type, - 301, 101, "invoice_101.pdf", "invoice", - 302, 102, "receipt_102.pdf", "receipt", - 303, 103, "invoice_103.pdf", "invoice", - 304, 104, "receipt_104.pdf", "receipt", - 305, 105, "invoice_105.pdf", "invoice", - 306, 106, "receipt_106.pdf", "receipt", - 307, 107, "invoice_107.pdf", "invoice", - 308, 108, "receipt_108.pdf", "receipt", - 309, 109, "invoice_109.pdf", "invoice", - 310, 110, "receipt_110.pdf", "receipt", - 311, 111, "invoice_111.pdf", "invoice", - 312, 112, "receipt_112.pdf", "receipt" - ) - - products <- tibble::tribble( - ~id, ~name, ~price, ~category, ~stock_quantity, - 401, "Laptop Pro", 100.00, "Electronics", 15, - 402, "Wireless Mouse", 50.00, "Electronics", 50, - 403, "Office Chair", 75.00, "Furniture", 8 - ) - - product_components <- tibble::tribble( - ~id, ~product_id, ~component_name, ~component_type, ~quantity_required, ~cost, - 501, 401, "CPU", "Processor", 1, 25.00, - 502, 401, "RAM", "Memory", 2, 15.00, - 503, 401, "SSD", "Storage", 1, 20.00, - 504, 401, "Screen", "Display", 1, 30.00, - 505, 402, "Optical Sensor", "Sensor", 1, 8.00, - 506, 402, "Wireless Module", "Connectivity", 1, 12.00, - 507, 402, "Battery", "Power", 1, 5.00, - 508, 403, "Steel Frame", "Structure", 1, 35.00, - 509, 403, "Cushion", "Comfort", 1, 20.00, - 510, 403, "Wheels", "Mobility", 5, 3.00 - ) -}) - -join_keys(data) <- join_keys( - join_key("customers", keys = "id"), - join_key("orders", keys = c("id")), - join_key("products", keys = c("id")), - join_key("product_components", keys = c("id")), - # foreign keys - join_key("customers", "orders", keys = c(id = "customer_id")), - join_key("products", "order_items", keys = c(id = "product_id")), - join_key("products", "product_components", keys = c(id = "product_id")), - join_key("orders", "order_items", keys = c(id = "order_id")) -) - -print(join_keys(data)) -``` - -
- -Imagine now a scenario of a `ggplot` where one wants to select `x`, `y`, `color`, `facet_rows`, -`facet_cols` from any variable in any dataset. - -
-Example ggplot with dynamic variable selection - -```r -ggplot( - data = ?, - aes( - x = !!sym(input$x), # orders.order_date - y = !!sym(input$y), # order_items.total_price - color = !!sym(input$color) # products.category - ) -) + - geom_line() + - facet_grid( - vars(!!sym(input$facet_rows)) # customers.country - ) -``` - -
- -In order to create above visualization, datasets need to be merged as `ggplot::aes` is related to single -data object. Problem is solvable as `teal.data` has enough information to determine correct -merge call based and selected variables and `join_keys` (describing relationships between datasets). - -Using `dplyr` only we need to perform following merge operation given that following variables have -been selected: - -- x: `orders.order_date` -- y: `order_items.order_items.total_price` -- color: `products.category` -- facet_rows: `customers.country` - -
-Merge operation using dplyr joins - -```r -data_w_merged <- within(data, { - anl <- dplyr::select(orders, id, customer_id, order_date) %>% - dplyr::left_join(dplyr::select(order_items, order_id, product_id, total_price), by = c(id = "order_id")) %>% - dplyr::left_join(dplyr::select(products, id, category), by = c(product_id = "id")) %>% - dplyr::left_join(dplyr::select(customers, id, country), by = c(customer_id = "id")) -}) -``` - -
- -Now `anl` can produce desired visualization - -
-Creating visualization with merged dataset - -```r -# Create the visualization with merged data - sum moved to ggplot -data_w_plot <- within(data_w_merged, { - library(ggplot2) - - # Create ggplot with sum calculation inside - plot <- ggplot( - data = anl, - aes( - x = order_date, - y = total_price, - color = category - ) - ) + - geom_line() + - facet_grid( - rows = vars(country), - labeller = label_both - ) - - print(plot) -}) - -get_outputs(data_w_plot)[[1]] -``` - -
- -### Handling ambiguous variables - -When merging datasets containing duplicated variable names `dplyr::*_join(suffix = c(".x", ".y"))` automatically -adds a suffix to the columns, so that names are alway unique. - -## Merging interactively - -Developing system which can interactively handle merge is a challenging task not only for a reasons described above -but also due to additional layers which need to control described operation. These layers include: - -1. Providing an API for app-developer to enable and set specific merge configuration. -2. Handling reactive relationship between all inputs (dataset -> variable -> value) and avoid unnecessary triggers. -3. Providing robust, easy to use merge-modules which can handle weirdest app-developer needs (1) and provide meaningful information to the app-user about consequences of the data/variable selections. - -# Configure possible selection - -## picks and choices/selected - -We came with an idea of `picks` which allows app-developer to specify `datasets`, `variables` and `values` to be -selected by app-user during an app run. Each of them is based on the idea of `choices/selected` where app-developer -provides `choices` and what is `selected` by default. App-user though changes `selected` interactively. - -```mermaid -graph TB - subgraph AppDeveloper["👨‍💻 App Developer (Configuration Time)"] - Dev[App Developer] - end - - subgraph Variables["variables()"] - VAR_Choices["choices
(choices set by app-developer)"] - VAR_Selected["selected
(default set by app-developer)"] - end - - subgraph AppUser["👤 App User (Runtime)"] - User[App User] - UI["selectInput
(UI Component)"] - end - - Dev -->|"sets choices"| VAR_Choices - Dev -->|"sets default selected"| VAR_Selected - VAR_Choices -->|"displayed in"| UI - VAR_Selected -->|"initial value in"| UI - UI -->|"presents choices"| User - User -->|"changes selection"| VAR_Selected - - classDef devStyle fill:#e1f5ff,stroke:#0066cc,stroke-width:2px - classDef userStyle fill:#fff4e1,stroke:#cc6600,stroke-width:2px - classDef choicesStyle fill:#d4edda,stroke:#28a745,stroke-width:2px - classDef selectedStyle fill:#fff3cd,stroke:#ffc107,stroke-width:2px - - class Dev devStyle - class User,UI userStyle - class VAR_Choices choicesStyle - class VAR_Selected selectedStyle -``` - - -New design bases on an idea that a module can consume its arguments referring to any variable in any dataset. Consider following example, where: -- a module uses `x`, `y` and `facet` arguments to create an interactive inputs, -- user can select a variable from any dataset for `x`, `y`, `facet` -- visualization will be build on a merged dataset containing these three variables. - -```r -# pseudocode -tm_example <- function(x, y, facet) { - ui = function(id, x, y, facet) ...., # inputs will be here - server = function(id, x, y, facet) { - moduleServer(id, function(input, output, session) { - output$plot <- renderPlot({ - merged_dataset |> - ggplot( - aes( - x = , - y = - ) - ) + geom_point() + facet_wrap(vars()) - }) - }) - } -} -``` - -To provide choices and default selection for `x`, `y` and `facet` we propose following api: - -
-Proposed API using picks() for variable selection - -```r -# pseudocode -tm_example( - x = picks( - datasets(, ), - variables(, ) - ), - y = picks( - datasets(, ), - variables(, ) - ), - facet = picks( - datasets(, ), - variables(, ) - ) -) -``` - -
- -Where each function creates an object which holds the information consumed by the framework. `choices` and `selected` can be either: -- `tidyselect` selection_helpers (`?tidyselect::language`) -- Integer denoting index of column(s) -- explicit character denoting the name of the objects/columns/level - -## Relationship between `picks` elements - -Each `picks` element is evaluated in a sequence starting from `datasets`. `selected` in one of them determines possible choices of the next one. For example: - -If `datasets` is selected to be `iris`, then following variables's `choices` will be variables of iris. `selected` can't be something else than a `choices` and so on. - -```mermaid -graph TB - subgraph "picks()" - subgraph "datasets()" - DS_Choices["choices
(available datasets)"] - DS_Selected["selected
(chosen dataset)"] - end - - subgraph "variables()" - VAR_Choices["choices
(available variables)"] - VAR_Selected["selected
(chosen variable)"] - end - end - - DS_Choices -->|"user selects from"| DS_Selected - DS_Selected -->|"determines"| VAR_Choices - VAR_Choices -->|"user selects from"| VAR_Selected - - DS_Selected -.->|"e.g., if 'iris' selected"| VAR_Choices - VAR_Choices -.->|"then choices become
iris columns"| VAR_Selected - - classDef choicesStyle fill:#d4edda,stroke:#28a745,stroke-width:2px - classDef selectedStyle fill:#fff3cd,stroke:#ffc107,stroke-width:2px - classDef flowStyle fill:#e8f4f8,stroke:#0066cc,stroke-width:1px,stroke-dasharray: 5 5 - - class DS_Choices,VAR_Choices choicesStyle - class DS_Selected,VAR_Selected selectedStyle - - style DS_Selected stroke-width:3px - style VAR_Choices stroke-width:3px -``` - -## Example settings - -Please read carefully the code and see the description to understand how `picks` work. - -### Strict variables picks - -`picks` below will create an input in the module where single variable can be selected from `c("Sepal.Length", "Sepal.Width")`. `multiple = FALSE` disallow user to select more than one choice. - -
-Example: Strict variable picks with single selection - -```r -picks( - datasets(choices = "iris", selected = "iris"), - variables(choices = c("Sepal.Length", "Sepal.Width"), selected = "Sepal.Length", multiple = FALSE) -) -``` - -
- -### Dynamic variables choices - -Following `picks` will create an input in the module where user will be able to select any variable from iris (any = `everything()`) and by default `1`-st will be selected. Be careful, setting explicit `selected` when `choices` throws a warning as it is not certain for example that `"Species" %in% everything()`. - -
-Example: Dynamic variable choices with tidyselect - -```r -picks( - datasets(choices = "iris", selected = "iris"), - variables(choices = tidyselect::everything(), selected = 1, multiple = FALSE) -) -``` - -
- -### Dynamic variables from multiple datasets - -Consider a situation when one wants to select a variable from either `iris` or `mtcars`. Instead of forcing app-developer to enumerate all possible choices for `iris` and `mtcars`. Following picks will create two related inputs for datasets and for variables. Input for variables will automatically update when dataset selection changes. - -
-Example: Multiple datasets with dynamic variables - -```r -picks( - datasets(choices = c("iris", "mtcars"), selected = "iris"), - variables(choices = tidyselect::everything(), selected = 1, multiple = FALSE) -) -``` - -
- -### Dynamic everything - -In extreme scenario also lists of datasets could be unknown. Or to avoid writing too much text, one can specify following `picks`. - -
-Example: Fully dynamic dataset and variable selection - -```r -picks( - datasets(choices = tidyselect::where(is.data.frame), selected = 1), - variables(choices = tidyselect::everything(), selected = 1, multiple = FALSE) -) -``` - -
- - -## Implementation in `teal_module` - -`teal_module` will accept `x`, `y` and `facet` and hand-over them to both `ui` and `server`. - -
-Module definition with picks arguments - -```r -tm_example <- function(x, y, facet) { - module( - ui = ui_example, - server = srv_example, - ui_args = list(x = x, y = y, facet = facet), - server_args = list(x = x, y = y, facet = facet) - ) -} -``` - -
- -On the `ui` part it is necessary to call `picks_ui` for each `picks` object. - -
-UI implementation with picks_ui - -```r -ui_example <- function(id, x, y, facet) { - ns <- NS(id) - div( - picks_ui(id = ns("x"), picks = x), - picks_ui(id = ns("y"), picks = y), - picks_ui(id = ns("facet"), picks = facet), - plotOutput(ns("plot")) - ) -} -``` - -
- -In the `server`, `picks` are utilized in `picks_srv` which can be called per each pick, or for all at once (as in the example below). `picks_srv` is used only to resolve dynamic choices/selected and to handle interaction between inputs. `selectors` contain a list of selected datasets/variables for each `pick`. In this example `selectors` structure looks like this: - -```yaml -x: (reactiveVal) - datasets: - choices: ... - selected: ... - variables: - choices: ... - selected: ... -y: ... -facet: ... -``` - -To create a merged-dataset using information from app-user selection one needs to call `merge_srv`. `picks_srv` doesn't do anything else than controlling a selection for a number of reasons: - -- One might want to use different set of `variables` to perform merge. For example, some might be controlled with `picks_ui/srv` and have an UI element and some might be fixed and added optionally to the `merge_srv(selectors)`. -- Before merge is performed, one might want to validate if the selection is correct from a module perspective. - -`merge_srv` returns a list with two reactives: -- `data`: `teal_data` object with merged dataset and -- `merge_vars`: named list of variables. List is named after selector name, for example `merge_vars()$facet` - -
-Server implementation with merge_srv - -```r -srv_example <- function(id, data, x, y, facet) { - moduleServer(id, function(input, output, session) { - selectors <- picks_srv(data = data, picks = list(x = x, y = y, facet = facet)) - - merged <- merge_srv("merge", data = data, selectors = selectors) - - plot_q <- reactive({ - within(merged$data(), - { - merged %>% - ggplot(aes(x = x, y = y)) + - geom_point() + - facet_wrap(vars(facet)) - }, - x = str2lang(merged$variables()$x), - y = str2lang(merged$variables()$y), - facet = str2lang(merged$variables()$facet) - ) - }) - - output$plot <- renderPlot({ - req(plot_q()) - rev(get_outputs(plot_q()))[[1]] - }) - }) -} -``` - -
- -### App example - -
-Complete working app example with relational data and dynamic merging - -```r -devtools::load_all("teal.data") -devtools::load_all("teal.transform") -devtools::load_all("teal") -devtools::load_all("teal.modules.general") -library(dplyr) - -data <- within(teal.data::teal_data(), { - customers <- tibble::tribble( - ~id, ~name, ~age, ~country, - 1, "Alice Johnson", 30, "USA", - 2, "Bob Smith", 25, "Canada", - 3, "Charlie Brown", 35, "UK", - 4, "David Wilson", 28, "Australia", - 5, "Emma Davis", 32, "USA", - 6, "Frank Miller", 27, "Canada", - 7, "Grace Taylor", 29, "UK", - 8, "Henry Clark", 33, "Australia", - 9, "Isabella Martinez", 26, "USA", - 10, "Jack Thompson", 31, "Canada" - ) - - orders <- tibble::tribble( - ~id, ~customer_id, ~order_date, ~total_amount, - 101, 1, as.Date("2024-01-15"), 250.00, - 102, 1, as.Date("2024-02-01"), 150.00, - 103, 2, as.Date("2024-02-10"), 125.00, - 104, 3, as.Date("2024-02-15"), 200.00, - 105, 4, as.Date("2024-02-20"), 175.00, - 106, 5, as.Date("2024-03-01"), 300.00, - 107, 6, as.Date("2024-03-05"), 50.00, - 108, 7, as.Date("2024-03-10"), 225.00, - 109, 8, as.Date("2024-03-12"), 100.00, - 110, 9, as.Date("2024-03-15"), 275.00, - 111, 10, as.Date("2024-03-18"), 125.00, - 112, 2, as.Date("2024-03-20"), 150.00 - ) - - order_items <- tibble::tribble( - ~id, ~order_id, ~product_id, ~quantity, ~unit_price, ~total_price, - 201, 101, 401, 2, 100.00, 200.00, - 202, 101, 402, 1, 50.00, 50.00, - 203, 102, 402, 3, 50.00, 150.00, - 204, 103, 402, 1, 50.00, 50.00, - 205, 103, 403, 1, 75.00, 75.00, - 206, 104, 401, 2, 100.00, 200.00, - 207, 105, 403, 2, 75.00, 150.00, - 208, 105, 402, 1, 50.00, 50.00, - 209, 106, 401, 3, 100.00, 300.00, - 210, 107, 402, 1, 50.00, 50.00, - 211, 108, 401, 1, 100.00, 100.00, - 212, 108, 403, 2, 75.00, 150.00, - 213, 109, 402, 2, 50.00, 100.00, - 214, 110, 401, 2, 100.00, 200.00, - 215, 110, 403, 1, 75.00, 75.00, - 216, 111, 402, 2, 50.00, 100.00, - 217, 111, 401, 1, 100.00, 100.00, - 218, 112, 403, 2, 75.00, 150.00 - ) - - order_files <- tibble::tribble( - ~id, ~order_id, ~file_name, ~file_type, - 301, 101, "invoice_101.pdf", "invoice", - 302, 102, "receipt_102.pdf", "receipt", - 303, 103, "invoice_103.pdf", "invoice", - 304, 104, "receipt_104.pdf", "receipt", - 305, 105, "invoice_105.pdf", "invoice", - 306, 106, "receipt_106.pdf", "receipt", - 307, 107, "invoice_107.pdf", "invoice", - 308, 108, "receipt_108.pdf", "receipt", - 309, 109, "invoice_109.pdf", "invoice", - 310, 110, "receipt_110.pdf", "receipt", - 311, 111, "invoice_111.pdf", "invoice", - 312, 112, "receipt_112.pdf", "receipt" - ) - - products <- tibble::tribble( - ~id, ~name, ~price, ~category, ~stock_quantity, - 401, "Laptop Pro", 100.00, "Electronics", 15, - 402, "Wireless Mouse", 50.00, "Electronics", 50, - 403, "Office Chair", 75.00, "Furniture", 8 - ) - - product_components <- tibble::tribble( - ~id, ~product_id, ~component_name, ~component_type, ~quantity_required, ~cost, - 501, 401, "CPU", "Processor", 1, 25.00, - 502, 401, "RAM", "Memory", 2, 15.00, - 503, 401, "SSD", "Storage", 1, 20.00, - 504, 401, "Screen", "Display", 1, 30.00, - 505, 402, "Optical Sensor", "Sensor", 1, 8.00, - 506, 402, "Wireless Module", "Connectivity", 1, 12.00, - 507, 402, "Battery", "Power", 1, 5.00, - 508, 403, "Steel Frame", "Structure", 1, 35.00, - 509, 403, "Cushion", "Comfort", 1, 20.00, - 510, 403, "Wheels", "Mobility", 5, 3.00 - ) - - iris <- iris - mtcars <- mtcars - iris$id <- seq_len(nrow(iris)) - mtcars$id <- seq_len(nrow(mtcars)) - ADSL <- rADSL - ADTTE <- rADTTE - ADRS <- rADRS - ADAE <- rADAE - ADLB <- rADLB - ADTR <- rADTR -}) - -join_keys(data) <- c( - teal.data::default_cdisc_join_keys[c("ADSL", "ADTTE", "ADRS", "ADAE", "ADQS", "ADTR", "ADLB")], - teal.data::join_keys( - join_key("iris", keys = "id"), - join_key("mtcars", keys = "id"), - teal.data::join_key("customers", keys = "id"), - teal.data::join_key("orders", keys = c("id")), - teal.data::join_key("products", keys = c("id")), - teal.data::join_key("product_components", keys = c("id")), - # foreign keys - teal.data::join_key("customers", "orders", keys = c(id = "customer_id")), - teal.data::join_key("products", "order_items", keys = c(id = "product_id")), - teal.data::join_key("products", "product_components", keys = c(id = "product_id")), - teal.data::join_key("orders", "order_items", keys = c(id = "order_id")), - # add missing keys - teal.data::join_key("ADTR", "ADTR", keys = c("STUDYID", "USUBJID", "PARAMCD", "AVISIT")), - teal.data::join_key("ADSL", "ADTR", keys = c("STUDYID", "USUBJID")) - ) -) - -tm_example <- function(x, y, facet) { - module( - ui = ui_example, - server = srv_example, - ui_args = list(x = x, y = y, facet = facet), - server_args = list(x = x, y = y, facet = facet) - ) -} - -ui_example <- function(id, x, y, facet) { - ns <- NS(id) - div( - picks_ui(id = ns("x"), picks = x), - picks_ui(id = ns("y"), picks = y), - picks_ui(id = ns("facet"), picks = facet), - plotOutput(ns("plot")) - ) -} - -srv_example <- function(id, data, x, y, facet) { - moduleServer(id, function(input, output, session) { - selectors <- picks_srv(data = data, picks = list(x = x, y = y, facet = facet)) - - merged <- merge_srv("merge", data = data, selectors = selectors) - - plot_q <- reactive({ - within(merged$data(), - { - anl %>% - ggplot(aes(x = x, y = y)) + - geom_point() + - facet_wrap(vars(facet)) - }, - x = str2lang(merged$variables()$x), - y = str2lang(merged$variables()$y), - facet = str2lang(merged$variables()$facet) - ) - }) - - output$plot <- renderPlot({ - req(plot_q()) - rev(get_outputs(plot_q()))[[1]] - }) - }) -} - -app <- init( - data = data, - modules = modules( - tm_example( - x = picks( - datasets("orders"), - variables(selected = "order_date") - ), - y = picks( - datasets("order_items"), - variables(selected = "total_price") - ), - facet = picks( - datasets("customers"), - variables(selected = "country") - - ) - ), - modules( - label = "Display e2e configuration", - tm_merge( - label = "adam", - inputs = list( - a = picks( - datasets("ADTTE"), - variables(multiple = TRUE) - ), - b = picks( - datasets(choices = tidyselect::where(is.data.frame), selected = "ADSL"), - variables(is_categorical(min.len = 2, max.len = 20), selected = 1, multiple = TRUE) - ), - c = picks( - datasets(tidyselect::everything(), "ADTTE"), - variables(choices = c(AGE:ARM, PARAMCD), selected = AGE, multiple = TRUE) - ), - d = picks( - datasets(choices = "ADRS", selected = "ADRS"), - variables(choices = "PARAM", selected = "PARAM"), - values(selected = tidyselect::everything(), multiple = TRUE) - ), - e = picks( - datasets(selected = "ADSL"), - variables( - choices = variable_choices("whatever", subset = function(data) { - idx <- vapply(data, is.factor, logical(1)) - names(data)[idx] - }) - ) - ) - ) - ), - tm_merge( - label = "non adam", - inputs = list( - a = picks( - datasets( - choices = tidyselect::where(is.data.frame) & !tidyselect::starts_with("AD"), - selected = "orders" - ), - variables( - selected = "order_date", - multiple = TRUE - ) - ), - b = picks( - datasets(selected = "products"), - variables(selected = "price", multiple = TRUE) - ), - c = picks( - datasets(selected = "order_items"), - variables(multiple = TRUE) - ) - ) - ) - ) - ) -) - -shinyApp(app$ui, app$server, enableBookmarking = "server") -``` - -
- -### Select specific variable(s) from a specific dataset - -``` -data_extract_spec( - data = "iris" - select = select_spec( - choices = c("Sepal.Length", "Species"), - selected = "Species" - ) -) - -# to -picks( - datasets("iris", "iris"), - variables( - choices = c("Sepal.Length", "Species"), - selected = "Species" - ) -) - -``` - - -### Select specific variable(s) from a selected dataset - -``` -list( - data_extract_spec( - data = "iris" - select = select_spec( - choices = c("Sepal.Length", "Species"), - selected = "Species" - ) - ), - data_extract_spec( - data = "mtcars" - select = select_spec( - choices = c("mpg", "cyl"), - selected = "mpg" - ) - ) -) - -# to -picks( - datasets(c("iris", "mtcars"), "iris"), - variables( - choices = c("Sepal.Length", "Species", "mpg", "cyl"), - selected = c("Species", "mpg") - ) -) -``` - -### Select unknown variable(s) from a selected dataset - -``` -list( - data_extract_spec( - data = "iris" - select = select_spec( - choices = variable_choices("iris"), - selected = first_choice() - ) - ), - data_extract_spec( - data = "mtcars" - select = select_spec( - choices = variable_choices("mtcars"), - selected = first_choice() - ) - ) -) - -# to -picks( - datasets(c("iris", "mtcars"), "iris"), - variables( - choices = tidyselect::everything(), - selected = 1L - ) -) - -``` -### filtering by any variable - -`picks` provides no equivalent to `filter_spec` feature. To achieve this, please create a `teal_transform_module` with -a filtering mechanism. - -``` -list( - data_extract_spec( - data = "iris" - select = select_spec( - choices = c("Sepal.Length", "Species"), - selected = first_choice() - ), - filter = filter_spec( - vars = "Species", - choices = c("setosa", "versicolor", "virginica"), - selected = "setosa" - ) - ) -) - -# to picks and transformators -picks( - datasets("iris", "iris"), - variables( - choices = c("Sepal.Length", "Species"), - selected = 1L - ) -) - -# Apply filtering through teal_transform_module -transformators = teal_transform_module( - ui = function(id) { - ns <- NS(id) - selectInput( - ns("species"), - label = "Select species", - choices = c("setosa", "versicolor", "virginica"), - selected = "setosa" - ) - }, - server = function(id, data) { - moduleServer(id, function(input, output, session) { - reactive({ - req(input$species) - within( - data(), { - iris <- iris %>% dplyr::filter(Species %in% !!filter_values) - }, - filter_values = input$species) - }) - }) - } -) - -``` - -## Conversion from to data-extract-spec - -`picks` will completelly replace `data_extract_spec` (des) and will be the only tool to select-and-merge -in `teal` framework. So far des will be supported as soft deprecated. `help("as.picks")` -contains the information how to convert des into picks but in a limited scope. -- `data_extract_spec` (or a list of des) containing only `select_spec` are convertible 1:1 to the `picks` -- `filter_spec` is not convertible to `picks` as it variables used in filter can be different than variables selected in `select_spec`, thus hierarchical form of `picks` can't handle this case. -- `filter_spec` can be converted to `teal_transform_module` and used in `transformators` argument instead and we recommend to do so. `teal.transform::teal_transform_filter` provides a simplified way to create such `transformator`. - - -### Issues with `data_extract_spec` - -API of `data_extract_spec` is bad encapsulation, hard to extend, confusing and easy to break. - -#### Bad encapsulation - -In `filter_spec` one can specify `choices = value_choices(dataname, subset = function(data))`, this is vulnerable -for multiple failures: - -- `value_choices("dataname")` can be completelly different than `data_extract_spec(dataname)`, guess what happens? ;] -- `subset = function(data)` is a function of a dataset, it means that even if `vars = "Species"` has been provideed one still have to do `levels(data$Species)` instead of `levels(column)` - -As you can see, there are few places where scope of the classes is not well separated which leads to: - -- repeating same information on multiple levels of the hierarchy `data_extract_spec(dataname)` and `value_choices(dataname)`, `vars = "Species"`, `levels(data$Species)` -- Repeating the same information also requires to be cautious to have both places correctly specified, otherwise error will occur - -```r -data_extract_spec( - dataname = "iris", - select = select_spec( - choices = variable_choices(subset = function(data) names(data)) - selected = "Sepal.Length" - ), - filter = filter_spec( - vars = "Species", - choices = value_choices("iris, subset = function(data) levels(data$Species)), - selected = first_choice() - ) -) -``` - -Conclusion: - -- `value_choices(data)` shouldn't have an argument `data` as it is "given" by the `data_extract_spec`. Same applies to `variable_choices(data)`. -- `value_choices(subset = function(data))` should be a function of column which is set in `filter_spec(vars)` - -#### Hard to extend - -Recently one user asked to make `data_extract_spec(datanames)` delayed, so that it will adjust automatically to the existing datasets when resolved. Problem is API allow to have des for multiple datasets only when one knows their names. It is just done by making a list-of-des. Following code will produce dropdown with "iris" and "mtcars" and app-user will be able to switch between datasets (switching between des) - -```r -# pseudocode -list( - data_extract_spec(dataname = "iris", ...), - data_extract_spec(dataname = "mtcars", ...) -) -``` - -Proposition was that `dataname = dataset_choices()`, similar to the `filter_spec(vars = variable_choices())`. Let's consider how would it look like: - -```r -data_extract_spec( - dataname = dataset_choices(choices = all_datasets(), selected = first_choice()), - select = select_spec( - choices = variable_choices(dataname = ??, choices = function(x) names(data)) - ) - filter = filter_spec( - vars = variable_choices(dataname = ??, choices = function(x) names(data)), # how to obtain delayed `dataname` - choices = value_choices(dataname = ??, choices = function(x) data$?? |> levels()) # how to obtain delayed `vars` - ) -) -``` - -To achive this, package would have to be seriously refactored, to be able to do following: - -```r -data_extract_spec( - dataname = dataset_choices(choices = all_datasets(), selected = first_choice()), - select = select_spec( - choices = variable_choices(choices = function(x) names(data)) - ), - filter = filter_spec( - vars = variable_choices(choices = function(data) names(data)), - choices = value_choices(choices = function(column) column |> levels()) - ) -) -``` - -Let's just use above example and change function names: - -``` -picks( - datanames(choices = all_datasets(), selected = first_choice()), - variables( - choices = variable_choices(choices = function(x) names(data)) - ), - values( - vars = variable_choices(choices = function(data) names(data)), - choices = value_choices(choices = function(column) column |> levels()) - ) -) -``` From 621603df655f4c051de612f1c35a66cf44a81756 Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Fri, 31 Oct 2025 08:36:10 +0100 Subject: [PATCH 142/142] pkgdown --- R/0-as_picks.R | 2 ++ R/0-module_picks.R | 2 +- R/0-tidyselect-helpers.R | 4 +++- _pkgdown.yml | 25 +++++++++++++++++++++++++ man/as.picks.Rd | 1 + man/dot-update_rv.Rd | 1 + man/picks_module.Rd | 2 -- man/tidyselectors.Rd | 3 ++- 8 files changed, 35 insertions(+), 5 deletions(-) diff --git a/R/0-as_picks.R b/R/0-as_picks.R index df605106..43fa2de8 100644 --- a/R/0-as_picks.R +++ b/R/0-as_picks.R @@ -1,5 +1,7 @@ #' Convert data_extract_spec to picks #' +#' @description +#' `r lifecycle::badge("experimental")` #' Helper functions to ease transition between [data_extract_spec()] and [picks()]. #' @inheritParams teal::teal_transform_module #' @param x (`data_extract_spec`, `select_spec`, `filter_spec`) object to convert to [`picks`] diff --git a/R/0-module_picks.R b/R/0-module_picks.R index 2b4b29a1..4a79cef3 100644 --- a/R/0-module_picks.R +++ b/R/0-module_picks.R @@ -1,7 +1,6 @@ #' Interactive picks #' #' @description -#' `r lifecycle::badge("experimental")` #' #' Creates UI and server components for interactive [picks()] in Shiny modules. The module is based on #' configuration provided via [picks()] and its responsibility is to determine relevant input @@ -315,6 +314,7 @@ picks_srv.picks <- function(id, picks, data) { #' @param rv (`reactiveVal`) #' @param value (`vector`) #' @param log (`character(1)`) message to `log_debug` +#' @keywords internal .update_rv <- function(rv, value, log) { if (!isTRUE(all.equal(rv(), value, tolerance = 1e-15))) { # tolerance 1e-15 is a max precision in widgets. logger::log_debug(log) diff --git a/R/0-tidyselect-helpers.R b/R/0-tidyselect-helpers.R index a9b94b4c..2e90aad2 100644 --- a/R/0-tidyselect-helpers.R +++ b/R/0-tidyselect-helpers.R @@ -1,6 +1,8 @@ #' `tidyselect` helpers #' -#' +#' @description +#' #' `r lifecycle::badge("experimental")` +#' Predicate functions simplifying `picks` specification. #' @examples #' # select factor column but exclude foreign keys #' variables(choices = is_categorical(min.len = 2, max.len = 10)) diff --git a/_pkgdown.yml b/_pkgdown.yml index 1fb8c182..43605f6c 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -65,3 +65,28 @@ reference: - title: Human-readable formatting of a data extract object contents: - format_data_extract + - title: Picks + desc: >- + Picks contructors + contents: + - picks + - datasets + - variables + - values + - title: Shiny modules + desc: >- + Modules to interactively select-and-merge + contents: + - merge_srv + - picks_srv + - picks_ui + - tm_merge + - title: Picks utilities + desc: >- + Additional tools to help working with picks + contents: + - as.picks + - is_categorical + - resolver + - teal_transform_filter + diff --git a/man/as.picks.Rd b/man/as.picks.Rd index 8102f105..2975d143 100644 --- a/man/as.picks.Rd +++ b/man/as.picks.Rd @@ -15,6 +15,7 @@ teal_transform_filter(x, label = "Filter") \item{label}{(\code{character(1)}) Label of the module.} } \description{ +\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} Helper functions to ease transition between \code{\link[=data_extract_spec]{data_extract_spec()}} and \code{\link[=picks]{picks()}}. } \details{ diff --git a/man/dot-update_rv.Rd b/man/dot-update_rv.Rd index 4fb50551..7fba79dc 100644 --- a/man/dot-update_rv.Rd +++ b/man/dot-update_rv.Rd @@ -16,3 +16,4 @@ \description{ Update reactive values only if values differ to avoid unnecessary reactive trigger } +\keyword{internal} diff --git a/man/picks_module.Rd b/man/picks_module.Rd index aea3c789..68b3c2ac 100644 --- a/man/picks_module.Rd +++ b/man/picks_module.Rd @@ -39,8 +39,6 @@ functions. By default, elements are wrapped in a package-specific drop-down.} } } \description{ -\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} - Creates UI and server components for interactive \code{\link[=picks]{picks()}} in Shiny modules. The module is based on configuration provided via \code{\link[=picks]{picks()}} and its responsibility is to determine relevant input values diff --git a/man/tidyselectors.Rd b/man/tidyselectors.Rd index 7dc889d3..58cdb0cd 100644 --- a/man/tidyselectors.Rd +++ b/man/tidyselectors.Rd @@ -13,7 +13,8 @@ is_categorical(min.len, max.len) \item{max.len}{(\code{integer(1)}) maximal number of unique values} } \description{ -\code{tidyselect} helpers +#' \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} +Predicate functions simplifying \code{picks} specification. } \examples{ # select factor column but exclude foreign keys