Why is my reactive data frame in R shiny not updating correctly when using an observeEvent?-CodePudding

In the below code, I use observeEvent(input$delSeries3, {...}) and renderUI(selectInput(...)) to allow the user to delete selected columns from the reactive data frame emptyTbl(). When running that observeEvent() and sending the data frame values (after deleting a column) into the global environment with test <<- tmp, for testing purposes, it works fine. I review the resulting post-deletion values of the test object in the R studio console and they look fine. However, when I comment out that test <<- tmp and replace it with emptyTbl(tmp) (currently commented out in the below code) in an attempt to send those tmp values back into the reactive space and re-render the table to reflect the column deletion, the code no longer works as intended: it incorrectly automatically deletes the first column and otherwise gives strange results. I tried wrapping with isolate() in different places and this didn't help.

The code is supposed to allow the user to add columns with action button "addSeries" (this works), allow the user to manually edit cells using the rhandsontable package and retain those edits (this works, using hot_to_r(input$hottable)), and allow the user to delete selected columns with action button "delSeries" (not quite working).

What am I doing wrong here with column deletion? Something is missing in my understanding of reactivity and observers.

Code:

library(dplyr)
library(rhandsontable)
library(shiny)
library(shinyjs)

mydata <- data.frame('Series 1' = c(1,24,0,1), check.names = FALSE)
rownames(mydata) <- c('Term A','Term B','Term C','Term D') 

ui <- fluidPage(br(),
  useShinyjs(), 
  rHandsontableOutput('hottable'),br(),
  fluidRow(
    column(1,actionButton("addSeries", "Add",width = '70px')),
    column(1,actionButton("delSeries","Delete",width = '70px')),
    column(3,hidden(uiOutput("delSeries2"))) 
  )
)

server <- function(input, output) {
  
  emptyTbl <- reactiveVal(mydata)
  
  observeEvent(input$hottable, {emptyTbl(hot_to_r(input$hottable))})
  
  output$hottable <- renderRHandsontable({
    rhandsontable(emptyTbl(),rowHeaderWidth = 100, useTypes = TRUE)
  })
  
  observeEvent(input$addSeries, {
    newCol <- data.frame(c(1,24,0,1))
    names(newCol) <- paste("Series", ncol(hot_to_r(input$hottable))   1)
    emptyTbl(cbind(emptyTbl(), newCol))
  })
  
  observeEvent(input$delSeries3, {
    tmp <- emptyTbl()                                       # values of reactive DF emptyTbl sent to tmp
    delCol <- input$delSeries3                              # specify column to delete from selectInput() choice
    tmp <- tmp[ , !(names(tmp) %in% delCol), drop = FALSE]  # delete selected column
    newNames <- sprintf("Series %d",seq(1:ncol(tmp)))       # generate new column header sequence
    names(tmp) <- newNames                                  # assign new column headers to DF
    test <<- tmp                                            # send tmp DF to global environment for testing only
    # emptyTbl(tmp)                                           # sends values of tmpDF back to reactive DF emptyTbl
  })

  observeEvent(input$delSeries, show("delSeries2"))
  observeEvent(input$addSeries, hide("delSeries2")) 
  
  output$delSeries2 <- renderUI(selectInput("delSeries3", label = NULL,
                                   choices = colnames(hot_to_r(input$hottable)), 
                                   selected = "")
                                )

}

shinyApp(ui,server)

CodePudding user response：

The issue is that by default the selected value of a selectInput defaults to the first element in the choices list when not specified. Hence, when creating "delSeries3" the selected argument is the the first column or series which triggers the observeEvent and deletes that column. One easy fix would be to set multiple=TRUE in which case selected defaults to no values. A second option would be to "slow down the app" by e.g. adding another actionButton which the user has to click after selecting the column(s) he wants to delete.

library(dplyr)
library(rhandsontable)
library(shiny)
library(shinyjs)

mydata <- data.frame("Series 1" = c(1, 24, 0, 1), check.names = FALSE)
rownames(mydata) <- c("Term A", "Term B", "Term C", "Term D")

ui <- fluidPage(
  br(),
  useShinyjs(),
  rHandsontableOutput("hottable"), br(),
  fluidRow(
    column(1, actionButton("addSeries", "Add", width = "70px")),
    column(1, actionButton("delSeries", "Delete", width = "70px")),
    column(3, hidden(uiOutput("delSeries2")))
  )
)

server <- function(input, output) {
  emptyTbl <- reactiveVal(mydata)

  observeEvent(input$hottable, {
    emptyTbl(hot_to_r(input$hottable))
  })

  output$hottable <- renderRHandsontable({
    rhandsontable(emptyTbl(), rowHeaderWidth = 100, useTypes = TRUE)
  })

  observeEvent(input$addSeries, {
    newCol <- data.frame(c(1, 24, 0, 1))
    names(newCol) <- paste("Series", ncol(hot_to_r(input$hottable))   1)
    emptyTbl(cbind(emptyTbl(), newCol))
  })

  observeEvent(input$delSeries3, {
    tmp <- emptyTbl() # values of reactive DF emptyTbl sent to tmp
    delCol <- input$delSeries3 # specify column to delete from selectInput() choice
    tmp <- tmp[, !(names(tmp) %in% delCol), drop = FALSE] # delete selected column
    newNames <- sprintf("Series %d", seq(1:ncol(tmp))) # generate new column header sequence
    names(tmp) <- newNames # assign new column headers to DF
    # test <<- tmp                                            # send tmp DF to global environment for testing only
    emptyTbl(tmp) # sends values of tmpDF back to reactive DF emptyTbl
  })

  observeEvent(input$delSeries, show("delSeries2"))
  observeEvent(input$addSeries, hide("delSeries2"))

  output$delSeries2 <- renderUI(selectInput("delSeries3",
    label = NULL,
    choices = colnames(hot_to_r(input$hottable)),
    selected = NULL,
    multiple = TRUE
  ))
}

shinyApp(ui, server)