From fbf01497c0d05b46440974ac43c7b6e687397fbf Mon Sep 17 00:00:00 2001 From: pvictor Date: Fri, 19 Apr 2024 10:18:07 +0200 Subject: [PATCH] added cut variable module --- NAMESPACE | 2 ++ R/esquisse-server.R | 8 ++++- R/esquisse-ui.R | 18 +++++++--- R/module-utils.R | 77 +++++++++++++++++++++++++++++++++++++++--- man/esquisse-module.Rd | 3 ++ 5 files changed, 98 insertions(+), 10 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 0eff745c..9c23c7a6 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -44,6 +44,8 @@ importFrom(bslib,nav_select) importFrom(bslib,navset_hidden) importFrom(bslib,navset_pill) importFrom(bslib,sidebar) +importFrom(datamods,cut_variable_server) +importFrom(datamods,cut_variable_ui) importFrom(datamods,filter_data_server) importFrom(datamods,filter_data_ui) importFrom(datamods,i18n) diff --git a/R/esquisse-server.R b/R/esquisse-server.R index 6dc9f1a5..90eb4e5d 100644 --- a/R/esquisse-server.R +++ b/R/esquisse-server.R @@ -107,13 +107,19 @@ esquisse_server <- function(id, observeEvent(updated_data(), { data_chart$data <- updated_data() }) - + # create column modal created_col <- create_col_server("create_col", reactive(data_chart$data)) observeEvent(created_col(), { data_chart$data <- created_col() }) + # cut variable modal + cutted_var <- cut_var_server("cut_var", reactive(data_chart$data)) + observeEvent(cutted_var(), { + data_chart$data <- cutted_var() + }) + ### Geom & aesthetics selection diff --git a/R/esquisse-ui.R b/R/esquisse-ui.R index b7dc3f94..d1a98f1a 100644 --- a/R/esquisse-ui.R +++ b/R/esquisse-ui.R @@ -74,7 +74,8 @@ esquisse_ui <- function(id, header_btns$import_data(ns("launch_import_data")), header_btns$show_data(ns("show_data")), header_btns$update_variable(ns("update_variable")), - header_btns$create_column(ns("create_col")) + header_btns$create_column(ns("create_col")), + header_btns$cut_variable(ns("cut_var")) ) ) @@ -233,6 +234,7 @@ esquisse_container <- function(width = "100%", height = "700px", fixed = FALSE) #' @param show_data Show button to display data. #' @param update_variable Show button to update selected variables and convert them. #' @param create_column Show button to create a new column based on an expression. +#' @param cut_variable Show button to allow to convert a numeric variable into factors. #' @param settings Show button to open settings modal (to select aesthetics to use). #' @param close Show button to stop the app and close addin. #' @@ -244,6 +246,7 @@ esquisse_header <- function(import_data = TRUE, show_data = TRUE, update_variable = TRUE, create_column = TRUE, + cut_variable = TRUE, settings = TRUE, close = TRUE) { list( @@ -251,6 +254,7 @@ esquisse_header <- function(import_data = TRUE, show_data = isTRUE(show_data), update_variable = isTRUE(update_variable), create_column = isTRUE(create_column), + cut_variable = isTRUE(cut_variable), settings = isTRUE(settings), close = isTRUE(close) ) @@ -279,6 +283,11 @@ make_btn_header <- function(.list) { } else { function(id) NULL }, + cut_variable = if (isTRUE(.list$cut_variable)) { + cut_var_ui + } else { + function(id) NULL + }, settings = if (isTRUE(.list$settings)) { btn_header(i18n("Display settings"), "gear-fine") } else { @@ -292,13 +301,14 @@ make_btn_header <- function(.list) { ) } -btn_header <- function(label, icon) { +btn_header <- function(label, icon, class = NULL) { function(id) { actionButton( inputId = id, - label = ph(icon, height = "2em", title = label), + label = if (is.character(icon)) ph(icon, height = "2em", title = label) else icon, class = "btn-sm btn-primary", - title = label + title = label, + class = class ) } } diff --git a/R/module-utils.R b/R/module-utils.R index 0f474b85..d7ca8f5d 100644 --- a/R/module-utils.R +++ b/R/module-utils.R @@ -2,9 +2,22 @@ # Show data ------------------------------------------------------------------------- #' @importFrom shiny NS +#' @importFrom htmltools tags css +#' @importFrom phosphoricons ph show_data_ui <- function(id) { ns <- NS(id) - btn_header(i18n("Show data"), "table")(ns("btn")) + icon <- tags$div( + style = css(position = "relative", width = "35px"), + ph("table", height = "2em", title = i18n("Show data")), + ph( + "eye", + style = css(position = "absolute", top = 0, right = 0), + height = "1.2em", + weight = "bold", + title = i18n("Show data") + ) + ) + btn_header(i18n("Show data"), icon, class = " px-0")(ns("btn")) } #' @importFrom shiny moduleServer observeEvent showNotification reactive @@ -13,7 +26,7 @@ show_data_server <- function(id, data_r = reactive(NULL)) { moduleServer( id, function(input, output, session) { - + observeEvent(input$btn, { data <- data_r() if (!is.data.frame(data)) { @@ -27,7 +40,7 @@ show_data_server <- function(id, data_r = reactive(NULL)) { show_data(data, title = i18n("Dataset"), type = "modal") } }) - + } ) } @@ -38,9 +51,22 @@ show_data_server <- function(id, data_r = reactive(NULL)) { # Update vars ----------------------------------------------------------------------- #' @importFrom shiny NS +#' @importFrom htmltools tags css +#' @importFrom phosphoricons ph update_vars_ui <- function(id) { ns <- NS(id) - btn_header(i18n("Update variables"), "brackets-angle")(ns("btn")) + icon <- tags$div( + style = css(position = "relative", width = "35px"), + ph("table", height = "2em", title = i18n("Update variables")), + ph( + "gear", + style = css(position = "absolute", top = 0, right = 0), + height = "1.2em", + weight = "bold", + title = i18n("Update variables") + ) + ) + btn_header(i18n("Update variables"), icon, class = " px-0")(ns("btn")) } #' @importFrom shiny moduleServer observeEvent modalDialog showModal reactive @@ -91,7 +117,7 @@ create_col_server <- function(id, data_r = reactive(NULL)) { function(input, output, session) { ns <- session$ns observeEvent(input$btn, datamods::modal_create_column(ns("mod"))) - res <-datamods::create_column_server( + res <- datamods::create_column_server( id = "mod", data = data_r ) @@ -101,3 +127,44 @@ create_col_server <- function(id, data_r = reactive(NULL)) { } + + + +# Cut variable ------------------------------------------------------------ + +#' @importFrom shiny NS +#' @importFrom htmltools tags css +#' @importFrom phosphoricons ph +cut_var_ui <- function(id) { + ns <- NS(id) + icon <- tags$div( + style = css(position = "relative", width = "35px"), + ph("list-numbers", height = "2em", title = i18n("Cut numeric variable into factors")), + ph( + "scissors", + style = css(position = "absolute", top = 0, right = 0, transform = "scale(-1, 1)"), + height = "1.2em", + weight = "bold", + title = i18n("Cut numeric variable into factors") + ) + ) + btn_header(i18n("Cut numeric variable into factors"), class = " px-0", icon)(ns("btn")) +} + +#' @importFrom shiny moduleServer observeEvent modalDialog showModal reactive +#' @importFrom datamods cut_variable_ui cut_variable_server +cut_var_server <- function(id, data_r = reactive(NULL)) { + moduleServer( + id, + function(input, output, session) { + ns <- session$ns + observeEvent(input$btn, datamods::modal_cut_variable(ns("mod"))) + observeEvent(res(), shiny::removeModal()) + res <- datamods::cut_variable_server( + id = "mod", + data = data_r + ) + return(res) + } + ) +} diff --git a/man/esquisse-module.Rd b/man/esquisse-module.Rd index 48790f9e..e85838e1 100644 --- a/man/esquisse-module.Rd +++ b/man/esquisse-module.Rd @@ -38,6 +38,7 @@ esquisse_header( show_data = TRUE, update_variable = TRUE, create_column = TRUE, + cut_variable = TRUE, settings = TRUE, close = TRUE ) @@ -103,6 +104,8 @@ It's possible to use a vector of CSS unit of length 4 to specify the margins \item{create_column}{Show button to create a new column based on an expression.} +\item{cut_variable}{Show button to allow to convert a numeric variable into factors.} + \item{settings}{Show button to open settings modal (to select aesthetics to use).} \item{close}{Show button to stop the app and close addin.}