Reactive Data Issues in RShiny - r

I'm working on a Shiny dashboard for a personal project with some football stats. Whenever I change the statistic to be graphed and/or the filter, I get the same players that were in the first dataset. For example, when I start the app, the app creates a graph of the top ten rushers in school history with a filter of rushing attempts >= 0. When I change the statistic selection to rushing average, however, those ten players are the ones shown, which is incorrect.
library(readxl)
library(tidyverse)
library(purrr)
library(shiny)
interface <- fluidPage(
titlePanel(" "),
sidebarLayout(
sidebarPanel(
h1("Stats!"),
selectInput("stat_selection",
label = "Select a season statistics",
choices = c("Rushing Yards",
"Rushing Touchdowns",
"Rushing Average",
"Reciving Yards",
"Receptions",
"Receiving Touchdowns",
"Receiving Average"),
selected = "Rushing Yards"),
selectInput("filter_input",
label = "Select a statistic to filter by",
choices = c("Rushing Yards",
"Rushing Touchdowns",
"Rushing Average",
"Rushing Attempts",
"Reciving Yards",
"Receptions",
"Receiving Touchdowns",
"Receiving Average"),
selected = "Rushing Attempts"),
numericInput("filter_number",
label = "Type a number for the filter (>=)",
value = 0, min = 0),
actionButton("button", "Graph")),
mainPanel(
plotOutput("plot_button"),
tableOutput("table_button")
)
)
)
server_osu <- function(input, output) {
dataInput <- reactive({
switch(input$stat_selection,
"Rushing Yards" = rush_yds,
"Rushing Touchdowns" = rush_tds,
"Rushing Average" = rush_avg,
"Reciving Yards" = rec_yds,
"Receptions" = rec_rec,
"Receiving Touchdowns" = rec_td,
"Receiving Average" = rec_avg)
})
filterInput <- reactive({
switch(input$filter_input,
"Rushing Yards" = rush_yds,
"Rushing Touchdowns" = rush_tds,
"Rushing Average" = rush_avg,
"Rushing Attempts" = rush_att,
"Reciving Yards" = rec_yds,
"Receptions" = rec_rec,
"Receiving Touchdowns" = rec_td,
"Receiving Average" = rec_avg)
})
filter_number <- reactive(as.double(input$filter_number))
table_button_react <- eventReactive(input$button, {
dataset <- dataInput()
val <- filter_number()
colnames(dataset)[1] = "Player and Season"
dataset_filter <- filterInput()
colnames(dataset_filter)[1] = "Player and Season"
dataset <- left_join(dataset, dataset_filter)
colnames(dataset)[1] = "Player and Season"
og <- colnames(dataset)[3]
colnames(dataset)[3] = "filter"
original <- colnames(dataset)[2]
colnames(dataset)[2] = 'selected'
dataset <- dataset %>%
filter(filter >= val)
dataset <- dataset %>%
top_n(10) %>%
arrange(-selected)
colnames(dataset)[2] = original
colnames(dataset)[3] = og
dataset
})
plot_button_react <- eventReactive(input$button, {
dataset <- dataInput()
val <- filter_number()
colnames(dataset)[1] = "Player and Season"
dataset_filter <- filterInput()
colnames(dataset_filter)[1] = "Player and Season"
dataset <- left_join(dataset, dataset_filter)
colnames(dataset)[1] = "Player and Season"
colnames(dataset)[2] = "selected"
colnames(dataset)[3] = "filter"
dataset <- dataset %>%
filter(filter >= val)
top_ten <- dataset %>% top_n(10)
min = min(top_ten$selected)
max = max(top_ten$selected)
ggplot(top_ten, aes(x = reorder(`Player and Season`, -selected), y = selected)) +
geom_bar(stat = 'identity') + theme_minimal() + xlab('SEASON') +
ylab(input$stat_selection) + theme(text=element_text(size=16)) +
scale_fill_manual(values = c('#BBBBBB', '#BB0000')) +
theme(axis.text.x = element_text(angle = 45, hjust = 1)) +
theme(legend.position = 'none') +
coord_cartesian(ylim=c(min - 0.05*min, max + 0.05*max)) +
theme(axis.title.y = element_text(margin = margin(t = 0, r = 10, b = 0, l = 10))) +
theme(axis.title.x = element_text(margin = margin(t = 10, r = 0, b = 10, l = 0))) +
theme(axis.text.y = element_text(size=14),
axis.title=element_text(size=16,face='bold')) +
labs(caption = '')
})
output$plot_button <- renderPlot({
plot_button_react()
})
output$table_button <- renderTable({
table_button_react()
})
}

As I mentioned above, a reprex - including input data - would help us to help you. That said, I think the problem is that your XXX_button_reacts depend only on input$button. They don't depend on input$stat_selection, input$filter_number or input$filter_input. That's why they don't update as you want them to.
The fix is easy. Just add them (in a call to req() if you like) at the top of each XXXX_button_react, for example:
plot_button_react <- eventReactive(input$button, {
input$stat_selection
input$filter_number
input$filter_input
<your code here>
})
As a point of style, I feel it's better to separate data generation from data presentation. It makes the logic of your code more obvious, reduces the chance of errors, reduces the need for code duplication and makes your code more reusable.
In your case, I would create a reactive that holds the data you wish to tablulate and plot and then reference that reactive in each of your render_XXXX functions. That would also remove the need for your input$button: the plot and graph would each update automatically whenever you changed one of your other input widgets.

Related

How do I put a reactive subset of data into renderplot?

