1

I have a bar-plot the click action of which produces another plot alongside the bar-plot. As of now the user can only click on one agegroup and have the corresponding race distribution. Is there a way to enable multiple agegroup selections and subset the race data accordingly ?

Took inspiration of this plot from https://plot.ly/r/shiny-coupled-events/

enter image description here

The code is as under

    ui <- fluidPage(
  theme = shinytheme("spacelab"),

  h2("Coupled events in plotly charts using Shiny"),
  h4("This Shiny app showcases coupled events using Plotly's ", tags$code("event_data()"), " function."),

  tags$hr(),

  fixedRow(
    column(6, plotlyOutput("Plot1", height = "600px")),
    column(6, plotlyOutput("Plot2", height = "600px"))))







    server <- function(input, output){

        patdata_age<- subset(patdata, select="agegroup")
    patdata_age<-as.data.frame(table(patdata_age))
    selection<-patdata_age

    output$Plot1 <- renderPlotly({
      colnames(selection)<-c("agegroup","Freq")
      selection$y<-round((patdata_age$Freq*100/sum(patdata_age$Freq)))
      plot_ly(source = "subset",selection, x = ~agegroup, y = selection$y, type = 'bar',
              marker = list(color = 'rgb(255,140,0)',    
                            # marker = list(color,alpha = d),
                            line = list(color = 'rgb(8,48,107)', width = 1.5))) %>%
        layout(title = paste0("Age-group distribution of patients "),xaxis = list(title = 'age group'),dragmode =  "select",
               yaxis = list(title = paste0('Percentage of Patients')),titlefont=list(size=13),
               annotations = list(x = ~agegroup, y = selection$y, text = paste0(selection$y, "%"),
                                  xanchor = 'center', yanchor = 'bottom',
                                  showarrow = FALSE))    })



    output$Plot2 <- renderPlotly({

      eventdata <<- event_data("plotly_click", source = "subset")
      validate(need(!is.null(eventdata), "Click the age plot to populate this race plot"))

      datapoint <<- as.numeric(eventdata$pointNumber)[1]
      sel<<-patdata  %>% filter(dp %in% datapoint)


      raceselection<-subset(sel,select="Race")
      raceselection<-as.data.frame(table(raceselection))
      colnames(raceselection)<-c("Race","Freq")
      raceselection$y<-round((raceselection$Freq*100/sum(raceselection$Freq)))

      raceall<-merge(raceselection,boston_race)


      raceall$Race<- as.character(raceall$Race)
      raceall$Percent<-round(raceall$Percent,0)



      plot_ly(raceall, x = ~Race, y = ~Percent, type = 'bar', name = 'Total Population',marker = list(color = 'rgb(255,140,0)',
                                                                                                      line = list(color = 'rgb(8,48,107)', width = 1))
      ) %>%
        add_trace(y = ~y, name = 'Patient Population',marker = list(color = 'rgb(49,130,189)',
                                                                    line = list(color = 'rgb(8,48,107)', width = 1))) %>%
        layout(yaxis = list(title = 'Population Percent'), barmode = 'group',
               title = paste0("Patient Race comparison"))



    })

Data snippet: patdata

Race    Ethnicity   dp  agegroup
Latino Hispanic Puerto Rican    1   20-29
African American    Not Hispanic or Latino  2   30-39
White   Not Hispanic or Latino  4   50+
White   Russian 4   50+
Asian   American    1   20-29
White   Not Hispanic or Latino  2   30-39
White   Unknown/not specified   1   20-29
White   Not Hispanic or Latino  0   <20
African American    American    0   <20
Asian   Asian   3   40-49
White   Not Hispanic or Latino  1   20-29
Latino Hispanic Unknown/not specified   0   <20
White   Not Hispanic or Latino  0   <20
White   Unknown/not specified   1   20-29
Unknown Unknown/not specified   1   20-29
Latino Hispanic Dominican   2   30-39
White   European    4   50+
White   American    4   50+
White   Unknown/not specified   0   <20

bostonrace:

Race    Percent
White   47
Unknown 0
Other   1.8
Latino Hispanic 17.5
Asian   8.9
African American    22.4
Florian
  • 24,425
  • 4
  • 49
  • 80
Dee V
  • 137
  • 1
  • 11

1 Answers1

1

You could use reactiveVal to store the selected points, and an observeEvent to update that:

library(shiny)
library(plotly)

patdata = data.frame(Race=rep(letters[5:1],4),    Ethnicity=letters[1:20],   dp=sample(1:5,20,replace=T),  agegroup=rep(letters[1:5],4))
boston_race = data.frame(Race = letters[1:5], Percent = sample(20:50,5))

ui <- fluidPage(

  h2("Coupled events in plotly charts using Shiny"),
  h4("This Shiny app showcases coupled events using Plotly's ", tags$code("event_data()"), " function."),

  tags$hr(),

  fixedRow(
    column(6, plotlyOutput("Plot1", height = "600px")),
    column(6, plotlyOutput("Plot2", height = "600px"))),
  fixedRow(
    actionButton('reset','Reset selection'))
)




server <- function(input, output){

  patdata_age<- subset(patdata, select="agegroup")
  patdata_age<-as.data.frame(table(patdata_age))
  selection<-patdata_age

  output$Plot1 <- renderPlotly({
    colnames(selection)<-c("agegroup","Freq")
    selection$y<-round((patdata_age$Freq*100/sum(patdata_age$Freq)))
    plot_ly(source = "subset",selection, x = ~agegroup, y = selection$y, type = 'bar',
            marker = list(color = 'rgb(255,140,0)',    
                          # marker = list(color,alpha = d),
                          line = list(color = 'rgb(8,48,107)', width = 1.5))) %>%
      layout(title = paste0("Age-group distribution of patients "),xaxis = list(title = 'age group'),dragmode =  "select",
             yaxis = list(title = paste0('Percentage of Patients')),titlefont=list(size=13),
             annotations = list(x = ~agegroup, y = selection$y, text = paste0(selection$y, "%"),
                                xanchor = 'center', yanchor = 'bottom',
                                showarrow = FALSE))    })

  selectedPoints <- reactiveVal()
  observeEvent(event_data("plotly_click", source = "subset"),{
    print(event_data("plotly_click", source = "subset"))
    pn <- event_data("plotly_click", source = "subset")$pointNumber
    selectedPoints(c(selectedPoints(),pn))
    print(selectedPoints())
  })
  observeEvent(input$reset,{
               selectedPoints(NULL)})

  output$Plot2 <- renderPlotly({

    validate(need(!is.null(selectedPoints()), "Click the age plot to populate this race plot"))
    datapoints <- selectedPoints()
    sel<-patdata  %>% filter(dp %in% datapoints)
    raceselection<-subset(sel,select="Race")
    raceselection<-as.data.frame(table(raceselection))
    colnames(raceselection)<-c("Race","Freq")
    raceselection$y<-round((raceselection$Freq*100/sum(raceselection$Freq)))
    raceall<-merge(raceselection,boston_race)
    raceall$Race<- as.character(raceall$Race)
    raceall$Percent<-round(raceall$Percent,0)

    plot_ly(raceall, x = ~Race, y = ~Percent, type = 'bar', name = 'Total Population',marker = list(color = 'rgb(255,140,0)',
                                                                                                    line = list(color = 'rgb(8,48,107)', width = 1))
    ) %>%
      add_trace(y = ~y, name = 'Patient Population',marker = list(color = 'rgb(49,130,189)',
                                                                  line = list(color = 'rgb(8,48,107)', width = 1))) %>%
      layout(yaxis = list(title = 'Population Percent'), barmode = 'group',
             title = paste0("Patient Race comparison"))

  })
}
  shinyApp(ui,server)

Some tips for future questions; please add your data with dput, see here, and try and reduce your code to the bare minimum, makes it also easier for you to see what I have changed ;) Anyway, hope this helps!

Florian
  • 24,425
  • 4
  • 49
  • 80