如何优化表生成的闪亮代码答案

【问题标题】：How to optimize shiny code for table generation如何优化表生成的闪亮代码
【发布时间】：2021-12-28 22:07:24
【问题描述】：

代码运行正常，但我想稍微调整一下。

你能帮我调整下面的代码吗，注意data_subset2 与data_subset1 非常相似。但是，我在data_subset2 中插入了更多信息。所以我想而不是在data_subset2中插入这部分：

req(input$daterange1)
        req(input$daterange1[1] <= input$daterange1[2])
        days <- seq(input$daterange1[1], input$daterange1[2], by = 'day')
        Test <- filter(data(),
                       date1 %in% days | 
                         date2 %in% days)
    meanTest<-Test%>%
      group_by(date2,Week, Category)%>%
      summarize(Time=mean(time),.groups = 'drop')

我想只放data_subset1()。所以我想到了这样的事情：

data_subset2 <- reactive({
   data_subset1()      

    rename<- Test %>%
      select(starts_with("DR")) %>% names %>%
      paste0("Time-",.)
    
    meanTest<-left_join(meanTest, Test, by = c("date2","Week","Category")) %>%
      mutate(across(starts_with("DR"), ~ Time - .))  %>%
      select(-date1, -Week, -time) %>%
      rename_at(-c(1:3), ~rename)
  })

但是，它没有用。那么我该如何调整呢？你能帮帮我吗？

下面是完整代码！

library(shiny)
library(shinythemes)
library(dplyr)

Test <- structure(list(date1 = as.Date(c("2021-11-01")),
                       date2 = as.Date(c("2021-10-22")), 
                       Week = c("Friday"),
                       Category = c("ABC"), 
                       time = c(4),DR1 = c(2),DR2 = c(3)), class = "data.frame",row.names = c(NA, -1L))
ui <- fluidPage(
  
  shiny::navbarPage(theme = shinytheme("flatly"), collapsible = TRUE,
                    br(),
                    tabPanel("",
                             sidebarLayout(
                               sidebarPanel(
                                 uiOutput('daterange'),
                                 downloadButton("dl", "Download")
                               ),
                               mainPanel(
                                 dataTableOutput('table')
                                 
                               )
                             ))
  ))

server <- function(input, output,session) {
  
  data <- reactive(Test)
  
  output$daterange <- renderUI({
    dateRangeInput("daterange1", "Period you want to see:",
                   min   = min(data()$date1))
    
  })
  
  observe({updateDateRangeInput(session,"daterange1",start = NA, end = NA)})
  
  data_subset1 <- reactive({
    req(input$daterange1)
    req(input$daterange1[1] <= input$daterange1[2])
    days <- seq(input$daterange1[1], input$daterange1[2], by = 'day')
    Test <- filter(data(),
                   date1 %in% days | 
                     date2 %in% days)
    meanTest<-Test%>%
      group_by(Week,Category)%>%
      summarize(time=mean(time))
    
  })
  
  
  data_subset2 <- reactive({
    req(input$daterange1)
    req(input$daterange1[1] <= input$daterange1[2])
    days <- seq(input$daterange1[1], input$daterange1[2], by = 'day')
    Test <- filter(data(),
                   date1 %in% days | 
                     date2 %in% days)
    meanTest<-Test%>%
      group_by(date2,Week, Category)%>%
      summarize(Time=mean(time),.groups = 'drop')
    
    rename<- Test %>%
      select(starts_with("DR")) %>% names %>%
      paste0("Time-",.)
    
    meanTest<-left_join(meanTest, Test, by = c("date2","Week","Category")) %>%
      mutate(across(starts_with("DR"), ~ Time - .))  %>%
      select(-date1, -Week, -time) %>%
      rename_at(-c(1:3), ~rename)
  })
  
  output$table <- renderDataTable({
    data_subset1()
  })

  
    output$dl <- downloadHandler(
    filename = function() { "data.xlsx"},
    content = function(file) {
    data1<-data_subset1()
    data2<-data_subset2()
    sheets <- mget(ls(pattern = "data"))
    writexl::write_xlsx(sheets, path = file)
    }
  )
  
  
}