I am new to Shiny and have been trying to learn in my spare time. I have a dataframe of Fantasy Football statistics that I am trying to plot based on selectinput()'s and sliderbar()'s. I used renderprint() to ensure my inputs and correct when the slider's or selects are changed. I have the sliders and select inputs in a reactive() where I am simply subsetting the data. I am then feeding the reactive function into my ggplot() as the data. When trying to plot these graphs I am getting an "Error: object 'columnName' not found", but for only some columns. Please help me find the source of this issue.
Best, Davis
Here is the code:
######################################################################
#------------------------Load libraries------------------------------#
######################################################################
library(shiny)
library(bslib)
library(shinydashboardPlus)
library(ggplot2)
library(shinyWidgets)
######################################################################
#------------------------Data import and Clean-----------------------#
######################################################################
FantFootDF <- read_excel("~/Desktop/Fantasy/2021 Fantasy Stats.xltx")
FantFootDF <- as.data.frame(FantFootDF)
colnames(FantFootDF) <- paste(FantFootDF[1,])
FantFootDF <- FantFootDF[-1,]
colnames(FantFootDF) <- c("Rk","Player","Team","FantPos","Age",
"G","GS","Cmp","PAtt","PYds","PTD",
"Int","RuAtt","RuYds","RuYA","RuTD",
"Rec","ReYds","ReYA","ReTD","Fmb","FL",
"TTD","2PM","2PP","FantPt","PPR","DKPt",
"FDPt","VBD","PosRank","OvRank")
FantFootDF[!is.na(FantFootDF$FantPos),]
NumColumns <- c("Rk","Age",
"G","GS","Cmp","PAtt","PYds","PTD",
"Int","RuAtt","RuYds","RuYA","RuTD",
"Rec","ReYds","ReYA","ReTD","Fmb","FL",
"TTD","2PM","2PP","FantPt","PPR","DKPt",
"FDPt","VBD","PosRank","OvRank")
FantFootDF[NumColumns] <- lapply(FantFootDF[NumColumns], as.numeric)
FantFootDF[is.na(FantFootDF)] = 0
FinalDF <- FantFootDF
######################################################################
#------------------------User Interface------------------------------#
######################################################################
# Define UI for application that draws a histogram
ui <- fluidPage(
# Application title
titlePanel("Fantasy Football GUI"),
#Sidebar
sidebarLayout(
sidebarPanel(
pickerInput("position",
"Position(s)",
choices = unique(FinalDF$FantPos),
options = list(`actions-box` = TRUE),
multiple = T),
pickerInput("playername",
"Player Name",
choices = unique(FinalDF$Player),
options = list(`actions-box` = TRUE),
multiple = T),
pickerInput("team",
"Team",
choices = unique(FinalDF$Team),
options = list(`actions-box` = TRUE),
multiple = T),
sliderInput("age",
"Age",
min = min(FinalDF$Age),
max = max(FinalDF$Age),
value = c(min(FinalDF$Age), max(FinalDF$Age))),
sliderInput("completions",
"Completions",
min = min(FinalDF$Cmp),
max = max(FinalDF$Cmp),
value = c(min(FinalDF$Cmp), max(FinalDF$Cmp))),
sliderInput("Pattempts",
"Passing Attempts",
min = min(FinalDF$PAtt),
max = max(FinalDF$PAtt),
value = c(min(FinalDF$PAtt), max(FinalDF$PAtt))),
sliderInput("Pyards",
"Passing Yards",
min = min(FinalDF$PYds),
max = max(FinalDF$PYds),
value = c(min(FinalDF$PYds), max(FinalDF$PYds))),
sliderInput("Ptds",
"Passing TD's",
min = min(FinalDF$PTD),
max = max(FinalDF$PTD),
value = c(min(FinalDF$PTD), max(FinalDF$PTD))),
sliderInput("RuAttempts",
"Rushing Attempts",
min = min(FinalDF$RuAtt),
max = max(FinalDF$RuAtt),
value = c(min(FinalDF$RuAtt), max(FinalDF$RuAtt))),
sliderInput("RuYards",
"Rushing Yards",
min = min(FinalDF$RuYds),
max = max(FinalDF$RuYds),
value = c(min(FinalDF$RuYds), max(FinalDF$RuYds))),
sliderInput("RuYperA",
"Yards per Rushing Attempt",
min = min(FinalDF$RuYA),
max = max(FinalDF$RuYA),
value = c(min(FinalDF$RuYA), max(FinalDF$RuYA))),
sliderInput("RuTDs",
"Rushing TD's",
min = min(FinalDF$RuTD),
max = max(FinalDF$RuTD),
value = c(min(FinalDF$RuTD), max(FinalDF$RuTD))),
sliderInput("rec",
"Receptions",
min = min(FinalDF$Rec),
max = max(FinalDF$Rec),
value = c(min(FinalDF$Rec), max(FinalDF$Rec))),
sliderInput("ReYards",
"Receiving Yards",
min = min(FinalDF$ReYds),
max = max(FinalDF$ReYds),
value = c(min(FinalDF$ReYds), max(FinalDF$ReYds))),
sliderInput("ReYperA",
"Yards per Reception",
min = min(FinalDF$ReYA),
max = max(FinalDF$ReYA),
value = c(min(FinalDF$ReYA), max(FinalDF$ReYA))),
sliderInput("ReTDs",
"Receiving TD's",
min = min(FinalDF$ReTD),
max = max(FinalDF$ReTD),
value = c(min(FinalDF$ReTD), max(FinalDF$ReTD))),
sliderInput("fumb",
"Fumbles",
min = min(FinalDF$Fmb),
max = max(FinalDF$Fmb),
value = c(min(FinalDF$Fmb), max(FinalDF$Fmb))),
sliderInput("ppr",
"1 PPR Total Points",
min = min(FinalDF$PPR),
max = max(FinalDF$PPR),
value = c(min(FinalDF$PPR), max(FinalDF$PPR)))
),
#Main Panel
mainPanel(
selectInput("plottype",
"Which Plot",
choices = c("PPR by Player",
"PPR by Team",
"PPR by Age")),
plotOutput("plot1"),
tableOutput("table"),
verbatimTextOutput("minmax")
)
)
)
######################################################################
#--------------------------------Server------------------------------#
######################################################################
server <- function(input, output) {
#Reactive to subset data and reduce size in graps
df <- reactive({
a = subset(FinalDF,
FantPos = input$position,
Player = input$playername,
Team = input$team,
Age >= input$age[1] & Age <= input$age[2],
Cmp >= input$completions[1] & Cmp <= input$completions[2],
PAtt >= input$Pattempts[1] & PAtt <= input$Pattempts[2],
PYds >= input$Pyards[1] & PYds <= input$Pyards[2],
PTD >= input$Ptds[1] & PTD <= input$Ptds[2],
RuYA >= input$RuYperA[1] & RuYA <= input$RuYperA[2],
RuAtt >= input$RuAttempts[1] & RuAtt <= input$RuAttempts[2],
RuYds >= input$RuYards[1] & RuYds <= input$RuYards[2],
RuTD >= input$RuTDs[1] & RuTD <= input$RuTDs[2],
Rec >= input$rec[1] & Rec <= input$rec[2],
ReYds >= input$ReYards[1] & ReYds <= input$ReYards[2],
ReYA >= input$ReYperA[1] & ReYA <= input$ReYperA[2],
ReTD >= input$ReTDs[1] & ReTD <= input$ReTDs[2],
Fmb >= input$fumb[1] & Fmb <= input$fumb[2],
PPR >= input$ppr[1] & PPR <= input$ppr[2]
)
return(a)
})
#Plot
output$plot1 <- renderPlot({
# generate bins based on input$bins from ui.R
if(input$plottype == "PPR by Player"){
ggplot(data = df()) +
geom_point(data = df(),
aes(x = Player,
y = PPR,
color = FantPos)) +
ggtitle("PPR Points") +
xlab("Player") +
ylab("PPR Points")
}
else if(input$plottype == "PPR by Team"){
ggplot(data = df()) +
geom_point(data = df(),
aes(x = Team,
y = PPR,
color = FantPos)) +
ggtitle("PPR Points") +
xlab("Player") +
ylab("PPR Points")
}
else if(input$plottype == "PPR by Age"){
ggplot(data = df()) +
geom_point(data = df(),
aes(x = Age,
y = PPR,
color = FantPos)) +
ggtitle("PPR Points") +
xlab("Player") +
ylab("PPR Points")
}
})
#Checking inputs
output$minmax <- renderText(
paste("age", input$age[1], input$age[2], "\ncompletions =",
input$completions[1],input$completions[2],"\nPattempts =",
input$Pattempts[1],input$Pattempts[2],"\nPyards =",
input$Pyards[1],input$Pyards[2],"\nPtds =",
input$Ptds[1],input$Ptds[2],"\nRuYperA =",
input$RuYperA[1],input$RuYperA[2],"\nRuAttempts =",
input$RuAttempts[1],input$RuAttempts[2],"\nRuYards =",
input$RuYards[1],input$RuYards[2],"\nRuTDs =",
input$RuTDs[1],input$RuTDs[2],"\nrec =",
input$rec[1],input$rec[2],"\nReYards =",
input$ReYards[1],input$ReYards[2],"\nReYperA =",
input$ReYperA[1],input$ReYperA[2],"\nReTDs =",
input$ReTDs[1],input$ReTDs[2],"\nfumb =",
input$fumb[1],input$fumb[2],"\nppr =",
input$ppr[1], input$ppr[2])
)
}
# Run the application
shinyApp(ui = ui, server = server)
My apologies. I will be sure to include a reproducible example next time. I replicated the code by making a smaller DataFrame. The replicated code and it worked, so I had another look at my original data. There was a column that was NA at the end. When renaming the columns I forgot the index at the end. I also changed from subset to filter. Not sure why the last column with no name messed everything up, but the shiny ran how I wanted after those changes.

