Delayed execution in R Shiny app - r

Is it possible have some parts of RShiny app execute in a delayed fashion much like the Delayed start in Windows Services?
Let me elaborate.
I have a shiny app with tabs. Each tab have a bunch of radio buttons on the sidebarPanel. Clicking on each radio button brings up a report. My set up is as simple as this.
However when I load the app every time and when the first tab is auto rendered, all reports associated with all radio buttons under this tab is executed and then the first radio button is selected and its correlating report is displayed. This whole process takes about 10-11 seconds which I want to bring down.
During server start, I simply read my myData.RData file in global.R. So all data is pre-fetched (and I am assuming kept in memory) during server start. What happens when the tab is brought to focus is that the data.frames from myData.RData are read and a series of ggplots (renderPlot) and tables (renderText) are called.
Is there a way I can render the first report within few seconds and then proceed to executing other ggplots and tables? I did go thru reactivity conductors and isolations but couldn't figure what solution fits my problem here.
Or is there any other way I can speeden the load (and refresh) time?
Some code to help understand the issue..
# In server.R
library(shiny)
library(plyr)
library(ggplot2)
library(grid)
source("a.R", local=TRUE)
source("b.R", local=TRUE)
shinyServer(function(input, output) {
# The below two lines represent a report pair to me. So I have a Bar plot and the associated Table report.
output$wSummaryPlot = renderPlot({ print(drawBarPlotA("Bar Plot A")) })
output$wSummaryTable = renderText({ tableA() })
# There are about 20 such pairs in server.R
# Please note that I am including other R file by "source". The first two lines shows that. Don't know if that is what is causing the problem.
# The drawBarPlotA and tableA are functions defined in one of the source files which are included above.
# There are 5 such files which are included similarly.
})
# In ui.R
shinyUI(pageWithSidebar(
headerPanel(windowTitle = "Perfios - DAS", addHeader()),
sidebarPanel(
conditionalPanel(condition = "input.reportTabs == 1 && input.reportType == 'reportTypeA'",
wellPanel(radioButtons("showRadio", strong("Attributes:"),
c("Analysis A" = "a",
"Analysis B" = "b",
"Analysis C" = "c",
"Analysis D" = "d",
"Analysis E" = "e",
"Analysis F" = "f"
)))
))
mainPanel(
tabPanel("A", value = "1",
conditionalPanel(condition = "input.reportType == 'reportTypeA'",
conditionalPanel(condition = "showRadio == 'X'",
plotOutput("wSummaryPlot"), h4("Summary:"), verbatimTextOutput("wSummaryTable"))
# Many such element here to accomodate for those 20 reports...
)))
))
# In drawBarPlotA
drawBarPlotA = function(mainText) {
ggplot(data, aes(variable, value, fill = some_fill)) +
geom_bar(stat = "identity", position = "dodge", color = "grey") +
ylab("Y Label") +
xlab(NULL) +
theme_bw() +
ggtitle(mainText) +
scale_fill_brewer(palette = "Set1") +
annotate("text", x = 1.2, y = 0, label = "Copyright...", size = 4) +
theme(axis.text.x = element_text(angle = 45, hjust = 1, size = "12", face = "bold"),
axis.text.y = element_text(size = "12"),
plot.title = element_text(size = "14", vjust = 3, face = "bold"))
}
tableA = function() {
# This is a data.frame which is returned
data
}

shinyServer(function(input, output, session) {
values <- reactiveValues(starting = TRUE)
session$onFlushed(function() {
values$starting <- FALSE
})
output$fast <- renderText({ "This happens right away" })
output$slow <- renderText({
if (values$starting)
return(NULL)
"This happens later"
})
})

Related

How to convert a piece of R code into Shiny apps?

