链接dataTableOutput和R中闪亮的绘图

Question

我想在闪亮的应用程序中链接dataTableOutput 和绘图，以便在表格中选择行或单元格时，绘图将使用与该行关联的数据进行反应性更新。

这是我的数据：-

数据

#relevant libraries
library(wakefield)#for generating the Status variable
library(dplyr)
library(stringi)
library(Pareto)
library(uuid)
library(ggplot2)
library(shiny)
library(DT)


#mock data creation
set.seed(1)
#data<-data.frame()
Date<-seq(as.Date("2015-01-01"), as.Date("2015-12-31"), by = "1 day")
Date<-sample(rep(Date,each=10),replace = T)

event<-r_sample_factor(x = c("Wrestling", "Drama", 
                                    "Information", "Football", "Rugby", "Movie", "Music", "News"), n=length(Date))

channel<-r_sample_factor(x = c("Channel 1", "Channel 2", "Channel 3", "Channel 4"), n=length(Date))

Hour<-r_sample_factor(x = c(0:23), n=length(Date))

Group<-r_sample_factor(x = c("A","B","C","D","E"), n=length(Date))

#creating user ID

set.seed(1)

n_users <- 100
n_rows <- 3650

relative_probs <- rPareto(n = n_users, t = 1, alpha = 0.3, truncation = 500) 
unique_ids <- UUIDgenerate(n = n_users)

AnonID <- sample(unique_ids, size = n_rows, prob = relative_probs, replace = TRUE)


data<-data.frame(AnonID,Group,Date,Hour,channel,event)
data$Hour<-as.numeric(data$Hour)
head(data)

到目前为止，这是我闪亮的应用程序：-

闪亮的代码

#ui================================
ui<-fluidPage(
  titlePanel("Example panel"),
  tabsetPanel(
    tabPanel("example text",
             sidebarPanel(width = 4,
                          dateRangeInput("daterange","Select dates", format = "yyyy-mm-dd",
                                         start = min("2015-01-01"),
                                         end = max("2015-01-10")),
                          numericInput("hourmin", "Select mininum hour",10,0,23),
                          numericInput("hourmax", "Select maximum hour", 22,0,23),
                          pickerInput("channel", "Select channel",
                                      choices = unique(channel), options = list('actions-box'=T,'live-search'=T),multiple = T)),#end of sidebarPanel
             mainPanel(
               column(width = 10, plotOutput("barplot", width = "100%")),
                      column(width = 8, dataTableOutput("table"))
             )#end of mainPanel
                          
             )
             )#end of tabPanel
  )#end of tabsetPanel
)#end of fluidPage


#server===========================================

server<-function(input,output,session){

  
 rv <- reactiveVal(NULL)  
  
  observe({
    
    rv(data)
  
    output$table<-renderDT({
      rv()%>%
        arrange(desc(Date))%>%
        filter(Date>=input$daterange[1] & Date<=input$daterange[2])%>%
        filter(Hour>=input$hourmin & Hour<=input$hourmax)%>%
        filter(channel %in% input$channel)%>%  
        group_by(channel,Date)%>%
        arrange(Date)%>%
        summarise(Programme=paste0(Hour,":",substr(event,1,3)), .groups = 'drop')%>%
        #mutate(rn=rowid(Date))%>%
        pivot_wider(names_from = Date,values_from = Programme) # %>%
      #select(-rn)
    })
    output$barplot<-renderPlot({
      
      rv()%>%
        filter(Date>=input$daterange[1] & Date<=input$daterange[2])%>%
        filter(Hour>=input$hourmin & Hour<=input$hourmax)%>%
        filter(channel %in% input$channel)%>%
        group_by(Date,Group)%>%
        summarise(UniqueID=n_distinct(AnonID))%>%
        ggplot()+
        geom_bar(aes(x=Date,y=UniqueID, fill=Group), stat = "identity", position = "dodge")
        
      
    })
    
    })#end of observe
  }

shinyApp(ui,server)

这会给你这个：-