Include multiple different graphics in shiny app

I am attempting to build my first shiny app. I need to include multiple graphics (about 50) and I am having problems selecting them based on their label from the dropdown control. I am able to show the first one but I don't know how to display the other ones on the main panel. I currently have 3 on the dropdown control but only the first one works. How do I make lambda2, lambda3 and so on show on the main panel? I also would like to dynamically plot the number of years selected on the slider. Here is the code:
library(shiny)
library(tidyverse)
library(shinythemes)
library(plotly)
library(scales)
library(shinyWidgets)
library(shinydashboard)
# Define input choices
type <- c("lambda","lambda2","lambda3")
table <- structure(list(year = 1991:2010,
lambda = c(0.68854, 0.75545,
1.63359, 1.22282, 1.70744, 1.09692, 0.51159, 1.3904, 1.09132,
0.59846, 0.43055, 0.80135, 0.69027, 0.65646, 0.95485, 1.04818,
0.67859, 1.00461, 1.16665, 1.28203)), row.names = c(NA, -20L), class = "data.frame")
# Define UI
ui <- fluidPage(
navbarPage("Fish",
windowTitle = "Fish Graphs",
sidebarPanel(
h3("Select Graphics to Visualize"),
selectInput(inputId = "graphtype",
label = "Graphic",
choices = type,
selected = "lambda"),
sliderInput(inputId = "Yearslider",
label="Years to plot",
sep="",
min=1991,
max=2011,
value=c(1991,2011))),
mainPanel(plotOutput("plot"))))
####################################
server<- function (input, output, session) {
session$onSessionEnded(function() {
stopApp()
})
output$plot <- renderPlot({
xlabels <- 1991:2011
ggplot(table,aes(year,lamda)) + geom_line(size=1.5,colour="blue") + geom_point(colour="orange",size=4) +
scale_x_continuous("",breaks = xlabels) +
theme(axis.text.x = element_text(angle = 45, vjust = 0.5)) +
labs(x="",y=expression("Lambda ("~lambda *")"),title="Population growth rate - fraction per year- \nof Delta Smelt")
if (input$lambda2 == TRUE) {
xlabels <- 1991:2011
ggplot(table,aes(year,lamda)) + geom_line(size=1.5,colour="green") + geom_point(colour="orange",size=4) +
scale_x_continuous("",breaks = xlabels) +
theme(axis.text.x = element_text(angle = 45, vjust = 0.5)) +
labs(x="",y=expression("Lambda ("~lambda *")"),title="Population growth rate - fraction per year- \nof Delta Smelt")
}
if (input$lambda3 == TRUE) {
xlabels <- 1991:2011
ggplot(table,aes(year,lamda)) + geom_line(size=1.5,colour="red") + geom_point(colour="orange",size=4) +
scale_x_continuous("",breaks = xlabels) +
theme(axis.text.x = element_text(angle = 45, vjust = 0.5)) +
labs(x="",y=expression("Lambda ("~lambda *")"),title="Population growth rate - fraction per year- \nof Delta Smelt")
}
})
}
shinyApp(ui = ui, server = server)
The main issue with your code is that the element of the input list containing the lambda choice is called graphtype. Using input$lambda2 returns NULL. Do e.g. input$graphtype == "lambda2" instead. Also, if you want to switch between different choices you have to use an if-else with a branch for "each" choice or perhaps use switch as I do below. To make your plot react to the year slider I use an reactive which filters the data for years in the selected range. Also, instead of duplicating the ggplot code I would suggest to move it in a separate function outside of the server which also makes it easier to debug the code.
plot_fun <- function(.data, point.color = "black") {
breaks <- unique(.data$year)
ggplot(.data, aes(year, lambda)) +
geom_line(size = 1.5, colour = "blue") +
geom_point(colour = point.color, size = 4) +
scale_x_continuous("", breaks = breaks) +
theme(axis.text.x = element_text(angle = 45, vjust = 0.5)) +
labs(x = "", y = expression("Lambda (" ~ lambda * ")"), title = "Population growth rate - fraction per year- \nof Delta Smelt")
}
server <- function(input, output, session) {
session$onSessionEnded(function() {
stopApp()
})
plot_data <- reactive({
table[table$year >= input$Yearslider[1] & table$year <= input$Yearslider[2], ]
})
output$plot <- renderPlot({
switch(input$graphtype,
"lambda" = plot_fun(plot_data(), point.color = "orange"),
"lambda2" = plot_fun(plot_data(), point.color = "purple"),
"lambda3" = plot_fun(plot_data(), point.color = "green")
)
})
}
shinyApp(ui = ui, server = server)