A new self-learner for Shiny apps, still trying to explore the structure of Shiny apps. I have a piece of code which I want to convert into Shiny apps. I wonder if someone can walk me through how the process goes. My goal is to make the figure title/subtitle dynamic based on inputs (i.e., lnHR0, p_ctl0, tfu) to function. Thanks!!!
R code:
library(tidyverse)
library(ggplot2)
WR_sim_OC <- function(n_trt, n_ctl, lnHR0, p_trt0, med_ctl, tfu, enroll, dur_boost){
#n_trt=60: number of subjects (treatment)
#n_ctl=30: number of subjects (control)
#lnHR0=log(1): Overall Survival Log Hazard Ratio
#p_trt0 = seq(0.46, 0.66, 0.01): Response Rate (Treatment)
#med_ctl=21.8: Median Overall Survival (Control)
#tfu=9: Minimum Follow-up Time
#enroll=19: Enrollment Time
#dur_boost=0: Durability Boost (percentage)
## insert real simulation code here ##
## Fake Results
results <- tibble(ORR_trt = p_trt0, avg_HR = rep(0.774, times = 4), maturity = rep(36.7, times = 4), ORR = c(20.71, 38.87, 60.61, 78.95),
WR = c(46.8, 56.0, 64.3, 72.8), WO = c(46.0, 55.0, 63.7, 71.9), OS = rep(55.0, times = 4))
## Create Operating Characteristic Figure
dat <- results %>% pivot_longer(c(ORR, WR, WO, OS), names_to = 'Method', values_to = 'POS')
out1 <- ggplot(data = dat, aes(x = ORR_trt, y = POS, group = Method)) +
geom_line(aes(color = Method), size = 1) +
geom_point(aes(color = Method), size = 2.5) +
theme(legend.position = 'bottom') +
labs(title = 'HR=1.0 Treatment vs. Control', subtitle = 'ORR in Control Arm=46%, 9mo follow-up', color = 'Method') +
ylab('Probability of Incorrect Go') +
xlab('ORR in Treatment Arm') +
ylim(0, 100)
## Output OC Table + Figure to shiny app
list(results, out1)
}
WR_sim_OC(n_trt=60, n_ctl=30, lnHR0=log(1), p_ctl0=0.46, p_trt0 = seq(0.46, 0.66, 0.06), med_ctl=21.8, tfu=9, enroll=19, dur_boost=0)
I tried writing the ui.R as follows (suppose the suv_plot is the output name), which I know is wrong. The server.R part is too hard for me... Can someone help?
fluidPage(
numericInput("lnHRO",
label = h3("ln(HRO)"),
value = log(1)),
numericInput("pctl",
label = h3("Response Rate (Control)"),
value = 0.46),
numericInput("tfu",
label = h3("Minimum Follow-up Time (Month)"),
value = 9),
hr(),
plotOutput("suv_plot")
)
My first suggestion is just to look at tutorials on shiny, they give a great overview on how to start a project: https://shiny.rstudio.com/tutorial/
I didn't know a thing about programming a few years back, so I understand it can be hard figuring out where to start, so I wanted to give you an idea of how to implement a function, and use shiny inputs to make the resulting table/plot be dynamic.
I switched up your code to be easier to reproduce for myself. I hope this gives you the starting point you need:
library(tidyverse)
library(ggplot2)
library(shiny)
WR_sim_OC <- function(MPG, CYL, DISP){
results <- mtcars%>% #Function to make a table
filter(cyl > CYL,
mpg > MPG,
disp > DISP)
out1 <- ggplot(data = results, aes(x = mpg, y = disp, group = cyl)) +
geom_line(aes(color = hp), size = 1) #Function to make a plot
list(results, out1) #List to create table and function
}
ui <- fluidPage(
numericInput("MilesPerGallon", "mpg", value = 15),
numericInput("Cylinders", "cyl", value = 4),
numericInput("Displacement", "disp", value = 200),
tableOutput("TABLE"),
plotOutput("PLOT")
)
server <- function(input, output, session) {
output$TABLE<-renderTable({
req(input$MilesPerGallon, input$Cylinders, input$Displacement) #Requires all three inputs before it makes the table
WR_sim_OC(input$MilesPerGallon, input$Cylinders, input$Displacement)[1] #Only pulling the table from the function
})
output$PLOT<-renderPlot({
req(input$MilesPerGallon, input$Cylinders, input$Displacement) #Requires all three inputs before it makes the plot
WR_sim_OC(input$MilesPerGallon, input$Cylinders, input$Displacement)[2] #Only pulling the plot from the function
})
}
shinyApp(ui, server)
Essentially on the server side where you render the plot or table, you use those inputs from the ui as the dynamic points in your function. I used req() for both of the renderTable and renderPlot to make sure the inputs are filled out before it makes the table plot. Best of luck!

R Shiny dynamically edit reactiveTimer timer interval

