CODEWITHSUNDEEP
rshinydt
stomper
stomper

Reputation: 1387

How to integrate Shiny updateSelectInput to update choices for specific cell InputIDs in editable data table

What I am trying to do? I am building a Shiny app that imports data, runs some analysis, and allows the User to make selections regarding the analysis via drop downs in a data table. The initial choices available are specific to each row in the table based on values found in the data. I want the User to be able to augment the data so new values that weren’t found in the imported data are available as choices, too. It is this last part that is giving me trouble.

I’ve created an example based on mtcars to illustrate. The construct I have for creating an editable data table is based on ID's for each cell in a column as follows (thanks to some earlier help I had on Stack to figure it out). The snippet of code below is contained in an observeEvent when I load new data. [Note the full code is at the bottom]

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)]
                ))})
            )

I've set up another observeEvent for when a new model is added. I expect I need to use updateSelectInput to update the choices under the model variable. I've tried this by recreating v$initTbl under this observeEvent, but haven't figured out how to work in the updateSelectInput instead of SelectInput. The former is calling for a "session" argument, so if I just substitute "updateSelectInput" I get an error saying that I cannot convert an environment to character. If I remove the "as.character" I get a "cannot unclass an environment" error.

Further Context Below is further context for what I am trying to do followed by the code I have. When running the app, the Load Data button imports the mtcars data and splits the car name into make and model fields. The model field in the display table is a drop down list and has as choices the various models that are found in the data for the specific make of car. The first one in each list is the default value. The User can select from the drop downs and use the Commit button to register the choices selected. The User can go back to make changes and Commit multiple times.

There are fields to allow the User to add a new model name for a particular make of car. Save Model should apply the new model entry as a drop down choice for the relevant make of car. This is what I haven’t been able to get working.

In order to be able to confirm the updates that were committed, once the User selects Commit the first time, I am showing the resultsTbl as verbatim output at the bottom of the page. The output refreshes every time the Commit button is clicked. It is the resultsTbl that I store and will use for onward processing in another module.

Here is a sequence of steps that should be able to be completed. Step 1: Load Data Step 2: Change the Model in the 2nd row from “RX4” to “RX4 Wag” Step 3: Commit and see updates reflected in the resultsTbl Step 4: Set Select Make to “Valiant” Step 5: Set Add Model Name to “V” Step 6: Save Model Step 7: “V” should appear under “Valiant” as a selection in the drop down Step 8: Commit and “V” should appear as the model for row 6 in resultsTbl Step 9: Change the Model in the last row from “240D” to “280” Step10: Commit and see update reflected in the resultsTbl

What have I tried? The Load Data button triggers an observeEvent that does the following: Sets up the data Determines which models are available for which makes of car (for the drop downs) Initiates the data table (initTbl)

I use a reactive (displayTbl) to capture the updates to feed the proxy table. I then use a reactive (resultTbl) to store the captured values. This all works fine.

I use Save Model as another observeEvent to update which models are available for which makes of car, to add new values to the drop downs where relevant.

I have not been able to figure how to make this work.

I believe I need some way to reinitialize the data table with the refreshed choices for the drop downs, whilst preserving any previously selected values. As noted above, I am unsure how to integrate updateSelectInput into the existing code.

Any help would be greatly appreciated.

Here is the current state of my code:

#********* 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, ...)
}

Upvotes: 0

Views: 469

Answers (1)

Goran
Goran

Reputation: 191

use updateSelectInput inside an observeEvent or observe function. Pass in the Shiny session object, the input ID of the selectInput element and a vector of new choices.

like this

observeEvent(input$saveModelButton, {
  updateSelectInput(session, "sel_model6", choices = c("V", "Other models"))
})

Upvotes: 0

Related Questions