Shiny app: Download data source outside of renderPlot for quicker user manipulation

This is my first shiny app. I would like for the user to be able to update the number of facet columns and the dimensions of downloaded plot. readNWISuv, the function to download data can take a long time if multiple years are queried. Currently, the app downloads the data each time the user wants to change the plot format or plot dimensions. Not sure if I need to use reactiveValues, but I would assume that I want the data to be downloaded and manipulated outside of renderPlot. Thanks!
library(shiny)
library(dataRetrieval)
library(lubridate)
library(tidyverse)
library(plotly)
#flow wrecker
ui <- pageWithSidebar( #fluidPage(
# Application title
titlePanel("Flow Record"),
# Sidebar with a date input
#sidebarLayout
sidebarPanel(
dateRangeInput("daterange", "Date range: (yyyy-mm-dd)",
start = Sys.Date()-10,
min = "1980-10-01"),
textInput("gage", "USGS Gage #", "11532500"),
#actionButton("dload","Download data"),
selectInput("facet_x", "Facet Column #:", 2, choices =1:4),
submitButton("Update View", icon("refresh")),
helpText("When you click the button above, you should see",
"the output below update to reflect the values you",
"entered above:"),
#verbatimTextOutput("value"),
downloadButton('downloadImage', 'Download figure'),
numericInput("fig_x", "Fig. Dim. x:", 10, min = 3, max = 16),
numericInput("fig_y", "Fig. Dim. y:", 10, min = 3, max = 16),
width = 3
),
# Show a plot of the generated WY
mainPanel(
plotlyOutput("WYfacet")
)
)
# Define server draw WY facets
server <- function(input, output) {
parameterCd <- "00060" # discharge
#water year
wtr_yr <- function(dates, start_month=10) {
# Convert dates into POSIXlt
dates.posix = as.POSIXlt(dates)
# Year offset
offset = ifelse(dates.posix$mon >= start_month - 1, 1, 0)
# Water year
adj.year = dates.posix$year + 1900 + offset
# Return the water year
adj.year
}
output$WYfacet <- renderPlotly({
#progress bar
withProgress(readNWISuv(input$gage, parameterCd, input$daterange[1], input$daterange[2],tz="America/Los_Angeles") %>% addWaterYear,
message = 'Download in progress',
detail = 'This may take a while...', value = 1)
#download
temperatureAndFlow <- readNWISuv(input$gage, parameterCd, input$daterange[1], input$daterange[2],tz="America/Los_Angeles") %>% addWaterYear
names(temperatureAndFlow)<-c("agc","site","date","WY", "flow","a","tzone")
temperatureAndFlow$commonDate <- as.Date(format(temperatureAndFlow$date, format="2000-%m-%d"))
tf.df<-temperatureAndFlow %>%
filter(WY<=max(WY) & WY>=if_else(month(min(date))<10,min(WY)+1,min(WY)))
tf.df$date.d<-format(tf.df$date, format="%Y-%m-%d")
#mutate commonDate
df4 <- tf.df %>%
mutate(WY=factor(wtr_yr(date.d))) %>%
#seq along dates starting with the beginning of your water year
mutate(commonDate=as.Date(paste0(ifelse(month(date.d) < 10, "2001", "2000"),
"-", month(date.d), "-", day(date.d))), Date=date.d)
#plot
ploty<-ggplot(data = df4,mapping = aes(x = commonDate, y = flow,label=Date, colour = factor(WY))) +
geom_line() +
labs(x = " ", y = "Discharge (cfs)") +
facet_wrap(facets = ~WY,ncol=as.integer(input$facet_x)) +
scale_y_log_eng()+
annotation_logticks(sides = "l")+
theme_bw()+
theme(panel.grid.minor.x = element_blank())+
scale_x_date(labels = function(x) format(x, "%b"),date_breaks = "1 months")+
guides(colour=FALSE)
ggplotly(ploty, tooltip=c("flow","Date"))
})
#fig dimensions
output$fig_x <- renderText({ input$fig_x })
output$fig_y <- renderText({ input$fig_y })
#facet columns
output$facet_x <- renderText({ input$facet_x })
#download to computer
output$downloadImage <- downloadHandler(
filename = function(){paste("plot",'.png',sep='')},
content = function(file){
ggsave(file,width = input$fig_x,height = input$fig_y, dpi = 600, units = "in", device='png')
print(ggplot(data = df4,mapping = aes(x = commonDate, y = flow, colour = factor(WY))) +
geom_line() +
#geom_point()+
#geom_vline(data = trip,aes(xintercept=commonDate),trip_df,color="black")+
labs(x = " ", y = "Discharge (cfs)") +
facet_wrap(facets = ~WY,ncol=as.integer(input$facet_x)) +
scale_y_log_eng()+
annotation_logticks(sides = "l")+
theme_bw()+
theme(panel.grid.minor.x = element_blank())+
scale_x_date(labels = function(x) format(x, "%b"),date_breaks = "1 months")+
guides(colour=FALSE))
})
}
# Run the application
shinyApp(ui = ui, server = server)
There are a few changes to make to your sever section to make this work. Primarily:
splitting the creation of the dataframe into a new eventReactive function, dependent on an actionButton.
referring to the function inside the renderPlotly call
Try this:
## Within ui function call ############################################
# submitButton("Update View", icon("refresh")), # line to replace
actionButton(inputId = "update", "Update View", icon("refresh")),
## (if you want to keep a button to control when data is downloaded ##
server <- function(input, output) {
parameterCd <- "00060" # discharge
#water year
wtr_yr <- function(dates, start_month=10) {
# Convert dates into POSIXlt
dates.posix = as.POSIXlt(dates)
# Year offset
offset = ifelse(dates.posix$mon >= start_month - 1, 1, 0)
# Water year
adj.year = dates.posix$year + 1900 + offset
# Return the water year
adj.year
}
# New part here - use `reactive` to make df4 a new thing, which is processed separately. The `eventReactive` function waits till it sees the button pressed.
df4 <- eventReactive(input$update, ignoreNULL = FALSE, {
#progress bar
withProgress(readNWISuv(input$gage, parameterCd, input$daterange[1], input$daterange[2],tz="America/Los_Angeles") %>% addWaterYear,
message = 'Download in progress',
detail = 'This may take a while...', value = 1)
#download
temperatureAndFlow <- readNWISuv(input$gage, parameterCd, input$daterange[1], input$daterange[2],tz="America/Los_Angeles") %>% addWaterYear
names(temperatureAndFlow)<-c("agc","site","date","WY", "flow","a","tzone")
temperatureAndFlow$commonDate <- as.Date(format(temperatureAndFlow$date, format="2000-%m-%d"))
tf.df<-temperatureAndFlow %>%
filter(WY<=max(WY) & WY>=if_else(month(min(date))<10,min(WY)+1,min(WY)))
tf.df$date.d<-format(tf.df$date, format="%Y-%m-%d")
#mutate commonDate
tf.df %>%
mutate(WY=factor(wtr_yr(date.d))) %>%
#seq along dates starting with the beginning of your water year
mutate(commonDate=as.Date(paste0(ifelse(month(date.d) < 10, "2001", "2000"),
"-", month(date.d), "-", day(date.d))), Date=date.d)
})
output$WYfacet <- renderPlotly({
# req will pause plot loading till new data downloaded above, but changes to display will render without new download
req(df4())
#plot
ploty<-ggplot(data = df4(), # Put brackets here to refer to df4 as a reactive input!!!
mapping = aes(x = commonDate, y = flow, label=Date, colour = factor(WY))) +
geom_line() +
labs(x = " ", y = "Discharge (cfs)") +
facet_wrap(facets = ~WY,ncol=as.integer(input$facet_x)) +
scale_y_log10()+
# annotation_logticks(sides = "l")+
theme_bw()+
theme(panel.grid.minor.x = element_blank())+
scale_x_date(labels = function(x) format(x, "%b"),date_breaks = "1 months")+
guides(colour=FALSE)
ggplotly(ploty, tooltip=c("flow","Date"))
})
#fig dimensions
output$fig_x <- renderText({ input$fig_x })
output$fig_y <- renderText({ input$fig_y })
#facet columns
output$facet_x <- renderText({ input$facet_x })
#download to computer
output$downloadImage <- downloadHandler(
filename = function(){paste("plot",'.png',sep='')},
content = function(file){
ggsave(file,width = input$fig_x,height = input$fig_y, dpi = 600, units = "in", device='png')
print(ggplot(data = df4() ,mapping = aes(x = commonDate, y = flow, colour = factor(WY))) +
geom_line() +
#geom_point()+
#geom_vline(data = trip,aes(xintercept=commonDate),trip_df,color="black")+
labs(x = " ", y = "Discharge (cfs)") +
facet_wrap(facets = ~WY,ncol=as.integer(input$facet_x)) +
scale_y_log10()+
annotation_logticks(sides = "l")+
theme_bw()+
theme(panel.grid.minor.x = element_blank())+
scale_x_date(labels = function(x) format(x, "%b"),date_breaks = "1 months")+
guides(colour=FALSE))
})
}

