R语言如何集成Shiny updateSelectInput来更新可编辑数据表中特定单元格InputID的选项

- 我想做什么？**我正在开发一个导入数据、运行分析的应用程序，并允许用户通过数据表中的下拉菜单进行有关分析的选择。可用的初始选择特定于表中的每一行，基于在数据中找到的值。我希望用户能够增加数据，以便新值不会' t在导入的数据中找到的也可以作为选择。正是这最后一部分给我带来了麻烦。

我已经创建了一个基于mtcars的例子来说明。我创建可编辑数据表的构造是基于列中每个单元格的ID，如下所示（感谢之前在Stack上的一些帮助，我了解了这一点）。下面的代码片段包含在我加载新数据时的observeEvent中。[注意完整的代码在底部]

selectInputIDmodel <<- paste0("sel_model", 1:nrow(v$cars()$cars_meta))

v$model_applied <- reactive({match_cars(v$cars())$model_applied})

v$initTbl <-
            dplyr::tibble(
                car = v$cars()$cars_meta$car,
                make = v$cars()$cars_meta$make,
                mpg = v$cars()$cars_meta$mpg,
                model = sapply(selectInputIDmodel, function(x){as.character(selectInput(inputId = ns(x), label = "",
                                                                                        choices = v$model_applied()$model[v$model_applied()$car == v$cars()$cars_meta$car[which(selectInputIDmodel == x)]],
                                                                                        selected = v$cars()$cars_meta$model[which(selectInputIDmodel == x)]
                ))})
            )

我已经设置了另一个observeEvent，用于添加新模型时。我预计我需要使用updateSelectInput来更新模型变量下的选项。我已经尝试过在此observeEvent下重新创建v $initTbl，但还没有弄清楚如何使用updateSelectInput而不是SelectInput。前者调用"session"参数，因此，如果我只是替换"updateSelectInput"，我会得到一个错误，说我无法将环境转换为字符。如果我删除"as. character"，我会得到一个"无法取消环境类"错误。

- 其他上下文**以下是我尝试执行的操作的其他上下文，后面是我拥有的代码。运行应用程序时，加载数据按钮导入mtcars数据，并将汽车名称拆分为品牌和型号字段。2显示表格中的型号字段是一个下拉列表，可选择在特定品牌汽车的数据中找到的各种型号。每个列表中的第一个是默认值。用户可以从下拉列表中进行选择，并使用"提交"按钮注册所选选项。用户可以返回进行更改并多次提交。

有字段允许用户添加一个新的型号名称为一个特定的汽车。保存模型应该应用新的型号条目作为一个下拉选择为相关的汽车。这是我还没有能够得到工作。
为了能够确认提交的更新，一旦用户第一次选择Commit，我就在页面底部显示resultsTbl作为逐字输出。每次单击Commit按钮时，输出都会刷新。我存储的是resultsTbl，并将用于在另一个模块中进行后续处理。
下面是应该能够完成的一系列步骤。步骤1：加载数据步骤2：将第2行中的型号从"RX4"更改为"RX4 Wag"步骤3：提交并查看结果表中反映的更新步骤4：将"选择制造"设置为"Valiant"第5步：将添加型号名称设置为"V"步骤6：保存模型步骤7："V"应显示在"Valiant"下，作为下拉菜单步骤8中的选项：Commit和"V"应显示为results表第6行的模型步骤9：将最后一行中的型号从"240D"更改为"280"步骤10：提交并查看结果表中反映的更新

- 我尝试了哪些操作？**"加载数据"按钮触发一个observeEvent，该事件执行以下操作：设置数据确定哪种车型可用于哪种车型（用于下拉列表）初始化数据表（initTbl）

我使用一个reactive（displayTbl）来捕获更新以提供给代理表，然后使用一个reactive（resultTbl）来存储捕获的值，这一切都很好。
我使用SaveModel作为另一个observeEvent来更新哪些车型可用于哪些车型，并在相关的下拉列表中添加新值。
我一直想不出该怎么做。
我认为我需要一些方法来重新初始化数据表，使用下拉列表的刷新选项，同时保留任何先前选择的值。如上所述，我不确定如何将updateSelectInput集成到现有代码中。
任何帮助都将不胜感激。

- 以下是代码的当前状态：**

#********* LIBRARIES *************************************************

