CODEWITHSUNDEEP
rshinydtshinymodules
franuentes
franuentes

Reputation: 27

R shiny - Returning editable datatable from module

I've written an R shiny app which uses a module to create an editable datatable. The editable datatable is displayed correctly when the module runs using a reactiveValues I've named rved. However, when I try to return rved from the module after an actionButton is pressed, the module returns NA.

The app is intended to work as follows: A user first selects which rows to view. For each selected case, a module is run. This module creates inputs for how many variables to edit, which variables to edit, and outputs an editable datatable. The user is then meant write in a new value for the selected variables for the selected rows.

When the user presses a confirm actionButton, the module should return the editable datatable and save these results to a .rds file.

It appears the module takes the initial value when I initially define rved = reactiveValues(data = NA) , but does not appear to update rved outside of the observe() and observeEvent({}) environments.

Any help would be greatly appreciated.

library(shiny)
library(DT)

set.seed(2024)
data <- data.frame(rowID=1:4, var1=sample(1:4,4), var2=sample(1:4,4), var3=sample(1:4,4), var4=sample(1:4,4))

ui_module <- function(id, idx){
  ns <- NS(id)
  tagList(
    wellPanel(uiOutput(ns("num_changes")), uiOutput(ns("vars_to_change")), 
              dataTableOutput(ns("edit_table")),id=paste0("well", idx), class="wells"))
}

server_module <- function(id, rowID, returnedittable=F){
  moduleServer(
    id,
    function(input, output, session) {
      
      ns <- session$ns
      
      output$num_changes <- renderUI({
        numericInput(ns("num_changes"), "select number of variables to change:", value=1, min=1, max = 4, step=1)
      })
      
      output$vars_to_change <- renderUI({
        req(input$num_changes)
        vars_to_change_list <- lapply(1:input$num_changes, function(i) {
          name <- ns(paste0("vars_to_change_", i, sep=""))
          selectInput(name, "Select variable to change", names(data)[2:ncol(data)], selected="")
        })
        do.call(tagList, vars_to_change_list)
      })
      
      edit_table_func <- reactive({
        req(rowID)
        req(input$num_changes)
        df <- data.frame(matrix(nrow=input$num_changes, ncol=4))
        colnames(df) <- c("rowID", "var_name", "current_value", "new_value")
        df$rowID <- rowID
        df$var_name <- sapply(1:input$num_changes, FUN=function(i) {
          name <- paste0("vars_to_change_", i, sep="")
          input[[name]]
        })
        df$current_value <- sapply(1:input$num_changes, FUN=function(i) {
          data[data$rowID==rowID, as.character(df$var_name[i])]
        })
        return(df)
      })
      
      rved <- reactiveValues(data=NA)

      observe({
        req(rowID)
        req(input$num_changes)
        rved$data <- edit_table_func()
      })
      
      output$edit_table <- renderDataTable({
        req(rowID)
        req(input$num_changes)
        df <- edit_table_func()
        editable_columns = c("new_value")
        not_editable_columns = which(!colnames(df) %in% editable_columns) - 1
        datatable(rved$data, rownames = F,editable=list(target="cell", disable=list(columns=not_editable_columns)), selection = "none", options = list(iDisplayLength = 1000, dom = 'tir', columnDefs = list(list(className = 'dt-center', targets = "_all"))))
      })
      
      observeEvent(input$edit_table_cell_edit, {
        req(rowID)
        req(input$num_changes)
        for(i in 1:input$num_changes){
          name_input <- paste0("vars_to_change_", i, sep="")
          req(input[[name_input]])
        }
        rved$data <- data.frame(lapply(rved$data, as.character), stringsAsFactors=FALSE)
        req(input$edit_table_cell_edit)
        rved$data <<- editData(rved$data, input$edit_table_cell_edit, rownames = FALSE)
      })
      
      reactive(for (i in 1:input$num_changes) {
        local({
          name <- ns(paste0("vars_to_change_", i, sep=""))
          input[[name]]
        })
      })
      
      if(isTRUE(returnedittable)){
        return(reactive({rved$data}))
      }
    }
  )
}

ui <- fluidPage(
  titlePanel("Simple app w module"),
  sidebarLayout(
    sidebarPanel(width=2,
                                  uiOutput("rowID"),
                                  actionButton("confirm", "Confirm & save")
    ),
    mainPanel( width=10,
                           tabPanel("Resolve rowID", value='editor', 
                                    wellPanel(style = "background: powderBlue", id="fixed_panel")
                           )
    )
  )
)

