Skip to content

Commit

Permalink
use var_labels only in edit modal
Browse files Browse the repository at this point in the history
  • Loading branch information
@pvictor
pvictor committed Jan 8, 2024
1 parent 429b1ac commit e2ec08d
Show file tree
Hide file tree
Showing 5 changed files with 90 additions and 49 deletions.
4 changes: 4 additions & 0 deletions NAMESPACE
View file
Original file line number Diff line number Diff line change
Expand Up @@ -63,6 +63,7 @@ importFrom(rio,import)
importFrom(rlang,"%||%")
importFrom(rlang,as_function)
importFrom(rlang,as_label)
importFrom(rlang,as_list)
importFrom(rlang,enquo)
importFrom(rlang,eval_tidy)
importFrom(rlang,exec)
Expand All @@ -72,6 +73,9 @@ importFrom(rlang,is_double)
importFrom(rlang,is_function)
importFrom(rlang,is_list)
importFrom(rlang,is_named)
importFrom(rlang,is_null)
importFrom(rlang,is_vector)
importFrom(rlang,set_names)
importFrom(rlang,sym)
importFrom(shiny,NS)
importFrom(shiny,actionButton)
Expand Down
59 changes: 42 additions & 17 deletions R/edit-data-utils.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -27,20 +27,16 @@ edit_modal <- function(default = list(),
id_validate = "add_row",
title = i18n("Add a row"),
data,
colnames = names(data),
var_edit,
var_mandatory,
var_edit = NULL,
var_mandatory = NULL,
var_labels = colnames(data),
modal_size = "m",
modal_easy_close = FALSE,
session = getDefaultReactiveDomain()) {
ns <- session$ns

if (identical(var_edit, character(0)) | identical(var_edit, NULL)) {
data <- data
position_var_edit <- seq_len(ncol(data))
} else {
if (length(var_edit) > 0) {
data <- data[, ..var_edit]
position_var_edit <- as.numeric(gsub("col_", "", var_edit))
}

showModal(modalDialog(
Expand All @@ -61,9 +57,8 @@ edit_modal <- function(default = list(),
edit_input_form(
default = default,
data = data,
colnames = colnames,
var_mandatory = var_mandatory,
position_var_edit = position_var_edit,
var_labels = var_labels,
session = session
),
actionButton(
Expand All @@ -89,35 +84,41 @@ edit_modal <- function(default = list(),
#' @importFrom shiny numericInput textInput
#' @importFrom shinyWidgets virtualSelectInput prettyCheckbox airDatepickerInput
#' @importFrom htmltools tagList tags
#' @importFrom rlang is_vector is_named
#'
#' @return different shiny widgets with edited columns according to their respective class
#' @noRd
#'
edit_input_form <- function(default = list(),
data,
colnames,
var_mandatory,
position_var_edit,
var_mandatory = NULL,
var_labels = colnames(data),
session = getDefaultReactiveDomain()) {

ns <- session$ns

if (is_vector(var_labels) & !is_named(var_labels)) {
var_labels <- setNames(var_labels, unlist(var_labels))
}

tagList(
lapply(
X = seq_len(ncol(data)),
FUN = function(i) {
variable_id <- colnames(data)[i]
variable_name <- colnames[position_var_edit[i]]
variable_label <- var_labels[which(names(var_labels) == variable_id)]
if (length(variable_label) < 1)
variable_label <- variable_id
variable <- data[[i]]

suffix <- if (isTRUE((inherits(variable, "logical")))) "" else " : "
if (variable_name %in% var_mandatory) {
if (variable_id %in% var_mandatory) {
label <- tagList(
variable_name,
variable_label,
tags$span(HTML("&#42;"), class = "asterisk", style = "color: red;"), suffix
)
} else {
label <- paste0(variable_name, suffix)
label <- paste0(variable_label, suffix)
}

if (isTRUE(inherits(variable, c("numeric", "integer")))) {
Expand Down Expand Up @@ -252,6 +253,30 @@ rename_edit <- function(data, var_labels) {
}


#' @importFrom rlang set_names is_null as_list is_list is_named
get_variables_labels <- function(labels, column_names, internal_names) {
if (is_null(labels)) {
labels <- column_names
} else {
if (!is_list(labels)) {
stopifnot(
"If `var_labels` is an unnamed vector, it must have same length as `colnames(data)`" = length(labels) == length(column_names)
)
labels <- set_names(as_list(labels), column_names)
}
stopifnot(
"`var_labels` must be a named list" = is_named(labels)
)
names(labels) <- internal_names[match(names(labels), column_names)]
labels <- modifyList(
x = set_names(as_list(column_names), internal_names),
val = labels
)
}
return(labels)
}


#' @title The update column definition
#'
#' @return A column definition object that can be used to customize the update column in reactable().
Expand Down
39 changes: 19 additions & 20 deletions R/edit-data.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -46,14 +46,15 @@ edit_data_ui <- function(id) {
#'
#' @param id Module ID
#' @param data_r data_r `reactive` function containing a `data.frame` to use in the module.
#' @param add `boolean`, if `TRUE`, allows you to add a row in the table via a button at the top right
#' @param update `boolean`, if `TRUE`, allows you to modify a row of the table via a button located in the table on the row you want to edit
#' @param delete `boolean`, if `TRUE`, allows a row to be deleted from the table via a button in the table
#' @param download_csv if `TRUE`, allows to export the table in csv format via a download button
#' @param download_excel if `TRUE`, allows to export the table in excel format via a download button
#' @param file_name_export `character` that allows you to choose the export name of the downloaded file
#' @param var_edit vector of `character` which allows to choose the names of the editable columns
#' @param var_mandatory vector of `character` which allows to choose obligatory fields to fill
#' @param add `boolean`, if `TRUE`, allows you to add a row in the table via a button at the top right.
#' @param update `boolean`, if `TRUE`, allows you to modify a row of the table via a button located in the table on the row you want to edit.
#' @param delete `boolean`, if `TRUE`, allows a row to be deleted from the table via a button in the table.
#' @param download_csv if `TRUE`, allows to export the table in csv format via a download button.
#' @param download_excel if `TRUE`, allows to export the table in excel format via a download button.
#' @param file_name_export `character` that allows you to choose the export name of the downloaded file.
#' @param var_edit vector of `character` which allows to choose the names of the editable columns.
#' @param var_mandatory vector of `character` which allows to choose obligatory fields to fill.
#' @param var_labels named list, where names are colnames and values are labels to be used in edit modal.
#' @param return_class Class of returned data: `data.frame`, `data.table`, `tbl_df` (tibble) or `raw`.
#' @param reactable_options Options passed to [reactable::reactable()].
#' @param modal_size `character` which allows to choose the size of the modalDialog. One of "s" for small, "m" (the default) for medium, "l" for large, or "xl" for extra large.
Expand All @@ -80,7 +81,7 @@ edit_data_ui <- function(id) {
#' @importFrom writexl write_xlsx
#' @importFrom utils write.csv
#' @importFrom htmltools tagList
#' @importFrom rlang is_function
#' @importFrom rlang is_function is_list
#'
#' @export
#'
Expand Down Expand Up @@ -125,13 +126,10 @@ edit_data_server <- function(id,
data_init_r <- eventReactive(data_r(), {
req(data_r())
data <- data_r()
if (is.reactive(var_labels))
var_labels <- var_labels()
if (is.null(var_labels))
var_labels <- names(data)
data <- rename_edit(data = data, var_labels = var_labels)
if (is.reactive(var_mandatory))
var_mandatory <- var_mandatory()
if (is.reactive(var_labels))
var_labels <- var_labels()
if (is.reactive(var_edit))
var_edit <- var_edit()
if (is.null(var_edit))
Expand All @@ -142,8 +140,9 @@ edit_data_server <- function(id,
setnames(data, paste0("col_", seq_along(data)))
data_rv$internal_colnames <- copy(colnames(data))
}
data_rv$mandatory <- colnames(data)[which(data_rv$colnames %in% var_mandatory)]
data_rv$edit <- colnames(data)[which(data_rv$colnames %in% var_edit)]
data_rv$mandatory <- data_rv$internal_colnames[data_rv$colnames %in% var_mandatory]
data_rv$edit <- data_rv$internal_colnames[data_rv$colnames %in% var_edit]
data_rv$labels <- get_variables_labels(var_labels, data_rv$colnames, data_rv$internal_colnames)

data[, .datamods_id := seq_len(.N)]

Expand Down Expand Up @@ -213,9 +212,9 @@ edit_data_server <- function(id,
edit_modal(
id_validate = "add_row",
data = data_rv$data,
colnames = data_rv$colnames,
var_edit = data_rv$edit,
var_mandatory = var_mandatory,
var_mandatory = data_rv$mandatory,
var_labels = data_rv$labels,
modal_size = modal_size,
modal_easy_close = modal_easy_close
)
Expand Down Expand Up @@ -298,9 +297,9 @@ edit_data_server <- function(id,
title = i18n("Update row"),
id_validate = "update_row",
data = data,
colnames = data_rv$colnames,
var_edit = data_rv$edit,
var_mandatory = var_mandatory,
var_mandatory = data_rv$mandatory,
var_labels = data_rv$labels,
modal_size = modal_size,
modal_easy_close = modal_easy_close
)
Expand Down
9 changes: 6 additions & 3 deletions examples/edit_data.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -39,14 +39,17 @@ server <- function(input, output, session) {
defaultColDef = colDef(filterable = TRUE),
selection = "single",
columns = list(
name = colDef(style = list(fontWeight = "bold")),
date_obtained = colDef(format = colFormat(date = TRUE)),
name = colDef(name = "Name", style = list(fontWeight = "bold")),
credit_card_security_code = colDef(name = "Credit card security code"),
date_obtained = colDef(name = "Date obtained", format = colFormat(date = TRUE)),
contactless_card = colDef(
name = "Contactless Card",
cell = function(value) {
# Render as an X mark or check mark
if (value == FALSE) "\u274c No" else "\u2714\ufe0f Yes"
}),
}),
credit_card_provider = colDef(
name = "Credit card provider",
style = function(value) {
if (value == "Mastercard") {
color <- "#e06631"
Expand Down
28 changes: 19 additions & 9 deletions man/edit-data.Rd
View file

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

0 comments on commit e2ec08d

Please sign in to comment.