0

考虑以下示例应用程序：

library(shiny)
library(shinyWidgets)


module_UI <- function(id){
    tagList(
        div(
            uiOutput(
                outputId = NS(id, "selection")
            ),
            shinyWidgets::dropdown(
                uiOutput(outputId = NS(id, "new_option")),
                style = "unite",
                label = "New",
                color = "primary",
                animate = animateOptions(
                    enter = animations$fading_entrances$fadeInLeftBig,
                    exit = animations$fading_exits$fadeOutRightBig
                ),
                up = F,
                width = "600px",
                inline = T
            )
        )
    )
}

module_server <- function(id){
    moduleServer(id, function(input, output, session){
        ns <- session$ns
        return_values <- reactiveValues(selection=NULL)
        
        output$selection <- renderUI({
            selectInput(inputId = ns("selection"), label = "Select:", choices = 1:5)
            
        })
        
        output$new_option <- renderUI({
            div(
                numericInput(ns("new_option_input"), label = "Add a new option:"),
                shinyWidgets::actionBttn(
                    inputId = ns("submit_new_option"),
                    label = "Submit",
                    icon = icon("paper-plane"))
            )
            
        })
        
        observeEvent(input$submit_new_option, {
            
            #does not work as intended
            updateSelectInput(session = session, inputId = "selection", selected = input$new_option_input)
        })
        
        
        observe({
            return_values$selection <- input$selection
        })
        
        return(return_values)
    })
}


# Define UI for application that draws a histogram
ui <- fluidPage(
    title = "Test App",
    module_UI("test"),
    verbatimTextOutput(outputId = "selection_chosen")
)

# Define server logic required to draw a histogram
server <- function(input, output) {
    
    picker <- module_server("test")

    output$selection_chosen <- renderText({
        picker$selection
    })
}

# Run the application 
shinyApp(ui = ui, server = server)

基本上，模块应该做两件事：

  1. 允许用户选择预先存在的选项 --> 从模块返回该值
  2. 允许用户创建自己的新选项 --> 从模块返回该值

我有 #1 工作，但在 #2 上苦苦挣扎。具体来说，我有“不起作用”的评论。我怎样才能实现这个功能？从 Shiny 模块返回服务器端创建的值的最佳实践是什么？这是一个示例应用程序；真正的涉及从数据库中读取selectInput选项，以及将新创建的选项保存在数据库中。感谢您对此的任何帮助！很多关于 Shiny 模块的 SO 答案都具有较旧的callModule(...)语法，这使得研究这个主题变得更加混乱。

4

1 回答 1

1

您只需要在numericInput. 也许你正在寻找这个。

library(shiny)
library(shinyWidgets)

module_UI <- function(id){
  ns <- NS(id)
  tagList(
    div(
      uiOutput(
        outputId = NS(id, "selection")
      ),
      shinyWidgets::dropdown(
        uiOutput(outputId = NS(id, "new_option")),
        style = "unite",
        label = "New",
        color = "primary",
        animate = animateOptions(
          enter = animations$fading_entrances$fadeInLeftBig,
          exit = animations$fading_exits$fadeOutRightBig
        ),
        up = F,
        width = "600px",
        inline = T
      ),
      DTOutput(ns("t1"))
    )
  )
}

module_server <- function(id){
  moduleServer(id, function(input, output, session){
    ns <- session$ns
    return_values <- reactiveValues(selection=NULL,myiris = iris)
    
    output$selection <- renderUI({
      selectInput(inputId = ns("selection"), label = "Select:", choices = 1:5)
    })
    
    output$new_option <- renderUI({
      tagList(
        numericInput(ns("new_option_input"), label = "Add a new option:",10, min = 1, max = 100),
        shinyWidgets::actionBttn(
          inputId = ns("submit_new_option"),
          label = "Submit",
          icon = icon("paper-plane"))
      )
      
    })
    
    observeEvent(input$submit_new_option, {
      return_values$myiris <- iris[1:input$new_option_input,]
      #does work as intended
      updateSelectInput(session = session, inputId = "selection", choices= c(1:input$new_option_input), selected = input$new_option_input)
      
    })
    
    output$t1 <- renderDT({return_values$myiris})
    
    observe({
      
      return_values$selection <- input$selection
    })
    
    return(return_values)
  })
}


# Define UI for application that draws a histogram
ui <- fluidPage(
  title = "Test App",
  module_UI("test"),
  verbatimTextOutput(outputId = "selection_chosen"),
  DTOutput("t2")
)

# Define server logic required to draw a histogram
server <- function(input, output) {
  
  picker <- module_server("test")
  
  output$selection_chosen <- renderText({
    picker$selection
  })
  
  output$t2 <- renderDT({picker$myiris[,c(3:5)]})
}

# Run the application 
shinyApp(ui = ui, server = server)
于 2021-12-08T00:23:24.693 回答