From 02bb84e4a2eb45b3b422af084a61b2e9b4415cec Mon Sep 17 00:00:00 2001 From: pvictor Date: Thu, 24 Oct 2019 13:37:04 +0200 Subject: [PATCH] selectizeGroupServer() accept reactive data and vars --- .Rbuildignore | 1 + NAMESPACE | 1 + NEWS.md | 7 ++ R/module-selectizeGroup.R | 195 ++++++++++++++--------------- R/module-utils.R | 2 +- examples/selectizeGroup-default.R | 43 +++++++ examples/selectizeGroup-subset.R | 61 +++++++++ examples/selectizeGroup-vars.R | 60 +++++++++ man/selectizeGroup-module.Rd | 199 ++++++++++++++++++++++++------ 9 files changed, 430 insertions(+), 139 deletions(-) create mode 100644 examples/selectizeGroup-default.R create mode 100644 examples/selectizeGroup-subset.R create mode 100644 examples/selectizeGroup-vars.R diff --git a/.Rbuildignore b/.Rbuildignore index 42fce02a..23658285 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -13,3 +13,4 @@ ^data-raw$ ^revdep$ ^codecov\.yml$ +^examples$ diff --git a/NAMESPACE b/NAMESPACE index ea896047..2de0997f 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -119,6 +119,7 @@ importFrom(shiny,animationOptions) importFrom(shiny,getDefaultReactiveDomain) importFrom(shiny,icon) importFrom(shiny,insertUI) +importFrom(shiny,is.reactive) importFrom(shiny,observe) importFrom(shiny,observeEvent) importFrom(shiny,reactive) diff --git a/NEWS.md b/NEWS.md index c6124537..7c8ea834 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,10 @@ +shinyWidgets 0.5.0 +====================== + +* `selectizeGroupServer() `(module `selectizeGroup`) now accept `reactive` data and `reactive` vars arguments, see examples for details `?selectizeGroupServer`. + + + shinyWidgets 0.4.9 ====================== diff --git a/R/module-selectizeGroup.R b/R/module-selectizeGroup.R index 2d1c39fc..2e3420fb 100644 --- a/R/module-selectizeGroup.R +++ b/R/module-selectizeGroup.R @@ -18,48 +18,9 @@ #' @importFrom htmltools tagList tags #' @importFrom shiny NS selectizeInput actionLink icon singleton #' -#' @examples -#' if (interactive()) { -#' -#' library(shiny) -#' library(shinyWidgets) -#' -#' data("mpg", package = "ggplot2") -#' -#' ui <- fluidPage( -#' fluidRow( -#' column( -#' width = 10, offset = 1, -#' tags$h3("Filter data with selectize group"), -#' panel( -#' selectizeGroupUI( -#' id = "my-filters", -#' params = list( -#' manufacturer = list(inputId = "manufacturer", title = "Manufacturer:"), -#' model = list(inputId = "model", title = "Model:"), -#' trans = list(inputId = "trans", title = "Trans:"), -#' class = list(inputId = "class", title = "Class:") -#' ) -#' ), status = "primary" -#' ), -#' DT::dataTableOutput(outputId = "table") -#' ) -#' ) -#' ) -#' -#' server <- function(input, output, session) { -#' res_mod <- callModule( -#' module = selectizeGroupServer, -#' id = "my-filters", -#' data = mpg, -#' vars = c("manufacturer", "model", "trans", "class") -#' ) -#' output$table <- DT::renderDataTable(res_mod()) -#' } -#' -#' shinyApp(ui, server) -#' -#' } +#' @example examples/selectizeGroup-default.R +#' @example examples/selectizeGroup-vars.R +#' @example examples/selectizeGroup-subset.R selectizeGroupUI <- function(id, params, label = NULL, btn_label = "Reset filters", inline = TRUE) { # Namespace @@ -76,7 +37,8 @@ selectizeGroupUI <- function(id, params, label = NULL, btn_label = "Reset filter FUN = function(x) { input <- params[[x]] tagSelect <- tags$div( - class="btn-group", + class = "btn-group", + id = ns(paste0("container-", input$inputId)), selectizeInput( inputId = ns(input$inputId), label = input$title, @@ -148,44 +110,72 @@ selectizeGroupUI <- function(id, params, label = NULL, btn_label = "Reset filter } -#' @param input standard \code{shiny} input. -#' @param output standard \code{shiny} output. -#' @param session standard \code{shiny} session. -#' @param data a \code{data.frame}, or an object that can be coerced to \code{data.frame}. +#' @param input,output,session standards \code{shiny} server arguments. +#' @param data Either a \code{data.frame} or a \code{reactive} +#' function returning a \code{data.frame} (do not use parentheses). #' @param vars character, columns to use to create filters, -#' must correspond to variables listed in \code{params}. +#' must correspond to variables listed in \code{params}. Can be a +#' \code{reactive} function, but values must be included in the initial ones (in \code{params}). #' #' @export #' #' @rdname selectizeGroup-module -#' @importFrom shiny updateSelectizeInput observeEvent reactiveValues reactive +#' @importFrom shiny updateSelectizeInput observeEvent reactiveValues reactive is.reactive selectizeGroupServer <- function(input, output, session, data, vars) { # nocov start - data <- as.data.frame(data) - # Namespace ns <- session$ns + toggleDisplayServer( + session = session, id = ns("reset_all"), display = "none" + ) - toggleDisplayServer(session = session, id = ns("reset_all"), display = "none") - lapply( - X = vars, - FUN = function(x) { - vals <- sort(unique(data[[x]])) - updateSelectizeInput( - session = session, - inputId = x, - choices = vals, - server = TRUE - ) + # data <- as.data.frame(data) + rv <- reactiveValues(data = NULL, vars = NULL) + observe({ + if (is.reactive(data)) { + rv$data <- data() + } else { + rv$data <- as.data.frame(data) } - ) + if (is.reactive(vars)) { + rv$vars <- vars() + } else { + rv$vars <- vars + } + for (var in names(rv$data)) { + if (var %in% rv$vars) { + toggleDisplayServer( + session = session, id = ns(paste0("container-", var)), display = "table-cell" + ) + } else { + toggleDisplayServer( + session = session, id = ns(paste0("container-", var)), display = "none" + ) + } + } + }) + + observe({ + lapply( + X = rv$vars, + FUN = function(x) { + vals <- sort(unique(rv$data[[x]])) + updateSelectizeInput( + session = session, + inputId = x, + choices = vals, + server = TRUE + ) + } + ) + }) observeEvent(input$reset_all, { lapply( - X = vars, + X = rv$vars, FUN = function(x) { - vals <- sort(unique(data[[x]])) + vals <- sort(unique(rv$data[[x]])) updateSelectizeInput( session = session, inputId = x, @@ -197,55 +187,62 @@ selectizeGroupServer <- function(input, output, session, data, vars) { # nocov s }) - lapply( - X = vars, - FUN = function(x) { + observe({ + vars <- rv$vars + lapply( + X = vars, + FUN = function(x) { + + ovars <- vars[vars != x] + + observeEvent(input[[x]], { - ovars <- vars[vars != x] + data <- rv$data - observeEvent(input[[x]], { + indicator <- lapply( + X = vars, + FUN = function(x) { + data[[x]] %inT% input[[x]] + } + ) + indicator <- Reduce(f = `&`, x = indicator) + data <- data[indicator, ] - indicator <- lapply( - X = vars, - FUN = function(x) { - data[[x]] %inT% input[[x]] + if (all(indicator)) { + toggleDisplayServer(session = session, id = ns("reset_all"), display = "none") + } else { + toggleDisplayServer(session = session, id = ns("reset_all"), display = "block") } - ) - indicator <- Reduce(f = `&`, x = indicator) - data <- data[indicator, ] - if (all(indicator)) { - toggleDisplayServer(session = session, id = ns("reset_all"), display = "none") - } else { - toggleDisplayServer(session = session, id = ns("reset_all"), display = "block") - } + for (i in ovars) { + if (is.null(input[[i]])) { + updateSelectizeInput( + session = session, + inputId = i, + choices = sort(unique(data[[i]])), + server = TRUE + ) + } + } - for (i in ovars) { - if (is.null(input[[i]])) { + if (is.null(input[[x]])) { updateSelectizeInput( session = session, - inputId = i, - choices = sort(unique(data[[i]])), + inputId = x, + choices = sort(unique(data[[x]])), server = TRUE ) } - } - - if (is.null(input[[x]])) { - updateSelectizeInput( - session = session, - inputId = x, - choices = sort(unique(data[[x]])), - server = TRUE - ) - } - }, ignoreNULL = FALSE, ignoreInit = TRUE) + }, ignoreNULL = FALSE, ignoreInit = TRUE) - } - ) + } + ) + }) return(reactive({ + data <- rv$data + vars <- rv$vars indicator <- lapply( X = vars, FUN = function(x) { diff --git a/R/module-utils.R b/R/module-utils.R index 45620514..07b0412b 100644 --- a/R/module-utils.R +++ b/R/module-utils.R @@ -45,7 +45,7 @@ toggleDisplayUi <- function() { #' @param display character, 'none' to hide, 'block' or 'inline-block' to show #' #' @noRd -toggleDisplayServer <- function(session, id, display = c("none", "block", "inline-block")) { +toggleDisplayServer <- function(session, id, display = c("none", "block", "inline-block", "table-cell")) { display <- match.arg(display) session$sendCustomMessage( type = 'toggleDisplay', diff --git a/examples/selectizeGroup-default.R b/examples/selectizeGroup-default.R new file mode 100644 index 00000000..2c6bd70c --- /dev/null +++ b/examples/selectizeGroup-default.R @@ -0,0 +1,43 @@ +# Default ----------------------------------------------------------------- + +if (interactive()) { + + library(shiny) + library(shinyWidgets) + + data("mpg", package = "ggplot2") + + ui <- fluidPage( + fluidRow( + column( + width = 10, offset = 1, + tags$h3("Filter data with selectize group"), + panel( + selectizeGroupUI( + id = "my-filters", + params = list( + manufacturer = list(inputId = "manufacturer", title = "Manufacturer:"), + model = list(inputId = "model", title = "Model:"), + trans = list(inputId = "trans", title = "Trans:"), + class = list(inputId = "class", title = "Class:") + ) + ), status = "primary" + ), + DT::dataTableOutput(outputId = "table") + ) + ) + ) + + server <- function(input, output, session) { + res_mod <- callModule( + module = selectizeGroupServer, + id = "my-filters", + data = mpg, + vars = c("manufacturer", "model", "trans", "class") + ) + output$table <- DT::renderDataTable(res_mod()) + } + + shinyApp(ui, server) + +} diff --git a/examples/selectizeGroup-subset.R b/examples/selectizeGroup-subset.R new file mode 100644 index 00000000..26df469a --- /dev/null +++ b/examples/selectizeGroup-subset.R @@ -0,0 +1,61 @@ + +# Subset data ------------------------------------------------------------- + +if (interactive()) { + + library(shiny) + library(shinyWidgets) + + data("mpg", package = "ggplot2") + + ui <- fluidPage( + fluidRow( + column( + width = 10, offset = 1, + tags$h3("Filter data with selectize group"), + panel( + pickerInput( + inputId = "car_select", + choices = unique(mpg$manufacturer), + options = list( + `live-search` = TRUE, + title = "None selected" + ) + ), + selectizeGroupUI( + id = "my-filters", + params = list( + manufacturer = list(inputId = "manufacturer", title = "Manufacturer:"), + model = list(inputId = "model", title = "Model:"), + trans = list(inputId = "trans", title = "Trans:"), + class = list(inputId = "class", title = "Class:") + ) + ), + status = "primary" + ), + DT::dataTableOutput(outputId = "table") + ) + ) + ) + + server <- function(input, output, session) { + + mpg_filter <- reactive({ + subset(mpg, manufacturer %in% input$car_select) + }) + + res_mod <- callModule( + module = selectizeGroupServer, + id = "my-filters", + data = mpg_filter, + vars = c("manufacturer", "model", "trans", "class") + ) + + output$table <- DT::renderDataTable({ + req(res_mod()) + res_mod() + }) + } + + shinyApp(ui, server) +} diff --git a/examples/selectizeGroup-vars.R b/examples/selectizeGroup-vars.R new file mode 100644 index 00000000..666617f5 --- /dev/null +++ b/examples/selectizeGroup-vars.R @@ -0,0 +1,60 @@ + +# Select variables -------------------------------------------------------- + +if (interactive()) { + + library(shiny) + library(shinyWidgets) + + data("mpg", package = "ggplot2") + + ui <- fluidPage( + fluidRow( + column( + width = 10, offset = 1, + tags$h3("Filter data with selectize group"), + panel( + checkboxGroupInput( + inputId = "vars", + label = "Variables to use:", + choices = c("manufacturer", "model", "trans", "class"), + selected = c("manufacturer", "model", "trans", "class"), + inline = TRUE + ), + selectizeGroupUI( + id = "my-filters", + params = list( + manufacturer = list(inputId = "manufacturer", title = "Manufacturer:"), + model = list(inputId = "model", title = "Model:"), + trans = list(inputId = "trans", title = "Trans:"), + class = list(inputId = "class", title = "Class:") + ) + ), + status = "primary" + ), + DT::dataTableOutput(outputId = "table") + ) + ) + ) + + server <- function(input, output, session) { + + vars_r <- reactive({ + input$vars + }) + + res_mod <- callModule( + module = selectizeGroupServer, + id = "my-filters", + data = mpg, + vars = vars_r + ) + + output$table <- DT::renderDataTable({ + req(res_mod()) + res_mod() + }) + } + + shinyApp(ui, server) +} diff --git a/man/selectizeGroup-module.Rd b/man/selectizeGroup-module.Rd index 62f8e79a..442dd7b1 100644 --- a/man/selectizeGroup-module.Rd +++ b/man/selectizeGroup-module.Rd @@ -23,16 +23,14 @@ selectizeGroupServer(input, output, session, data, vars) \item{inline}{If \code{TRUE} (the default), `selectizeInput`s are horizontally positioned, otherwise vertically.} -\item{input}{standard \code{shiny} input.} +\item{input, output, session}{standards \code{shiny} server arguments.} -\item{output}{standard \code{shiny} output.} - -\item{session}{standard \code{shiny} session.} - -\item{data}{a \code{data.frame}, or an object that can be coerced to \code{data.frame}.} +\item{data}{Either a \code{data.frame} or a \code{reactive} +function returning a \code{data.frame} (do not use parentheses).} \item{vars}{character, columns to use to create filters, -must correspond to variables listed in \code{params}.} +must correspond to variables listed in \code{params}. Can be a +\code{reactive} function, but values must be included in the initial ones (in \code{params}).} } \value{ a \code{reactive} function containing data filtered. @@ -41,45 +39,168 @@ a \code{reactive} function containing data filtered. Group of mutually dependent `selectizeInput` for filtering data.frame's columns (like in Excel). } \examples{ +# Default ----------------------------------------------------------------- + if (interactive()) { -library(shiny) -library(shinyWidgets) - -data("mpg", package = "ggplot2") - -ui <- fluidPage( - fluidRow( - column( - width = 10, offset = 1, - tags$h3("Filter data with selectize group"), - panel( - selectizeGroupUI( - id = "my-filters", - params = list( - manufacturer = list(inputId = "manufacturer", title = "Manufacturer:"), - model = list(inputId = "model", title = "Model:"), - trans = list(inputId = "trans", title = "Trans:"), - class = list(inputId = "class", title = "Class:") - ) - ), status = "primary" - ), - DT::dataTableOutput(outputId = "table") + library(shiny) + library(shinyWidgets) + + data("mpg", package = "ggplot2") + + ui <- fluidPage( + fluidRow( + column( + width = 10, offset = 1, + tags$h3("Filter data with selectize group"), + panel( + selectizeGroupUI( + id = "my-filters", + params = list( + manufacturer = list(inputId = "manufacturer", title = "Manufacturer:"), + model = list(inputId = "model", title = "Model:"), + trans = list(inputId = "trans", title = "Trans:"), + class = list(inputId = "class", title = "Class:") + ) + ), status = "primary" + ), + DT::dataTableOutput(outputId = "table") + ) ) ) -) - -server <- function(input, output, session) { - res_mod <- callModule( - module = selectizeGroupServer, - id = "my-filters", - data = mpg, - vars = c("manufacturer", "model", "trans", "class") + + server <- function(input, output, session) { + res_mod <- callModule( + module = selectizeGroupServer, + id = "my-filters", + data = mpg, + vars = c("manufacturer", "model", "trans", "class") + ) + output$table <- DT::renderDataTable(res_mod()) + } + + shinyApp(ui, server) + +} + +# Select variables -------------------------------------------------------- + +if (interactive()) { + + library(shiny) + library(shinyWidgets) + + data("mpg", package = "ggplot2") + + ui <- fluidPage( + fluidRow( + column( + width = 10, offset = 1, + tags$h3("Filter data with selectize group"), + panel( + checkboxGroupInput( + inputId = "vars", + label = "Variables to use:", + choices = c("manufacturer", "model", "trans", "class"), + selected = c("manufacturer", "model", "trans", "class"), + inline = TRUE + ), + selectizeGroupUI( + id = "my-filters", + params = list( + manufacturer = list(inputId = "manufacturer", title = "Manufacturer:"), + model = list(inputId = "model", title = "Model:"), + trans = list(inputId = "trans", title = "Trans:"), + class = list(inputId = "class", title = "Class:") + ) + ), + status = "primary" + ), + DT::dataTableOutput(outputId = "table") + ) + ) ) - output$table <- DT::renderDataTable(res_mod()) + + server <- function(input, output, session) { + + vars_r <- reactive({ + input$vars + }) + + res_mod <- callModule( + module = selectizeGroupServer, + id = "my-filters", + data = mpg, + vars = vars_r + ) + + output$table <- DT::renderDataTable({ + req(res_mod()) + res_mod() + }) + } + + shinyApp(ui, server) } -shinyApp(ui, server) +# Subset data ------------------------------------------------------------- + +if (interactive()) { + + library(shiny) + library(shinyWidgets) + + data("mpg", package = "ggplot2") + + ui <- fluidPage( + fluidRow( + column( + width = 10, offset = 1, + tags$h3("Filter data with selectize group"), + panel( + pickerInput( + inputId = "car_select", + choices = unique(mpg$manufacturer), + options = list( + `live-search` = TRUE, + title = "None selected" + ) + ), + selectizeGroupUI( + id = "my-filters", + params = list( + manufacturer = list(inputId = "manufacturer", title = "Manufacturer:"), + model = list(inputId = "model", title = "Model:"), + trans = list(inputId = "trans", title = "Trans:"), + class = list(inputId = "class", title = "Class:") + ) + ), + status = "primary" + ), + DT::dataTableOutput(outputId = "table") + ) + ) + ) + + server <- function(input, output, session) { + + mpg_filter <- reactive({ + subset(mpg, manufacturer \%in\% input$car_select) + }) + + res_mod <- callModule( + module = selectizeGroupServer, + id = "my-filters", + data = mpg_filter, + vars = c("manufacturer", "model", "trans", "class") + ) + + output$table <- DT::renderDataTable({ + req(res_mod()) + res_mod() + }) + } + shinyApp(ui, server) } }