How can I reduce SQL Query complexity and length in RShiny App? - sql

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?

Related

How to efficiently paste many variables into a sql query (Rshiny)

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).

How to use dateRangeInput in sqlInterpolate in RShiny

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()
})
}

D3 Table Filter in R Shiny update SQL server

I am working on a project to update a SQL database with a Shiny app using D3 Table Filter.
I am able to query the server with different text inputs and the table will render with only those rows. The next step is to edit the table in the shiny app, and have that send a query back to the server to update it.
I have enabled editing in specific columns. How could I make an edit and have it send a query?
Thank you very much in advance.
Here is my code so far:
#install.packages("devtools")
#devtools::install_github("ThomasSiegmund/D3TableFilter")
library(shiny)
library(htmlwidgets)
library(D3TableFilter)
library(RSQLite)
library(RODBCext)
library(sqldf)
dbhandle = odbcDriverConnect(connection = "driver={SQL Server};server= ... ;database= ... ;trusted_connection=true")
fulldata = sqlExecute(dbhandle, "SELECT * FROM ...", fetch = TRUE, stringsAsFactors = FALSE)
ui <- fluidPage(
# Application title
titlePanel("Patient Search"),
sidebarLayout(
sidebarPanel(
textInput(inputId = "Id", label = "Search by Account Number, Date of Birth (YYYY-MM-DD) or Last Name"),
textInput(inputId = "NextAppt", label = "Search by Next Appointment (YYYY-MM-DD)"),
submitButton(text = "Go!")
),
mainPanel(
title = 'Patient Search with D3 Table Filter in Shiny',
fluidRow(
column(width = 12, d3tfOutput('data'))
)
)
)
)
# server.R
# --------------------------------------------------------
server <- shinyServer(function(input, output, session) {
#this reactive will return the row numbers that will need to be returned in our table.
#this could depend on any of our inputs: last name, DoB, account number, or next appointment
search.criteria <- reactive({
out <- c()
outAppt <- c()
if(grepl("\\d{4}\\-\\d{2}\\-\\d{2}", input$Id)==TRUE){
out <- which(fulldata$PatientDOB==input$Id)
print(out)
} else if(grepl("\\d{5}", input$Id)==TRUE){
out <- which(fulldata$AccountNo==input$Id)
} else{
out <- which(fulldata$PatientLastName==toupper(input$Id))
}
# filter for appointment
if(grepl("\\d{4}\\-\\d{2}\\-\\d{2}", input$NextAppt)==TRUE){
outAppt <- which(fulldata$NextAppt==input$NextAppt)
if(length(out)){
out <- intersect(out, outAppt)
}else{
out <- outAppt
}
}
out
})
#make the output table
output$data <- renderD3tf({
# Define table properties
tableProps <- list(
btn_reset = TRUE,
# alphabetic sorting for the row names column, numeric for all other columns
col_types = c("string", rep("number", ncol(fulldata)))
);
d3tf(fulldata[search.criteria(),],
tableProps = tableProps,
extensions = list(
list(name = "sort")
),
showRowNames = TRUE,
tableStyle = "table table-bordered",
#this optional argument enables editing on these specific columns
edit = c("col_49", "col_50", "col_51", "col_52", "col_53"));
})
#NEED TO ADD SOMETHING HERE TO SEND QUERY TO SERVER WHEN USER EDITS
})
runApp(list(ui=ui,server=server))
I used rhandsontable. It works better as you can convert the output using hot_to_r. But because of it's simple excel like formatting, it's difficult to render images like DT
If only data, go ahead and use rhandsontable.
Eg.
rhandsontable(df) %>%
hot_cols(colWidths = c(80,150,80,80,80,80,200,200,80,80,300,80,80), manualColumnResize = TRUE) %>%
hot_col(2:13, renderer = "html") %>%
hot_col(2:13, renderer = htmlwidgets::JS("safeHtmlRenderer")) %>%
hot_col(1, renderer = "
function(instance, td, row, col, prop, value, cellProperties) {
var escaped = Handsontable.helper.stringify(value),
img;
if (escaped.indexOf('http') === 0) {
img = document.createElement('IMG');
img.src = value;
Handsontable.dom.addEvent(img, 'mousedown', function (e){
e.preventDefault(); // prevent selection quirk
});
Handsontable.dom.empty(td);
td.appendChild(img);
}
else {
// render as text
Handsontable.renderers.TextRenderer.apply(this, arguments);
}
return td;
}")
})
observeEvent(input$submitComments, {
a = hot_to_r(input$upcomingAuctionsTable)
# sqlSave(myConnUpcom, a, tablename = "test", rownames = FALSE, varTypes = c(date = "varchar(255)"))
sqlUpdate(myConnUpcom, a, tablename = "temp", index = "item_id")
})

multiple selectizeInput from fileInput