I am trying to create an R shiny dashboard which has a play and pause button for updating displaying a graph data along a sequence of time. To do this I was using a reactiveTimer, but it does not allow me to dynamically edit the reactiveTimer interval.
Error in .getReactiveEnvironment()$currentContext() :
Operation not allowed without an active reactive context. (You tried to do something that can only be done from inside a reactive expression or observer.)
My attempted code is
library(shiny)
library(ggplot2)
library(tidyr)
input.df <- read.csv(file = 'InputData.csv', header = TRUE, sep=",")
ui<-fluidPage(
titlePanel("Auckland Volcanic Simulation"),
hr(style="border-color: grey;"),
sidebarLayout(
# panel with all inputs
sidebarPanel(
fluidRow(
column(7,actionButton("stop","Pause")),
column(5,actionButton("play","Play"))
),
fluidRow(
column(7,actionButton("skip","Skip")),
column(3,actionButton("reset","Reset"))
)
),
# plot panel
mainPanel(
# visual data on same row
fluidRow(
span(textOutput("Date"), style="font-size: 24px;font-style: italic;")
),
fluidRow(
column(12,plotOutput('defGraph'))
)
)
)
)
server<-function(input,output){
control<-reactiveValues() # reactive to store all reactive variables
control$resetindicator<-0 # used to change button labels
control$count<-0 # day number in sequence
control$min<-0
control$max<-0
control$timer<-Inf
forward<-function(){
print("in forward")
control$resetindicator<-1 # change button label
step <- 12
if (step >= control$count) {
min <- 0
max <- control$count
} else {
min <- control$count - step
max <- control$count
}
control$min <- min
control$max <- max
control$count<-control$count+1
}
observeEvent(input$skip,{
forward()
})
session<-reactiveValues()
session$timer<-reactiveTimer(intervalMs = control$timer, session = getDefaultReactiveDomain())
observeEvent(input$play,{
print("play")
control$timer<-1000
#session$timer<-reactiveTimer(intervalMs = 1000, session = getDefaultReactiveDomain())# Time interval
observeEvent(session$timer(),{
print("calling forward")
forward()
})
})
observeEvent(input$stop,{
print("stop")
control$timer<-Inf
#session$timer<-reactiveTimer(intervalMs = Inf, session = getDefaultReactiveDomain())
})
## when reset button is pressed (set everything to original values, plus set seed)
observeEvent(input$reset,{
control$resetindicator<-0
control$count= 0
})
# ## depth plot output
output$DepthGraph <- renderPlot({
eqdepthdata.df <- input.df[(input.df$DayTimeID <= control$max & input.df$DayTimeID >= control$min), ]
ggplot(data.df, aes(x = DateTime, y = -1*AverageDepth_km)) +
geom_point() +
scale_color_manual(values = c("darkorange")) +
labs(title = "Average depth of earthquakes", x = "", y = "Depth (km)") +
ylim(-40, 0) +
theme_light() +
theme(text = element_text(size = 14)) +
theme(axis.text.x = element_text(angle = 45, hjust = 1))
})
## visual data outputs
output$Date<-renderText({
paste("Date:", input.df$DateTime[input.df$DayTimeID == control$count-1])
})
}
shinyApp(ui = ui, server = server)
CSV example is
DayTimeID,Date, Time, DateTime, AverageDepth_km
0, 20/08/20, 0:00, 20/08/20 0:00, 17
1, 20/08/20, 4:00, 20/08/20 4:00, 8
2, 20/08/20, 8:00, 20/08/20 8:00, 14
3, 20/08/20, 12:00, 20/08/20 12:00, 3
4, 20/08/20, 16:00, 20/08/20 16:00, 5
5, 20/08/20, 20:00, 20/08/20 20:00, 9
I was trying to update a parameter for the interval by updating the parameter. I was following code presented here https://nhsrcommunity.com/blog/animating-a-graph-over-time-in-shiny/ but if press play->pause->play but the time interval goes twice as fast as if I understand you create another reactiveTimer.
Any assistance would be appreciated.

ggplot won't use levels for x-axis order when a reactive input is empty