library(magrittr)
library(dplyr)
library(tidyselect)
library(shiny)
library(stringr)
library(purrr)
library(shinyjs)
library(zeallot)
library(DT)

#********  FUNCTIONS ***************************************************

# Creates the new data set / cars object
create_data2 <- function(){
    #simulate data import
    cars_df <- head(mtcars, 10)
    
    #simulate creating meta table
    cars_meta <- dplyr::tibble(car = rownames(cars_df), make = sub("([A-Za-z]+).*", "\\1", rownames(cars_df)), cars_df)
    cars_meta$model <- NA
    
    #simulate creating cars_list
    names <- rownames(cars_df)
    `%<-%` <- zeallot::`%<-%`
    car <- list()
    car[c("head", "m1", "m2")] %<-% data.frame(stringr::str_split(names, " ", simplify = TRUE))
    car$m <- paste(car$m1, car$m2)
    
    cars_list <- list()
    for(h in car$head){
        cars_list[[h]] <- list(car$m[car$head==h])
    }
    
    #simulate creating the cars_object
    cars_object <- list()
    cars_object$cars_df <- cars_df
    cars_object$cars_meta <- cars_meta
    cars_object$cars_list <- cars_list
    
    return(cars_object)
}



# Updates the cars object with resultTbl 
meta_table <- function(object, table){
    tbl <- table
    object$cars_meta <- tbl
    return(object)
}


# Matches the models and makes of the cars
match_cars <- function(cars_object){
    
    cv <- cars_object$cars_meta
    car_match <- list()
    
    for (car in cv$car){
        x <- 1
        for (model in cars_object$cars_list[[cv$make[cv$car == car]]][[1]]){
            car_match[[paste0(car,"@",x)]][["model"]] <- model
            x <- x + 1
        }
    }
    
    model_applied <-
        if(nrow(dplyr::bind_rows(car_match)) >0) {
            dplyr::bind_rows(car_match) %>%
                mutate(car = stringr::str_replace_all(names(car_match),"@\\d",""))
        } else {
            data.frame(car = "", drop = FALSE)
        }
    
    model_reduced <- model_applied %>%
        dplyr::group_by(car) %>%
        dplyr::slice(1) %>%
        dplyr::ungroup()
    
    cv <- cv %>%
        select(-model) %>%
        left_join(model_reduced, by = "car") %>%
        select(car, make, mpg, model)
    
    cars_object$cars_meta <- cv
    
    cars_object$model_applied <- model_applied
    
    return(cars_object)
}

# Adds a new make/model combination to cars_list of the cars object
new_model <- function(cars_object, make, new){
    cars_object$cars_list[[make]] <- c(new, cars_object$cars_list[[make]][[1]])
    return(cars_object)
}

#******** UI ********************************************************

mod_data_ui <- function(id) {
    
    fluidPage(
        
        actionButton(NS(id,"new_data"), "Load Data"),
        br(),
        DT::dataTableOutput(NS(id, 'dt')),
        br(),
        actionButton(NS(id, "commit_meta"), "Commit"),
        br(),
        verbatimTextOutput(NS(id,"results")),
        br(),
        uiOutput(NS(id,"make_set")),
        br(),
        uiOutput(NS(id, "model_value")),
        br(),
        uiOutput(NS(id, "save_model")),
        br(),
        verbatimTextOutput(NS(id,"meta"))
    )
}

shiny_ui <- function() {
    
    navbarPage(
        title = div(span("Data",
                         style = "position: relative; top: 50%; transform: translateY(-50%);")),
        
        tabPanel(
            "Data Management",
            mod_data_ui("data")
        )
    )
    
    
}

#**** SERVER ***********************************************************