server <- function(input, output, session) {
  get_rowID_options <- reactive({
    rowID_options <- unique(data$rowID)
    return(rowID_options)
  })
  
  output$rowID <- renderUI({
    selectInput("rowID", "Select rowID", get_rowID_options(), get_rowID_options(), multiple = T)
  })
  
  observeEvent(input$rowID, ignoreNULL = F, {
      choices <- get_rowID_options()
      num_choices <- length(choices)
      
      if(is.null(input$rowID)){
        removeUI(selector = ".wells", multiple = T)
        
      } else{
        matches <- match(input$rowID, choices)
        lapply(seq_along(matches), FUN=function(x) {
          id_name = paste0("id", matches[x])
          removeUI(selector = paste0("#well", matches[x]), multiple = T)
          if(x==1){
            well_id <- "#fixed_panel"
            insertUI(
              selector = well_id,
              where = "beforeEnd",
              ui = ui_module(id = id_name, idx=matches[x])
            )
          }
          if(x>1){
            well_id <- paste0("#well", matches[x-1])
            insertUI(
              selector = well_id,
              where = "afterEnd",
              ui = ui_module(id = id_name, idx=matches[x])
            )
          }
          rowID_idx = choices[matches[x]]
          server_module(id=id_name, rowID=rowID_idx)
        })
        
        if(length(input$rowID) < num_choices){
          lapply(which(!choices %in% input$rowID), FUN=function(i){
            id_idx <- paste0("id", i)
            removeUI(selector = paste0("#well", i), multiple = T)
          })
        }
      }
  })
  
  observeEvent(input$confirm, {
    lapply(1:length(input$rowID), FUN=function(i) {
      id_name = paste0("id", i)
      idx <- paste0("id",i, "-")
      rows = input[[paste0(idx, "num_changes")]]
      
      df <- data.frame(matrix(nrow=rows, ncol=5))
      colnames(df) <- c("rowID", "edit_date", "var_name", "current_value", "new_value")
      df[,] <- NA
      
      rved2 <- server_module(id=id_name, rowID=input$rowID[i], returnedittable = T)

      df$var_name <- rved2()$var_name
      df$current_value <- rved2()$current_value
      df$new_value <- rved2()$new_value
      
      df$rowID <- input$rowID[i]
      df$edit_date <- as.character(Sys.Date())

      #assuming changes.rds already exists
      new_df <- rbind(readRDS("changes.rds"), df)
      saveRDS(new_df, "changes.rds")
    }
    )
  })
}

shinyApp(ui = ui, server = server)

Upvotes: 0

Views: 58

Answers (1)

St&#233;phane Laurent
St&#233;phane Laurent

Reputation: 84529

This seems to work. A notable change is that I execute the module server for every rowID, not in an observer.

library(shiny)
library(DT)

set.seed(2024)
data <- data.frame(
  rowID=1:4, 
  var1=sample(1:4,4), 
  var2=sample(1:4,4), 
  var3=sample(1:4,4), 
  var4=sample(1:4,4)
)

ui_module <- function(id, idx){
  ns <- NS(id)
  wellPanel(
    uiOutput(ns("ui_num_changes")), 
    uiOutput(ns("vars_to_change")), 
    DTOutput(ns("edit_table")),
    id = paste0("well", idx), 
    class = "wells"
  )
}