I am trying to create a shiny app with multiple sections, the section I am having trouble with right now displays calculated values on a ggplot graph. The user selects one Target gene from a dropdown list, and the graph displays calculated analysis values against a selection of other, Control genes. So far so simple.
I have a few default Control genesets, which I have preselected and that are always displayed, and then I have an option for the user to specify their own Control genes to perform analysis against. There is a checkbox that can be ticked if the user wants to select their own Controls. The user can also select different numbers of custom Controls, whereas the default controls each have sets of 3 Control genes.
Code for the default genesets as so:
ABC_control <- reactive(
Analysis_function(c("ACTB", "GAPDH", "TUBB")))
And code for the custom genesets is as so:
CUSTOM_control1 <- reactive( if (input$custom_checkbox1) {
Analysis_function(input$custom_controls1)
} else { NA } )
I have an if command in the Custom genesets so that they are not calculated and displayed if the tickbox is not checked.
First problem: The plot still displays an x axis label for the Custom control even if none is selected and the checkbox is not ticked. This is not a major problem, just an annoying one.
The second problem:
When displaying just the default genesets everything runs perfectly. And when the user selects their own Control genes, everything runs fine.
The problem is when the user ticks the CheckboxInput(), and the selectizeInput() for the custom control genes is still empty, the graph goes and re-orders its x-axis into alphabetical order, rather than the levels order that I have specified earlier. As soon as a Control gene is selected, it re-orders back into the levels order. The problem only occurs when the selectizeInput box is empty, or a new gene is being selected.
How can I force the plot to always display in the correct levels order, even when the reactive custom input is empty?
Also, preferably, how can I prevent the Custom input from being displayed on the graph at all unless the checkbox is ticked.
A full Shiny app data is below:
#### Load packages ####
library(shiny)
library(ggplot2)
library(dplyr)
#### Load data files ####
load("GeneNames.Rda")
load("Dataset.Rda")
#### Define UI ####
ui <- fluidPage(
#### Sidebar inputs ####
sidebarLayout(
sidebarPanel(width = 3,
#first wellpanel for selecting Target gene
h4("Target gene selection"),
wellPanel(
selectInput(
inputId = "gene_select",
label = NULL,
choices = GeneNames,
selected = "ESAM")),
#Second wellpanel for selecting custom Control genes
h4("Custom control genes"),
wellPanel(
checkboxInput(inputId = "custom_checkbox1",
label = "Custom 1:"),
conditionalPanel(condition = "input.custom_checkbox1 == true",
selectizeInput(inputId = "custom_controls1",
label = NULL,
choices = GeneNames,
multiple = TRUE,
options = list(openOnFocus = FALSE, closeAfterSelect = TRUE, maxOptions = 50, maxItems = 6))))
),
#### Mainpanel results Normal ####
mainPanel(width = 9,
#HTML code to have the last entry in any tables bolded (last entry is Mean in all tables)
#Results title and main bar plot graph
fluidRow(plotOutput(outputId = "celltype_bar_plot"),width = 9)
)))
#### Define server ####
server <- function(input, output) {
target_gene <- reactive({
input$gene_select
})
#### calculations ####
Analysis_function <- function(controls){
cor(Dataset[, target_gene()], Dataset[, controls])
}
ABC_control <- reactive(
Analysis_function(c("ACTB", "GAPDH", "TUBB")))
GHI_control <- reactive(
Analysis_function(c("ACTB", "GAPDH", "TUBB")))
DEF_control <- reactive(
Analysis_function(c("ACTB", "GAPDH", "TUBB")))
CUSTOM_control1 <- reactive( if (input$custom_checkbox1) {
Analysis_function(input$custom_controls1)
} else { NA } )
#### Analysis datatables Normal ####
control_list <- c("ABC_control", "GHI_control", "DEF_control", "CUSTOM_control1")
analysis_list <- reactive({ list(ABC_control(), GHI_control(), DEF_control(), CUSTOM_control1()) })
#generating melted data table of the induvidual analysed gene values, transposed to get in right format, and times = c(length()) to replicate titles the correct no of times
values_list <- reactive({
data.frame(Control_types2 = factor(rep(control_list, times = c(unlist(lapply(analysis_list(), length)))), levels =control_list),
values = c(unlist(lapply(analysis_list(), t))))
})
#Generating data table of the means of analysed values above
Mean_list <- reactive({
data.frame(Control_types = factor(control_list, levels =control_list),
Mean_correlation = c(unlist(lapply(analysis_list(), mean))))
})
#### Main Bar Plot Normal ####
output$celltype_bar_plot <- renderPlot({
ggplot() +
geom_point(data = values_list(),aes(x=Control_types2, y=values,size = 7, color = Control_types2), show.legend = FALSE, position=position_jitter(h=0, w=0.1), alpha = 0.7) +
geom_boxplot(data = Mean_list(), aes(Control_types, Mean_correlation), size = 0.5, colour = "black")
})
}
#### Run application ####
shinyApp(ui = ui, server = server)
I can't fully test this solution since the data you provided isn't available (so I can't run the app), but I suspect that the following should help.
First, by using ordered or factor(..., ordered = TRUE) you can tell the graph what order to put label in.
Second, in order to prevent the column from showing up on the graph you must remove all datapoints for that column INCLUDING NA.
control_list <- c("ABC_control", "GHI_control", "DEF_control", "CUSTOM_control1")
# Some data to try out
values_list <- data.frame(
Control_types2 = ordered(rep(control_list, times = 4), levels =control_list),
values = c(0.25,0.50,0.75,NA)
)
Mean_list <- data.frame(
Control_types = ordered(control_list, levels =control_list),
Mean_correlation = c(0.25,0.50,0.75,NA)
)
# Original plot code
ggplot() +
geom_point(data = values_list,aes(x=Control_types2, y=values,size = 7, color = Control_types2), show.legend = FALSE, position=position_jitter(h=0, w=0.1), alpha = 0.7) +
geom_boxplot(data = Mean_list, aes(Control_types, Mean_correlation), size = 0.5, colour = "black")
# New plot with NA values removed
ggplot() +
geom_point(data = values_list %>% filter(!is.na(values)),
aes(x=Control_types2, y=values,size = 7, color = Control_types2),
show.legend = FALSE,
position=position_jitter(h=0, w=0.1),
alpha = 0.7) +
geom_boxplot(data = Mean_list %>% filter(!is.na(Mean_correlation)),
aes(Control_types, Mean_correlation),
size = 0.5,
colour = "black")

passing Shiny variables from ui.R to server.R

I'm re-posting this from scratch in hopes someone can get me through this learning opportunity.
I'm having trouble passing a variable from ui.R to server.R in the following Shiny app.
I'm also including global.R. One section of that file pings my cloud-based MySQL db. I didn't want to share the password for that on here; you can get the query results as CSV files (2 of them) here.
The problem is with Line 22 of server.R. With the code as-is (y = n.emp,), it works as expected. When I replace that with (y = input$quant,), the code breaks. The error is in that line. I have isolated that.
I've tried aes_string, as previously suggested. It did not work. (Maybe I didn't use it properly?)
Can anyone help me on this? Thanks!
server.R
# Define server logic required to draw a histogram
shinyServer(function(input, output) {
output$distPlot <- renderPlot({
### ----- MANIPULATE DATA -----
colors17 <- c("#a7dfb9","#d0a0d4","#fde096","#96bbf1","#ecb489","#6eceea","#eaa99e","#8adbd3","#ddb9f1","#9cc18d","#ebaec8","#dceeb6","#b6bee4","#c5c88f","#dfb89b","#e9cf9d","#c8c09a")
colors6 <- c("#74d5e0", "#e5b197", "#93c1ed", "#cfd6a0", "#dfb1d8", "#9adabe")
naics_jll$market <- factor(naics_jll$m.mkt,
levels = as.character(MKT))
naics_jll <- naics_jll %>%
filter(m.mkt %in% input$markets
# , (other), (filters), (here)
)
### ----- PLOT -----
g <- ggplot(naics_jll)
g + geom_bar(stat = "identity",
position = input$geom_bar_pos,
aes(x = m.mkt,
y = n.emp,
fill = c1.name),
color = "lightgrey") +
scale_fill_manual (values=colors17) +
# facet_wrap(~ m.mkt) +
labs( y = input$quant, title = "Market Structure", subtitle = "by market & industry") +
theme(strip.text.x = element_text(size = 8),
axis.text.x = element_text(angle=90, size=6))
})
})
ui.R
# Define UI for application that draws a histogram
shinyUI(fluidPage(
title = "Company Data Explorer",
plotOutput('distPlot'),
hr(),
fluidRow(
column(3,
radioButtons("geom_bar_pos", "",
c("Stacked Bars" = "stack",
"Grouped Bars" = "dodge"),selected = "dodge")
),
column(4, offset = 1,
checkboxGroupInput("markets", "Include Markets:",
c("Boston" = "BOS",
"NYC" = "NYC",
"Chicago" = "CHI",
"San Francisco" = "SF",
"Los Angeles" = "LA",
"Washington, DC" = "DC"),
selected = c("BOS","NYC","CHI","SF","LA","DC"))),
column(4,
selectInput('quant', 'Y-Values', names(y_vals),names(y_vals)[[4]]))
)
))
global.R
library(shiny)
library(RNeo4j)
library(tidyverse)
library(stringr)
library(ggplot2)
### GET DATA
## MySQL SERVER CONNECT
con <- dbConnect(MySQL(),
user = 'shiny_apps',
password = '****',
host = 'mysql.mvabl.com',
dbname='sandbox191')
qmain <- dbSendQuery(con, "SELECT * FROM naics_jll;")
naics_jll <- as.data.frame(dbFetch(qmain,n=-1),na.rm=TRUE)
dbHasCompleted(qmain)
dbClearResult(qmain)
dbDisconnect(con)
## LOAD CSV
naics_jll <- select(naics_jll,-n.msa_naics,-c1.id,-q.level,-q.qtr,-q.nbrhd,-N.BldgClass)
y_vals <- subset(naics_jll,select = which(sapply(naics_jll,is.numeric)))
dropdown <- c("m.mkt","c1.name","q.nbrhd")
### "LEVELS" VARIABLES (currently unused)
IND <- naics_jll %>% distinct(c1.name)
MKT <- naics_jll %>% distinct(m.mkt)
I finally solved it, with help from Joe Cheng's gist. I needed to define my data source as reactive. Guess that's a new subject to read up on!!

