K Y'all, I'd really appreciate some help here. I'm having trouble getting the logic for the multiple shinyWidgets::updatePickerInput
correct.
The example below WORKS...but, you'll notice, you can only select one sport to begin. If you select 2 sports, then navigate to the "team" input, you can "Reset to Major Sport" and you will see your desired teams appear.
The goal is to have an app that allows a user to seamlessly toggle on/off both sports & teams, with a few caveats.
1) If you select a major sport(s), I'd like all teams to show up at first, and then have the option to deselect them one at a time.
2) If you select a single team(s), I'd like to be able to select a sport to compare that single team to (e.g. you've got the sharks selected and want to see how they look vs all football teams)
LONG CODE but thank you for your thoughts!
# load packages CHECK INSTALL 1st
library(tidyverse)
library(shiny)
library(ggrepel)
library(shinyWidgets)
# data wide
seriesDataWide <- data.frame(
date = seq.Date(from = as.Date("2019-01-01"), to = as.Date("2019-12-01"), by = "1 day"),
football_bears = rnorm(335, mean = 3, sd = 0.5),
football_eagles = rnorm(335, mean = 3, sd = 0.5),
football_giants = rnorm(335, mean = 3, sd = 0.5),
baseball_cubs = rnorm(335, mean = 3, sd = 0.5),
baseball_sox = rnorm(335, mean = 3, sd = 0.5),
hockey_bruins = rnorm(335, mean = 3, sd = 0.5),
hockey_flames = rnorm(335, mean = 3, sd = 0.5),
hockey_sharks = rnorm(335, mean = 3, sd = 0.5),
hockey_preds = rnorm(335, mean = 3, sd = 0.5),
stringsAsFactors = FALSE
)
# data long
seriesData <- seriesDataWide %>%
pivot_longer(-date, names_to = "sport_team", values_to = "value") %>%
separate(sport_team, into = c("sport", "team"), sep = "_")
#### SHINY APP
ui <- fluidPage(
# title
titlePanel(strong("My Sport Plot")),
# plot
plotOutput("plot", height = '600px'),
# selectors
fluidRow(
column(1),
column(5,
pickerInput(
inputId = "varsOfIntMajor",
label = "Select Sport",
choices = unique(seriesData$sport),
width = "100%",
options = list(
`actions-box` = TRUE,
size = 5,
dropdownAuto = FALSE
),
choicesOpt = list(
style = rep_len("font-size: 75%; line-height: 0.8;", length(unique(seriesData$sport)))
),
multiple = TRUE
)
),
column(5,
pickerInput(
inputId = "varsOfIntMinor",
label = "Add or Subtract Team",
choices = unique(seriesData$team),
width = "100%",
options = pickerOptions(
actionsBox = TRUE,
deselectAllText = "Reset to Major Sport",
size = 5
),
choicesOpt = list(
style = rep_len("font-size: 75%; line-height: 0.8;", length(unique(seriesData$team)))
),
multiple = TRUE
)
),
column(1)
),
sliderInput("daterange",
"Date Range:",
min = as.Date("2019-01-01","%Y-%m-%d"),
max = as.Date(Sys.Date(), "%Y-%m-%d"),
value = c(as.Date("2016-01-01"), Sys.Date()),
timeFormat = "%Y-%m-%d",
width = '80%')
)
# Define a server for the Shiny app
server <- function(input, output, session) {
# plot
output$plot <- renderPlot({
# filter date range
dat <- seriesData[seriesData$date >= input$daterange[1] & seriesData$date <= input$daterange[2],]
# first check minor vals
if(is.null(input$varsOfIntMinor)) {
if(is.null(input$varsOfIntMajor)) {
seriesData <- dat
} else {
seriesData <- dat %>%
filter(sport %in% input$varsOfIntMajor)
## TURNING THIS OFF ALLOWS MULTIPLE SELECTIONS FOR MAJOR, BUT DISABLES FINER GRAIN MINOR W/I MAJOR
## THIS HAPPENS BECAUSE IF YOU UPDATE MINOR SECTOR IT NO LONGER SEES IT AS NULL AND SO JUMPS TO THE
## BOTTOM OF THE LOOP
updatePickerInput(session = session,
"varsOfIntMajor",
selected = unique(seriesData$sport))
updatePickerInput(session = session,
"varsOfIntMinor",
selected = unique(seriesData$team))
}
} else {
seriesData <- dat %>%
filter(team %in% input$varsOfIntMinor)
updatePickerInput(session = session,
"varsOfIntMinor",
selected = unique(seriesData$team))
}
# generate percentiles
seriesData$pctile <- ave(seriesData$value, seriesData$team, FUN = function(x) ecdf(x)(x))
# create df for last observations
lastObs <- data.frame(
date = unlist(lapply(unique(seriesData$team), function(x) max(seriesData[seriesData$team == x, "date"][[1]]))),
team = unique(seriesData$team),
stringsAsFactors = FALSE
)
lastObs <- merge(lastObs, seriesData)
# plot
ggplot(seriesData, aes(value, color = team)) +
stat_ecdf(lwd = 2, alpha = 0.5) +
geom_point(data = lastObs,
aes(x = value, pctile, color = team),
size = 4) +
geom_label_repel(data = lastObs,
aes(x = value, pctile, color = team, label = team),
force = 1,
nudge_x = 20,
fontface = "bold") +
scale_y_continuous(labels = scales::percent, expand = c(0,0), breaks = seq(0, 1, 0.1)) +
labs(x = "value",
y = "Percent Rank",
color = "",
title = "CDF Sports") +
guides(color = "none") +
theme_minimal()
})
}
shinyApp(ui, server)