From 768afb8ffdbd59a281454ab51424db49ac49bda1 Mon Sep 17 00:00:00 2001 From: gsamra Date: Tue, 31 Oct 2023 09:11:47 +0100 Subject: [PATCH 1/3] maj module edit data : ajout options reactable + airDatepickerInput() pour variable de type POSIXct et POSIXt --- R/edit-data-utils.R | 29 ++++++++++++++++++++++++----- R/edit-data.R | 13 +++++++++++-- 2 files changed, 35 insertions(+), 7 deletions(-) diff --git a/R/edit-data-utils.R b/R/edit-data-utils.R index 58d570b..e83eaf7 100644 --- a/R/edit-data-utils.R +++ b/R/edit-data-utils.R @@ -157,6 +157,15 @@ edit_input_form <- function(default = list(), inline = TRUE, width = "100%" ) + } else if (isTRUE((inherits(variable, c("POSIXct", "POSIXt"))))) { + airDatepickerInput( + inputId = ns(variable_id), + label = label, + value = default[[variable_id]] %||% Sys.time(), + inline = TRUE, + timepicker = TRUE, + width = "100%" + ) } else { return(NULL) } @@ -178,7 +187,7 @@ edit_input_form <- function(default = list(), #' #' @importFrom reactable reactable colDef #' -table_display <- function(data, colnames = NULL) { +table_display <- function(data, colnames = NULL, reactableOptions = NULL) { cols <- list() for (i in seq_along(data)) { cols[[names(data)[i]]] <- colDef(name = colnames[i]) @@ -196,10 +205,19 @@ table_display <- function(data, colnames = NULL) { } cols$.datamods_id <- colDef(show = FALSE) - reactable( - data = data, - columns = cols - ) + + if (is.null(reactableOptions)) + reactableOptions <- list() + reactableOptions <- reactableOptions + reactableOptions$data <- data + reactableOptions$columns <- cols + + rlang::exec(reactable::reactable, !!!reactableOptions) + + # reactable( + # data = data, + # columns = cols + # ) } @@ -385,3 +403,4 @@ notification_info <- function(title, text) { clickToClose = TRUE ) } + diff --git a/R/edit-data.R b/R/edit-data.R index 0d144c1..cf40478 100644 --- a/R/edit-data.R +++ b/R/edit-data.R @@ -80,7 +80,8 @@ edit_data_server <- function(id, file_name_export = "data", var_edit = NULL, var_mandatory = NULL, - return_class = c("data.frame", "data.table", "tbl_df", "raw")) { + return_class = c("data.frame", "data.table", "tbl_df", "raw"), + reactableOptions = NULL) { return_class <- match.arg(return_class) moduleServer( id, @@ -146,9 +147,15 @@ edit_data_server <- function(id, data <- req(data_init_r()) table_display( data = data, - colnames = data_rv$colnames + colnames = data_rv$colnames, + reactableOptions = reactableOptions ) }) + + # Retrieve selected row(s) + selected_r <- reactive({ + getReactableState("table", "selected") + }) # Add a row --- @@ -393,6 +400,7 @@ edit_data_server <- function(id, } ) + return( reactive({ req(data_rv$data) @@ -401,6 +409,7 @@ edit_data_server <- function(id, data <- data[,-c(".datamods_id", ".datamods_edit_update", ".datamods_edit_delete")] setnames(data, data_rv$colnames) as_out(data, return_class) + setattr(data, "selected", selected_r()) }) ) From e29dc9bd62b3d8f58bc445e1d3badaccc2910c04 Mon Sep 17 00:00:00 2001 From: gsamra Date: Wed, 8 Nov 2023 10:26:48 +0100 Subject: [PATCH 2/3] maj module edit-data (utils et example) --- R/edit-data-utils.R | 122 ++++++++++++++++++++++++++++++++++--------- R/edit-data.R | 2 +- examples/edit_data.R | 37 ++++++++++++- 3 files changed, 135 insertions(+), 26 deletions(-) diff --git a/R/edit-data-utils.R b/R/edit-data-utils.R index e83eaf7..653e807 100644 --- a/R/edit-data-utils.R +++ b/R/edit-data-utils.R @@ -181,6 +181,7 @@ edit_input_form <- function(default = list(), #' #' @param data `data.frame` to use #' @param colnames `data.frame` column names +#' @param reactableOptions `list` allowing you to add reactable options #' #' @return the `data.frame` in reactable format #' @noRd @@ -188,37 +189,110 @@ edit_input_form <- function(default = list(), #' @importFrom reactable reactable colDef #' table_display <- function(data, colnames = NULL, reactableOptions = NULL) { + +# Table des correspondances des noms de colonnes de "data" +matches <- data.frame( + name_temp = setdiff(names(data), c(".datamods_edit_update", ".datamods_edit_delete", ".datamods_id")), + name_real = colnames +) + +# cols <- list() +if (!is.null(reactableOptions$columns)) { + cols <- reactableOptions$columns + + # Pour les colonnes qui sont éditées par l'utilisateur dans l'argument reactableOptions (dans reactableOptions$columns) : + # * si le "name" de colDef() d'une colonne est éditée par l'utilisateur : on ne fait rien + # * sinon on affecte le vrai nom initial de la colonne dans le "name" de colDef() de cette colonne + for (col in names(cols)) { + if (!("name" %in% names(cols[[col]]))) { + name_col <- col + cols[[col]][["name"]] <- name_col + } else { + NULL + } + } + + # Pour les colonnes qui ne sont pas éditées par l'utilisateur dans l'argument reactableOptions (dans reactableOptions$columns) : + # * leur affecter uniquement leur vrai nom initial de colonne dans le "name" de colDef() + unedited_columns <- setdiff( + matches$name_real[!matches$name_real %in% c(".datamods_edit_update", ".datamods_edit_delete", ".datamods_id")], + names(cols) + ) + for (i in seq_along(unedited_columns)) { + cols[[unedited_columns[i]]] <- colDef(name = unedited_columns[i]) + } + + # Remettre les noms temporaires : "col_1" , "col_2", ... pour le bon fonctionnement du module + for (i in seq_along(cols)) { + name_col <- names(cols)[i] + name_temp <- matches$name_temp[matches$name_real == name_col] + names(cols)[i] <- name_temp + } + +} else { cols <- list() for (i in seq_along(data)) { cols[[names(data)[i]]] <- colDef(name = colnames[i]) } - if (all(is.na(data$.datamods_edit_update))) { - cols$.datamods_edit_update = colDef(show = FALSE) - } else { - cols$.datamods_edit_update = col_def_update() - } +} - if (all(is.na(data$.datamods_edit_delete))) { - cols$.datamods_edit_delete = colDef(show = FALSE) - } else { - cols$.datamods_edit_delete = col_def_delete() - } - cols$.datamods_id <- colDef(show = FALSE) - - if (is.null(reactableOptions)) - reactableOptions <- list() - reactableOptions <- reactableOptions - reactableOptions$data <- data - reactableOptions$columns <- cols - - rlang::exec(reactable::reactable, !!!reactableOptions) - - # reactable( - # data = data, - # columns = cols - # ) +if (all(is.na(data$.datamods_edit_update))) { + cols$.datamods_edit_update = colDef(show = FALSE) +} else { + cols$.datamods_edit_update = col_def_update() +} + +if (all(is.na(data$.datamods_edit_delete))) { + cols$.datamods_edit_delete = colDef(show = FALSE) +} else { + cols$.datamods_edit_delete = col_def_delete() +} + +cols$.datamods_id <- colDef(show = FALSE) + + +if (is.null(reactableOptions)) + reactableOptions <- list() +reactableOptions <- reactableOptions +reactableOptions$data <- data +reactableOptions$columns <- cols + +rlang::exec(reactable::reactable, !!!reactableOptions) + } +# table_display <- function(data, colnames = NULL, reactableOptions = NULL) { +# cols <- list() +# for (i in seq_along(data)) { +# cols[[names(data)[i]]] <- colDef(name = colnames[i]) +# } +# if (all(is.na(data$.datamods_edit_update))) { +# cols$.datamods_edit_update = colDef(show = FALSE) +# } else { +# cols$.datamods_edit_update = col_def_update() +# } +# +# if (all(is.na(data$.datamods_edit_delete))) { +# cols$.datamods_edit_delete = colDef(show = FALSE) +# } else { +# cols$.datamods_edit_delete = col_def_delete() +# } +# +# cols$.datamods_id <- colDef(show = FALSE) +# +# if (is.null(reactableOptions)) +# reactableOptions <- list() +# reactableOptions <- reactableOptions +# reactableOptions$data <- data +# reactableOptions$columns <- cols +# +# rlang::exec(reactable::reactable, !!!reactableOptions) +# +# # reactable( +# # data = data, +# # columns = cols +# # ) +# } #' @title The update column definition diff --git a/R/edit-data.R b/R/edit-data.R index cf40478..a14ac1d 100644 --- a/R/edit-data.R +++ b/R/edit-data.R @@ -408,8 +408,8 @@ edit_data_server <- function(id, data <- as.data.table(data) data <- data[,-c(".datamods_id", ".datamods_edit_update", ".datamods_edit_delete")] setnames(data, data_rv$colnames) - as_out(data, return_class) setattr(data, "selected", selected_r()) + as_out(data, return_class) }) ) diff --git a/examples/edit_data.R b/examples/edit_data.R index 4f0d011..f93c0cb 100644 --- a/examples/edit_data.R +++ b/examples/edit_data.R @@ -24,7 +24,42 @@ server <- function(input, output, session) { download_excel = TRUE, file_name_export = "datas", # var_edit = c("name", "job", "credit_card_provider", "credit_card_security_code"), - var_mandatory = c("name", "job") + var_mandatory = c("name", "job"), + reactableOptions = list( + defaultColDef = colDef(filterable = TRUE), + columns = list( + 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" + } else if (value == "VISA 16 digit") { + color <- "#0c13cf" + } else if (value == "American Express") { + color <- "#4d8be8" + } else if (value == "JCB 16 digit") { + color <- "#23c45e" + } else { + color <- "#777" + } + list(color = color, fontWeight = "bold") + } + ) + ), + bordered = TRUE, + compact = TRUE, + searchable = TRUE, + highlight = TRUE + ) ) output$result <- renderPrint({ From 13ed191ed9f28b6d143bb843caf85e3a2fb43ef8 Mon Sep 17 00:00:00 2001 From: pvictor Date: Wed, 8 Nov 2023 10:57:24 +0100 Subject: [PATCH 3/3] updated edit data module (reactable options) --- NAMESPACE | 1 + R/edit-data-utils.R | 129 +++++++++++-------------------------------- R/edit-data.R | 20 +++---- examples/edit_data.R | 4 +- man/edit-data.Rd | 44 ++++++++++++++- 5 files changed, 86 insertions(+), 112 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index bfe7beb..0248c5e 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -37,6 +37,7 @@ importFrom(data.table,.SD) importFrom(data.table,as.data.table) importFrom(data.table,copy) importFrom(data.table,fread) +importFrom(data.table,setattr) importFrom(data.table,setnames) importFrom(data.table,uniqueN) importFrom(htmltools,HTML) diff --git a/R/edit-data-utils.R b/R/edit-data-utils.R index 653e807..ce1a307 100644 --- a/R/edit-data-utils.R +++ b/R/edit-data-utils.R @@ -181,119 +181,52 @@ edit_input_form <- function(default = list(), #' #' @param data `data.frame` to use #' @param colnames `data.frame` column names -#' @param reactableOptions `list` allowing you to add reactable options +#' @param reactable_options `list` allowing you to add reactable options #' #' @return the `data.frame` in reactable format #' @noRd #' #' @importFrom reactable reactable colDef -#' -table_display <- function(data, colnames = NULL, reactableOptions = NULL) { - -# Table des correspondances des noms de colonnes de "data" -matches <- data.frame( - name_temp = setdiff(names(data), c(".datamods_edit_update", ".datamods_edit_delete", ".datamods_id")), - name_real = colnames -) +#' @importFrom data.table copy setnames +table_display <- function(data, colnames = NULL, reactable_options = NULL) { -# cols <- list() -if (!is.null(reactableOptions$columns)) { - cols <- reactableOptions$columns - - # Pour les colonnes qui sont éditées par l'utilisateur dans l'argument reactableOptions (dans reactableOptions$columns) : - # * si le "name" de colDef() d'une colonne est éditée par l'utilisateur : on ne fait rien - # * sinon on affecte le vrai nom initial de la colonne dans le "name" de colDef() de cette colonne - for (col in names(cols)) { - if (!("name" %in% names(cols[[col]]))) { - name_col <- col - cols[[col]][["name"]] <- name_col - } else { - NULL - } - } - - # Pour les colonnes qui ne sont pas éditées par l'utilisateur dans l'argument reactableOptions (dans reactableOptions$columns) : - # * leur affecter uniquement leur vrai nom initial de colonne dans le "name" de colDef() - unedited_columns <- setdiff( - matches$name_real[!matches$name_real %in% c(".datamods_edit_update", ".datamods_edit_delete", ".datamods_id")], - names(cols) - ) - for (i in seq_along(unedited_columns)) { - cols[[unedited_columns[i]]] <- colDef(name = unedited_columns[i]) + data <- copy(data) + if (!is.null(colnames)) { + setnames(data, old = seq_along(colnames), new = colnames) } - - # Remettre les noms temporaires : "col_1" , "col_2", ... pour le bon fonctionnement du module - for (i in seq_along(cols)) { - name_col <- names(cols)[i] - name_temp <- matches$name_temp[matches$name_real == name_col] - names(cols)[i] <- name_temp + + cols <- reactable_options$columns %||% list() + if (all(is.na(data$.datamods_edit_update))) { + cols$.datamods_edit_update <- colDef(show = FALSE) + } else { + cols$.datamods_edit_update <- col_def_update() } - -} else { - cols <- list() - for (i in seq_along(data)) { - cols[[names(data)[i]]] <- colDef(name = colnames[i]) + + if (all(is.na(data$.datamods_edit_delete))) { + cols$.datamods_edit_delete <- colDef(show = FALSE) + } else { + cols$.datamods_edit_delete <- col_def_delete() } -} + cols$.datamods_id <- colDef(show = FALSE) -if (all(is.na(data$.datamods_edit_update))) { - cols$.datamods_edit_update = colDef(show = FALSE) -} else { - cols$.datamods_edit_update = col_def_update() -} + if (is.null(reactable_options)) + reactable_options <- list() + reactable_options <- reactable_options + reactable_options$data <- data + reactable_options$columns <- cols -if (all(is.na(data$.datamods_edit_delete))) { - cols$.datamods_edit_delete = colDef(show = FALSE) -} else { - cols$.datamods_edit_delete = col_def_delete() + rlang::exec(reactable::reactable, !!!reactable_options) } -cols$.datamods_id <- colDef(show = FALSE) - - -if (is.null(reactableOptions)) - reactableOptions <- list() -reactableOptions <- reactableOptions -reactableOptions$data <- data -reactableOptions$columns <- cols - -rlang::exec(reactable::reactable, !!!reactableOptions) - +#' @importFrom reactable updateReactable getReactableState +#' @importFrom data.table copy setnames +update_table <- function(data, colnames) { + data <- copy(data) + setnames(data, old = seq_along(colnames), new = colnames) + page <- getReactableState(outputId = "table", name = "page") + updateReactable("table", data = data, page = page) } -# table_display <- function(data, colnames = NULL, reactableOptions = NULL) { -# cols <- list() -# for (i in seq_along(data)) { -# cols[[names(data)[i]]] <- colDef(name = colnames[i]) -# } -# if (all(is.na(data$.datamods_edit_update))) { -# cols$.datamods_edit_update = colDef(show = FALSE) -# } else { -# cols$.datamods_edit_update = col_def_update() -# } -# -# if (all(is.na(data$.datamods_edit_delete))) { -# cols$.datamods_edit_delete = colDef(show = FALSE) -# } else { -# cols$.datamods_edit_delete = col_def_delete() -# } -# -# cols$.datamods_id <- colDef(show = FALSE) -# -# if (is.null(reactableOptions)) -# reactableOptions <- list() -# reactableOptions <- reactableOptions -# reactableOptions$data <- data -# reactableOptions$columns <- cols -# -# rlang::exec(reactable::reactable, !!!reactableOptions) -# -# # reactable( -# # data = data, -# # columns = cols -# # ) -# } - #' @title The update column definition #' diff --git a/R/edit-data.R b/R/edit-data.R index a14ac1d..e8ca24e 100644 --- a/R/edit-data.R +++ b/R/edit-data.R @@ -55,14 +55,15 @@ edit_data_ui <- function(id) { #' @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 return_class Class of returned data: `data.frame`, `data.table`, `tbl_df` (tibble) or `raw`. +#' @param reactable_options Options passed to [reactable::reactable()]. #' #' @return the edited `data.frame` in reactable format with the user modifications #' #' @name edit-data #' #' @importFrom shiny moduleServer eventReactive reactiveValues is.reactive reactive renderUI actionButton observeEvent isTruthy showModal removeModal downloadButton downloadHandler -#' @importFrom data.table copy as.data.table := copy setnames as.data.table -#' @importFrom reactable renderReactable reactableOutput getReactableState updateReactable +#' @importFrom data.table copy as.data.table := copy setnames as.data.table setattr +#' @importFrom reactable renderReactable reactableOutput getReactableState #' @importFrom phosphoricons ph #' @importFrom writexl write_xlsx #' @importFrom utils write.csv @@ -81,7 +82,7 @@ edit_data_server <- function(id, var_edit = NULL, var_mandatory = NULL, return_class = c("data.frame", "data.table", "tbl_df", "raw"), - reactableOptions = NULL) { + reactable_options = NULL) { return_class <- match.arg(return_class) moduleServer( id, @@ -148,10 +149,10 @@ edit_data_server <- function(id, table_display( data = data, colnames = data_rv$colnames, - reactableOptions = reactableOptions + reactable_options = reactable_options ) }) - + # Retrieve selected row(s) selected_r <- reactive({ getReactableState("table", "selected") @@ -216,8 +217,7 @@ edit_data_server <- function(id, # browser() data <- rbind(data, new, fill = TRUE) data_rv$data <- data - page <- getReactableState(outputId = "table", name = "page") - updateReactable("table", data = data, page = page) + update_table(data, data_rv$colnames) }) if (inherits(results_add, "try-error")) { notification_failure( @@ -273,8 +273,7 @@ edit_data_server <- function(id, })] data <- data[order(.datamods_id)] data_rv$data <- copy(data) - page <- getReactableState(outputId = "table", name = "page") - updateReactable("table", data = data, page = page) + update_table(data, data_rv$colnames) }) if (inherits(results_update, "try-error")) { notification_failure( @@ -312,8 +311,7 @@ edit_data_server <- function(id, data <- data[.datamods_id != input$delete] data <- data[order(.datamods_id)] data_rv$data <- data - page <- getReactableState(outputId = "table", name = "page") - updateReactable("table", data = data, page = page) + update_table(data, data_rv$colnames) }) if (inherits(results_delete, "try-error")) { notification_failure( diff --git a/examples/edit_data.R b/examples/edit_data.R index f93c0cb..06404c2 100644 --- a/examples/edit_data.R +++ b/examples/edit_data.R @@ -1,6 +1,7 @@ library(shiny) library(datamods) library(bslib) +library(reactable) ui <- fluidPage( theme = bs_theme( @@ -25,8 +26,9 @@ server <- function(input, output, session) { file_name_export = "datas", # var_edit = c("name", "job", "credit_card_provider", "credit_card_security_code"), var_mandatory = c("name", "job"), - reactableOptions = list( + reactable_options = list( defaultColDef = colDef(filterable = TRUE), + selection = "single", columns = list( name = colDef(name = "Name", style = list(fontWeight = "bold")), credit_card_security_code = colDef(name = "Credit card security code"), diff --git a/man/edit-data.Rd b/man/edit-data.Rd index 2a882ee..4e409ea 100644 --- a/man/edit-data.Rd +++ b/man/edit-data.Rd @@ -19,7 +19,8 @@ edit_data_server( file_name_export = "data", var_edit = NULL, var_mandatory = NULL, - return_class = c("data.frame", "data.table", "tbl_df", "raw") + return_class = c("data.frame", "data.table", "tbl_df", "raw"), + reactable_options = NULL ) } \arguments{ @@ -44,6 +45,8 @@ edit_data_server( \item{var_mandatory}{vector of \code{character} which allows to choose obligatory fields to fill} \item{return_class}{Class of returned data: \code{data.frame}, \code{data.table}, \code{tbl_df} (tibble) or \code{raw}.} + +\item{reactable_options}{Options passed to \code{\link[reactable:reactable]{reactable::reactable()}}.} } \value{ the edited \code{data.frame} in reactable format with the user modifications @@ -56,6 +59,7 @@ This module returns the edited table with the user modifications. library(shiny) library(datamods) library(bslib) +library(reactable) ui <- fluidPage( theme = bs_theme( @@ -79,7 +83,43 @@ server <- function(input, output, session) { download_excel = TRUE, file_name_export = "datas", # var_edit = c("name", "job", "credit_card_provider", "credit_card_security_code"), - var_mandatory = c("name", "job") + var_mandatory = c("name", "job"), + reactable_options = list( + defaultColDef = colDef(filterable = TRUE), + selection = "single", + columns = list( + 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" + } else if (value == "VISA 16 digit") { + color <- "#0c13cf" + } else if (value == "American Express") { + color <- "#4d8be8" + } else if (value == "JCB 16 digit") { + color <- "#23c45e" + } else { + color <- "#777" + } + list(color = color, fontWeight = "bold") + } + ) + ), + bordered = TRUE, + compact = TRUE, + searchable = TRUE, + highlight = TRUE + ) ) output$result <- renderPrint({