server_module <- function(id, rowID, returnedittable=FALSE){
  moduleServer(
    id,
    function(input, output, session) {
      
      ns <- session$ns
      
      output$ui_num_changes <- renderUI({
        numericInput(
          ns("num_changes"), "select number of variables to change:", 
          value=1, min=1, max = 4, step=1
        )
      })
      
      output$vars_to_change <- renderUI({
        req(input$num_changes)
        vars_to_change_list <- lapply(1:input$num_changes, function(i) {
          name <- ns(paste0("vars_to_change_", i, sep=""))
          selectInput(
            name, "Select variable to change", 
            names(data)[2:ncol(data)], selected=""
          )
        })
        do.call(tagList, vars_to_change_list)
      })
      
      observe({
        print(input$vars_to_change_1)
      })
      
      VarsToChange <- reactive({
        req(input$num_changes)
        vtc <- lapply(1:input$num_changes, FUN=function(i) {
          name <- paste0("vars_to_change_", i, sep="")
          input[[name]]
        })
        ok <- sapply(vtc, Negate(is.null))
        req(all(ok))
        unlist(vtc)
      })
      
      edit_table_func <- reactive({
        req(VarsToChange())
        #req(all(VarsToChange() != ""))
        df <- data.frame(matrix(nrow=input$num_changes, ncol=4))
        colnames(df) <- c("rowID", "var_name", "current_value", "new_value")
        df$rowID <- rowID
        df$var_name <- VarsToChange()
        df$current_value <- sapply(1:input$num_changes, FUN=function(i) {
          data[data$rowID==rowID, as.character(df$var_name[i])]
        })
        return(df)
      })
      
      rved <- reactiveValues(data=NA)
      
      observe({
        rved$data <- edit_table_func()
      })
      
      output$edit_table <- renderDT({
        df <- edit_table_func()
        editable_columns = c("new_value")
        not_editable_columns = which(!colnames(df) %in% editable_columns) - 1
        datatable(
          rved$data, rownames = FALSE, 
          editable=list(target="cell", disable=list(columns=not_editable_columns)), 
          selection = "none", 
          options = list(
            iDisplayLength = 1000, 
            dom = 'tir', 
            columnDefs = list(
              list(className = 'dt-center', targets = "_all")
            )
          )
        )
      })
      
      observeEvent(input$edit_table_cell_edit, {
        rved$data <- editData(rved$data, input$edit_table_cell_edit, rownames = FALSE)
      })
      
      if(isTRUE(returnedittable)){
        return(reactive({rved$data}))
      }
    }
  )
}

ui <- fluidPage(
  titlePanel("Simple app w module"),
  sidebarLayout(
    sidebarPanel(width=2,
                 uiOutput("ui_rowID"),
                 actionButton("confirm", "Confirm & save")
    ),
    mainPanel(
      width=10,
      wellPanel(style = "background: powderBlue", id="fixed_panel")
    )
  )
)

server <- function(input, output, session) {
  get_rowID_options <- unique(data$rowID)

  output$ui_rowID <- renderUI({
    selectInput(
      "rowID", "Select rowID", 
      get_rowID_options, multiple = TRUE, selected = NULL
    )
  })
  
  observeEvent(input$rowID, ignoreNULL = TRUE, {
    choices <- get_rowID_options
    num_choices <- length(choices)
    
    if(is.null(input$rowID)){
      removeUI(selector = ".wells", multiple = T)
      
    } else{
      matches <- match(input$rowID, choices)
      lapply(seq_along(matches), FUN=function(x) {
        id_name = paste0("id", matches[x])
        removeUI(selector = paste0("#well", matches[x]), multiple = TRUE)
        if(x==1){
          well_id <- "#fixed_panel"
          insertUI(
            selector = well_id,
            where = "beforeEnd",
            ui = ui_module(id = id_name, idx=matches[x])
          )
        }
        if(x>1){
          well_id <- paste0("#well", matches[x-1])
          insertUI(
            selector = well_id,
            where = "afterEnd",
            ui = ui_module(id = id_name, idx=matches[x])
          )
        }
      })
      
      if(length(input$rowID) < num_choices){
        lapply(which(!choices %in% input$rowID), FUN=function(i){
          id_idx <- paste0("id", i)
          removeUI(selector = paste0("#well", i), multiple = T)
        })
      }
    }
  })
  
  Tables <- setNames(lapply(1:4, function(i) {
    id_name <- paste0("id", i)
    rowID_idx <- get_rowID_options[i]
    server_module(id=id_name, rowID=rowID_idx, returnedittable=TRUE)
  }), as.character(get_rowID_options))
  
  observeEvent(input$confirm, {
    lapply(input$rowID, FUN=function(rowid) {
      tabl <- Tables[[as.character(rowid)]]()

      df <- tabl
      df$edit_date <- as.character(Sys.Date())
      
      if(file.exists("changes.rds")) {
        df <- rbind(readRDS("changes.rds"), df)
      }
      saveRDS(df, "changes.rds")
    }
    )
  })
}

shinyApp(ui = ui, server = server)

Upvotes: 1

Related Questions