I would like to have a user input a file (.csv) and from that file, two selectizeInputs will populate with the column names of the .csv. One will ask the user which of the columns from their uploaded file is the y-variable and which of the columns is the x-variable. This, I was able to do.
What I cannot do is the following: I would like to get the selection from their y-variable to disappear from their x-variable choices in the x-variable drop-down menu.
Also, I've used the answer to this question to try to help, but they are not using the values from a fileInput. As such, I cannot get my code, which is below, to work. Thank you for any advice/help you can give.
ui<- fluidPage(
titlePanel("Test"),
sidebarPanel(
fileInput(inputId = "file1", label = "Upload File"),
selectizeInput(
"sampleyvars", "Y-vars", choices = NULL, multiple = FALSE
),
selectizeInput(
"samplevars", "X-vars", choices = NULL, multiple = TRUE
)
),
mainPanel(h3("Nothing special")
)
)
server<- function(input, output, session) {
observe({
file1 <- input$file1
if(is.null(file1)){return()}
dataSet <- read.csv(file=file1$datapath)
vals1<-input$sampleyvars
vals2<-input$samplevars
updateSelectizeInput(session, "sampleyvars",
choices = colnames(dataSet)[! vals1 %in% vals2])
updateSelectizeInput(session, "samplexvars",
choices =colnames(dataSet)[! vals2 %in% vals1])
})
}
shinyApp(ui = ui,server = server)
You had wrong ID of the widget for X variable: samplevars instead of samplexvars which you used in update* function. I changed it to the latter ID and also slightly tweaked your code to get the desired effect.
Full example:
ui<- fluidPage(
titlePanel("Test"),
sidebarPanel(
fileInput(inputId = "file1", label = "Upload File"),
selectizeInput(
"sampleyvars", "Y-vars", choices = NULL, multiple = FALSE
),
# you had ID here wrong
selectizeInput(
"samplexvars", "X-vars", choices = NULL, multiple = TRUE
)
),
mainPanel(h3("Nothing special")
)
)
server<- function(input, output, session) {
data <- reactive({
file1 <- input$file1
req(file1)
dataSet <- read.csv(file=file1$datapath)
vars <- colnames(dataSet)
updateSelectizeInput(session, "sampleyvars", "Y-vars",
choices = vars, selected = vars[1])
updateSelectizeInput(session, "samplexvars", choices = vars[-1], selected = vars[2])
dataSet
})
observe({
varX <- colnames(data())
varX <- varX[!(varX %in% input$sampleyvars)]
updateSelectizeInput(session, "samplexvars", "X-vars", choices = varX)
})
}
shinyApp(ui = ui,server = server)

SQL Query Error when selecting separate columns

I do not understand the error which appears in my SQL Query. If i choose in SQL
Select * -> it is working fine and i do get the table,
however if i select any of the column/s it is giving me an Error:
Error in $<-.data.frame(*tmp*, "PROBE", value =
structure(integer(0), .Label = character(0), class = "factor")) :
replacement has 0 rows, data has 1427
Here is my SQL code:
if(input$filter == 1){
sqlOutput <- reactive({
sqlInput <- paste("select * from DWH.PROBE where DWH.PROBE.Nr =",paste0("'",d(),"'"), "And DWH.PROBE.AB BETWEEN",input$abmfrom, "AND",input$abmto,"ORDER BY Datum asc")
print(sqlInput)
dbGetQuery(con$cc, sqlInput)
})
}else{
sqlOutput <- reactive({
sqlInput <- paste("select * from DWH.PROBE where DWH.PROBE.S BETWEEN",d2(), "AND",input$sgehalt2, "And DWH.PROBE.AB BETWEEN",input$abmfrom2, "AND",input$abmto2,"ORDER BY Datum asc")
dbGetQuery(con$cc, sqlInput)
})}
And if i just add to those SQL Queries
select DWH.PROBE.S, DWH.PROBE.AB.. from DWH.PROBE
Then it comes above mentioned Error.
Additionally i need to say if i will use this SQL Query in a simple code:
rs <- dbSendQuery(con, paste("select DWH.PROBE.AB, DWH.PROBE.S from DWH.PROBE where DWH.PROBE.Nr = '50' And DWH.PROBE.AB BETWEEN 40 AND 50 ORDER BY Datum asc"))
data <- fetch(rs)
It is giving me the results...
Any ideas?
[EDIT *as my question is not a duplicate]
The question posted here: http://stackoverflow.com/questions/32048072/how-to-pass-input-variable-to-sql-statement-in-r-shiny actually has nothing to do with my topic. As we can see the error in this post:
Error in .getReactiveEnvironment()$currentContext() : Operation not
allowed without an active reactive context. (You tried to do something
that can only be done from inside a reactive expression or observer.)
I do not have a problems with passing input variable to sql statement and additionally if you can see in my SQL: The Query is in reactive context!:
sqlOutput <- reactive({...
The solution for above question was:
to put SQL Query in reactive context which is not a thing in my case
[EDIT 2] -> bits related to sqlOutput()
Here is a bit of code related to sqlOutput() which i am using in my Shiny App (at the moment this is the only bit because i am stuck with SQL Query)
output$tabelle <- DT::renderDataTable({
data <- sqlOutput()
data$PROBE <- as.factor(as.character(data$PROBE))
data
}, rownames=TRUE, filter="top", class = 'cell-border stripe',
options = list(pageLength = 100, lengthMenu=c(100,200,500), columnDefs = list(list(width = '200px', targets = "_all"),list(bSortable = FALSE, targets = "_all"))))
Thanks
Error doesn't relate to SQL statements, however, try changing your code to below:
sqlOutput <- reactive({
if(input$filter == 1){
sqlInput <- paste("select * from DWH.PROBE where DWH.PROBE.Nr =",paste0("'",d(),"'"), "And DWH.PROBE.AB BETWEEN",input$abmfrom, "AND",input$abmto,"ORDER BY Datum asc")
} else {
sqlInput <- paste("select * from DWH.PROBE where DWH.PROBE.S BETWEEN",d2(), "AND",input$sgehalt2, "And DWH.PROBE.AB BETWEEN",input$abmfrom2, "AND",input$abmto2,"ORDER BY Datum asc")
}
dbGetQuery(con$cc, sqlInput)
})