Quantcast
Channel: Active questions tagged r - Stack Overflow
Viewing all articles
Browse latest Browse all 201839

How to get multiple updatePickerInput logic correct in Shiny

$
0
0

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)



Viewing all articles
Browse latest Browse all 201839

Trending Articles



<script src="https://jsc.adskeeper.com/r/s/rssing.com.1596347.js" async> </script>