Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Field titles #333

Merged
merged 6 commits into from
Mar 6, 2024
Merged

Field titles #333

Show file tree
Hide file tree
Changes from 5 commits
Commits
Show all changes
6 commits
Select commit Hold shift + click to select a range
aefdde4
feat: use title for fields closes #319 fixes #314
JohnCoene Mar 6, 2024
388716d
feat: field titles as arguments
JohnCoene Mar 6, 2024
bf04c82
ci: add tests
JohnCoene Mar 6, 2024
38e28af
lint: blockr 193
JohnCoene Mar 6, 2024
7f9d4da
lint: block l 423
JohnCoene Mar 6, 2024
6381894
revert: do not expose field titles
JohnCoene Mar 6, 2024
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
122 changes: 81 additions & 41 deletions R/block.R
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -190,9 +190,11 @@ evaluate_block.plot_layer_block <- function(x, data, ...) {
#' @param selected Selected dataset.
#' @export
new_data_block <- function(
...,
dat = as.environment("package:datasets"),
selected = character()) {
...,
dat = as.environment("package:datasets"),
selected = character(),
field_dataset = "Dataset"
) {
is_dataset_eligible <- function(x) {
inherits(
get(x, envir = dat, inherits = FALSE),
Expand All @@ -206,7 +208,11 @@ new_data_block <- function(
if (length(selected) == 0) selected <- datasets[1]

fields <- list(
dataset = new_select_field(selected, datasets)
dataset = new_select_field(
selected,
datasets,
title = field_dataset
)
)

expr <- substitute(
Expand All @@ -230,15 +236,15 @@ data_block <- function(...) {

#' @rdname new_block
#' @export
new_upload_block <- function(...) {
new_upload_block <- function(..., field_file = "File") {

data_path <- function(file) {
if (length(file)) file$datapath else character()
}

new_block(
fields = list(
file = new_upload_field(),
file = new_upload_field(title = field_file),
expression = new_hidden_field(data_path)
),
expr = quote(c(.(expression))),
Expand All @@ -256,7 +262,7 @@ upload_block <- function(...) {
#' @rdname new_block
#' @param volumes Paths accessible by the shinyFiles browser.
#' @export
new_filesbrowser_block <- function(volumes = c(home = path.expand("~")), ...) {
new_filesbrowser_block <- function(volumes = c(home = path.expand("~")), ..., field_file = "File") {

data_path <- function(file) {

Expand All @@ -271,7 +277,7 @@ new_filesbrowser_block <- function(volumes = c(home = path.expand("~")), ...) {

new_block(
fields = list(
file = new_filesbrowser_field(volumes = volumes),
file = new_filesbrowser_field(volumes = volumes, title = field_file),
expression = new_hidden_field(data_path)
),
expr = quote(c(.(expression))),
Expand Down Expand Up @@ -374,10 +380,10 @@ xpt_block <- function(data, ...) {

#' @rdname new_block
#' @export
new_result_block <- function(...) {
new_result_block <- function(..., field_stack = "Stack") {

fields <- list(
stack = new_result_field()
stack = new_result_field(title = field_stack)
)

new_block(
Expand Down Expand Up @@ -414,11 +420,15 @@ initialize_block.data_block <- function(x, ...) {
#' @rdname new_block
#' @export
new_filter_block <- function(
data,
columns = colnames(data)[1L],
values = character(),
filter_fun = "==",
...) {
data,
columns = colnames(data)[1L],
values = character(),
filter_fun = "==",
...,
field_columns = "Columns",
field_filter_fun = "Comparison",
field_values = "Value"
) {
sub_fields <- function(data, columns) {
determine_field <- function(x) {
switch(class(x),
Expand Down Expand Up @@ -475,8 +485,7 @@ new_filter_block <- function(
col_choices <- function(data) colnames(data)

fields <- list(
columns = new_select_field(columns, col_choices, multiple = TRUE),
values = new_list_field(values, sub_fields),
columns = new_select_field(columns, col_choices, multiple = TRUE, title = field_columns),
filter_func = new_select_field(
filter_fun,
choices = c(
Expand All @@ -489,8 +498,10 @@ new_filter_block <- function(
"<",
">=",
"<="
)
),
title = field_filter_fun
),
values = new_list_field(values, sub_fields, title = field_values),
expression = new_hidden_field(filter_exps)
)

Expand All @@ -516,12 +527,12 @@ filter_block <- function(data, ...) {
#' @param columns Column(s) to select.
#' @rdname new_block
#' @export
new_select_block <- function(data, columns = colnames(data)[1], ...) {
new_select_block <- function(data, columns = colnames(data)[1], ..., field_columns = "Columns") {
all_cols <- function(data) colnames(data)

# Select_field only allow one value, not multi select
fields <- list(
columns = new_select_field(columns, all_cols, multiple = TRUE)
columns = new_select_field(columns, all_cols, multiple = TRUE, title = field_columns)
)

new_block(
Expand All @@ -543,10 +554,13 @@ new_select_block <- function(data, columns = colnames(data)[1], ...) {
#' @rdname new_block
#' @export
new_summarize_block <- function(
data,
func = c("mean", "se"),
default_columns = character(),
...) {
data,
func = c("mean", "se"),
default_columns = character(),
...,
field_columns = "Columns",
field_funcs = "Functions"
) {
if (length(default_columns) > 0) {
stopifnot(length(func) == length(default_columns))
}
Expand Down Expand Up @@ -635,8 +649,8 @@ new_summarize_block <- function(
)

fields <- list(
funcs = new_select_field(func, func_choices, multiple = TRUE),
columns = new_list_field(sub_fields = sub_fields),
funcs = new_select_field(func, func_choices, multiple = TRUE, title = field_funcs),
columns = new_list_field(sub_fields = sub_fields, title = field_columns),
expression = new_hidden_field(summarize_expr)
)

Expand Down Expand Up @@ -665,12 +679,18 @@ select_block <- function(data, ...) {

#' @rdname new_block
#' @export
new_arrange_block <- function(data, columns = colnames(data)[1], ...) {
new_arrange_block <- function(data, columns = colnames(data)[1], ..., field_columns = "Columns") {
all_cols <- function(data) colnames(data)

# Type as name for arrange and group_by
fields <- list(
columns = new_select_field(columns, all_cols, multiple = TRUE, type = "name")
columns = new_select_field(
columns,
all_cols,
multiple = TRUE,
type = "name",
title = field_columns
)
)

new_block(
Expand All @@ -689,12 +709,18 @@ arrange_block <- function(data, ...) {

#' @rdname new_block
#' @export
new_group_by_block <- function(data, columns = colnames(data)[1], ...) {
new_group_by_block <- function(data, columns = colnames(data)[1], ..., field_columns = "Columns") {
all_cols <- function(data) colnames(data)

# Select_field only allow one value, not multi select
fields <- list(
columns = new_select_field(columns, all_cols, multiple = TRUE, type = "name")
columns = new_select_field(
columns,
all_cols,
multiple = TRUE,
type = "name",
title = field_columns
)
)

new_block(
Expand All @@ -709,7 +735,10 @@ new_group_by_block <- function(data, columns = colnames(data)[1], ...) {

#' @rdname new_block
#' @export
group_by_block <- function(data, ...) {
group_by_block <- function(
data,
...
) {
initialize_block(new_group_by_block(data, ...), data)
}

Expand All @@ -719,8 +748,16 @@ group_by_block <- function(data, ...) {
#'
#' @rdname new_block
#' @export
new_join_block <- function(data, y = NULL, type = character(),
by = character(), ...) {
new_join_block <- function(
data,
y = NULL,
type = character(),
by = character(),
...,
field_join_func = "Type",
field_y = "Stack",
field_by = "By"
) {

by_choices <- function(data, y) {
intersect(colnames(data), colnames(y))
Expand All @@ -742,10 +779,11 @@ new_join_block <- function(data, y = NULL, type = character(),
join_func = new_select_field(
paste(type, "join", sep = "_"),
paste(join_types, "join", sep = "_"),
type = "name"
type = "name",
title = field_join_func
),
y = new_result_field(y),
by = new_select_field(by, by_choices, multiple = TRUE)
y = new_result_field(y, title = field_y),
by = new_select_field(by, by_choices, multiple = TRUE, title = field_by)
)

new_block(
Expand All @@ -767,10 +805,12 @@ join_block <- function(data, ...) {
#' @param n_rows_min Minimum number of rows.
#' @export
new_head_block <- function(
data,
n_rows = numeric(),
n_rows_min = 1L,
...) {
data,
n_rows = numeric(),
n_rows_min = 1L,
...,
field_n_rows = "Number of rows"
) {
tmp_expr <- function(n_rows) {
bquote(
head(n = .(n_rows)),
Expand All @@ -779,7 +819,7 @@ new_head_block <- function(
}

fields <- list(
n_rows = new_numeric_field(n_rows, n_rows_min, nrow(data)),
n_rows = new_numeric_field(n_rows, n_rows_min, nrow(data), title = field_n_rows),
expression = new_hidden_field(tmp_expr)
)

Expand Down
17 changes: 17 additions & 0 deletions R/field.R
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -557,3 +557,20 @@ generate_server.result_field <- function(x, ...) {
})
}
}

get_field_name <- function(field, name = "") {
Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Add unit test to get_field_name and get_field_names.

Copy link
Member Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

added tests

title <- attr(field, "title")

if (title == "")
return(name)

title
}

get_field_names <- function(x) {
titles <- character(length(x))
for (i in seq_along(x)){
titles[i] <- get_field_name(x[[i]], names(x)[i])
}
titles
}
16 changes: 8 additions & 8 deletions R/ui.R
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -26,7 +26,7 @@
ui_input,
x,
id = chr_ply(names(x), ns),
name = names(x)
name = get_field_names(x)
)

div(
Expand Down Expand Up @@ -629,21 +629,21 @@
#' @rdname generate_ui
#' @export
ui_update.string_field <- function(x, session, id, name) {
updateTextInput(session, input_ids(x, id), name, value(x))
updateTextInput(session, input_ids(x, id), get_field_name(x, name), value(x))

Check warning on line 632 in R/ui.R

View check run for this annotation

Codecov / codecov/patch

R/ui.R#L632 

Added line #L632 was not covered by tests
}

#' @rdname generate_ui
#' @export
ui_update.select_field <- function(x, session, id, name) {
updateSelectInput(
session, input_ids(x, id), name, value(x, "choices"), value(x)
session, input_ids(x, id), get_field_name(x, name), value(x, "choices"), value(x)

Check warning on line 639 in R/ui.R

View check run for this annotation

Codecov / codecov/patch

R/ui.R#L639 

Added line #L639 was not covered by tests
)
}

#' @rdname generate_ui
#' @export
ui_update.switch_field <- function(x, session, id, name) {
bslib::update_switch(input_ids(x, id), name, value(x), session)
bslib::update_switch(input_ids(x, id), get_field_name(x, name), value(x), session)

Check warning on line 646 in R/ui.R

View check run for this annotation

Codecov / codecov/patch

R/ui.R#L646 

Added line #L646 was not covered by tests
}

#' @rdname generate_ui
Expand All @@ -663,7 +663,7 @@

insertUI(
selector = paste0("#", ns_id, "_cont"),
ui = ui_input(field, ns_id, name),
ui = ui_input(field, ns_id, get_field_name(x, name)),

Check warning on line 666 in R/ui.R

View check run for this annotation

Codecov / codecov/patch

R/ui.R#L666 

Added line #L666 was not covered by tests
session = session
)
}
Expand All @@ -672,15 +672,15 @@
#' @export
ui_update.range_field <- function(x, session, id, name) {
updateSliderInput(
session, input_ids(x, id), name, value(x), value(x, "min"), value(x, "max")
session, input_ids(x, id), get_field_name(x, name), value(x), value(x, "min"), value(x, "max")

Check warning on line 675 in R/ui.R

View check run for this annotation

Codecov / codecov/patch

R/ui.R#L675 

Added line #L675 was not covered by tests
)
}

#' @rdname generate_ui
#' @export
ui_update.numeric_field <- function(x, session, id, name) {
updateNumericInput(
session, input_ids(x, id), name, value(x), value(x, "min"), value(x, "max")
session, input_ids(x, id), get_field_name(x, name), value(x), value(x, "min"), value(x, "max")

Check warning on line 683 in R/ui.R

View check run for this annotation

Codecov / codecov/patch

R/ui.R#L683 

Added line #L683 was not covered by tests
)
}

Expand Down Expand Up @@ -738,7 +738,7 @@
ui = do.call(
tagList,
map(
ui_input, fields, input_ids(x, ns_id), paste0(name, "_", names(fields))
ui_input, fields, input_ids(x, ns_id), paste0(name, ": ", names(fields))

Check warning on line 741 in R/ui.R

View check run for this annotation

Codecov / codecov/patch

R/ui.R#L741 

Added line #L741 was not covered by tests
)
),
session = session
Expand Down
Loading
Loading