mod_data_server <- function(id) {
    shiny::moduleServer(id, function(input, output,session){
        
        ns <- session$ns
        
        v <- reactiveValues()
        
        #place holders
        selectInputIDmodel <- "model"
        
        observeEvent(input$new_data, once = TRUE, {
            data <- create_data2()
            v$cars <- reactive({data})
            
            selectInputIDmodel <<- paste0("sel_model", 1:nrow(v$cars()$cars_meta))
            
            v$model_applied <- reactive({match_cars(v$cars())$model_applied})
            
            v$initTbl <-
                dplyr::tibble(
                    car = v$cars()$cars_meta$car,
                    make = v$cars()$cars_meta$make,
                    mpg = v$cars()$cars_meta$mpg,
                    model = sapply(selectInputIDmodel, function(x){as.character(selectInput(inputId = ns(x), label = "",
                                                                                            choices = v$model_applied()$model[v$model_applied()$car == v$cars()$cars_meta$car[which(selectInputIDmodel == x)]],
                                                                                            selected = v$cars()$cars_meta$model[which(selectInputIDmodel == x)]
                    ))})
                )
        })
        
        
        displayTbl <- reactive({
            req(input$new_data)
            dplyr::tibble(
                car = v$cars()$cars_meta$car,
                make = v$cars()$cars_meta$make,
                mpg = v$cars()$cars_meta$mpg,
                model = sapply(selectInputIDmodel, function(x){as.character(selectInput(inputId = ns(x), label = "",
                                                                                        choices = v$model_applied()$model[v$model_applied()$car == v$cars()$cars_meta$car[which(selectInputIDmodel == x)]],
                                                                                        selected = input[[x]]))})
            )
        })
        
        
        output$dt <- DT::renderDataTable({
            req(input$new_data)
            DT::datatable(
                v$initTbl, escape = FALSE, selection = 'none', rownames = FALSE,
                options = list(paging = FALSE, ordering = FALSE, scrollx = TRUE, dom = "t",
                               preDrawCallback = DT::JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
                               drawCallback = DT::JS('function() { Shiny.bindAll(this.api().table().node()); } ')
                )
            )
        })
        
        
        dt_table_proxy <- DT::dataTableProxy(outputId = "dt")
        
        
        observeEvent({sapply(selectInputIDmodel, function(x){input[[x]]})}, {
            DT::replaceData(proxy = dt_table_proxy, data = displayTbl(), rownames = FALSE)
        }, ignoreInit = TRUE)
        
        
        
        
        v$resultTbl <- reactive({
            dplyr::tibble(
                car = v$cars()$cars_meta$car,
                make = v$cars()$cars_meta$make,
                mpg = v$cars()$cars_meta$mpg,
                model = sapply(selectInputIDmodel, function(x){as.character(input[[x]])})
            )
        })
        
        
        
        
        
        observeEvent(input$commit_meta, {
            cars_updated <- meta_table(v$cars(), v$resultTbl())
            v$cars <- reactive({cars_updated})
        })
        
        
        # add model manually
        output$make_set <- renderUI({
            req(input$new_data)
            make <- v$cars()$cars_meta$make
            #make_sel <- unique(make)
            selectInput(NS(id, "make_set"), "Select Make", multiple = FALSE, choices = make)
        })
        
        
        output$model_value <- renderUI({
            req(input$new_data)
            textInput(NS(id, "model_value"), "Add Model Name")
        })
        
        
        output$save_model <- renderUI({
            req(input$new_data)
            actionButton(NS(id, "save_model"), "Save Model", style="color: #fff; background-color: #337ab7; border-color: #2e6da4")
            
        })
        
        
        observeEvent(input$save_model,{
            car <- meta_table(v$cars(), v$resultTbl()) # This is the same step as under commit
            
            v$cars <- reactive({match_cars(
                new_model(
                    cars_object = car,
                    make = input$make_set,
                    new = input$model_value
                )
            )
            })
            
            v$model_applied <- reactive({match_cars(v$cars())$model_applied})
            
            updateTextInput(session, "model_value", value = "")
        })
        
        
        
        
        
        
        output$meta <- renderPrint({
            req (input$commit_meta > 0)
            tf <- v$cars()$cars_meta
            tf %>% print(n = Inf)
        })
        return(reactive(v))
    })
}


shiny_server <- function(input, output, session) {
    
    v <- mod_data_server("data")
    
}

#********* APP *******************************

svyStudyapp_app <- function(...) {
    app <- shiny::shinyApp(
        ui = shiny_ui,
        server = shiny_server
    )
    
    shiny::runApp(app, ...)
}

R语言如何集成Shiny updateSelectInput来更新可编辑数据表中特定单元格InputID的选项

1条答案

相关问题

热门标签

最新问答

R语言 如何集成Shiny updateSelectInput来更新可编辑数据表中特定单元格InputID的选项

1条答案

相关问题

热门标签

最新问答

R语言如何集成Shiny updateSelectInput来更新可编辑数据表中特定单元格InputID的选项