Skip to content

Commit c3f8e42

Browse files
gogonzogogonzo
committed
WIP
1 parent 3302ffb commit c3f8e42

25 files changed

+2075
-562
lines changed

‎DESCRIPTION‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -31,6 +31,7 @@ Imports:
3131
shinyjs (>= 2.1.0),
3232
shinyvalidate (>= 0.1.3),
3333
stats,
34+
teal,
3435
teal.data (>= 0.8.0),
3536
teal.logger (>= 0.4.0),
3637
teal.widgets (>= 0.5.0),

‎NAMESPACE‎

Lines changed: 5 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,8 @@
11
# Generated by roxygen2: do not edit by hand
22

3+
S3method(.is.delayed,default)
4+
S3method(.is.delayed,list)
5+
S3method(.is.delayed,pick)
36
S3method(.picker_icon,Date)
47
S3method(.picker_icon,MultiAssayExperiment)
58
S3method(.picker_icon,POSIXct)
@@ -60,6 +63,7 @@ S3method(variable_choices,data.frame)
6063
export("%>%")
6164
export(add_no_selected_choices)
6265
export(all_choices)
66+
export(as.picks)
6367
export(check_no_multiple_selection)
6468
export(choices_labeled)
6569
export(choices_selected)
@@ -68,7 +72,6 @@ export(data_extract_multiple_srv)
6872
export(data_extract_spec)
6973
export(data_extract_srv)
7074
export(data_extract_ui)
71-
export(datanames)
7275
export(datanames_input)
7376
export(datasets)
7477
export(filter_spec)
@@ -103,6 +106,7 @@ export(select_spec)
103106
export(select_spec.default)
104107
export(select_spec.delayed_data)
105108
export(split_by_sep)
109+
export(teal_transform_filter)
106110
export(value_choices)
107111
export(values)
108112
export(variable_choices)

‎R/0-as_picks.R‎