shinyApp(ui = ui, server = server)

【问题讨论】：

标签： r shiny

【解决方案1】：

试试这个

library(shiny)
library(shinythemes)
library(dplyr)

Test <- structure(list(date1 = as.Date(c("2021-11-01")),
                       date2 = as.Date(c("2021-10-22")), 
                       Week = c("Friday"),
                       Category = c("ABC"), 
                       time = c(4),DR1 = c(2),DR2 = c(3)), class = "data.frame",row.names = c(NA, -1L))
ui <- fluidPage(
  
  shiny::navbarPage(theme = shinytheme("flatly"), collapsible = TRUE,
                    br(),
                    tabPanel("",
                             sidebarLayout(
                               sidebarPanel(
                                 uiOutput('daterange'),
                                 downloadButton("dl", "Download")
                               ),
                               mainPanel(
                                 dataTableOutput('table')
                                 ,dataTableOutput("t2")
                               )
                             ))
  ))

server <- function(input, output,session) {
  
  data <- reactive(Test)
  
  output$daterange <- renderUI({
    dateRangeInput("daterange1", "Period you want to see:",
                   min   = min(data()$date1))
    
  })
  
  observe({updateDateRangeInput(session,"daterange1",start = NA, end = NA)})
  
  data_subset1 <- reactive({
    req(input$daterange1)
    req(input$daterange1[1] <= input$daterange1[2])
    days <- seq(input$daterange1[1], input$daterange1[2], by = 'day')
    Test <- filter(data(),
                   date1 %in% days | 
                     date2 %in% days)
    meanTest<-Test%>%
      group_by(Week,Category)%>%
      dplyr::summarize(time=mean(time))
    return(list(meanTest,Test))
  })
  
  
  data_subset2 <- reactive({
    # req(input$daterange1)
    # req(input$daterange1[1] <= input$daterange1[2])
    # days <- seq(input$daterange1[1], input$daterange1[2], by = 'day')
    # Test <- filter(data(),
    #                date1 %in% days | 
    #                  date2 %in% days)
    req(data_subset1())
    Test <- data_subset1()[[2]]
    meanTest<-Test%>%
      group_by(date2,Week, Category)%>%
      dplyr::summarize(Time=mean(time),.groups = 'drop')
    
    rename<- Test %>%
      select(starts_with("DR")) %>% names %>%
      paste0("Time-",.)
    
    meanTest<-left_join(meanTest, Test, by = c("date2","Week","Category")) %>%
      dplyr::mutate(dplyr::across(starts_with("DR"), ~ Time - .))  %>%
      select(-date1, -Week, -time) %>%
      rename_at(-c(1:3), ~rename)
  })
  
  output$table <- renderDataTable({
    data_subset1()[[1]]
  })
  output$t2 <- renderDataTable({
    data_subset2()
  })
  
  output$dl <- downloadHandler(
    filename = function() { "data.xlsx"},
    content = function(file) {
      data1<-data_subset1()[[1]]
      data2<-data_subset2()
      sheets <- mget(ls(pattern = "data"))
      writexl::write_xlsx(sheets, path = file)
    }
  )
  
}

shinyApp(ui = ui, server = server)

【讨论】：

YBS，感谢您的回复！事实上，我的代码运行良好，我只是想要在data_subset2 中我不需要插入已经在data_subset1 中的所有部分。不知道现在是不是更清楚了？
那么，你想在 data_subset2 中使用 data_subset1 吗？
是的，正是@YBS！这样，我不需要将所有 data_subset1 代码插入到 data_subset2
请注意，data_subset2 不能使用来自 data_subset1 的 meanTest，因为它与 data_subset2 中定义的略有不同。但是，您可以使用 data_subset1 中的测试。那是你要找的吗？如果是这样，请尝试更新的代码。