如何根据 R Shiny 中的输入值数量动态更新计算值？

Question

我正在尝试更新 R 闪亮图表中的值，其计算值取决于输入的数量

library(shiny)
library(httr)
library(jsonlite)
library(dplyr)
library(plotly)
library(shinythemes)
library(flexdashboard)
library(shinydashboard)

setwd("X:/Work/Covid-19 Project/Shiny Dashboard")

rp_1 <- read.csv("Data/Risk Profile 1.csv")
rp_2 <- read.csv("Data/Risk Profile 2.csv")

gender <- c("Male","Female")
age <- c("Less than 20 years", "20 to 50 years","More than 50 years")
city <- c("Delhi","Chennai")
diabetes <- c("Have diabetes","Don't have diabetes")
hypertension <- c("Have hypertension","Don't have hypertension")

risk_level_est <- function(city, gender, age, db, ht){
  p_inv <- as.numeric(rp_1 %>%
                        filter(City == city & Gender == gender) %>%
                        select(Prob))
  
  p_adv <- as.numeric(rp_2 %>%
                        filter(Age == age & Diabetes == db & Hypertension == ht) %>%
                        summarise(Hosp + Death))
  
  as.numeric(p_inv*p_adv*100)
}

sar_risk_level_est <- function(age, db, ht){
  p_adv <- as.numeric(rp_2 %>%
                        filter(Age == age & Diabetes == db & Hypertension == ht) %>%
                        summarise(Hosp + Death))
  
  as.numeric(0.2*p_adv*100)
}

about_page <- tabPanel(
  title = "About",
  titlePanel("About"),
  "Created with R Shiny",
  br(),
  "2021 April"
)

main_page <- tabPanel(
  title = "Estimator",
  titlePanel(""),
  sidebarLayout(
    sidebarPanel(
      title = "Inputs",
      selectInput("gender", "Select your gender", gender),
      selectInput("age", "Select your age", age),
      selectInput("city", "Select your city", city),
      selectInput("db", "Do you have diabetes", diabetes),
      selectInput("ht", "Do you have hypertension", hypertension),
      radioButtons("radio", "Do you want to include your household members",
                   choices = list("No" = 1,"Yes" = 2)),
      conditionalPanel("input.radio == 2",
                       numericInput("members", label = "How many household members do you have?", value='1'),
                       uiOutput("member_input")
      ),
      actionButton("risk","Calculate my risk profile")
    ),
    mainPanel(
      tabsetPanel(
        tabPanel(
          title = "Risk Profile",
          plotlyOutput("risk_profile", height = 250, width = "75%"),
          plotlyOutput("overall_risk_profile", height = 250, width = "75%")
        )
      )
    )
  )
)

ui <- navbarPage(
  title = "Risk Estimator",
  theme = shinytheme('united'),
  main_page,
  about_page
)


server <- function(input, output, session) {
  
  output$member_input <- renderUI({
    
    numMembers <- as.integer(input$members)
    
    lapply(1:numMembers, function(i) {
      list(tags$p(tags$u(h4(paste0("Member ", i)))),
           selectInput(paste0("age", i), "Select their age", age, selected = NULL),
           selectInput(paste0("db", i), "Do they have diabetes", diabetes, selected = NULL),
           selectInput(paste0("ht", i), "Do they have hypertension", hypertension, selected = NULL))
    })
  })
  
  risk_level <- eventReactive(input$risk, {
    risk_level_est(input$city, input$gender, input$age, input$db, input$ht)
  })
  
  sar_risk_level <- eventReactive(input$risk,{
    
    sar_risk <- 0
    
    lapply(1:input$members, function(i){
      sar_risk <- sar_risk + sar_risk_level_est(input[[paste0("age", i)]],input[[paste0("db", i)]],input[[paste0("ht", i)]])
    })
    
    as.numeric(sar_risk)
  })
  
  output$risk_profile <- renderPlotly({
    
    fig <- plot_ly(
      domain = list(x = c(0, 1), y = c(0, 1)),
      value = risk_level(),
      title = list(text = "Personal Risk Profile"),
      type = "indicator",
      mode = "gauge+number",
      gauge = list(
        axis = list(range = list(0, 15)),
        bar = list(color = "gray"),
        bgcolor = "white",
        borderwidth = 2,
        bordercolor = "gray",
        steps = list(
          list(range = c(0, 3.75), color = "darkgreen"),
          list(range = c(3.75, 7.5), color = "chartreuse"),
          list(range = c(7.5,11.25), color = "orange"),
          list(range = c(11.25,15), color = "red")
        ))) 
    fig <- fig %>% layout(margin = list(l=30, r=30, t=80, b=30))
    
    fig
  })
  
  output$overall_risk_profile <- renderPlotly({
    
    fig <- plot_ly(
      domain = list(x = c(0, 1), y = c(0, 1)),
      value = risk_level() + sar_risk_level(),
      title = list(text = "Overall Risk Profile"),
      type = "indicator",
      mode = "gauge+number",
      gauge = list(
        axis = list(range = list(0, 15+(25*input*members))),
        bar = list(color = "gray"),
        bgcolor = "white",
        borderwidth = 2,
        bordercolor = "gray",
        steps = list(
          list(range = c(0, 3.75), color = "darkgreen"),
          list(range = c(3.75, 7.5), color = "chartreuse"),
          list(range = c(7.5,11.25), color = "orange"),
          list(range = c(11.25,15), color = "red")
        ))) 
    fig <- fig %>% layout(margin = list(l=30, r=30, t=80, b=30))
    
    fig
  })
  
}

shinyApp(ui, server)

虽然 risk_profile 图工作正常，但overall_risk_profile 图会抛出“non-numeric argument to binary operator”错误。 total_risk_profile 中的 sar_risk_level() 值取决于计算 (sar_risk_level_est)，该计算取决于输入的数量。我希望这个值 (sar_risk) 初始化为零并在每次按下操作按钮时更新。

Answer 1

外观精美的应用程序。我认为这只是一个错字。代码在第 151 行有 25*input*members 而不是 25*input$members。