Last active
February 10, 2017 17:39
-
-
Save mmparker/f44fef179280bbd2d90bb41684477d40 to your computer and use it in GitHub Desktop.
Trying to nest a plot-generating module inside a second module that creates several plots.
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
| options(stringsAsFactors = FALSE, | |
| scipen = 9999) | |
| library(shiny) | |
| library(ggplot2) | |
| library(dplyr) | |
| theme_set(theme_bw()) | |
| # Function to plot a single selected measurement - Sepal.Length, Sepal.Width | |
| generateMeasurePlot <- function(input, output, session, | |
| species_table, | |
| measurement) { | |
| measure_plot <- renderPlot({ | |
| ggplot(species_table(), aes_string(x = measurement())) + | |
| geom_histogram() | |
| }) | |
| return(measure_plot) | |
| } | |
| # Generate a plot for every measurement | |
| generateSpeciesPlots <- function(input, output, session, | |
| species_table) { | |
| # Identify the measures on the given table. | |
| # For iris, they're always the same, but my data has a varying number of | |
| # measures per table. | |
| measureNames <- reactive({ | |
| grep(x = names(species_table()), | |
| pattern = ".*Length|.*Width", | |
| value = TRUE) | |
| }) | |
| # Render each plot | |
| speciesPlots <- reactive({ | |
| lapply(measureNames(), FUN = function(this_measure_name) { | |
| # WHY DOES THIS EVEN WORK | |
| this_measure_fun <- reactive(this_measure_name) | |
| callModule(module = generateMeasurePlot, | |
| id = paste0(this_measure, "Plot"), | |
| species_table = reactive(species_table()), | |
| measurement = this_measure_fun) | |
| }) | |
| }) | |
| # Create a UI element for each plot | |
| speciesPlotsUI <- renderUI({ | |
| do.call(tagList, speciesPlots()) | |
| }) | |
| # Return | |
| speciesPlotsUI | |
| } | |
| ####################################### | |
| # User Interface | |
| ####################################### | |
| ui <- fluidPage( | |
| fluidRow( | |
| column(width = 3, | |
| selectInput(inputId = "selected_species", | |
| label = "Species", | |
| choices = c("setosa", "versicolor", "virginica"), | |
| selected = "setosa")), | |
| column(width = 3, | |
| selectInput(inputId = "selected_measurement", | |
| label = "Measurement", | |
| choices = "")) | |
| ), | |
| fluidRow( | |
| column(6, tag("h3", "measurePlot"), plotOutput("measurePlot")), | |
| column(6, tag("h3", "speciesPlots"), uiOutput("speciesPlots")) | |
| ) | |
| ) | |
| ####################################### | |
| # Serverside | |
| ####################################### | |
| server <- function(input, output, session) { | |
| # Extract the selected species. | |
| # In the real app, these are different tables, with potentially varying | |
| # schema. | |
| species_table <- reactive({ | |
| iris[iris$Species %in% input$selected_species, ] | |
| }) | |
| # Update the UI with the available measures | |
| # In this case, the measures are the same for all Species - but in the | |
| # real app, they vary. | |
| available_measures <- reactive({ | |
| grep(x = names(species_table()), | |
| pattern = ".*Length|.*Width", | |
| value = TRUE) | |
| }) | |
| observe({ | |
| updateSelectInput(session = session, | |
| inputId = "selected_measurement", | |
| choices = available_measures()) | |
| }) | |
| # Generate the output | |
| output$selectedMeasure <- reactive(input$selected_measurement) | |
| output$measurePlot <- callModule(module = generateMeasurePlot, | |
| id = "onemeasure", | |
| species_table = reactive(species_table()), | |
| measurement = reactive(input$selected_measurement)) | |
| output$speciesPlots <- callModule(module = generateSpeciesPlots, | |
| id = "allmeasures", | |
| species_table = reactive(species_table())) | |
| } | |
| # Run the app | |
| shinyApp(ui, server) | |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment