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 a1e03e0..095949f 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -28,12 +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_factor_server) +export(update_factor_ui) export(update_variables_server) export(update_variables_ui) export(validation_server) @@ -142,6 +145,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 +178,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 +187,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-factor.R b/R/update-factor.R new file mode 100644 index 0000000..c8e9094 --- /dev/null +++ b/R/update-factor.R @@ -0,0 +1,233 @@ + +#' @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 +#' @importFrom shinyWidgets virtualSelectInput prettyCheckbox +#' @importFrom toastui datagridOutput +#' @importFrom htmltools tags +#' +#' @name update-factor +#' +#' @example examples/update_factor.R +update_factor_ui <- function(id) { + ns <- NS(id) + tagList( + tags$style( + ".tui-grid-row-header-draggable span {width: 3px !important; height: 3px !important;}" + ), + fluidRow( + column( + width = 6, + virtualSelectInput( + inputId = ns("variable"), + label = "Factor variable to reorder:", + choices = NULL, + width = "100%", + zIndex = 50 + ) + ), + column( + width = 3, + class = "d-flex align-items-end", + actionButton( + inputId = ns("sort_levels"), + label = tagList( + ph("sort-ascending"), + "Sort levels" + ), + class = "btn-outline-primary mb-3", + width = "100%" + ) + ), + column( + width = 3, + class = "d-flex align-items-end", + actionButton( + inputId = ns("sort_occurrences"), + label = tagList( + ph("sort-ascending"), + "Sort count" + ), + class = "btn-outline-primary mb-3", + width = "100%" + ) + ) + ), + datagridOutput(ns("grid")), + 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") + ) +} + + +#' @param data_r A [shiny::reactive()] function returning a `data.frame`. +#' +#' @export +#' +#' @importFrom shiny moduleServer observeEvent reactive reactiveValues req bindEvent isTruthy updateActionButton +#' @importFrom shinyWidgets updateVirtualSelect +#' @importFrom toastui renderDatagrid datagrid grid_columns grid_colorbar +#' +#' @rdname update-factor +update_factor_server <- function(id, data_r = reactive(NULL)) { + moduleServer( + id, + function(input, output, session) { + + rv <- reactiveValues(data = NULL, data_grid = 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(), input$hidden) + + 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 count" + ) + } else { + decreasing <- TRUE + label <- tagList( + ph("sort-ascending"), + "Sort count" + ) + } + updateActionButton(inputId = "sort_occurrences", label = as.character(label)) + rv$data_grid <- rv$data_grid[order(rv$data_grid[[2]], decreasing = decreasing), ] + }) + + + output$grid <- renderDatagrid({ + req(rv$data_grid) + grid <- datagrid( + data = rv$data_grid, + draggable = TRUE, + sortable = FALSE, + data_as_input = TRUE + ) + 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, { + rv$data <- data_updated_r() + }) + return(reactive(rv$data)) + } + ) +} + + + +#' @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_factor.R b/examples/update_factor.R new file mode 100644 index 0000000..15f10ef --- /dev/null +++ b/examples/update_factor.R @@ -0,0 +1,68 @@ + +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-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) +}