Shiny combining inputs

I have a data set with three laps (15s/lap) each of which shows the different speed for every second:
AA <- as.data.frame(cbind(c(10,12,11,12,12,11,12,13,11,9,9,12,11,10,12,9,8,7,9,8,7,9,9,8,9,7,9,10,10,10,7,6,7,8,8,7,6,6,7,8,7,6,7,8,8),
c(rep("Lap_1",15),rep("Lap_2",15),rep("Lap_3",15))))
I want to compare the three laps together, but for the first one I'd like to use a sliderInput to select only some of the 15 secondes. I'm having some difficulties to add that to my code. Here is what I have for the moment:
install.packages("shiny")
install.packages("ggplot2")
library(shiny)
library(ggplot2)
colnames(AA) <- c("Speed","Lap")
AA$Speed <- as.numeric(as.character(AA$Speed))
ui=shinyUI(
fluidPage(
titlePanel("Title here"),
sidebarLayout(
sidebarPanel(
checkboxGroupInput("lap_choose",
label = "Choose the laps",
choices = c("Lap_1","Lap_2","Lap_3")),
sliderInput("secs_1",
"Seconds in L1:",
min = 0,
max = 15,
value = c(3,10),
step=1)),
mainPanel(
plotOutput("Comparison"))
)
)
)
server=function(input,output){
#data manipulation
data_1=reactive({
return(AA[AA$Lap%in%input$lap_choose,])
})
output$Comparison <- renderPlot({
ggplot(data=data_1(), aes(Speed, fill = Lap)) +
stat_density(aes(y = ..density..),
position = "identity",
color = "black",
alpha = 0.8) +
xlab("Distribution") +
ylab("Density") +
ggtitle("Comparison") +
theme(plot.title = element_text(hjust = 0.5,size=24, face="bold"))
})
}
shinyApp(ui,server)
I should use the secs_1 at some point to update data_1, but didn't find out how yet. Any ideas?
If i am understanding correctly, you want to filter out some values(based on sec_1 sliderInput) if "lap" variable is "lap_1".
Try using ifelse statement in data_1 function.
data_1=reactive({
xc <- AA[AA$Lap%in%input$lap_choose,]
gh <- ifelse(xc$Lap == "Lap_1" & xc$Speed %in% c(input$secs_1[1],input$secs_1[2]),
FALSE, TRUE)
return(xc[gh,])
})

