在 R 中的 Shiny 中部署 dataTableOutput 和绘图； “整理” dataTableOutput

Posted 2023-02-16

【中文标题】在 R 中的 Shiny 中部署 dataTableOutput 和绘图； “整理” dataTableOutput

【英文标题】：Deploying dataTableOutput and plot in Shiny in R; "tidying" the dataTableOutput

【发布时间】：2021-12-24 18:10:54

【问题描述】：

我正在一个闪亮的应用程序中开发一项功能，该功能显示dataTableOutput 和与之关联的情节。该图按组和日期显示唯一 ID 的计数，而表格显示与过滤的时间和日期相关的数据。表中的列标题是数据中的日期，它是使用pivot_wider 函数和tidyr 创建的。这是一些示例代码：-

数据

#relevant libraries
library(wakefield)#for generating the Status variable
library(dplyr)
library(stringi)
library(Pareto)
library(uuid)
library(ggplot2)
library(data.table)
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<-renderDataTable(
      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,Hour,Date)%>%
      arrange(Hour,Date)%>%
      summarise(Programme=event, .groups = 'drop')%>%
      mutate(rn=rowid(Hour,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)

这是输出：-

您可以看到数据表，我创建了一种“电视指南”，显示了节目的日期和时间。但是，我认为缺少字段有点碍眼。与其用其他文本填充它们，我想知道是否有更好的方法来显示这样的表格，以便几乎没有/没有空格并使其更简洁？

其次，我想知道如何使它具有交互性。我希望能够单击数据表的单元格/行，结果是在给定的时间和日期用UniqueID 的新计数反应性地更新绘图？这会很容易实现吗？如果可以，有人可以告诉我怎么做吗？谢谢你:)

【参考方案1】：

您应该考虑提出两个不同的问题。对于第一部分，您可以同时显示小时和事件，这样您就可以为每个频道显示一行。然后您可以在表格底部提供密钥，因为每个事件仅显示前 3 个字母。试试这个

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)
    )