├── .gitignore ├── pics ├── cover2.jpg └── screenshot2.JPG ├── dtdbshiny.Rproj ├── app ├── prep.R └── app.R └── README.md /.gitignore: -------------------------------------------------------------------------------- 1 | .Rproj.user 2 | .Rhistory 3 | .RData 4 | .Ruserdata 5 | -------------------------------------------------------------------------------- /pics/cover2.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/MangoTheCat/dtdbshiny/master/pics/cover2.jpg -------------------------------------------------------------------------------- /pics/screenshot2.JPG: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/MangoTheCat/dtdbshiny/master/pics/screenshot2.JPG -------------------------------------------------------------------------------- /dtdbshiny.Rproj: -------------------------------------------------------------------------------- 1 | Version: 1.0 2 | 3 | RestoreWorkspace: Default 4 | SaveWorkspace: Default 5 | AlwaysSaveHistory: Default 6 | 7 | EnableCodeIndexing: Yes 8 | UseSpacesForTab: Yes 9 | NumSpacesForTab: 2 10 | Encoding: UTF-8 11 | 12 | RnwWeave: knitr 13 | LaTeX: pdfLaTeX 14 | -------------------------------------------------------------------------------- /app/prep.R: -------------------------------------------------------------------------------- 1 | # Write source dataset to DB 2 | # 3 | #---------------------------------------- 4 | # Load libraries 5 | library(DBI) 6 | library(RPostgreSQL) 7 | library(dplyr) 8 | 9 | #---------------------------------------- 10 | # Write dplyr::nasa dataset to PostgreSQL 11 | con <- DBI::dbConnect(drv = dbDriver("PostgreSQL"), 12 | dbname="demo", 13 | host="localhost", 14 | user= "postgres", 15 | password="ava2post") 16 | 17 | nasa <- as.data.frame(nasa) %>% 18 | mutate(id = 1:n()) %>% 19 | select(id, everything()) 20 | 21 | DBI::dbWriteTable(con, "nasa", nasa, overwrite = TRUE, row.names = FALSE) 22 | 23 | #---------------------------------------- 24 | # Read from DB just to check 25 | #nasa1 <- dbReadTable(con, "nasa", check.names = FALSE) 26 | 27 | dbDisconnect(con) 28 | -------------------------------------------------------------------------------- /app/app.R: -------------------------------------------------------------------------------- 1 | # Demo DataTable + postgres in Shiny 2 | # 3 | #---------------------------------------- 4 | # Load libraries 5 | library(shiny) 6 | library(DT) 7 | library(pool) 8 | library(DBI) 9 | library(RPostgreSQL) 10 | library(dplyr) 11 | library(glue) 12 | 13 | if(packageVersion("DT")<"0.2.30"){ 14 | message("Inline editing requires DT version >= 0.2.30. Installing...") 15 | devtools::install_github('rstudio/DT') 16 | } 17 | 18 | if(packageVersion("glue")<"1.2.0.9000"){ 19 | message("String interpolation implemented in glue version 1.2.0 but this version doesn't convert NA to NULL. Requires version 1.2.0.9000. Installing....") 20 | devtools::install_github('tidyverse/glue') 21 | } 22 | 23 | #---------------------------------------- 24 | # helpers.R 25 | # Define function that updates a value in DB 26 | # updateDB(editedValue, pool, tbl) 27 | updateDB <- function(editedValue, pool, tbl){ 28 | # Keep only the last modification for a cell 29 | editedValue <- editedValue %>% 30 | group_by(row, col) %>% 31 | filter(value == dplyr::last(value)| is.na(value)) %>% 32 | ungroup() 33 | 34 | conn <- poolCheckout(pool) 35 | 36 | lapply(seq_len(nrow(editedValue)), function(i){ 37 | id = editedValue$row[i] 38 | col = dbListFields(pool, tbl)[editedValue$col[i]] 39 | value = editedValue$value[i] 40 | 41 | query <- glue::glue_sql("UPDATE {`tbl`} SET 42 | {`col`} = {value} 43 | WHERE id = {id} 44 | ", .con = conn) 45 | 46 | dbExecute(conn, sqlInterpolate(ANSI(), query)) 47 | }) 48 | 49 | poolReturn(conn) 50 | print(editedValue) 51 | return(invisible()) 52 | } 53 | 54 | 55 | 56 | #---------------------------------------- shiny 57 | # Define pool handler by pool on global level 58 | pool <- pool::dbPool(drv = dbDriver("PostgreSQL"), 59 | dbname="demo", 60 | host="localhost", 61 | user= "postgres", 62 | password="ava2post") 63 | 64 | onStop(function() { 65 | poolClose(pool) 66 | }) # important! 67 | 68 | #---------------------------------------- 69 | # Define UI 70 | ui <- fluidPage( 71 | 72 | # Application title 73 | titlePanel("dbdtshiny - Inline Editing and Database Updating"), 74 | 75 | sidebarLayout( 76 | sidebarPanel( 77 | width = 2, 78 | helpText("This shiny app demos inline editing with 79 | DataTable(DT) as frontend and postgresql as backend. 80 | After you double click on a cell and edit the value, 81 | the Save and Cancel buttons will show up. Click on Save if 82 | you want to save the updated values to database; click on 83 | Cancel to reset."), 84 | uiOutput("buttons") 85 | ), 86 | mainPanel( 87 | tabsetPanel( 88 | tabPanel("View", br(), DT::dataTableOutput("mydt")) 89 | ) 90 | ) 91 | ) 92 | ) 93 | #---------------------------------------- 94 | # Define server 95 | server <- function(input, output, session) { 96 | 97 | rvs <- reactiveValues( 98 | data = NA, 99 | dbdata = NA, 100 | dataSame = TRUE, 101 | editedInfo = NA 102 | ) 103 | 104 | #----------------------------------------- 105 | # Generate source via reactive expression 106 | mysource <- reactive({ 107 | pool %>% tbl("nasa") %>% collect() 108 | }) 109 | 110 | # Observe the source, update reactive values accordingly 111 | observeEvent(mysource(), { 112 | 113 | # Lightly format data by arranging id 114 | # Not sure why disordered after sending UPDATE query in db 115 | data <- mysource() %>% arrange(id) 116 | 117 | rvs$data <- data 118 | rvs$dbdata <- data 119 | 120 | }) 121 | 122 | #----------------------------------------- 123 | # Render DT table and edit cell 124 | # 125 | # no curly bracket inside renderDataTable 126 | # selection better be none 127 | # editable must be TRUE 128 | output$mydt <- DT::renderDataTable( 129 | rvs$data, rownames = FALSE, editable = TRUE, selection = 'none' 130 | ) 131 | 132 | proxy3 = dataTableProxy('mydt') 133 | 134 | observeEvent(input$mydt_cell_edit, { 135 | 136 | info = input$mydt_cell_edit 137 | 138 | i = info$row 139 | j = info$col = info$col + 1 # column index offset by 1 140 | v = info$value 141 | 142 | rvs$data[i, j] <<- DT::coerceValue(v, dplyr::pull(rvs$data[i, j])) 143 | replaceData(proxy3, rvs$data, resetPaging = FALSE, rownames = FALSE) 144 | 145 | rvs$dataSame <- identical(rvs$data, rvs$dbdata) 146 | 147 | if (all(is.na(rvs$editedInfo))) { 148 | rvs$editedInfo <- data.frame(info, stringsAsFactors = FALSE) 149 | } else { 150 | rvs$editedInfo <- dplyr::bind_rows(rvs$editedInfo, data.frame(info, stringsAsFactors = FALSE)) 151 | } 152 | 153 | }) 154 | 155 | 156 | #----------------------------------------- 157 | # Update edited values in db once save is clicked 158 | observeEvent(input$save, { 159 | 160 | updateDB(editedValue = rvs$editedInfo, pool = pool, tbl = "nasa") 161 | 162 | rvs$dbdata <- rvs$data 163 | rvs$dataSame <- TRUE 164 | }) 165 | 166 | #----------------------------------------- 167 | # Oberve cancel -> revert to last saved version 168 | observeEvent(input$cancel, { 169 | rvs$data <- rvs$dbdata 170 | rvs$dataSame <- TRUE 171 | }) 172 | 173 | #----------------------------------------- 174 | # UI buttons 175 | output$buttons <- renderUI({ 176 | div( 177 | if (! rvs$dataSame) { 178 | span( 179 | actionButton(inputId = "save", label = "Save", 180 | class = "btn-primary"), 181 | actionButton(inputId = "cancel", label = "Cancel") 182 | ) 183 | } else { 184 | span() 185 | } 186 | ) 187 | }) 188 | 189 | } 190 | 191 | # Run the application 192 | shinyApp(ui = ui, server = server) 193 | 194 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Database Bulk Update and Inline Editing in Shiny Application 2 | ================ 3 | Ava Yang 4 | 5 | Motivation 6 | ---------- 7 | 8 | There are times when it costs more than it should to leverage javascript, database, html, models and algorithms in one language. Now maybe is time for connecting some dots, without stretching too much. 9 | 10 | - If you have been developing shiny apps, consider letting it sit on one live database instead of manipulating data I/O by hand? 11 | - If you use DT to display tables in shiny apps, care to unleash the power of interactivity to its full? 12 | - If you struggle with constructing SQL queries in R, so did we. 13 | 14 | Inspired (mainly) by exciting new inline editing feature of [DT](https://blog.rstudio.com/2018/03/29/dt-0-4/), we created a minimal shiny app demo to show how you can update multiple values from DT and send the edits to database at a time. 15 | 16 | As seen in the screenshot, after double clicking on a cell and editing the value, Save and Cancel buttons will show up. Continue editing, the updates are stored in a temporary (reactiveValue) object. Click on Save if you want to send bulk updates to database; click on Cancel to reset. 17 | 18 | 19 | 20 | Global 21 | ------ 22 | 23 | On global level, we use `pool` to manage database connections. A database connection pool object is constructed. With the `onStop()` function, the pool object gets closed after a session ends. It massively saves you from worrying about when to open or close a connection. 24 | 25 | ``` r 26 | # Define pool handler by pool on global level 27 | pool <- pool::dbPool(drv = dbDriver("PostgreSQL"), 28 | dbname="demo", 29 | host="localhost", 30 | user= "postgres", 31 | password="ava2post") 32 | 33 | onStop(function() { 34 | poolClose(pool) 35 | }) # important! 36 | ``` 37 | 38 | Next job is to define a function to update database. The `glue_sql` function puts together a SQL query in a human readable way. Writing SQL queries in R was bit of a nightmare. If you used to assemble a SQL clause by `sprintf` or `past`, you know what I'm talking about. The glued query is then processed by `sqlInterpolate` for SQL injection protection before being executed. 39 | 40 | ``` r 41 | updateDB <- function(editedValue, pool, tbl){ 42 | # Keep only the last modification for a cell 43 | editedValue <- editedValue %>% 44 | group_by(row, col) %>% 45 | filter(value == dplyr::last(value)| is.na(value)) %>% 46 | ungroup() 47 | 48 | conn <- poolCheckout(pool) 49 | 50 | lapply(seq_len(nrow(editedValue)), function(i){ 51 | id = editedValue$row[i] 52 | col = dbListFields(pool, tbl)[editedValue$col[i]] 53 | value = editedValue$value[i] 54 | 55 | query <- glue::glue_sql("UPDATE {`tbl`} SET 56 | {`col`} = {value} 57 | WHERE id = {id} 58 | ", .con = conn) 59 | 60 | dbExecute(conn, sqlInterpolate(ANSI(), query)) 61 | }) 62 | 63 | poolReturn(conn) 64 | print(editedValue) 65 | return(invisible()) 66 | } 67 | ``` 68 | 69 | Server 70 | ------ 71 | 72 | We begin with server.R from defining a couple of reactive values: **data** for most dynamic data object, **dbdata** for what's in database, **dataSame** for whether data has changed from database, **editedInfo** for edited cell information (row, col and value). Next, create a reactive expression of source data to retrieve data, and assign it to reactive values. 73 | 74 | ``` r 75 | # Generate reactive values 76 | rvs <- reactiveValues( 77 | data = NA, 78 | dbdata = NA, 79 | dataSame = TRUE, 80 | editedInfo = NA 81 | ) 82 | 83 | # Generate source via reactive expression 84 | mysource <- reactive({ 85 | pool %>% tbl("nasa") %>% collect() 86 | }) 87 | 88 | # Observe the source, update reactive values accordingly 89 | observeEvent(mysource(), { 90 | 91 | # Lightly format data by arranging id 92 | # Not sure why disordered after sending UPDATE query in db 93 | data <- mysource() %>% arrange(id) 94 | 95 | rvs$data <- data 96 | rvs$dbdata <- data 97 | 98 | }) 99 | ``` 100 | 101 | We then render a DataTable object, create its proxy. Note that the **editable** parameter needs to be explicitly turned on. Finally with some format tweaking, we can merge the cell information, including row id, column id and value, with DT proxy and keep all edits as a single reactive value. See [examples](https://github.com/rstudio/DT/pull/480) for details. 102 | 103 | ``` r 104 | # Render DT table and edit cell 105 | # 106 | # no curly bracket inside renderDataTable 107 | # selection better be none 108 | # editable must be TRUE 109 | output$mydt <- DT::renderDataTable( 110 | rvs$data, rownames = FALSE, editable = TRUE, selection = 'none' 111 | ) 112 | 113 | proxy3 = dataTableProxy('mydt') 114 | 115 | observeEvent(input$mydt_cell_edit, { 116 | 117 | info = input$mydt_cell_edit 118 | 119 | i = info$row 120 | j = info$col = info$col + 1 # column index offset by 1 121 | v = info$value 122 | 123 | info$value <- as.numeric(info$value) 124 | 125 | rvs$data[i, j] <<- DT::coerceValue(v, purrr::flatten_dbl(rvs$data[i, j])) 126 | replaceData(proxy3, rvs$data, resetPaging = FALSE, rownames = FALSE) 127 | 128 | rvs$dataSame <- identical(rvs$data, rvs$dbdata) 129 | 130 | if (all(is.na(rvs$editedInfo))) { 131 | rvs$editedInfo <- data.frame(info) 132 | } else { 133 | rvs$editedInfo <- dplyr::bind_rows(rvs$editedInfo, data.frame(info)) 134 | } 135 | }) 136 | ``` 137 | 138 | Once Save button is clicked upon, send bulk updates to database using the function we defined above. Discard current edits and revert DT to last saved status of database when you hit Cancel. Last chunk is a little trick that generates interactive UI buttons. When dynamic data object differs from the database representative object, show Save and Cancel buttons; otherwise hide them. 139 | 140 | ``` r 141 | # Update edited values in db once save is clicked 142 | observeEvent(input$save, { 143 | updateDB(editedValue = rvs$editedInfo, pool = pool, tbl = "nasa") 144 | 145 | rvs$dbdata <- rvs$data 146 | rvs$dataSame <- TRUE 147 | }) 148 | 149 | # Observe cancel -> revert to last saved version 150 | observeEvent(input$cancel, { 151 | rvs$data <- rvs$dbdata 152 | rvs$dataSame <- TRUE 153 | }) 154 | 155 | # UI buttons 156 | output$buttons <- renderUI({ 157 | div( 158 | if (! rvs$dataSame) { 159 | span( 160 | actionButton(inputId = "save", label = "Save", 161 | class = "btn-primary"), 162 | actionButton(inputId = "cancel", label = "Cancel") 163 | ) 164 | } else { 165 | span() 166 | } 167 | ) 168 | }) 169 | ``` 170 | 171 | UI 172 | -- 173 | 174 | The UI part is exactly what you normally do. Nothing new. 175 | 176 | Bon Appétit 177 | ----------- 178 | 179 | 1. Set up a database instance e.g. PostgreSQL, SQLite, mySQL or MS SQL Server etc. 180 | 2. Download/clone the [GitHub repository](https://github.com/MangoTheCat/dtdbshiny) 181 | 3. Run through script `app/prep.R` but change database details to one's own. It writes to DB our demo dataset which is the *nasa* dataset from dplyr with an index column added 182 | 4. Also update database details in `app/app.R` and run 183 | 184 | shiny::runApp("app") 185 | 186 | Acknowledgement 187 | --------------- 188 | 189 | Workhorse functionality is made possible by: 190 | 191 | - DBI: R Database Interface 192 | - RPostgreSQL: R Interface to PostgreSQL (one of many relational database options) 193 | - pool: DBI connection object pooling 194 | - DT: R Interface to the jQuery Plug-in DataTables (requires version >= 0.2.30) 195 | - Shiny: Web Application Framework for R 196 | - dplyr: Data manipulation 197 | - glue: Glue strings to data in R. Small, fast, dependency free interpreted string literals (requires version >= 1.2.0.9000. Blank cell crashes the app with version 1.2.0) 198 | --------------------------------------------------------------------------------