Updating y-axis Reactively with geom_histogram from ggplot and Shiny R

So I am trying to tackle the following but I may have started down the wrong road.
As these sample sizes increase, I need to update the y-limits so the highest bar in geom_histogram() doesn't go off the top. The especially happens if the st. dev. is set near 0.
This is literally my second day working with Shiny and reactive applications so I feel I've gotten myself into a pickle.
I think I need to save the ggplot() objects and then update their ylimit reactively with the value of the largest bar from the last histogram. Just not sure if I can do that the way this thing is set up now.
(I am realizing I had a similar problem over 2 years ago)
ggplot2 Force y-axis to start at origin and float y-axis upper limit
This is different because it is the height of a histogram that needs to tell the y-axis to increase, not the largest data value. Also, because Shiny.
My server.R function looks like
library(shiny)
library(ggplot2)
library(extrafont)
# Define server logic for random distribution application
function(input, output, session) {
data <- reactive({
set.seed(123)
switch(input$dist,
norm = rnorm(input$n,
sd = input$stDev),
unif = runif(input$n,-4,4),
lnorm = rlnorm(input$n)
)
})
height="100%"
plotType <- function(blah, maxVal, stDev, n, type) {
roundUp <- function(x) 10^ceiling(log10(x)+0.001)
maxX<- roundUp(maxVal)
breakVal<-max(floor(maxX/10),1)
switch(type,
norm = ggplot(as.data.frame(blah), aes(x=blah))+
geom_histogram(binwidth = 0.2,
boundary = 0,
colour = "black") +
scale_y_continuous(limits = c(0, maxX),
breaks = seq(0, maxX, breakVal),
expand = c(0, 0)) +
scale_x_continuous(breaks = seq(-4, 4, 1),
expand = c(0, 0)) +
theme_set(theme_bw(base_size = 40) +
ylab("Frequency")+
xlab("")+
coord_cartesian(xlim=c(-4, 4))+
ggtitle(paste("n = ",n, "St Dev =", stDev," Normal Distribution ", sep = ' ')),
unif = ggplot(as.data.frame(blah), aes(x=blah))+
geom_histogram(binwidth=0.1, boundary =0,colour = "black")+
scale_y_continuous(limits = c(0,roundUp(maxVal*(3/stDev))),
breaks=seq(0,roundUp(maxVal*(3/stDev)), roundUp(maxVal*(3/stDev))/10),
expand = c(0, 0))+
scale_x_continuous(breaks=seq(-4,4,1),expand = c(0, 0))+
theme_set(theme_bw(base_size = 40))+
ylab("Frequency")+xlab("")+
coord_cartesian(xlim=c(-4,4))+
ggtitle(paste("n = ",n, " Uniform Distribution ", sep = ' ')),
lnorm = ggplot(as.data.frame(blah), aes(x=blah))+
geom_histogram(binwidth=0.2, boundary =0,colour = "black")+
scale_y_continuous(limits = c(0,maxX),
breaks=seq(0,maxX, breakVal),
expand = c(0, 0))+
scale_x_continuous(breaks=seq(0,8,1),expand = c(0, 0))+
theme_set(theme_bw(base_size = 40))+
ylab("Frequency")+xlab("")+
coord_cartesian(xlim=c(0,8))+
ggtitle(paste("n = ",n, " Log-Normal Distribution ", sep = ' '))
)
}
observe({
updateSliderInput(session, "n",
step = input$stepSize,
max=input$maxN)
})
plot.dat <- reactiveValues(main=NULL, layer1=NULL)
#plotType(data, maxVal, stDev, n, type)
output$plot <- renderPlot({
plotType(data(),
switch(input$dist,
norm = max((input$n)/7,1),
unif = max((input$n)/50,1),
lnorm =max((input$n)/8,1)
),
input$stDev,
input$n,
input$dist) })
# Generate a summary of the data
output$summary <- renderTable(
as.array(round(summary(data())[c(1,4,6)],5)),
colnames=FALSE
)
output$stDev <- renderTable(
as.array(sd(data())),
colnames=FALSE
)
# Generate an HTML table view of the data
output$table <- renderTable({
data.frame(x=data())
})
}
And my ui.R looks like
library(shiny)
library(shinythemes)
library(DT)
# Define UI for random distribution application
shinyUI(fluidPage(theme = shinytheme("slate"),
# Application title
headerPanel("Michael's Shiny App"),
# Sidebar with controls to select the random distribution type
# and number of observations to generate. Note the use of the
# br() element to introduce extra vertical spacing
sidebarLayout(
sidebarPanel(
tags$head(tags$style("#plot{height:90vh !important;}")),
radioButtons("dist", "Distribution:",
c("Standard Normal" = "norm",
"Uniform" = "unif",
"Log-normal" = "lnorm")),
br(),
numericInput("stepSize", "Step", 1, min = 1, max = NA, step = NA,
width = NULL),
numericInput("maxN", "Max Sample Size", 50, min = NA, max = NA, step = NA,
width = NULL),
br(),
sliderInput("n",
"Number of observations:",
value = 0,
min = 1,
max = 120000,
step = 5000,
animate=animationOptions(interval=1200, loop=T)),
sliderInput("stDev",
"Standard Deviation:",
value = 1,
min = 0,
max = 3,
step = 0.1,
animate=animationOptions(interval=1200, loop=T)),
p("Summary Statistics"),
tabPanel("Summary", tableOutput("summary")),
p("Sample St. Dev."),
tabPanel("Standard Dev", tableOutput("stDev")),
width =2
),
# Show a tabset that includes a plot, summary, and table view
# of the generated distribution
mainPanel(
tabsetPanel(type = "tabs",
tabPanel("Plot", plotOutput("plot")),
tabPanel("Table", tableOutput("table"))
))
)))
The whole thing has a lot of redundancy. What I want to do, is once the biggest bar on the histogram gets close to the upper y-limit, I want the ylimit to jump to the next power of 10.
Any suggestions are greatly appreciated.
Update Loosely, the solution that I ended up using is as follows: In the renderPlot() function, you need to save the ggplot object. Then as mentioned below, access the ymax value (still within renderPlot()),
ggplot_build(norm)$layout$panel_ranges[[1]]$y.range[[2]]
and then use that to update the y-axis. I used the following function to make the axis limit "nice".
roundUpNice <- function(x, nice=c(1,2,4,5,6,8,10)) {
10^floor(log10(x)) * nice[[which(x <= 10^floor(log10(x)) * nice)[[1]]]]
}
Then updating the y-axis. (still within renderplot())
ymaxX = roundUpNice(ggplot_build(norm)$layout$panel_ranges[[1]]$y.range[[2]])
norm+scale_y_continuous(limits = c(0, max(ymaxX, 20)),
expand=c(0,0))
First, store the histogram (default axes).
p1 <- ggplot(...) + geom_histogram()
Then, Use ggplot_build(p1) to access the heights of the histogram bars. For example,
set.seed(1)
df <- data.frame(x=rnorm(10000))
library(ggplot2)
p1 <- ggplot(df, aes(x=x)) + geom_histogram()
bar_max <- max(ggplot_build(p1)[['data']][[1]]$ymax) # where 1 is index 1st layer
bar_max # returns 1042
You will need a function to tell you what the next power of 10 is, for example:
nextPowerOfTen <- function(x) as.integer(floor(log10(x) + 1))
# example: nextPowerOfTen(999) # returns 3 (10^3=1000)
You will want to check whether the bar_max is within some margin (based on your preference) of the next power of 10. If an adjustment is triggered, you can simply do p1 + scale_y_continuous(limits=c(0,y_max_new)).
I found the answer hidden in the "scale_y_continuous()" portion of your code. The app was very close, but in some cases, the data maxed out the y-axis, which made it appear like it was running further than the axis limits as you said.
To fix this problem, the expand argument within the scale_y_continuous section needs to be set to "c(0.05, 0)", instead of "c(0, 0)".
First, I've replicated an example of the graph run-off you were describing by setting the sample size to 50 and standard deviation to 0.3 within your app. After running the original code with "expand=c(0, 0)", we can see we get the following graph:
This problem is fixed by changing the argument to "expand=c(0.05, 0)", as shown here:
For copies of the fixed scripts, see below.
Part 1 -- server.R
library(shiny)
library(ggplot2)
library(extrafont)
# Define server logic for random distribution application
function(input, output, session) {
data <- reactive({
set.seed(123)
switch(input$dist,
norm = rnorm(input$n,
sd = input$stDev),
unif = runif(input$n,-4,4),
lnorm = rlnorm(input$n)
)
})
height="100%"
plotType <- function(blah, maxVal, stDev, n, type){
roundUp <- function(x){10^ceiling(log10(x)+0.001)}
maxX<- roundUp(maxVal)
breakVal<-max(floor(maxX/10),1)
switch(type,
norm=ggplot(as.data.frame(blah), aes(x=blah)) +
geom_histogram(binwidth = 0.2,
boundary = 0,
colour = "black") +
scale_y_continuous(limits = c(0, maxX),
breaks = seq(0, maxX, breakVal),
expand = c(0.05, 0)) +
scale_x_continuous(breaks = seq(-4, 4, 1),
expand = c(0, 0)) +
theme_set(theme_bw(base_size = 40)) +
ylab("Frequency") +
xlab("") +
coord_cartesian(xlim=c(-4, 4))+
ggtitle(paste("n = ",n, "St Dev =", stDev,
" Normal Distribution ", sep = ' ')),
unif=ggplot(as.data.frame(blah), aes(x=blah)) +
geom_histogram(binwidth=0.1, boundary=0, colour="black")+
scale_y_continuous(
limits = c(0,roundUp(maxVal*(3/stDev))),
breaks=seq(0,roundUp(maxVal*(3/stDev)),
roundUp(maxVal*(3/stDev))/10),
expand = c(0.05, 0))+
scale_x_continuous(breaks=seq(-4,4,1),expand=c(0, 0)) +
theme_set(theme_bw(base_size = 40))+
ylab("Frequency")+xlab("")+
coord_cartesian(xlim=c(-4,4))+
ggtitle(paste("n = ",n,
" Uniform Distribution ", sep = ' ')),
lnorm=ggplot(as.data.frame(blah), aes(x=blah))+
geom_histogram(binwidth=0.2,boundary=0, colour="black") +
scale_y_continuous(limits=c(o,maxX),
breaks=seq(0,maxX, breakVal),
expand = c(0.05, 0)) +
scale_x_continuous(breaks=seq(0,8,1),
expand = c(0, 0)) +
theme_set(theme_bw(base_size = 40)) +
ylab("Frequency") +
xlab("") +
coord_cartesian(xlim=c(0,8)) +
ggtitle(paste("n = ",n,
" Log-Normal Distribution ",
sep = ' '))
)
}
observe({
updateSliderInput(session, "n",
step = input$stepSize,
max=input$maxN)
})
plot.dat <- reactiveValues(main=NULL, layer1=NULL)
#plotType(data, maxVal, stDev, n, type)
output$plot <- renderPlot({
plotType(data(),
switch(input$dist,
norm = max((input$n)/7,1),
unif = max((input$n)/50,1),
lnorm =max((input$n)/8,1)
),
input$stDev,
input$n,
input$dist) })
# Generate a summary of the data
output$summary <- renderTable(
as.array(round(summary(data())[c(1,4,6)],5)),
colnames=FALSE
)
output$stDev <- renderTable(
as.array(sd(data())),
colnames=FALSE
)
# Generate an HTML table view of the data
output$table <- renderTable({
data.frame(x=data())
})
}
Part 2 -- ui.R
library(shiny)
library(shinythemes)
library(DT)
# Define UI for random distribution application
shinyUI(fluidPage(theme = shinytheme("slate"),
# Application title
headerPanel("Michael's Shiny App"),
# Sidebar with controls to select the random distribution type
# and number of observations to generate. Note the use of the
# br() element to introduce extra vertical spacing
sidebarLayout(
sidebarPanel(
tags$head(tags$style("#plot{height:90vh !important;}")),
radioButtons("dist", "Distribution:",
c("Standard Normal" = "norm",
"Uniform" = "unif",
"Log-normal" = "lnorm")),
br(),
numericInput("stepSize", "Step", 1,
min = 1, max = NA, step = NA, width = NULL),
numericInput("maxN", "Max Sample Size", 50,
min = NA, max = NA, step = NA,width = NULL),
br(),
sliderInput("n", "Number of observations:", value = 0,
min = 1, max = 120000, step = 5000,
animate=animationOptions(interval=1200, loop=T)),
sliderInput("stDev","Standard Deviation:",value = 1,
min = 0,max = 3,step = 0.1,
animate=animationOptions(interval=1200, loop=T)),
p("Summary Statistics"),
tabPanel("Summary", tableOutput("summary")),
p("Sample St. Dev."),
tabPanel("Standard Dev", tableOutput("stDev")),
width =2),
# Show a tabset that includes a plot, summary, and table view
# of the generated distribution
mainPanel(tabsetPanel(type = "tabs",
tabPanel("Plot", plotOutput("plot")),
tabPanel("Table", tableOutput("table"))
))
)))
Update Loosely, the solution that I ended up using is as follows: In the renderPlot() function, you need to save the ggplot object. Then as mentioned below, access the ymax value (still within renderPlot()),
ggplot_build(p1)$layout$panel_ranges[[1]]$y.range[[2]]
and then use that to update the y-axis. I used the following function to make the axis limit "nice".
roundUpNice <- function(x, nice=c(1,2,4,5,6,8,10)) {
if(length(x) != 1) stop("'x' must be of length 1")
10^floor(log10(x)) * nice[[which(x <= 10^floor(log10(x)) * nice)[[1]]]]
}

Resources