Lines changed: 235 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,235 @@
1+
#' Convert data_extract_spec to picks
2+
#'
3+
#' Helper functions to ease transition between [data_extract_spec()] and [picks()].
4+
#' @param x (`data_extract_spec`, `select_spec`, `filter_spec`) object to convert to [`picks`]
5+
#'
6+
#' @details
7+
#' With introduction of [`picks`], [`data_extract_spec`] will no longer serve a primary tool to
8+
#' define variable choices and default selection in teal-modules and eventually [`data_extract_spec`]
9+
#' will be deprecated.
10+
#' To ease the transition to the new tool, we provide `as.picks` method which can handle 1:1
11+
#' conversion from [`data_extract_spec`] to [`picks`]. Unfortunately, when [`data_extract_spec`]
12+
#' contains [`filter_spec`] then `as.picks` is unable to provide reliable [`picks`] equivalent.
13+
#'
14+
#' @examples
15+
#' # convert des with eager select_spec
16+
#' as.picks(
17+
#' data_extract_spec(
18+
#' dataname = "iris",
19+
#' select_spec(
20+
#' choices = c("Sepal.Length", "Sepal.Width", "Species"),
21+
#' selected = c("Sepal.Length", "Species"),
22+
#' multiple = TRUE,
23+
#' ordered = TRUE
24+
#' )
25+
#' )
26+
#' )
27+
#'
28+
#' # convert des with delayed select_spec
29+
#' as.picks(
30+
#' data_extract_spec(
31+
#' dataname = "iris",
32+
#' select_spec(
33+
#' choices = variable_choices("iris"),
34+
#' selected = first_choice(),
35+
#' multiple = TRUE,
36+
#' ordered = TRUE
37+
#' )
38+
#' )
39+
#' )
40+
#'
41+
#' as.picks(
42+
#' data_extract_spec(
43+
#' dataname = "iris",
44+
#' select_spec(
45+
#' choices = variable_choices("iris", subset = function(data) names(Filter(is.numeric, data))),
46+
#' selected = first_choice(),
47+
#' multiple = TRUE,
48+
#' ordered = TRUE
49+
#' )
50+
#' )
51+
#' )
52+
#'
53+
#' @export
54+
as.picks <- function(x, ...) {
55+
if (inherits(x, c("picks", "pick"))) {
56+
x
57+
} else if (checkmate::test_list(x, c("data_extract_spec", "filter_spec"))) {
58+
Filter(length, lapply(x, as.picks, ...))
59+
} else if (inherits(x, "data_extract_spec")) {
60+
args <- Filter(
61+
length,
62+
list(
63+
datasets(choices = x$dataname, fixed = TRUE),
64+
as.picks(x$select),
65+
as.picks(x$filter, dataname = x$dataname)
66+
# filter_spec as they are not necessary linked with `select` (selected variables)
67+
# as filter_spec can be specified on the variable(s) different than select_spec for example:
68+
# for example: #pseudocode select = select_spec(AVAL); filter = filter_spec(PARAMCD))
69+
)
70+
)
71+
do.call(picks, args)
72+
} else if (inherits(x, "select_spec")) {
73+
.select_spec_to_variables(x)
74+
} else if (inherits(x, "filter_spec")) {
75+
dataname <- list(...)$dataname
76+
# warning
77+
warning(
78+
"`filter_spec` are not convertible to picks - please use `transformers` argument",
79+
"and create `teal_transform_module` containing necessary filter. See `?teal_transform_filter`"
80+
)
81+
82+
NULL
83+
}
84+
}
85+
86+
#' @rdname as.picks
87+
#' @examples
88+
#' # teal_transform_module build on teal.transform
89+
#'
90+
#' teal_transform_filter(
91+
#' data_extract_spec(
92+
#' dataname = "iris",
93+
#' filter = filter_spec(
94+
#' vars = "Species",
95+
#' choices = c("setosa", "versicolor", "virginica"),
96+
#' selected = c("setosa", "versicolor")
97+
#' )
98+
#' )
99+
#' )
100+
#'
101+
#' teal_transform_filter(
102+
#' picks(
103+
#' datasets(choices = "iris", select = "iris"),
104+
#' variables(choices = "Species", "Species"),
105+
#' values(
106+
#' choices = c("setosa", "versicolor", "virginica"),
107+
#' selected = c("setosa", "versicolor")
108+
#' )
109+
#' )
110+
#' )
111+
#'
112+
#' @export
113+
teal_transform_filter <- function(x, label = "Filter") {
114+
checkmate::assert_multi_class(x, c("data_extract_spec", "picks"))
115+
if (inherits(x, "data_extract_spec")) {
116+
lapply(as.picks.filter(x), teal_transform_filter, label = label)
117+
} else {
118+
checkmate::assert_true("values" %in% names(x))
119+
teal::teal_transform_module(
120+
label = label,
121+
ui <- function(id) {
122+
ns <- NS(id)
123+
picks_ui(ns("transformer"), picks = x, container = div)
124+
},
125+
server <- function(id, data) {
126+
moduleServer(id, function(input, output, session) {
127+
selector <- picks_srv("transformer", picks = x, data = data)
128+
reactive({
129+
req(data(), selector())
130+
# todo: make sure filter call is not executed when setequal(selected, all_possible_choices)
131+
filter_call <- .make_filter_call(
132+
datasets = selector()$datasets$selected,
133+
variables = selector()$variables$selected,
134+
values = selector()$values$selected
135+
)
136+
teal.code::eval_code(data(), filter_call)
137+
})
138+
})
139+
}
140+
)
141+
}
142+
}
143+
144+
as.picks.filter <- function(x, dataname) {
145+
if (inherits(x, "filter_spec")) {
146+
if (inherits(x$choices, "delayed_data")) {
147+
warning(
148+
"filter_spec(choices) doesn't support delayed_data when using with teal_transform_filter. ",
149+
"Setting to all possible choices..."
150+
)
151+
x$choices <- function(x) TRUE
152+
}
153+
if (inherits(x$selected, "delayed_data")) {
154+
warning(
155+
"filter_spec(selected) doesn't support delayed_data when using with teal_transform_filter. ",
156+
"Setting to all possible choices..."
157+
)
158+
x$selected <- function(x) TRUE
159+
}
160+
picks(
161+
datasets(choices = dataname, selected = dataname),
162+
variables(choices = x$vars_choices, selected = x$vars_selected, multiple = FALSE), # can't be multiple
163+
values(choices = x$choices, selected = x$selected, multiple = x$multiple)
164+
)
165+
} else if (checkmate::test_list(x, "filter_spec")) {
166+
lapply(x, as.picks.filter, dataname = dataname)
167+
} else if (inherits(x, "data_extract_spec")) {
168+
as.picks.filter(x$filter, dataname = x$dataname)
169+
} else if (checkmate::test_list(x, c("data_extract_spec", "list", "NULL"))) {
170+
unlist(
171+
lapply(Filter(length, x), as.picks.filter),
172+
recursive = FALSE
173+
)
174+
}
175+
}
176+
177+
.make_filter_call <- function(datasets, variables, values) {
178+
checkmate::assert_character(datasets)
179+
checkmate::assert_character(variables)
180+
checkmate::assert_character(values)
181+
substitute(
182+
dataname <- dplyr::filter(dataname, varname %in% values),
183+
list(
184+
dataname = as.name(datasets),
185+
varname = if (length(variables) == 1) {
186+
as.name(variables)
187+
} else {
188+
as.call(
189+
c(
190+
quote(paste),
191+
lapply(variables, as.name),
192+
list(sep = ", ")
193+
)
194+
)
195+
},
196+
values = values
197+
)
198+
)
199+
}
200+
201+
.select_spec_to_variables <- function(x) {
202+
if (length(x)) {
203+
variables(
204+
choices = if (inherits(x$choices, "delayed_data")) {
205+
out <- x$choices$subset
206+
if (is.null(out)) {
207+
function(x) TRUE # same effect as tidyselect::everything
208+
} else {
209+
class(out) <- "des-delayed"
210+
out
211+
}
212+
} else {
213+
x$choices
214+
},
215+
selected = if (inherits(x$selected, "delayed_choices")) {
216+
out <- x$selected
217+
class(out) <- "des-delayed"
218+
out
219+
} else if (inherits(x$selected, "delayed_data")) {
220+
out <- x$selected$subset
221+
if (is.null(out)) {
222+
1L
223+
} else {
224+
class(out) <- "des-delayed"
225+
out
226+
}
227+
} else {
228+
unname(x$selected)
229+
},
230+
ordered = x$ordered,
231+
multiple = x$multiple,
232+
fixed = x$fixed
233+
)
234+
}
235+
}

0 commit comments

Comments
 (0)