Shiny: Conditional Panel and Conditional List of checkboxGroupInput

I want to create a shiny app for plotting the most recent pollstR charts of US presidential primaries. Users should be able to select a Party (Dem or Rep), the Candidates and the states, where the primaries (or Caucusus) took place.
I have three problems:
Based on the selected party (Dem or Rep), users should get the next checkboxGroupInput, where only the Democratic or Republican candidates appear. I try to solved that with a conditionalPanel. However, I cannot use "Candidate" twice as a name for the Widget (later in the server.R I need input$Candidate). How can I solve that?
Based on the selected party (again Dem or Rep), users should get a list of all states, where primaries and caucusus took place up to now. At the moment, I am listing all US states, which I defined before (and hence I get errors, if I want to plot the results of states, where no polls are available). Is there a way to get the list of states from the dataset, which is generated in the server.R part (it is called polls$state there, but I cannot use it, because the ui.R does not now "polls").
I plot the results as bar-charts with ggplot and the facet_wrap function (with two columns). The more states I choose, the smaller the plots get. Is there a way to set the height of the plots and insert a vertical scrollbar in the main panel?
Here is the code for the UI:
shinyUI(fluidPage(
titlePanel("2016 Presidential primaries"),
sidebarLayout(position = "right",
sidebarPanel(
helpText("Choose between Democratic (Dem) and Republican (Rep)
Primaries and Caucuses:"),
selectInput("party",
label = "Dem or Rep?",
choices = c("Dem", "Rep",
selected = "Dem")),
conditionalPanel(
condition = "input.party == 'Dem'",
checkboxGroupInput("Candidate", label = h4("Democratic Candidates"),
choices = list("Clinton" = "Clinton", "Sanders" = "Sanders"),
selected = NULL)),
conditionalPanel(
condition = "input.party == 'Rep'",
checkboxGroupInput("Candidate", label = h4("Republican Candidates"),
choices = list("Bush" = "Bush", "Carson" = "Carson", "Christie" = "Christie",
"Cruz" = "Cruz", "Kasich" = "Kasich", "Rubio" = "Rubio",
"Trump" = "Trump"),
selected = NULL)),
checkboxGroupInput("state",
label = "Select State",
choices = states,
inline = TRUE,
selected = NULL)
),
mainPanel(
tabsetPanel(
tabPanel("Plot", plotOutput("plot")),
tabPanel("Table", tableOutput("table"))
)
)
)
))
And here the code for the server.R:
### getting and cleaning the data for the shiny app-----------------------------
# load pollstR-package to get Huffpost opinion polls
require(pollstR)
# load dplyr and tidyr for data wrangling
require(dplyr)
require(tidyr)
# load ggplot2 for plotting
require(ggplot2)
# download 2016 GOP presidential primaries
repPoll <- pollstr_charts(topic='2016-president-gop-primary', showall = TRUE)
# extract and combine columns needed
choice <- repPoll$estimates$choice
value <- repPoll$estimates$value
election <- repPoll$estimates$slug
party <- repPoll$estimates$party
rep.df <- data_frame(election, choice, value, party)
# extract and combine slug and state info to add list of US state abbreviations
election <- repPoll$charts$slug
state <- repPoll$charts$state
r.stateAbb <- data_frame(election, state)
# join both data frames based on slug
rep.df <- left_join(rep.df, r.stateAbb, by = "election")
## download 2016 DEM presidential primaries
demPoll <- pollstr_charts(topic='2016-president-dem-primary', showall = TRUE)
# extract and combine columns needed
choice <- demPoll$estimates$choice
value <- demPoll$estimates$value
election <- demPoll$estimates$slug
party <- demPoll$estimates$party
dem.df <- data_frame(election, choice, value, party)
# extract and combine slug and state info to add list of US state abbreviations
election <- demPoll$charts$slug
state <- demPoll$charts$state
d.stateAbb <- data_frame(election, state)
# join both data frames based on slug
dem.df <- left_join(dem.df, d.stateAbb, by = "election")
# combine dem and rep datasets
polls <- bind_rows(dem.df, rep.df)
polls$party <- as.factor(polls$party)
polls$state <- as.factor(polls$state)
polls$choice <- as.factor(polls$choice)
shinyServer(function(input, output) {
df <- reactive({
polls %>% filter(party %in% input$party) %>% filter(choice %in% input$Candidate) %>%
filter(state %in% input$state)
})
# generate figures
output$plot <- renderPlot({
validate(
need(input$party, "Please select a party"),
need(input$Candidate, "Please choose at least one candidate"),
need(input$state, "Please select at least one state")
)
p <- ggplot(df())
p <- p + geom_bar(aes(x = choice, weight = value, fill = choice),
position = "dodge", width=.5)
# colorize bars based on parties
if (input$party == "Dem")
p <- p + scale_fill_brewer(palette = "Blues", direction = -1)
if (input$party == "Rep")
p <- p + scale_fill_brewer(palette = "Reds", direction = -1)
# add hlines for waffle-design
p <- p + geom_hline(yintercept=seq(0, 100, by = 10), col = 'white') +
geom_text(aes(label = value, x = choice, y = value + 1), position = position_dodge(width=0.9), vjust=-0.25) +
# facet display
facet_wrap( ~ state, ncol = 2) +
# scale of y-axis
ylim(0, 100) +
# delete labels of x- and y-axis
xlab("") + ylab("") +
# blank background and now grids and legend
theme(panel.grid.major.x = element_blank(), panel.grid.major.y = element_blank(),
panel.grid.minor.y = element_blank(),
panel.background = element_blank(), legend.position = "none")
print(p)
}
)
# Generate a table view of the data
output$table <- renderTable({
polls %>% filter(party %in% input$party) %>% filter(choice %in% input$Candidate) %>%
filter(state %in% input$state)
})
}
)
Here is the solution for problem 1 and 2:
In ui.R, replace conditionalPanel and checkboxGroupInput with
uiOutput('candidates'),
uiOutput('states')
In server.R, add the following code before df <- reactive({..... Note that you need to change some of your input$Candidate code to lower case.
observeEvent(input$party, {
output$candidates <- renderUI({
checkboxGroupInput(
"candidate",
ifelse(input$party == 'Dem', "Democratic Candidates", "Republican Candidates"),
as.vector(unique(filter(polls,party==input$party)$choice))
)
})
})
observeEvent(input$candidate, {
output$states <- renderUI({
states_list <- as.vector(unique(filter(polls, party==input$party & choice==input$candidate)$state))
checkboxGroupInput(
"state",
"Select state",
# Excluding national surveys
states_list[states_list!="US"]
)
})
})
For problem 3, change the df reactive to observe, and then set plot height depending on how many states selected. Also change this line p <- ggplot(df)
observe({
df <- polls %>% filter(party %in% input$party) %>% filter(choice %in% input$candidate) %>% filter(state %in% input$state)
height <- ceiling(length(input$state) / 2) * 200
output$plot <- renderPlot({
#Your plot code
}, height=height)
})

Resources