Shiny展示散点图报错及水平线不显示问题修复咨询

问题核心原因 #

• 原始代码中D列存储的是空字符串""而非NA值，subset(df_grouped,is.na(D))筛选结果为空，后续计算的周均值、标准差均为NaN，导致水平线无法绘制
• 函数返回的date字段不存在，原始数据中仅存在date1、date2两个日期列，日期选择器的配置逻辑因此失效
• 基础R绘图是基于副作用执行，不需要将绘图结果赋值后返回，直接执行绘图语句即可正常输出

修正后完整代码 #

rm(list=ls())
library(shiny)
library(shinythemes)
library(dplyr)
library(ggplot2)
library(tidyr)
library(lubridate)

function.cl<-function(dt){
  
  df <- structure(
    list(Id=c(1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1),
         date1 = c("2021-07-20","2021-07-20","2021-07-20","2021-07-20","2021-07-20",
                   "2021-07-20","2021-07-20","2021-07-20","2021-07-20","2021-07-20","2021-07-20",
                   "2021-07-20","2021-07-20","2021-07-20","2021-07-20","2021-07-20","2021-07-20",
                   "2021-07-20","2021-07-20","2021-07-20","2021-07-20"),
         date2 = c("2021-07-01","2021-07-01","2021-07-01","2021-07-01","2021-04-02",
                   "2021-04-02","2021-04-02","2021-04-02","2021-04-02","2021-04-02","2021-04-03",
                   "2021-04-03","2021-04-03","2021-04-03","2021-04-03","2021-04-08","2021-04-08",
                   "2021-04-09","2021-04-09","2021-04-10","2021-04-10"),
         Week= c("Thursday","Thursday","Thursday","Thursday","Friday","Friday","Friday","Friday",
                 "Friday","Friday","Saturday","Saturday","Saturday","Saturday","Saturday","Thursday",
                 "Thursday","Friday","Friday","Saturday","Saturday"),
         D = c("","","Ho","","","","","","Ho","","","","","","","","","","","",""), 
         D1 = c(8,1,9, 3,5,4,7,6,3,8,2,3,4,6,7,8,4,2,6,2,3), DR01 = c(4,1,4,3,3,4,3,6,3,7,2,3,4,6,7,8,4,2,6,7,3),
         DR2 = c(2,1,4,3,3,4,1,6,3,7,2,3,4,6,7,8,4,2,6,2,3), DR03 = c(7,5,4,3,3,4,1,5,3,3,2,3,4,6,7,8,4,2,6,4,3)),
    class = "data.frame", row.names = c(NA, -21L))
  
  
  df<-subset(df,df$date2<df$date1) 
  
  dim_data<-dim(df)
  
  day<-c(seq.Date(from = as.Date(df$date2[1]),
                  to = as.Date(df$date2[dim_data[1]]),
                  by = "1 day"))
  
  df_grouped <- df %>%
    mutate(across(starts_with("date"), as.Date)) %>% 
    group_by(date2) %>% 
    summarise(Id = first(Id),
              date1 = first(date1),
              Week = first(Week),
              D = first(D),
              D1 = sum(D1)) %>% 
    select(Id,date1,date2,Week,D,D1)
  
  df_grouped <- df_grouped %>% mutate(date1=format(date1,"%d/%m/%Y"),
                                      date2=format(date2,"%d/%m/%Y"))
  df_grouped<-data.frame(df_grouped)
  
  #create scatter plot
  scatter_date <- function(dt, dta = df) {
    
    # get the week day
    my_day <- weekdays(as.Date(dt))
    
    # 修正筛选逻辑，匹配空字符串而非NA
    df_OC<-subset(df_grouped, D == "") 
    ds_OC<-subset(df_OC,df_OC$Week==my_day) 
    
    
    mean_Week<-mean(as.numeric(ds_OC[,"D1"]) )
    sdeviation_Week<-sd(as.numeric(ds_OC[,"D1"]))
    
    
    mean_Week_pos <- (mean_Week + sdeviation_Week)
    mean_Week_neg <- (mean_Week - sdeviation_Week)
    
    dta %>%
      filter(date2 == ymd(dt)) %>%
      summarize(across(starts_with("DR"), sum)) %>%
      pivot_longer(everything(), names_pattern = "DR(.+)", values_to = "val") %>%
      mutate(name = as.numeric(name)) %>%
      plot(xlab = "Days", ylab = "Types", xlim = c(0, 7),
           ylim = c((min(.$val) %/% 10) * 10, (max(.$val) %/% 10 + 1) * 15))
    abline(h=mean_Week, col='blue') 
    abline(h= mean_Week_pos, col='green',lty=2) 
    abline(h= mean_Week_neg, col='orange',lty=2)
  }  

  # 直接执行绘图
  scatter_date(dt)
  
  # 修正返回的日期字段，取date2的唯一值
  return(list(
    date = unique(df$date2)
  ))
}

ui <- fluidPage(
  
  shiny::navbarPage(theme = shinytheme("flatly"), collapsible = TRUE,
                          br(),
                          
                          tabPanel("",
                                   sidebarLayout(
                                     sidebarPanel(
                                       
                                       uiOutput("date"),
                                       
                                       br(),
                                     ),
                                     
                                     mainPanel(
                                       tabsetPanel(
                                         tabPanel("",plotOutput("Graph",width = "95%", height = "600"))),
                                     ))
                          )))


server <- function(input, output,session) {
  data <- reactive(function.cl("2021-07-01"))
  
  output$date <- renderUI({
    all_dates <- seq(as.Date('2021-01-01'), as.Date('2021-12-31'), by = "day")
    disabled <- as.Date(setdiff(all_dates, as.Date(data()$date)), origin = "1970-01-01")
    dateInput(input = "date", 
              label = "Select Date",
              min = min(as.Date(data()$date)),
              max = max(as.Date(data()$date)),
              value = max(as.Date(data()$date)),
              format = "dd-mm-yyyy",
              datesdisabled = disabled)
  })
  
  output$Graph <- renderPlot({
    req(input$date)
    function.cl(input$date)
  })
  
}

shinyApp(ui = ui, server = server)

内容的提问来源于stack exchange，提问作者Antonio