我想要做的是能够单击dataTableOutput 中的一行（按日期和时间），然后在与该日期和时间关联的数据中绘制唯一UniqueID 的数量.我的代码中遗漏了什么可以让我这样做？

谢谢！

Answer 1

作为第一步，我们可以使用reactiveValues 来保存来自渲染的datatable 的数据。

rv <- reactiveValues(data = NULL)

其次，我们可以利用从DT 表中选择行的可能性。

    output$table <- DT::renderDataTable({
      DT::datatable(rv$data, selection = list(target = "row"))
    })

现在剩下的就是捕获结果表中包含的小时和日期，并使用该信息创建 de barplot。

请注意，由于之前使用 pivot_table 的方式，此表将包含作为列名的日期和包含在字符串中的小时。

代码：

# relevant libraries
library(wakefield) # for generating the Status variable
library(tidyverse)
library(stringi)
library(Pareto)
library(uuid)
library(shiny)
library(DT)
library(shinyWidgets)

################### // UI //###################

ui <- fluidPage(
  titlePanel("Example panel"),
  tabsetPanel(
    tabPanel(
      "example text",
      sidebarPanel(
        width = 4,
        dateRangeInput("daterange", "Select dates",
          format = "yyyy-mm-dd",
          start = min("2015-01-01"),
          end = max("2015-01-10")
        ),
        numericInput("hourmin", "Select mininum hour", 10, 0, 23),
        numericInput("hourmax", "Select maximum hour", 22, 0, 23),
        pickerInput("channel", "Select channel",
          choices = unique(channel),
          options = list("actions-box" = T, "live-search" = T),
          multiple = T,
          selected = unique(channel)
        )
      ), # end of sidebarPanel
      mainPanel(
        column(width = 10, plotOutput("barplot", width = "100%")),
        column(width = 8, DTOutput("table"))
      ) # end of mainPanel
    ) # end of tabPanel
  ) # end of tabsetPanel
) # end of fluidPage


################### // SERVER //###################


server <- function(input, output, session) {
  rv <- reactiveValues(data = NULL)


  # TABLE -------------------------------------------------------------------

  observe({
    rv$data <-
      data %>% # data was created outside the shiny app meaning that is present in the global env
      arrange(desc(Date)) %>%
      filter(Date >= input$daterange[1] & Date <= input$daterange[2]) %>%
      filter(Hour >= input$hourmin & Hour <= input$hourmax) %>%
      filter(channel %in% input$channel) %>%
      group_by(channel, Date) %>%
      arrange(Date) %>%
      summarise(Programme = paste0(Hour, ":", substr(event, 1, 3)), .groups = "drop") %>%
      pivot_wider(
        names_from = Date,
        values_from = Programme,
        values_fn = as_mapper(~ reduce(., paste, sep = ","))
      )

    output$table <- DT::renderDataTable({
      DT::datatable(rv$data, selection = list(target = "row"))
    })
  })



  observeEvent(input$table_rows_selected, {
    req(input$table_rows_selected)

    # the dates i want are the names of the columns
    dts <- rv$data[input$table_rows_selected, ] %>%
      names() %>%
      `[`(-1)



    hrs <- # this will give me the hours present in the cells selected from DT
      rv$data[input$table_rows_selected, ] %>%
      map(~ str_extract_all(., "\\d+")) %>%
      `[`(-1) %>%
      reduce(c) %>%
      reduce(c)

    # i know that i need the first column only
    channel_values <- rv$data[input$table_rows_selected, 1] %>%
      pull(channel) %>%
      as.character()


    ###### BARPLOT #########
    output$barplot <- renderPlot({
      data %>%
        filter(Date >= min(dts) & Date <= max(dts)) %>%
        filter(Hour >= min(hrs, na.rm = TRUE) & Hour <= max(hrs, na.rm = TRUE)) %>%
        filter(channel %in% channel_values) %>%
        group_by(Date, Group) %>%
        summarise(UniqueID = n_distinct(AnonID)) %>%
        ggplot() +
        geom_bar(aes(x = Date, y = UniqueID, fill = Group), stat = "identity", position = "dodge")
    })
  }) # end of observe
}

shinyApp(ui, server)