From f02cb7594da3c89f580e0fc702f21b3a1c3d86f3 Mon Sep 17 00:00:00 2001 From: gsamra Date: Mon, 8 Apr 2024 11:24:31 +0200 Subject: [PATCH 1/6] module update-factors to reorder factor variables --- R/update-factors.R | 122 ++++++++++++++++++++++++++++++++++++++ examples/update-factors.R | 62 +++++++++++++++++++ 2 files changed, 184 insertions(+) create mode 100644 R/update-factors.R create mode 100644 examples/update-factors.R diff --git a/R/update-factors.R b/R/update-factors.R new file mode 100644 index 0000000..48aceae --- /dev/null +++ b/R/update-factors.R @@ -0,0 +1,122 @@ + +#' @title Module to Reorder the Levels of a Factor Variable +#' +#' @description +#' This module contain an interface to reorder the levels of a factor variable. +#' +#' +#' @param id Module ID. +#' +#' @return A [shiny::reactive()] function returning the data. +#' @export +#' +#' @importFrom shiny NS fluidRow tagList column actionButton verbatimTextOutput +#' @importFrom shinyWidgets virtualSelectInput +#' @importFrom toastui datagridOutput2 +#' @importFrom htmltools tags +#' +#' @name update-factors +#' +#' @example examples/update_factors.R +update_factors_ui <- function(id) { + ns <- NS(id) + tagList( + fluidRow( + column( + width = 3, + virtualSelectInput( + inputId = ns("variable"), + label = "Factor variable levels to reorder:", + choices = NULL, + width = "100%" + ) + ), + column( + width = 9, + datagridOutput2(ns("grid")) + ) + ), + actionButton( + inputId = ns("create"), + label = tagList(ph("arrow-clockwise"), "Update factor variable"), + class = "btn-outline-primary float-end" + ), + tags$div(class = "clearfix"), + tags$b("Data:"), + verbatimTextOutput(ns("data")), + ) +} + + +#' @param data_r A [shiny::reactive()] function returning a `data.frame`. +#' +#' @export +#' +#' @importFrom shiny moduleServer observe observeEvent reactive reactiveValues req bindEvent isTruthy renderPrint +#' @importFrom shinyWidgets updateVirtualSelect +#' @importFrom toastui renderDatagrid2 datagrid grid_columns grid_colorbar +#' @importFrom forcats fct_relevel fct_inorder +#' +#' @rdname update-factors +update_factors_server <- function(id, data_r = reactive(NULL)) { + moduleServer( + id, + function(input, output, session) { + + rv <- reactiveValues(data = NULL) + + bindEvent(observe({ + data <- data_r() + rv$data <- data + vars_factor <- vapply(data, is.factor, logical(1)) + vars_factor <- names(vars_factor)[vars_factor] + updateVirtualSelect( + inputId = "variable", + choices = vars_factor, + selected = if (isTruthy(input$variable)) input$variable else vars_factor[1] + ) + }), data_r()) + + output$grid <- renderDatagrid2({ + data_r <- data_r() + datagrid( + data = as.data.frame(table(data_r[[input$variable]])), + draggable = TRUE, + sortable = FALSE, + data_as_input = TRUE + ) %>% + grid_columns( + columns = c("Var1", "Freq"), + header = c("Levels", "Number of occurences") + ) %>% + grid_colorbar( + column = "Freq", + label_outside = TRUE, + label_width = "30px", + background = "#D8DEE9", + from = c(0, nrow((data_r()))) + ) + }) + + output$data <- renderPrint({ + input$grid_data + }) + + data_updated_r <- reactive({ + data <- req(data_r()) + variable <- req(input$variable) + data_grid <- req(input$grid_data) + data[[paste0(variable, "_updated")]] <- fct_relevel( + data[[variable]], + levels(fct_inorder(as.factor(data_grid[["Var1"]]))) + ) + data + }) + + data_returned_r <- observeEvent(input$create, { + rv$data <- data_updated_r() + }) + return(reactive(rv$data)) + } + ) +} diff --git a/examples/update-factors.R b/examples/update-factors.R new file mode 100644 index 0000000..accb78a --- /dev/null +++ b/examples/update-factors.R @@ -0,0 +1,62 @@ + +library(shiny) +library(datamods) +library(ggplot2) +library(ggpubr) +library(stringr) + +ui <- fluidPage( + theme = bslib::bs_theme(version = 5L, preset = "bootstrap"), + tags$h2("Reorder the Levels of a Factor"), + fluidRow( + column( + width = 6, + update_factors_ui("id") + ), + column( + width = 6, + plotOutput(outputId = "graph"), + verbatimTextOutput("code") + ) + ) +) + +server <- function(input, output, session) { + + rv <- reactiveValues(data = MASS::Cars93[c(1, 2, 3, 9, 10, 11, 16, 26, 27)]) + + data_inline_r <- update_factors_server( + id = "id", + data_r = reactive(rv$data) + ) + observeEvent(data_inline_r(), rv$data <- data_inline_r()) + + # Show result + output$graph <- renderPlot({ + data <- req(rv$data) + names_cols_updated <- str_subset(names(data), pattern = "_updated$") + + if (identical(names_cols_updated, character(0))) { + ggplot() + } else { + listes_graphiques <- lapply( + X = str_subset(names(data), pattern = "_updated$"), + FUN = function(x) { + ggplot(data) + + geom_bar(aes(x = .data[[x]]), fill = "#112466") + + theme_minimal() + + labs(y = NULL) + } + ) + ggarrange(ncol = 1, plotlist = listes_graphiques) + } + }) + + output$code <- renderPrint({ + data <- req(rv$data) + data %>% str() + }) +} + +if (interactive()) + shinyApp(ui, server) From e4a70796555ee077e06471132891c8ea5fd0688f Mon Sep 17 00:00:00 2001 From: gsamra Date: Tue, 9 Apr 2024 16:53:23 +0200 Subject: [PATCH 2/6] update-factors : sort levels and number of occurrences --- R/update-factors.R | 63 +++++++++++++++++++++++++++++++++++----------- 1 file changed, 48 insertions(+), 15 deletions(-) diff --git a/R/update-factors.R b/R/update-factors.R index 48aceae..8ab43fe 100644 --- a/R/update-factors.R +++ b/R/update-factors.R @@ -26,13 +26,25 @@ update_factors_ui <- function(id) { width = 3, virtualSelectInput( inputId = ns("variable"), - label = "Factor variable levels to reorder:", + label = "Factor variable to reorder:", choices = NULL, width = "100%" ) ), column( width = 9, + # radioGroupButtons( + # inputId = ns("sort"), + # label = "Sort:", + # choices = c( + # "Increasing levels" = "increasing_levels", + # "Decreasing levels" = "decreasing_levels", + # "Increasing occurrences" = "increasing_occurrences", + # "Decreasing occurrences" = "decreasing_occurrences" + # ), + # selected = "increasing_levels", + # width = "100%" + # ), datagridOutput2(ns("grid")) ) ), @@ -63,7 +75,7 @@ update_factors_server <- function(id, data_r = reactive(NULL)) { id, function(input, output, session) { - rv <- reactiveValues(data = NULL) + rv <- reactiveValues(data = NULL) # data_grid = NULL bindEvent(observe({ data <- data_r() @@ -77,14 +89,45 @@ update_factors_server <- function(id, data_r = reactive(NULL)) { ) }), data_r()) + data_updated_r <- reactive({ + data <- req(data_r()) + variable <- req(input$variable) + data_grid <- req(input$grid_data) + data[[paste0(variable, "_updated")]] <- fct_relevel( + data[[variable]], + levels(fct_inorder(as.factor(data_grid[["Var1"]]))) + ) + data + }) + output$grid <- renderDatagrid2({ data_r <- data_r() + variable <- req(input$variable) + data_grid <- as.data.frame(table(data_r[[variable]])) + + # if (input$sort == "increasing_levels") { + # rv$data_grid <- data_grid %>% + # arrange(Var1) + # } + # if (input$sort == "decreasing_levels") { + # rv$data_grid <- data_grid %>% + # arrange(desc(Var1)) + # } else if (input$sort == "increasing_occurrences") { + # rv$data_grid <- data_grid %>% + # arrange(Freq) + # } else if (input$sort == "decreasing_occurrences"){ + # rv$data_grid <- data_grid %>% + # arrange(desc(Freq)) + # } else { + # NULL + # } + datagrid( - data = as.data.frame(table(data_r[[input$variable]])), + data = data_grid, #rv$data_grid draggable = TRUE, - sortable = FALSE, + # sortable = FALSE, data_as_input = TRUE - ) %>% + ) %>% grid_columns( columns = c("Var1", "Freq"), header = c("Levels", "Number of occurences") @@ -102,16 +145,6 @@ update_factors_server <- function(id, data_r = reactive(NULL)) { input$grid_data }) - data_updated_r <- reactive({ - data <- req(data_r()) - variable <- req(input$variable) - data_grid <- req(input$grid_data) - data[[paste0(variable, "_updated")]] <- fct_relevel( - data[[variable]], - levels(fct_inorder(as.factor(data_grid[["Var1"]]))) - ) - data - }) data_returned_r <- observeEvent(input$create, { rv$data <- data_updated_r() From 913b45fbc9f6cc22bcf336f76e3239c5c106a73e Mon Sep 17 00:00:00 2001 From: gsamra Date: Thu, 11 Apr 2024 18:17:56 +0200 Subject: [PATCH 3/6] maj module update factors --- R/update-factors.R | 127 ++++++++++++++++++++++---------------- examples/update-factors.R | 22 ------- 2 files changed, 74 insertions(+), 75 deletions(-) diff --git a/R/update-factors.R b/R/update-factors.R index 8ab43fe..de5c0a6 100644 --- a/R/update-factors.R +++ b/R/update-factors.R @@ -10,7 +10,7 @@ #' @return A [shiny::reactive()] function returning the data. #' @export #' -#' @importFrom shiny NS fluidRow tagList column actionButton verbatimTextOutput +#' @importFrom shiny NS fluidRow tagList column actionButton #' @importFrom shinyWidgets virtualSelectInput #' @importFrom toastui datagridOutput2 #' @importFrom htmltools tags @@ -23,7 +23,7 @@ update_factors_ui <- function(id) { tagList( fluidRow( column( - width = 3, + width = 4, virtualSelectInput( inputId = ns("variable"), label = "Factor variable to reorder:", @@ -32,30 +32,33 @@ update_factors_ui <- function(id) { ) ), column( - width = 9, - # radioGroupButtons( - # inputId = ns("sort"), - # label = "Sort:", - # choices = c( - # "Increasing levels" = "increasing_levels", - # "Decreasing levels" = "decreasing_levels", - # "Increasing occurrences" = "increasing_occurrences", - # "Decreasing occurrences" = "decreasing_occurrences" - # ), - # selected = "increasing_levels", - # width = "100%" - # ), - datagridOutput2(ns("grid")) + width = 4, + actionButton( + inputId = ns("sort_levels"), + label = tagList( + ph("sort-ascending"), + "Sort Levels" + ) + ) + ), + column( + width = 4, + actionButton( + inputId = ns("sort_occurrences"), + label = tagList( + ph("sort-ascending"), + "Sort Number of Occurrences" + ) + ) ) ), + datagridOutput2(ns("grid")), actionButton( inputId = ns("create"), label = tagList(ph("arrow-clockwise"), "Update factor variable"), class = "btn-outline-primary float-end" ), - tags$div(class = "clearfix"), - tags$b("Data:"), - verbatimTextOutput(ns("data")), + tags$div(class = "clearfix") ) } @@ -64,7 +67,7 @@ update_factors_ui <- function(id) { #' #' @export #' -#' @importFrom shiny moduleServer observe observeEvent reactive reactiveValues req bindEvent isTruthy renderPrint +#' @importFrom shiny moduleServer observeEvent reactive reactiveValues req bindEvent isTruthy updateActionButton #' @importFrom shinyWidgets updateVirtualSelect #' @importFrom toastui renderDatagrid2 datagrid grid_columns grid_colorbar #' @importFrom forcats fct_relevel fct_inorder @@ -75,7 +78,7 @@ update_factors_server <- function(id, data_r = reactive(NULL)) { id, function(input, output, session) { - rv <- reactiveValues(data = NULL) # data_grid = NULL + rv <- reactiveValues(data = NULL, data_grid = NULL) bindEvent(observe({ data <- data_r() @@ -89,43 +92,66 @@ update_factors_server <- function(id, data_r = reactive(NULL)) { ) }), data_r()) + observeEvent(input$variable, { + data <- req(data_r()) + variable <- req(input$variable) + grid <- as.data.frame(table(data[[variable]])) + rv$data_grid <- grid + }) + + observeEvent(input$sort_levels, { + if (input$sort_levels %% 2 == 1) { + decreasing <- FALSE + label <- tagList( + ph("sort-descending"), + "Sort Levels" + ) + } else { + decreasing <- TRUE + label <- tagList( + ph("sort-ascending"), + "Sort Levels" + ) + } + updateActionButton(inputId = "sort_levels", label = as.character(label)) + rv$data_grid <- rv$data_grid[order(rv$data_grid[[1]], decreasing = decreasing), ] + }) + + observeEvent(input$sort_occurrences, { + if (input$sort_occurrences %% 2 == 1) { + decreasing <- FALSE + label <- tagList( + ph("sort-descending"), + "Sort Number of Occurrences" + ) + } else { + decreasing <- TRUE + label <- tagList( + ph("sort-ascending"), + "Sort Number of Occurrences" + ) + } + updateActionButton(inputId = "sort_occurrences", label = as.character(label)) + rv$data_grid <- rv$data_grid[order(rv$data_grid[[2]], decreasing = decreasing), ] + }) + data_updated_r <- reactive({ data <- req(data_r()) variable <- req(input$variable) - data_grid <- req(input$grid_data) - data[[paste0(variable, "_updated")]] <- fct_relevel( - data[[variable]], - levels(fct_inorder(as.factor(data_grid[["Var1"]]))) + grid <- req(input$grid_data) + # grid <- req(rv$data_grid) + data[[paste0(variable, "_updated")]] <- factor( + as.character(data[[variable]]), + levels(as.factor(grid[["Var1"]])) ) data }) output$grid <- renderDatagrid2({ - data_r <- data_r() - variable <- req(input$variable) - data_grid <- as.data.frame(table(data_r[[variable]])) - - # if (input$sort == "increasing_levels") { - # rv$data_grid <- data_grid %>% - # arrange(Var1) - # } - # if (input$sort == "decreasing_levels") { - # rv$data_grid <- data_grid %>% - # arrange(desc(Var1)) - # } else if (input$sort == "increasing_occurrences") { - # rv$data_grid <- data_grid %>% - # arrange(Freq) - # } else if (input$sort == "decreasing_occurrences"){ - # rv$data_grid <- data_grid %>% - # arrange(desc(Freq)) - # } else { - # NULL - # } - datagrid( - data = data_grid, #rv$data_grid + data = rv$data_grid, draggable = TRUE, - # sortable = FALSE, + sortable = FALSE, data_as_input = TRUE ) %>% grid_columns( @@ -141,11 +167,6 @@ update_factors_server <- function(id, data_r = reactive(NULL)) { ) }) - output$data <- renderPrint({ - input$grid_data - }) - - data_returned_r <- observeEvent(input$create, { rv$data <- data_updated_r() }) diff --git a/examples/update-factors.R b/examples/update-factors.R index accb78a..24534c2 100644 --- a/examples/update-factors.R +++ b/examples/update-factors.R @@ -2,7 +2,6 @@ library(shiny) library(datamods) library(ggplot2) -library(ggpubr) library(stringr) ui <- fluidPage( @@ -15,7 +14,6 @@ ui <- fluidPage( ), column( width = 6, - plotOutput(outputId = "graph"), verbatimTextOutput("code") ) ) @@ -32,26 +30,6 @@ server <- function(input, output, session) { observeEvent(data_inline_r(), rv$data <- data_inline_r()) # Show result - output$graph <- renderPlot({ - data <- req(rv$data) - names_cols_updated <- str_subset(names(data), pattern = "_updated$") - - if (identical(names_cols_updated, character(0))) { - ggplot() - } else { - listes_graphiques <- lapply( - X = str_subset(names(data), pattern = "_updated$"), - FUN = function(x) { - ggplot(data) + - geom_bar(aes(x = .data[[x]]), fill = "#112466") + - theme_minimal() + - labs(y = NULL) - } - ) - ggarrange(ncol = 1, plotlist = listes_graphiques) - } - }) - output$code <- renderPrint({ data <- req(rv$data) data %>% str() From 8bddacfa8a9c99aa3661c4d5336f674f9be1104b Mon Sep 17 00:00:00 2001 From: pvictor Date: Wed, 17 Apr 2024 16:04:04 +0200 Subject: [PATCH 4/6] update_factors: updated ui --- NAMESPACE | 7 ++ R/update-factors.R | 63 ++++++++++-------- .../{update-factors.R => update_factors.R} | 0 man/update-factors.Rd | 65 +++++++++++++++++++ 4 files changed, 109 insertions(+), 26 deletions(-) rename examples/{update-factors.R => update_factors.R} (100%) create mode 100644 man/update-factors.Rd diff --git a/NAMESPACE b/NAMESPACE index a1e03e0..16578a3 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -34,6 +34,8 @@ export(select_group_server) export(select_group_ui) export(set_i18n) export(show_data) +export(update_factors_server) +export(update_factors_ui) export(update_variables_server) export(update_variables_ui) export(validation_server) @@ -50,6 +52,8 @@ importFrom(data.table,setattr) importFrom(data.table,setnames) importFrom(data.table,setorderv) importFrom(data.table,uniqueN) +importFrom(forcats,fct_inorder) +importFrom(forcats,fct_relevel) importFrom(graphics,abline) importFrom(graphics,axis) importFrom(graphics,hist) @@ -142,6 +146,7 @@ importFrom(shiny,tabPanel) importFrom(shiny,tabPanelBody) importFrom(shiny,tableOutput) importFrom(shiny,tabsetPanel) +importFrom(shiny,tagList) importFrom(shiny,tags) importFrom(shiny,textAreaInput) importFrom(shiny,textInput) @@ -174,6 +179,7 @@ importFrom(shinybusy,notify_warning) importFrom(stats,setNames) importFrom(tibble,as_tibble) importFrom(toastui,datagrid) +importFrom(toastui,datagridOutput) importFrom(toastui,datagridOutput2) importFrom(toastui,grid_colorbar) importFrom(toastui,grid_columns) @@ -182,6 +188,7 @@ importFrom(toastui,grid_editor_opts) importFrom(toastui,grid_format) importFrom(toastui,grid_selection_row) importFrom(toastui,grid_style_column) +importFrom(toastui,renderDatagrid) importFrom(toastui,renderDatagrid2) importFrom(tools,file_ext) importFrom(utils,data) diff --git a/R/update-factors.R b/R/update-factors.R index de5c0a6..23fbd08 100644 --- a/R/update-factors.R +++ b/R/update-factors.R @@ -10,9 +10,9 @@ #' @return A [shiny::reactive()] function returning the data. #' @export #' -#' @importFrom shiny NS fluidRow tagList column actionButton +#' @importFrom shiny NS fluidRow tagList column actionButton #' @importFrom shinyWidgets virtualSelectInput -#' @importFrom toastui datagridOutput2 +#' @importFrom toastui datagridOutput #' @importFrom htmltools tags #' #' @name update-factors @@ -21,38 +21,48 @@ update_factors_ui <- function(id) { ns <- NS(id) tagList( + tags$style( + ".tui-grid-row-header-draggable span {width: 3px !important; height: 3px !important;}" + ), fluidRow( column( - width = 4, + width = 6, virtualSelectInput( inputId = ns("variable"), label = "Factor variable to reorder:", choices = NULL, - width = "100%" + width = "100%", + zIndex = 50 ) ), column( - width = 4, + width = 3, + class = "d-flex align-items-end", actionButton( inputId = ns("sort_levels"), label = tagList( ph("sort-ascending"), - "Sort Levels" - ) + "Sort levels" + ), + class = "btn-outline-primary mb-3", + width = "100%" ) ), column( - width = 4, + width = 3, + class = "d-flex align-items-end", actionButton( inputId = ns("sort_occurrences"), label = tagList( ph("sort-ascending"), - "Sort Number of Occurrences" - ) + "Sort count" + ), + class = "btn-outline-primary mb-3", + width = "100%" ) ) ), - datagridOutput2(ns("grid")), + datagridOutput(ns("grid")), actionButton( inputId = ns("create"), label = tagList(ph("arrow-clockwise"), "Update factor variable"), @@ -69,7 +79,7 @@ update_factors_ui <- function(id) { #' #' @importFrom shiny moduleServer observeEvent reactive reactiveValues req bindEvent isTruthy updateActionButton #' @importFrom shinyWidgets updateVirtualSelect -#' @importFrom toastui renderDatagrid2 datagrid grid_columns grid_colorbar +#' @importFrom toastui renderDatagrid datagrid grid_columns grid_colorbar #' @importFrom forcats fct_relevel fct_inorder #' #' @rdname update-factors @@ -77,8 +87,8 @@ update_factors_server <- function(id, data_r = reactive(NULL)) { moduleServer( id, function(input, output, session) { - - rv <- reactiveValues(data = NULL, data_grid = NULL) + + rv <- reactiveValues(data = NULL, data_grid = NULL) bindEvent(observe({ data <- data_r() @@ -91,14 +101,14 @@ update_factors_server <- function(id, data_r = reactive(NULL)) { selected = if (isTruthy(input$variable)) input$variable else vars_factor[1] ) }), data_r()) - + observeEvent(input$variable, { data <- req(data_r()) variable <- req(input$variable) grid <- as.data.frame(table(data[[variable]])) rv$data_grid <- grid }) - + observeEvent(input$sort_levels, { if (input$sort_levels %% 2 == 1) { decreasing <- FALSE @@ -116,25 +126,25 @@ update_factors_server <- function(id, data_r = reactive(NULL)) { updateActionButton(inputId = "sort_levels", label = as.character(label)) rv$data_grid <- rv$data_grid[order(rv$data_grid[[1]], decreasing = decreasing), ] }) - + observeEvent(input$sort_occurrences, { if (input$sort_occurrences %% 2 == 1) { decreasing <- FALSE label <- tagList( ph("sort-descending"), - "Sort Number of Occurrences" + "Sort count" ) } else { decreasing <- TRUE label <- tagList( ph("sort-ascending"), - "Sort Number of Occurrences" + "Sort count" ) } updateActionButton(inputId = "sort_occurrences", label = as.character(label)) rv$data_grid <- rv$data_grid[order(rv$data_grid[[2]], decreasing = decreasing), ] }) - + data_updated_r <- reactive({ data <- req(data_r()) variable <- req(input$variable) @@ -146,27 +156,28 @@ update_factors_server <- function(id, data_r = reactive(NULL)) { ) data }) - - output$grid <- renderDatagrid2({ + + output$grid <- renderDatagrid({ + req(rv$data_grid) datagrid( - data = rv$data_grid, + data = rv$data_grid, draggable = TRUE, sortable = FALSE, data_as_input = TRUE ) %>% grid_columns( columns = c("Var1", "Freq"), - header = c("Levels", "Number of occurences") + header = c("Levels", "Count") ) %>% grid_colorbar( column = "Freq", label_outside = TRUE, label_width = "30px", background = "#D8DEE9", - from = c(0, nrow((data_r()))) + from = c(0, max(rv$data_grid$Freq) + 1) ) }) - + data_returned_r <- observeEvent(input$create, { rv$data <- data_updated_r() }) diff --git a/examples/update-factors.R b/examples/update_factors.R similarity index 100% rename from examples/update-factors.R rename to examples/update_factors.R diff --git a/man/update-factors.Rd b/man/update-factors.Rd new file mode 100644 index 0000000..873540d --- /dev/null +++ b/man/update-factors.Rd @@ -0,0 +1,65 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/update-factors.R +\name{update-factors} +\alias{update-factors} +\alias{update_factors_ui} +\alias{update_factors_server} +\title{Module to Reorder the Levels of a Factor Variable} +\usage{ +update_factors_ui(id) + +update_factors_server(id, data_r = reactive(NULL)) +} +\arguments{ +\item{id}{Module ID.} + +\item{data_r}{A \code{\link[shiny:reactive]{shiny::reactive()}} function returning a \code{data.frame}.} +} +\value{ +A \code{\link[shiny:reactive]{shiny::reactive()}} function returning the data. +} +\description{ +This module contain an interface to reorder the levels of a factor variable. +} +\examples{ + +library(shiny) +library(datamods) +library(ggplot2) +library(stringr) + +ui <- fluidPage( + theme = bslib::bs_theme(version = 5L, preset = "bootstrap"), + tags$h2("Reorder the Levels of a Factor"), + fluidRow( + column( + width = 6, + update_factors_ui("id") + ), + column( + width = 6, + verbatimTextOutput("code") + ) + ) +) + +server <- function(input, output, session) { + + rv <- reactiveValues(data = MASS::Cars93[c(1, 2, 3, 9, 10, 11, 16, 26, 27)]) + + data_inline_r <- update_factors_server( + id = "id", + data_r = reactive(rv$data) + ) + observeEvent(data_inline_r(), rv$data <- data_inline_r()) + + # Show result + output$code <- renderPrint({ + data <- req(rv$data) + data \%>\% str() + }) +} + +if (interactive()) + shinyApp(ui, server) +} From 921c3540163dfdd39aeb9cace6519ab7b36f6009 Mon Sep 17 00:00:00 2001 From: pvictor Date: Fri, 19 Apr 2024 10:46:13 +0200 Subject: [PATCH 5/6] fix module + update same variable --- DESCRIPTION | 1 + NAMESPACE | 2 - R/update-factors.R | 78 ++++++++++++++++++++++++--------------- examples/update_factors.R | 33 ++++++++++++----- man/update-factors.Rd | 33 ++++++++++++----- 5 files changed, 97 insertions(+), 50 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 2ac7aa7..594e163 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -47,6 +47,7 @@ Imports: writexl Suggests: bslib, + ggplot2, jsonlite, knitr, MASS, diff --git a/NAMESPACE b/NAMESPACE index 16578a3..499f0e7 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -52,8 +52,6 @@ importFrom(data.table,setattr) importFrom(data.table,setnames) importFrom(data.table,setorderv) importFrom(data.table,uniqueN) -importFrom(forcats,fct_inorder) -importFrom(forcats,fct_relevel) importFrom(graphics,abline) importFrom(graphics,axis) importFrom(graphics,hist) diff --git a/R/update-factors.R b/R/update-factors.R index 23fbd08..889c754 100644 --- a/R/update-factors.R +++ b/R/update-factors.R @@ -11,7 +11,7 @@ #' @export #' #' @importFrom shiny NS fluidRow tagList column actionButton -#' @importFrom shinyWidgets virtualSelectInput +#' @importFrom shinyWidgets virtualSelectInput prettyCheckbox #' @importFrom toastui datagridOutput #' @importFrom htmltools tags #' @@ -63,10 +63,21 @@ update_factors_ui <- function(id) { ) ), datagridOutput(ns("grid")), - actionButton( - inputId = ns("create"), - label = tagList(ph("arrow-clockwise"), "Update factor variable"), - class = "btn-outline-primary float-end" + tags$div( + class = "float-end", + prettyCheckbox( + inputId = ns("new_var"), + label = i18n("Create a new variable"), + value = FALSE, + status = "primary", + outline = TRUE, + inline = TRUE + ), + actionButton( + inputId = ns("create"), + label = tagList(ph("arrow-clockwise"), "Update factor variable"), + class = "btn-outline-primary" + ) ), tags$div(class = "clearfix") ) @@ -80,7 +91,6 @@ update_factors_ui <- function(id) { #' @importFrom shiny moduleServer observeEvent reactive reactiveValues req bindEvent isTruthy updateActionButton #' @importFrom shinyWidgets updateVirtualSelect #' @importFrom toastui renderDatagrid datagrid grid_columns grid_colorbar -#' @importFrom forcats fct_relevel fct_inorder #' #' @rdname update-factors update_factors_server <- function(id, data_r = reactive(NULL)) { @@ -145,37 +155,45 @@ update_factors_server <- function(id, data_r = reactive(NULL)) { rv$data_grid <- rv$data_grid[order(rv$data_grid[[2]], decreasing = decreasing), ] }) - data_updated_r <- reactive({ - data <- req(data_r()) - variable <- req(input$variable) - grid <- req(input$grid_data) - # grid <- req(rv$data_grid) - data[[paste0(variable, "_updated")]] <- factor( - as.character(data[[variable]]), - levels(as.factor(grid[["Var1"]])) - ) - data - }) output$grid <- renderDatagrid({ req(rv$data_grid) - datagrid( + grid <- datagrid( data = rv$data_grid, draggable = TRUE, sortable = FALSE, data_as_input = TRUE - ) %>% - grid_columns( - columns = c("Var1", "Freq"), - header = c("Levels", "Count") - ) %>% - grid_colorbar( - column = "Freq", - label_outside = TRUE, - label_width = "30px", - background = "#D8DEE9", - from = c(0, max(rv$data_grid$Freq) + 1) - ) + ) + grid <- grid_columns( + grid, + columns = c("Var1", "Freq"), + header = c("Levels", "Count") + ) + grid <- grid_colorbar( + grid, + column = "Freq", + label_outside = TRUE, + label_width = "30px", + background = "#D8DEE9", + from = c(0, max(rv$data_grid$Freq) + 1) + ) + grid + }) + + data_updated_r <- reactive({ + data <- req(data_r()) + variable <- req(input$variable) + grid <- req(input$grid_data) + name_var <- if (isTRUE(input$new_var)) { + paste0(variable, "_updated") + } else { + variable + } + data[[name_var]] <- factor( + as.character(data[[variable]]), + levels = grid[["Var1"]] + ) + data }) data_returned_r <- observeEvent(input$create, { diff --git a/examples/update_factors.R b/examples/update_factors.R index 24534c2..31d1c96 100644 --- a/examples/update_factors.R +++ b/examples/update_factors.R @@ -2,7 +2,6 @@ library(shiny) library(datamods) library(ggplot2) -library(stringr) ui <- fluidPage( theme = bslib::bs_theme(version = 5L, preset = "bootstrap"), @@ -14,25 +13,41 @@ ui <- fluidPage( ), column( width = 6, - verbatimTextOutput("code") + selectInput( + "var", + label = "Variable to plot:", + choices = NULL + ), + plotOutput("plot"), + verbatimTextOutput("res") ) ) ) server <- function(input, output, session) { - - rv <- reactiveValues(data = MASS::Cars93[c(1, 2, 3, 9, 10, 11, 16, 26, 27)]) - + + rv <- reactiveValues(data = MASS::Cars93[c(1, 2, 3, 9, 10, 11, 16, 26, 27)]) + observe( + updateSelectInput(inputId = "var", choices = names(rv$data)) + ) + data_inline_r <- update_factors_server( id = "id", data_r = reactive(rv$data) ) observeEvent(data_inline_r(), rv$data <- data_inline_r()) - - # Show result - output$code <- renderPrint({ + + # Plot results + output$plot <- renderPlot({ + req(input$var, rv$data) + ggplot(rv$data) + + aes(x = !!sym(input$var)) + + geom_bar() + }) + # Show results + output$res <- renderPrint({ data <- req(rv$data) - data %>% str() + str(data) }) } diff --git a/man/update-factors.Rd b/man/update-factors.Rd index 873540d..33e81db 100644 --- a/man/update-factors.Rd +++ b/man/update-factors.Rd @@ -26,7 +26,6 @@ This module contain an interface to reorder the levels of a factor variable. library(shiny) library(datamods) library(ggplot2) -library(stringr) ui <- fluidPage( theme = bslib::bs_theme(version = 5L, preset = "bootstrap"), @@ -38,25 +37,41 @@ ui <- fluidPage( ), column( width = 6, - verbatimTextOutput("code") + selectInput( + "var", + label = "Variable to plot:", + choices = NULL + ), + plotOutput("plot"), + verbatimTextOutput("res") ) ) ) server <- function(input, output, session) { - - rv <- reactiveValues(data = MASS::Cars93[c(1, 2, 3, 9, 10, 11, 16, 26, 27)]) - + + rv <- reactiveValues(data = MASS::Cars93[c(1, 2, 3, 9, 10, 11, 16, 26, 27)]) + observe( + updateSelectInput(inputId = "var", choices = names(rv$data)) + ) + data_inline_r <- update_factors_server( id = "id", data_r = reactive(rv$data) ) observeEvent(data_inline_r(), rv$data <- data_inline_r()) - - # Show result - output$code <- renderPrint({ + + # Plot results + output$plot <- renderPlot({ + req(input$var, rv$data) + ggplot(rv$data) + + aes(x = !!sym(input$var)) + + geom_bar() + }) + # Show results + output$res <- renderPrint({ data <- req(rv$data) - data \%>\% str() + str(data) }) } From 3527609f9fc8058f39ad600fbd12e6ea6e6acbb4 Mon Sep 17 00:00:00 2001 From: pvictor Date: Fri, 19 Apr 2024 10:58:41 +0200 Subject: [PATCH 6/6] update_factor: rename + modal --- NAMESPACE | 5 +- R/{update-factors.R => update-factor.R} | 40 +++++- .../{update_factors.R => update_factor.R} | 17 ++- man/update-factor.Rd | 118 ++++++++++++++++++ man/update-factors.Rd | 80 ------------ 5 files changed, 170 insertions(+), 90 deletions(-) rename R/{update-factors.R => update-factor.R} (84%) rename examples/{update_factors.R => update_factor.R} (70%) create mode 100644 man/update-factor.Rd delete mode 100644 man/update-factors.Rd diff --git a/NAMESPACE b/NAMESPACE index 499f0e7..095949f 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -28,14 +28,15 @@ export(list_allowed_operations) export(list_pkg_data) export(modal_create_column) export(modal_cut_variable) +export(modal_update_factor) export(sample_server) export(sample_ui) export(select_group_server) export(select_group_ui) export(set_i18n) export(show_data) -export(update_factors_server) -export(update_factors_ui) +export(update_factor_server) +export(update_factor_ui) export(update_variables_server) export(update_variables_ui) export(validation_server) diff --git a/R/update-factors.R b/R/update-factor.R similarity index 84% rename from R/update-factors.R rename to R/update-factor.R index 889c754..c8e9094 100644 --- a/R/update-factors.R +++ b/R/update-factor.R @@ -15,10 +15,10 @@ #' @importFrom toastui datagridOutput #' @importFrom htmltools tags #' -#' @name update-factors +#' @name update-factor #' -#' @example examples/update_factors.R -update_factors_ui <- function(id) { +#' @example examples/update_factor.R +update_factor_ui <- function(id) { ns <- NS(id) tagList( tags$style( @@ -92,8 +92,8 @@ update_factors_ui <- function(id) { #' @importFrom shinyWidgets updateVirtualSelect #' @importFrom toastui renderDatagrid datagrid grid_columns grid_colorbar #' -#' @rdname update-factors -update_factors_server <- function(id, data_r = reactive(NULL)) { +#' @rdname update-factor +update_factor_server <- function(id, data_r = reactive(NULL)) { moduleServer( id, function(input, output, session) { @@ -110,7 +110,7 @@ update_factors_server <- function(id, data_r = reactive(NULL)) { choices = vars_factor, selected = if (isTruthy(input$variable)) input$variable else vars_factor[1] ) - }), data_r()) + }), data_r(), input$hidden) observeEvent(input$variable, { data <- req(data_r()) @@ -203,3 +203,31 @@ update_factors_server <- function(id, data_r = reactive(NULL)) { } ) } + + + +#' @inheritParams shiny::modalDialog +#' @export +#' +#' @importFrom shiny showModal modalDialog textInput +#' @importFrom htmltools tagList +#' +#' @rdname update-factor +modal_update_factor <- function(id, + title = "Update levels of a factor", + easyClose = TRUE, + size = "l", + footer = NULL) { + ns <- NS(id) + showModal(modalDialog( + title = tagList(title, button_close_modal()), + update_factor_ui(id), + tags$div( + style = "display: none;", + textInput(inputId = ns("hidden"), label = NULL, value = genId()) + ), + easyClose = easyClose, + size = size, + footer = footer + )) +} diff --git a/examples/update_factors.R b/examples/update_factor.R similarity index 70% rename from examples/update_factors.R rename to examples/update_factor.R index 31d1c96..15f10ef 100644 --- a/examples/update_factors.R +++ b/examples/update_factor.R @@ -9,7 +9,8 @@ ui <- fluidPage( fluidRow( column( width = 6, - update_factors_ui("id") + update_factor_ui("id"), + actionButton("modal", "Or click here to open a modal to update factor's level") ), column( width = 6, @@ -31,12 +32,24 @@ server <- function(input, output, session) { updateSelectInput(inputId = "var", choices = names(rv$data)) ) - data_inline_r <- update_factors_server( + # Inline mode + data_inline_r <- update_factor_server( id = "id", data_r = reactive(rv$data) ) observeEvent(data_inline_r(), rv$data <- data_inline_r()) + # modal window mode + observeEvent(input$modal, modal_update_factor("modal")) + data_modal_r <- update_factor_server( + id = "modal", + data_r = reactive(rv$data) + ) + observeEvent(data_modal_r(), { + shiny::removeModal() + rv$data <- data_modal_r() + }) + # Plot results output$plot <- renderPlot({ req(input$var, rv$data) diff --git a/man/update-factor.Rd b/man/update-factor.Rd new file mode 100644 index 0000000..17dd8aa --- /dev/null +++ b/man/update-factor.Rd @@ -0,0 +1,118 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/update-factor.R +\name{update-factor} +\alias{update-factor} +\alias{update_factor_ui} +\alias{update_factor_server} +\alias{modal_update_factor} +\title{Module to Reorder the Levels of a Factor Variable} +\usage{ +update_factor_ui(id) + +update_factor_server(id, data_r = reactive(NULL)) + +modal_update_factor( + id, + title = "Update levels of a factor", + easyClose = TRUE, + size = "l", + footer = NULL +) +} +\arguments{ +\item{id}{Module ID.} + +\item{data_r}{A \code{\link[shiny:reactive]{shiny::reactive()}} function returning a \code{data.frame}.} + +\item{title}{An optional title for the dialog.} + +\item{easyClose}{If \code{TRUE}, the modal dialog can be dismissed by +clicking outside the dialog box, or be pressing the Escape key. If +\code{FALSE} (the default), the modal dialog can't be dismissed in those +ways; instead it must be dismissed by clicking on a \code{modalButton()}, or +from a call to \code{\link[shiny:removeModal]{removeModal()}} on the server.} + +\item{size}{One of \code{"s"} for small, \code{"m"} (the default) for medium, +\code{"l"} for large, or \code{"xl"} for extra large. Note that \code{"xl"} only +works with Bootstrap 4 and above (to opt-in to Bootstrap 4+, +pass \code{\link[bslib:bs_theme]{bslib::bs_theme()}} to the \code{theme} argument of a page container +like \code{\link[shiny:fluidPage]{fluidPage()}}).} + +\item{footer}{UI for footer. Use \code{NULL} for no footer.} +} +\value{ +A \code{\link[shiny:reactive]{shiny::reactive()}} function returning the data. +} +\description{ +This module contain an interface to reorder the levels of a factor variable. +} +\examples{ + +library(shiny) +library(datamods) +library(ggplot2) + +ui <- fluidPage( + theme = bslib::bs_theme(version = 5L, preset = "bootstrap"), + tags$h2("Reorder the Levels of a Factor"), + fluidRow( + column( + width = 6, + update_factor_ui("id"), + actionButton("modal", "Or click here to open a modal to update factor's level") + ), + column( + width = 6, + selectInput( + "var", + label = "Variable to plot:", + choices = NULL + ), + plotOutput("plot"), + verbatimTextOutput("res") + ) + ) +) + +server <- function(input, output, session) { + + rv <- reactiveValues(data = MASS::Cars93[c(1, 2, 3, 9, 10, 11, 16, 26, 27)]) + observe( + updateSelectInput(inputId = "var", choices = names(rv$data)) + ) + + # Inline mode + data_inline_r <- update_factor_server( + id = "id", + data_r = reactive(rv$data) + ) + observeEvent(data_inline_r(), rv$data <- data_inline_r()) + + # modal window mode + observeEvent(input$modal, modal_update_factor("modal")) + data_modal_r <- update_factor_server( + id = "modal", + data_r = reactive(rv$data) + ) + observeEvent(data_modal_r(), { + shiny::removeModal() + rv$data <- data_modal_r() + }) + + # Plot results + output$plot <- renderPlot({ + req(input$var, rv$data) + ggplot(rv$data) + + aes(x = !!sym(input$var)) + + geom_bar() + }) + # Show results + output$res <- renderPrint({ + data <- req(rv$data) + str(data) + }) +} + +if (interactive()) + shinyApp(ui, server) +} diff --git a/man/update-factors.Rd b/man/update-factors.Rd deleted file mode 100644 index 33e81db..0000000 --- a/man/update-factors.Rd +++ /dev/null @@ -1,80 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/update-factors.R -\name{update-factors} -\alias{update-factors} -\alias{update_factors_ui} -\alias{update_factors_server} -\title{Module to Reorder the Levels of a Factor Variable} -\usage{ -update_factors_ui(id) - -update_factors_server(id, data_r = reactive(NULL)) -} -\arguments{ -\item{id}{Module ID.} - -\item{data_r}{A \code{\link[shiny:reactive]{shiny::reactive()}} function returning a \code{data.frame}.} -} -\value{ -A \code{\link[shiny:reactive]{shiny::reactive()}} function returning the data. -} -\description{ -This module contain an interface to reorder the levels of a factor variable. -} -\examples{ - -library(shiny) -library(datamods) -library(ggplot2) - -ui <- fluidPage( - theme = bslib::bs_theme(version = 5L, preset = "bootstrap"), - tags$h2("Reorder the Levels of a Factor"), - fluidRow( - column( - width = 6, - update_factors_ui("id") - ), - column( - width = 6, - selectInput( - "var", - label = "Variable to plot:", - choices = NULL - ), - plotOutput("plot"), - verbatimTextOutput("res") - ) - ) -) - -server <- function(input, output, session) { - - rv <- reactiveValues(data = MASS::Cars93[c(1, 2, 3, 9, 10, 11, 16, 26, 27)]) - observe( - updateSelectInput(inputId = "var", choices = names(rv$data)) - ) - - data_inline_r <- update_factors_server( - id = "id", - data_r = reactive(rv$data) - ) - observeEvent(data_inline_r(), rv$data <- data_inline_r()) - - # Plot results - output$plot <- renderPlot({ - req(input$var, rv$data) - ggplot(rv$data) + - aes(x = !!sym(input$var)) + - geom_bar() - }) - # Show results - output$res <- renderPrint({ - data <- req(rv$data) - str(data) - }) -} - -if (interactive()) - shinyApp(ui, server) -}