Skip to content
Advertisement

How to consolidate action buttons for individual objects into a single selectInput() in R shiny?

The code posted below allows the user via clicks of action buttons to add/delete individual rhandsontable tables for data input. For deletion each table has its own action button underneath. Any ideas how to consolidate those delete action buttons into a single selectInput() where all tables are listed for deletion? I’ve tried un-nesting the deletion function observeEvent(input[[btnID]]...) which triggers a removeUI(), for quite a while now, but I have completely hit a brick wall.

Code:

library(shiny)
library(rhandsontable)

data1 <- data.frame(row.names = c("A","B","C","Sum"),"Tbl 1"=c(1,1,0,2),check.names=FALSE)

ui <- fluidPage(br(),
  actionButton("addTbl","Add table"),br(),br(),
  tags$div(id="placeholder",tags$div(rHandsontableOutput("hottable1")))
)

server <- function(input, output, session) {
  uiTbl <- reactiveValues(div_01_tbl = data1) 
  rv <- reactiveValues()                
  
  observeEvent(input$hottable1, {uiTbl$div_01_tbl <- hot_to_r(input$hottable1)})
  
  output$hottable1 <- renderRHandsontable({rhandsontable(uiTbl$div_01_tbl, useTypes = TRUE)})
  
  observeEvent(input$addTbl, {
    divID <- paste0("div_", if(input$addTbl+1 < 10){"0"},input$addTbl+1)
    dtID <- paste0(divID, "_DT")
    btnID <- paste0(divID, "_rmv")
    uiTbl[[paste0(divID,"_tbl")]] <- data1 
    
    insertUI(selector = "#placeholder",
      ui = tags$div(id = divID,
        rHandsontableOutput(dtID), 
        actionButton(btnID, "Delete", class = "pull-left btn btn-danger"),
      )
    )
    
    output[[dtID]] <- renderRHandsontable({
      req(uiTbl[[paste0(divID,"_tbl")]])
      rhandsontable(uiTbl[[paste0(divID,"_tbl")]], useTypes = TRUE)
    })
    
    observeEvent(input[[dtID]], {uiTbl[[paste0(divID,"_tbl")]] <- hot_to_r(input[[dtID]])})
    
    observeEvent(input[[btnID]],{
      removeUI(selector = paste0("#", divID))
      rv[[divID]] <- NULL
      uiTbl[[paste0(divID,"_tbl")]] <- NULL
    },
    ignoreInit = TRUE,
    once = TRUE)
  })
  
  observe({
    tables_list <- reactiveValuesToList(uiTbl)
    tables_list <- tables_list[order(names(tables_list))]
    table_lengths <- lengths(tables_list)
    cumsum_table_lengths <- cumsum(table_lengths)[table_lengths != 0L]
    for(i in seq_along(cumsum_table_lengths)){
      names(uiTbl[[names(cumsum_table_lengths[i])]]) <- paste("Col", cumsum_table_lengths[i])
    }
  })
  
}

shinyApp(ui, server)

Advertisement

Answer

You could collect the user’s deletion choices as a reactive value in the server part:

    deletable_tables <- reactiveVal()

… add a select input to your UI (I chose a selectize input)

    selectizeInput('deletionSelector', 'delete tables:',
                   choices = NULL, multiple = TRUE,
                   options = list(placeholder = 'choose table(s)')
                   )

and update this value in your event observer for input$addTbl:

    observeEvent(input$addTbl, {
    ## ...
        deletable_tables(c(deletable_tables(),  dtID))

        updateSelectizeInput(inputId = 'deletionSelector', 
                             session = session, 
                             choices = deletable_tables()
                             )
    ## ...
    }

(note that a reactiveVal is set with an argument rather than via assignment operator: my_reactive_val(x) instead of my_reactive_val <- x)

edit Please see working version below. I added a “Delete” button: when triggering delete on selection change, tables would be removed until none are left.

library(shiny)
library(rhandsontable)

data1 <- data.frame(row.names = c("A","B","C","Sum"),"Tbl 1"=c(1,1,0,2),check.names=FALSE)

ui <- fluidPage(
    selectizeInput('deletionSelector', 'delete tables:',
                   choices = NULL, multiple = FALSE,
                   options = list(placeholder = 'choose table(s)')
                   ),
    p(actionButton('deleteTbl', 'delete selection')),
    p(actionButton("addTbl","Add table")),
    tags$div(id="placeholder",tags$div(rHandsontableOutput("hottable1"))),
    )


server <- function(input, output, session) {
    ## store the tables in a list "data" within the
    ## reactive list "ui_tables":
    ui_tables <- reactiveValues(data = list()) 
    delete_ID <- reactiveVal()
    
    ## present initial table on initialisation
    observe({
        ui_tables$data$div_01_tbl <- rhandsontable(data1, useTypes = TRUE)
        output$hottable1 <- renderRHandsontable(ui_tables$data$div_01_tbl)
    }) |> bindEvent('input$addTbl')    

    observeEvent(input$addTbl, {
        divID <- sprintf('div_%02.f', input$addTbl + 1)
        dtID <- paste0(divID, '_tbl')
        ui_tables$data[[dtID]] <- rhandsontable(data1, useTypes = TRUE)
        
        insertUI(selector = "#placeholder",
                 ui = tags$div(id = divID,
                               h4(dtID),
                               rHandsontableOutput(outputId = dtID))
                 )

        output[[dtID]] <- renderRHandsontable({ui_tables$data[[dtID]]})
        
        updateSelectizeInput(
            inputId = 'deletionSelector', 
            session = session, 
            choices = c(dtID, names(ui_tables$data))
        )
    }, ignoreInit = TRUE, ignoreNULL = TRUE)


    observe({        
        delete_ID(input$deletionSelector)
        div_id  = gsub('(div_.*?)_.*$', '\1', delete_ID())
        removeUI(selector = paste0('#', div_id))
        ui_tables$data[[delete_ID()]] <- NULL
        updateSelectizeInput(inputId = 'deletionSelector', session = session, 
                             choices = names(ui_tables$data)
                             )

    }) |>  bindEvent(input$deleteTbl)

}


shinyApp(ui, server)


User contributions licensed under: CC BY-SA
1 People found this is helpful
Advertisement