从 R 闪亮的应用程序更新 PostgreSQL 数据库

Question

Please suggest how to update PostgreSQL database from R shiny app. I would like to be able to update values in table "testUpdate" in a PostgreSQL database:

1. Update "YN" after a checkbox is checked in 'x1' Data-table.
2. Update "Note" after "save_changes" button is pressed.

I've created fake data so you could see how the app works. Alternatively, I've included the data source. I haven't found one method that works well with R. Please suggest an implementation.

    library(dplyr)
    library(dbplyr)
    library(DBI)
    library(DT)
    library(data.table)
    library(shinyjs)
    library(shinydashboard)
    library(shinycssloaders)
    library(tidyr)
    library(tableHTML)
    library(shiny)
    
    library(RPostgreSQL)
    
    pool <- pool::dbPool(drv = dbDriver("PostgreSQL"),
                         dbname = "postgreDatabase",
                         host = "11.111.11.1",
                         port = '12342',
                         user = "fdc",
                         password = "password")
    
    shinyApp(
      
      ui = fluidPage(
        
      tabPanel("Test",
               sidebarLayout(position = "right",
                             sidebarPanel(id="sidebar",
                                          (DT::dataTableOutput("y1"))),
                             mainPanel(
                                           (DT::dataTableOutput("x1")))
                             
               ))),
      
      server = function(input, output, session) {
        
        buttonInput <- function(FUN, len, id, ...) {
          inputs <- character(len)
          for (i in seq_len(len)) {
            inputs[i] <- as.character(FUN(paste0(id, i), ...))
          }
          inputs
        }
        
        # create a character vector of shiny inputs
        shinyInput = function(FUN, len, id, value, width) {
          if (length(value) == 1) value <- rep(value, len)
          inputs = character(len)
          for (i in seq_len(len)) {
            inputs[i] = 
              as.character(FUN(paste0(id, i), label = NULL, value = value[i], width = width))
          }
          inputs
        }
        
        # obtain the values of inputs
        shinyValue = function(id, len, initial) {
          vapply(seq_len(len), function(i) {
            value = input[[paste0(id, i)]]
            if (is.null(value)) initial[i] else value
          }, FUN.VALUE = logical(1))
        }
        
#created fake data so you can run the app without the db.
        n = 10
        YN = rep(c(FALSE, TRUE), times = c(5,5))
       
        
        df1 = data.frame(
          cb = shinyInput(checkboxInput, n, 'cb_', 
                          value = YN, width='30px'),
          month = month.abb[1:n],
          YN = YN,
          ID = seq_len(n),
          stringsAsFactors = FALSE
        )
        
        #####alternatively data comes from table called "testUpdate"
        testUpdate <- tbl(db_pool,"testUpdate") %>% collect()
        testUpdate_cols <- testUpdate %>%
          select(ID, month, YN, Note)
        
        vals <- reactiveValues()
        
        vals$Data <- data.table(
          ID = seq_len(n),
          Note = c("test notes", "testing", "changed", "serial number", "", "", "", "", "testing", ""),
          'Update Note' = buttonInput(
            FUN = actionButton,
            len = n,
            id = 'button_',
            label = "?",
            onclick = 'Shiny.onInputChange(\"GoToNoteClick\",  this.id)'
          )
        )
        
        observeEvent(input$GoToNoteClick, {
          showModal(modal_modify)
        })
        
        modal_modify<-modalDialog(
          fluidPage(
            textAreaInput(
              "run_notes",
              label = "Notes:",
              width = "100%",
              height = "100px"
            ),
            actionButton("save_changes", "Save changes")
          ),
          size="l"
        )
        
        get_sel <- reactive({
          w <- input$x1_rows_selected
          df1[w,] -> out
          print(out)
          out
        })
        
        filterMain <- reactive({
          req(input$x1_rows_selected)
          w <- input$x1_rows_selected
          id_sel <- df1[w,'ID']
          print(id_sel)
          vals$Data %>% filter(ID %in% id_sel) -> out
          out
        })
        
        output$y1 <- DT::renderDataTable(
          
          datatable(
            {
              filterMain()
            }
            ,escape = FALSE,
            #class = "display compact",
            rownames=F,
            selection='none',
            options = list(
              dom = 't', paging = FALSE, ordering = FALSE)
            ))
          
        loopData = reactive({
          values = shinyValue('cb_', n, initial = YN)
          dat = df1
          dat$cb = shinyInput(checkboxInput, n, 'cb_',
                              value = values,
                              width = '30px')
          
          dat$YN = values
          dat
        })
        
        observeEvent(input$save_changes, {
          req(vals$Data)
          selected_row=as.numeric(gsub("button_","",input$GoToNoteClick))
          print(selected_row)
          curid <- vals$Data[selected_row,1]
          print(curid)
          print(input$run_notes)
          vals$Data$Note[vals$Data$ID %in% curid] <- input$run_notes
          ##write changes
          #write data back to postgreSQL
          qry = paste0("UPDATE SET Note = '';")
          print(qry)
          
          dbSendQuery(conn = db_pool, statement = qry)
          removeModal()
          
          
          #dbDisconnect(db_pool)
        })
        
        output$x1 = renderDT(
          df1, class = "display compact",
          escape = FALSE, selection = 'single', rownames=F,
          options = list(
            dom = 't', paging = FALSE, ordering = FALSE,
            preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
            drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); } ')
          ))
           
        proxy = dataTableProxy('x1')
        
        observe({
          replaceData(proxy, loopData(), resetPaging = FALSE, rownames=F)
        })
        
      }
    )

Answer 1

The database was updated using the following function from here: database bulk update

updateDB <- function(editedValue, id, field, pool, tbl){
  conn <- poolCheckout(pool)
  id = id
  col = field
  value = editedValue
  
  query <- glue::glue_sql("UPDATE {`tbl`} SET
                          {`col`} = {value}
                          WHERE runid = {id}
                          ", .con = conn)
  
  dbExecute(conn, sqlInterpolate(ANSI(), query))
  
  poolReturn(conn)
  return(invisible())
}

onStop(function() {
  poolClose(db_pool)
}) 

The functionally works great in Rstudio Server Pro, however doesn't work in a published app via Rstudio Connect. Any suggestion on how to make this work in Rstudio connect would be extremely helpful. Thanks