I'm building a shiny app where the user could update a table in a database by editing a selected row in a DT:table.
The problem is that process can be time-consuming when the dt:table has many columns (let's say 25 for instance). So I was wondering if there was a nice and efficient way to link my "vals" variables in the query below with the dataframe columns ?
The code below is working but since my DT:table has more than 60 columns I really cannot stick to this solution... :(
selected_row <- donnees[input$dt_rows_selected,]
query <- glue_sql('UPDATE myschema.mytable SET field1= ({vals*}), field2= ({vals2*}), field3 = ({vals3*}), field4= ({vals4*}), field5= ({vals5*}) WHERE id IN ({ID_field*});',
vals = selected_row$column1, vals2 = selected_row$column2, vals3= selected_row$column3, vals4= selected_row$column4, vals5= selected_row$column5, ID_field= selected_row$ID, .con = pool)
DBI::dbExecute(pool2, query)
The purpose of this answer is two-fold:
Demonstrate the (a?) proper postgres-style upsert action. I present a pg_upsert function, and in that function I've included (prefixed with #'#) what the query looks like when finished. The query is formed dynamically, so does not need a priori knowledge of the fields other than the user-provided idfields= argument.
Demonstrate how to react to DT-edits using this function. This is one way and there are definitely other ways to formulate how to deal with the reactive DT. If you have a different style for keeping track of changes in the DT, then feel free to take pg_upsert and run with it!
Notes:
it does not update the database with each cell edit, the changes are "batched" until the user clicks the Upsert! button; it is feasible to change to "upsert on each cell", but that would be a relatively trivial query, no need for upserts
since you're using postgres, the target table must have one or more unique indices (see No unique or exclusion constraint matching the ON CONFLICT); I'll create the sample data and the index on said table; if you don't understand what this means and your data doesn't have a clear "id" field(s), then do what I did: add an id column (both locally and in the db) that sequences along your real rows (this won't work if your data is preexisting and has no id fields)
the id field(s) must not be editable, so the editable= part of DT disables changing that column; I included a query (found in https://stackoverflow.com/a/2213199/3358272) that will tell you these fields programmatically; if this returns nothing, then go back to the previous bullet and fix it
the pg_upsert function takes a few steps to ensure things are clean (i.e., checks for duplicate ids), but does not check for incorrect new-values (DT does some of this for you, by class I believe), I'll assume you are verifying what you need before sending for an upsert;
the return value from pg_upsert is logical, indicating that the upsert action updated as many rows as we expected; this might be overly aggressive, though I cannot think of an example when it would correctly return other than nrow(value); caveat emptor
I include an optional "dbout" table in the shiny layout solely to show the current state of the database data, updated every time pg_upsert is called (indirectly); if no changes have been made, it will still query to show the current state, and is therefore the best way to show the starting condition for your testing; again, it is optional. When you remove it (and you should) and nothing else uses the do_update() reactive, then change
do_update <- eventReactive(input$upbtn, ...)
output$dbout <- renderTable({ do_update(); ... })
to
observeEvent(input$upbtn, ...)
# output$dbout <- renderTable({ do_update(); ... })
(Otherwise, a reactive(.) block that is never used downstream will never fire, so your updates would not happen.)
This app queries the database for all values (into curdata), this is likely already being done in your case. This app also finds (programmatically) the required indices. If you know ahead of time what these are, feel free to drop the query that feeds idfields and just assign it directly (case-sensitive).
When the app exits, the user-edited data is not stored in the local R console/environment, all changes are stored in the database. It's my assumption that this will be formalized into a shiny-server, RStudio Connect, or similar production server, in which case "console" has little meaning. If you really need the user-changed data to be available on the local R console while you are developing your app, then in addition to using mydata reactive values, after mydata$data is reassigned you can overwrite curdata <<- mydata$data (note the double < in <<-). I discourage this practice in production but it might be useful while in development.
Here is a setup for sample data. It doesn't matter if you have 6 (as here) or 60 columns, the premise remains. (After this, origdata is not used, it was a throw-away to prep for this answer.)
# pgcon <- DBI::dbConnect(...)
set.seed(42)
origdata <- iris[sample(nrow(iris), 6),]
origdata$id <- seq_len(nrow(origdata))
# setup for this answer
DBI::dbExecute(pgcon, "drop table if exists mydata")
DBI::dbWriteTable(pgcon, "mydata", origdata)
# postgres upserts require 'unique' index on 'id'
DBI::dbExecute(pgcon, "create unique index mydata_id_idx on mydata (id)")
Here is the UPSERT function itself, broken out to facilitate testing, console evaluation, and similar.
#' #param value 'data.frame', values to be updated, does not need to
#' include all columns in the database
#' #param name 'character', the table name to receive the updated
#' values
#' #param idfields 'character', one or more id fields that are present
#' in both the 'value' and the database table, these cannot change
#' #param con database connection object, from [DBI::dbConnect()]
#' #param verbose 'logical', be verbose about operation, default true
#' #return logical, whether 'nrow(value)' rows were affected; if an
#' error occurred, it is messaged to the console and a `FALSE` is
#' returned
pg_upsert <- function(value, name, idfields, con = NULL, verbose = TRUE) {
if (verbose) message(Sys.time(), " upsert ", name, " with ", nrow(value), " rows")
if (any(duplicated(value[idfields]))) {
message("'value' contains duplicates in the idfields, upsert will not work")
return(FALSE)
}
tmptable <- paste(c("uptemp_", name, "_", sample(1e6, size = 1)), collapse = "")
on.exit({
DBI::dbExecute(con, paste("drop table if exists", tmptable))
}, add = TRUE)
DBI::dbWriteTable(con, tmptable, value)
cn <- colnames(value)
quotednms <- DBI::dbQuoteIdentifier(con, cn)
notid <- DBI::dbQuoteIdentifier(con, setdiff(cn, idfields))
qry <- sprintf(
"INSERT INTO %s ( %s )
SELECT %s FROM %s
ON CONFLICT ( %s ) DO
UPDATE SET %s",
name, paste(quotednms, collapse = " , "),
paste(quotednms, collapse = " , "), tmptable,
paste(DBI::dbQuoteIdentifier(con, idfields), collapse = " , "),
paste(paste(notid, paste0("EXCLUDED.", notid), sep = "="), collapse = " , "))
#'# INSERT INTO mydata ( "Sepal.Length" , "Petal.Length" )
#'# SELECT "Sepal.Length" , "Petal.Length" , "id" FROM mydata
#'# ON CONFLICT ( "id" ) DO
#'# UPDATE SET "Sepal.Length"=EXCLUDED."Sepal.Length" , "Petal.Length"=EXCLUDED."Petal.Length"
# dbExecute returns the number of rows affected, this ensures we
# return a logical "yes, all rows were updated" or "no, something
# went wrong"
res <- tryCatch(DBI::dbExecute(con, qry), error = function(e) e)
if (inherits(res, "error")) {
msg <- paste("error upserting data:", conditionMessage(res))
message(Sys.time(), " ", msg)
ret <- FALSE
attr(ret, "error") <- conditionMessage(res)
} else {
ret <- (res == nrow(value))
if (!ret) {
msg <- paste("expecting", nrow(value), "rows updated, returned", res, "rows updated")
message(Sys.time(), " ", msg)
attr(ret, "error") <- msg
}
}
ret
}
Here's the shiny app. When you source this, you can immediately press Upsert! to get the current state of the database table (again, only an option, not required for production), no updated values are needed to requery.
library(shiny)
library(DT)
pgcon <- DBI::dbConnect(...) # fix this incomplete expression
curdata <- DBI::dbGetQuery(pgcon, "select * from mydata order by id")
# if you don't know the idfield(s) offhand, then use this:
idfields <- DBI::dbGetQuery(pgcon, "
select
t.relname as table_name,
i.relname as index_name,
a.attname as column_name
from
pg_class t,
pg_class i,
pg_index ix,
pg_attribute a
where
t.oid = ix.indrelid
and i.oid = ix.indexrelid
and a.attrelid = t.oid
and a.attnum = ANY(ix.indkey)
and t.relkind = 'r'
and t.relname = 'mydata'
order by
t.relname,
i.relname;")
idfieldnums <- which(colnames(curdata) %in% idfields$column_name)
shinyApp(
ui = fluidPage(
DTOutput("tbl"),
actionButton("upbtn", "UPSERT!"),
tableOutput("dbout")
),
server = function(input, output) {
mydata <- reactiveValues(data = curdata, changes = NULL)
output$tbl = renderDT(
mydata$data, options = list(lengthChange = FALSE),
editable = list(target = "cell", disable = list(columns = idfields)))
observeEvent(input$tbl_cell_edit, {
mydata$data <- editData(mydata$data, input$tbl_cell_edit)
mydata$changes <- rbind(
if (!is.null(mydata$changes)) mydata$changes,
input$tbl_cell_edit
)
# keep the most recent change to the same cell
dupes <- rev(duplicated(mydata$changes[rev(seq(nrow(mydata$changes))),c("row","col")]))
mydata$changes <- mydata$changes[!dupes,]
message(Sys.time(), " pending changes: ", nrow(mydata$changes))
})
do_update <- eventReactive(input$upbtn, {
if (isTRUE(nrow(mydata$changes) > 0)) {
# always include the 'id' field(s)
# idcol <- which(colnames(mydata$data) == "id")
updateddata <- mydata$data[ mydata$changes$row, c(mydata$changes$col, idfieldnums) ]
res <- pg_upsert(updateddata, "mydata", idfields = "id", con = pgcon)
# clear the stored changes only if the upsert was successful
if (res) mydata$changes <- mydata$changes[0,]
}
input$upbtn
})
output$dbout <- renderTable({
do_update() # react when changes are attempted, the button is pressed
message(Sys.time(), " query 'mydata'")
DBI::dbGetQuery(pgcon, "select * from mydata order by id")
})
}
)
In action:
(Left) When we start, we see the original DT and no database output.
(Middle) Press the Upsert! button just to query the db and show the optional table.
(Right) Make updates, then press Upsert!, and the database is updated (and the lower table re-queried).
I am trying to output a table that depends on a user selecting a date range in Shiny using sqlInterpolate. Although I have succeeded outputting a table based on a selectInput (dropdown), I can't figure out how to use a dateRangeInput with sqlInterpolate.
Error:
You have an error in your SQL syntax; check the manual that corresponds to your MariaDB server version for the right syntax to use near 'AND timestamp BETWEEN '2021-12-15' AND '2021-12-17'' at line 6
My approach:
pool <- dbPool(
MariaDB(),
db = "db",
user = user,
password = password,
host = host,
port = port
)
data_pool <- pool %>% tbl("table")
ui <- fluidPage(
uiOutput("daterange"),
tableOutput("table")
)
server <- function(input, output, session) {
output$daterange <- renderUI({
dateRangeInput("daterange2", "Date:", start = "2021-12-15", end = "2021-12-17")
})
data <- reactive({
req(input$daterange2[1], input$daterange2[2])
sql2 <- "
SELECT
STR_TO_DATE(timestamp, '%Y-%m-%d') AS timestamp
FROM table
WHERE timestamp BETWEEN ?date1 AND ?date2
"
query <- sqlInterpolate(pool, sql2, date1 = input$daterange[1], date2 = input$daterange[2])
dbGetQuery(pool, query)
})
output$table1 <- renderTable({
data()
})
}
I am building an app using RShiny which queries a SQLite database.
I have finished writing the code for the app, but I am having trouble reducing the complexity of the query / using glue_sql function. As it is right now there are many OR statements which I believe might be slowing the query down.
I used sqlInterpolate to conduct the query to prevent any SQL injections, as this is what is cited on the RShiny website as what should be done.
This is my code as of right now:
UI:
ui <- fluidPage(theme = shinytheme("cerulean"),
titlePanel("Application"),
sidebarLayout(
sidebarPanel(
checkboxGroupInput(inputId = "Assay", label = "Assay Type:", choices = c("MBP1","EV","Oxidation","WGAS","WLS","Genomics"),
selected = c("MBP1","EV","Oxidation","WGAS","WLS","Genomics")), #Assay
checkboxGroupInput(inputId = "Vendor", label = "Vendor:", choices = c("AKE","BSA"),
selected = c("AKE","BSA")), #Vendor
actionButton("read", "Read From Database"),
checkboxGroupInput(inputId = "Study",
label = "Study Type",
choices = c("MP", "CSP"),
selected = c("MP", "CSP")),
dateRangeInput(inputId = "Date", label = "Sample Date Range:", format ="yyyy-mm-dd"), #Date
actionButton("read", "Read From Database")),
mainPanel(h1("Sample Count:"),
dataTableOutput("Samples_Sorted_by_Study"),
dataTableOutput("Samples_Sorted_by_Assay_and_Vendor")) #table
) #closing navbarPage
) #closing fluidPage UI
Server:
server <- function(input, output){
#Storing values in myData variable
myData <- reactiveValues()
observeEvent(
input$read,
{
myData$assay <- input$Assay
myData$vendor <- input$Vendor
myData$date_val <- input$Date
myData$studytype <- input$Study
#Opening database connection
connectiontodb <- dbConnect(RSQLite::SQLite(), "example.sqlite")
#Shortening Query??
#myData$study_int <- c(myData$studytype[1], myData$studytype[2])
#myData$study_int <- glue_sql("{myData$study_int*}")
#conducting first query of samples grouped by study
#Sample query of example.sqlite database
myData$interpolatequery1 <- sqlInterpolate(connectiontodb,
"Select study, count(genomic_id), count(specimen_id)
FROM exampletable WHERE study = ?studytype1 OR study = ?studytype2
GROUP BY study",
studytype1 = myData$studytype[1], studytype2 = myData$studytype[2])
myData$exampledataSQLQuery1 <- dbGetQuery(connectiontodb, myData$interpolatequery1)
#Closing connection to database
dbDisconnect(connectiontodb)
#Correcting Column Names
colnames(myData$exampledataSQLQuery1) <- c("Study", "Genomic Id", "Specimen Id")
}
)
output$Samples_Sorted_by_Study <- renderDataTable(myData$exampleSQLQuery1)
}
shinyApp(ui = ui, server = server)
How can I condense the query so that there isn't a need for so many OR statements, but also protect against SQL injection?
I have the following code
res<-function(y) {
data <- sqlQuery(dbhandle, "select count([respondent serial]) from data1
where [variable]= y")
print(data)
}
dbhandle is the connection established to sql server.
Now if i pass res(gender) am not getting results as i would normally get with a select statement in SQL.
Any help with this is appreciated.
This happens because the string inside the query does not understand that y is a variable. Hence paste0() is here to help:
res<-function(y) {
data <- sqlQuery(dbhandle, paste0("select count([respondent serial]) from data1
where [variable]=", y))
return(data)
}
You can call the function by using res("gender").
EDIT
In order to pass a numeric value, you can do:
res2<-function(y) {
data <- sqlQuery(dbhandle, paste0("select count([respondent serial]) from data1
where [week number] =", y))
return(data)
}
You can check this out as well: res2(201752)
Alright, I modified the script following #Pork Chop advice:
server.R
library(shiny)
library(DT)
library(RMySQL)
con <- dbConnect(MySQL(), user="myuser", host="myhost", dbname="mydb")
shinyServer(function(input, output) {
sqlOutput <- reactive({
sqlInput <- paste0("select * from mydb.mytable",
" where value < ", input$value,
";")
dbGetQuery(con, sqlInput)
})
output$table <- DT::renderDataTable(sqlOutput(), server=TRUE, rownames=FALSE, filter="top", options=list(pageLength=10))
output$download <- downloadHandler("filtered.data.txt", content = function(file) {
rows <- input$table_rows_all
write.table(sqlOutput()[rows, ], file, sep="\t", quote=FALSE, col.names=TRUE, row.names=FALSE)
})
})
The DataTable now works!
However when I try to download the displayed data, I get a file with only column names and no data. According to the DT docs, input$table_rows_all should contain the row indices of the displayed table.
What's wrong?
I'm having troubles with Shiny reactivity and a MySQL database.
In short, I get an input value from the user, create an SQL query, capture the output and display it as a DataTable.
The output can be further filtered using the DataTable column filters and the user should be able to download the filtered dataset.
server.R
library(shiny)
library(DT)
library(RMySQL)
con <- dbConnect(MySQL(), user="myuser", host="myhost", dbname="mydb")
shinyServer(function(input, output) {
sqlInput <- reactive({
paste0("select * from mydb.mytable",
" where value < ", input$value,
";")
})
sqlOutput <- reactive({
dbGetQuery(con, sqlInput)
})
output$table <- DT::renderDataTable(sqlOutput, server=TRUE, rownames=FALSE, filter="top", options=list(pageLength=10))
output$download <- downloadHandler("filtered.data.txt", content = function(file) {
rows <- input$table_rows_all
write.table(sqlOutput[rows, ], file)
})
})
Instead of the DataTable, I get this error:
This works as expected if I embed sqlInput and sqlOutput within a reactive expression in DT::renderDataTable(), but then I'm not able to refer to sqlOutput from within downloadHandler() (object 'sqlOutput' not found). I thought this was the perfect use case for using reactive() but I can't get it to work.
What's the best way to make this work?
Any help is much appreciated, thanks!
1. sqlOutput is a function so change it to sqlOutput()
2. Try this, note this will export is as .csv hope its ok
output$download <- downloadHandler(filename = function() {paste(Sys.time(), ' Fltered_data.csv', sep='')}, content = function(file) {write.csv(sqlOutput()[input$table_rows_all, ], file, row.names = FALSE)})