Created
December 28, 2017 23:30
-
-
Save agberg/9f933f4dc82130c775a1f050c3e99dc4 to your computer and use it in GitHub Desktop.
The first half of a dynamic filtering Shiny application.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
library(shiny) | |
library(stringr) | |
# Module UI function | |
fieldSelectorInput <- function(id) { | |
# Create a namespace function using the provided id | |
ns <- NS(id) | |
tags$div(id = ns("id"), | |
tagList( | |
fluidRow( | |
column(12, selectInput(ns("select_input_one"), label = "Filter Variable", choices = c(1,2,3), width = '100%')) | |
), | |
fluidRow( | |
column(6, actionButton(ns("reshuffle_button"),label = "reshuffle")), | |
column(6, actionButton(ns("remove_button"),label = "remove")) | |
) | |
) | |
) | |
} | |
# Module server function | |
# This is the server functionality for a single server function (corresponding to a single UI group of elements) | |
fieldSelector <- function(input, output, session, div_instance) { | |
to_return <- reactive({ | |
input$reshuffle_button[1] | |
input$remove_button[1] | |
if(!is.null(input$remove_button)){ | |
if(input$remove_button > 0) {return(NULL)} else{ | |
return(sample(1:32, 5, replace = FALSE)) | |
} | |
} else{ | |
return(NULL) | |
} | |
}) | |
observeEvent(input$remove_button, once = TRUE, { | |
to_remove <- glue::glue("#{div_instance}") | |
removeUI( | |
selector = to_remove | |
) | |
}) | |
return(to_return) | |
} | |
# ----- | |
# Define UI | |
ui <- fluidPage( | |
# fieldSelectorInput("basic_field"), | |
# fieldSelectorInput("basic_field_two"), | |
tags$div(id = "content_filter"), | |
fluidRow(actionButton("create_new_filter", label = "Create New Filter")), | |
fluidRow(textOutput("values")), | |
fluidRow(textOutput("names")) | |
) | |
# Server logic | |
server <- function(input, output, session) { | |
# Initialize the "all_values" list, which is where you will put the filters you create | |
all_values <- reactiveValues() | |
observeEvent(input$create_new_filter, { | |
# Name the new filter | |
title <- glue::glue("field_selector_{input$create_new_filter}") | |
# Create and insert the UI for the new filter | |
insertUI(selector = '#content_filter', ui = fieldSelectorInput(title), where = "beforeEnd") | |
# Add the new filter's return value to the all_values list | |
# The callModule call also instantiates the server-side behavior of the new server. | |
# It does so inside its own scope, which helps to keep it sandboxed from other filters. | |
# You have to pass the information you want this server to use to it as reactiveValues, and you | |
# can only use values passed back as a reactive value from the server (if you want multiple things returned, | |
# you need to pass them in a list) | |
all_values[[title]] <- callModule(fieldSelector, id = title, div_instance = glue::glue("{title}-id")) | |
}) | |
# You end up with a reactiveValues element called "all_values" that has for its entries | |
# functions. You need to execute these funcitons to access the values. You can do this for | |
# the whole set of functions using invoke_map (after converting the reactiveValues object to a list) | |
list_of_elements <- reactive({ | |
list_version <- reactiveValuesToList(all_values) | |
purrr:::invoke_map(list_version) | |
}) | |
# This just displays the values of the output. This is just to show what's there. You'll want to use this information differently. | |
output$values <- renderText({ | |
unlist(list_of_elements()) | |
}) | |
# This just displays the names of the values of the output. Note that a "removed" filter is not removed from the "all_values" list; its value is | |
# just set to NULL. This isn't problematic, I don't think... you'll just want to ensure that you ignore NULL values (or you could set the value to | |
# something like "Deleted." Just something to separate it.) | |
output$names <- renderText({ | |
list_version <- reactiveValuesToList(all_values) | |
names(list_of_elements()) | |
}) | |
} | |
# Complete app with UI and server components | |
shinyApp(ui, server) | |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment