Question

我试图理解R闪亮的反应部分。在该过程中，我尝试根据输入更改更新输出表，同时从年龄下拉列表中选择值。它似乎是通过第一个值来实现的，但是当我从年龄下降中更改任何值时，它将不会更新我的表。我使用的输入是chooseage。以下是我正在使用的代码。

library(shiny)
library(shinydashboard)
library(shinyBS)
library(knitr)
library(kableExtra)
library(shiny)
library(shinythemes)


ui <- dashboardPage(
  dashboardHeader(disable = F, title = "PATH Study"),
  dashboardSidebar(sidebarMenu(
    menuItem(
      "Population Filter",
      uiOutput("choose_age")
    )
  )),
  dashboardBody(box(
    width = 12,
    tabBox(
      width = 12,
      id = "tabBox_next_previous",
      tabPanel("Initiation",
               fluidRow(
                 box(
                   width = 5,
                   solidHeader = TRUE,
                   status = "primary",
                   tableOutput("smoke"),
                   collapsible = F
                 )
               ))
      
    ),
    uiOutput("Next_Previous")
  ))
)
server <- function(input, output, session) {
  # Drop-down selection box for which Age bracket to be selected
  age_levels <- c("18 to 24 years old","25 to 34 years old","35 to 44 years old")
  
  output$choose_age <- renderUI({
    selectInput("selected_age", "Age", as.list(age_levels))
  })
  myData <- reactive({
    with_demo_vars %>%
      filter(age == input$choose_age) %>%
      pct_ever_user(type = "SM")
  })
  output$smoke <-
    renderTable({
      head(myData())
    })
  
}
shinyApp(ui = ui, server = server)

Answer 1

这是您的任务的快速原型

library(shiny)
library(tidyverse)
library(DT)

# 1. Dataset
df_demo <- data.frame(
  age = c(16, 17, 18, 19, 20),
  name = c("Peter", "Mary", "Mike", "Nick", "Phillipe"))

# 2. Server
server <- function(input, output, session) {

  # 1. UI element 'Age'
  output$ui_select_age <- renderUI({
    selectInput("si_age", "Age", df_demo$age)
  })

  # 2. Reactive data set
  df_data <- reactive({

    # 1. Read UI element
    age_selected <- input$si_age

    # 2. Filter data
    df <- df_demo %>%
      filter(age == age_selected)

    # 3. Return result
    df
  })

  # 3. Datatable
  output$dt_table <- renderDataTable({
      datatable(df_data())
  })

}

# 3. UI
ui <- fluidPage(
  fluidRow(uiOutput("ui_select_age")),
  fluidRow(dataTableOutput("dt_table"))
)


# 4. Run app
shinyApp(ui = ui, server = server)

Answer 2

我认为你的shineApp过度反应，因为服务器中的所有功能都是立即执行的，无需等待任何选定的输入。所以它要么会崩溃，要么表现得很奇怪。因此，您必须延迟与req()，validate() / need()或任何observeEvent或eventReactive()函数的反应。

也许这个片段可能会对您有所帮助，尽管有多种方法可以实现所需的行为。

library(shiny)
library(shinydashboard)
library(dplyr)

data(mtcars)
mtcars$age <- sample(x = c(10,20,30,40,50), size = nrow(mtcars), replace = T)
with_demo_vars <- mtcars

ui <- dashboardPage(
  dashboardHeader(disable = F, title = "PATH Study"),
  dashboardSidebar(sidebarMenu(
    menuItem(text = "Population Filter",
             uiOutput("choose_age")
    )
  )
  ),
  dashboardBody(
    tableOutput("smoke")
  )  
)

server <- function(input, output, session) {
  output$choose_age <- renderUI({
    selectInput("selected_age", "Age", with_demo_vars$age)
  })
  myData <- reactive({
    with_demo_vars %>%
      dplyr::filter(age == input$selected_age) 
  })
  output$smoke <- renderTable({
    req(input$selected_age)
    head(myData())
  })
}
shinyApp(ui = ui, server = server)

反应选择输入以更新表

2 个答案: