multiple selectizeInput from fileInput - file-io

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)

Related

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

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?

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

Subsetting or filtering of data as per dynamic user input

I like to filter data as per dynamic user input. Below mentioned sample code is executable, however, currently, it does not have the logic to filter the data. Therefore, the table does not change irrespective of selection of any variables. The code has mainly three components: 1. First few lines of code creates a data frame of which information can be used in creating controls widgets on the fly; 2. ui code; 3. server currently has logic to create control widgets on the fly, and I need to figure out how to use information from dynamically created control widgets and filter data (which is used for different purposes). I'm unable to figure out how to track the number of variable and filtering as per their range. Greatly appreciate suggestions.
## Create a data frame of which information is used in creating (dynamical) control widgets
varnames <- names(iris[,1:4]) # names
varinit <- apply(iris[,1:4],2,median) # initival value used in slider
varmin <- apply(iris[,1:4],2,min) # min.
varmax <- apply(iris[,1:4],2,max) # max.
## dataframe
vardf <- data.frame(varnames,varmin,varmax,varinit)
ui <- fluidPage(
checkboxGroupInput("ConditioningVariables", "Conditioning variables (choose one or more):",
varnames,inline = TRUE),
uiOutput("ControlWidgetsofConditioningVariables"),
tableOutput("data")
)
server <- function(input, output, session) {
output$ControlWidgetsofConditioningVariables <- renderUI({
if (is.null(input$ConditioningVariables)){
return()
} else {
selvarnames = sort(input$ConditioningVariables)
selpos = sapply(selvarnames,function(x) which(varnames==x))
# create a taglist of dynamic widgets
ListofDynamicWidgets <- lapply(selpos, function(x){sliderInput(as.character(vardf[x,1]),
as.character(vardf[x,1]),
vardf[x,2],vardf[x,3],
vardf[x,4],.1)})
do.call(tagList, ListofDynamicWidgets)
}
})
## filter data as per selected variables and their range
## this is where I'm kind of struck, I think I need to track number of variables (is list good idea?)
## and filter as per selected range of a specific variable
newdata <- reactive({
subset(iris)
})
output$data <- renderTable({ newdata() })
}
shinyApp(ui, server)
Here's one approach (note that I slightly modified the code to generate the widgets). The main idea is to generate a named list of the range vectors (conds), convert the ranges into a list of character strings that represent the filtering conditions (subs), collapse them into one long string of conditions, and use that as the subsetting argument for filter_().
library(dplyr)
server <- function(input, output, session) {
allControls <- lapply(setNames(varnames, varnames), function(x) {
sliderInput(x, x, varmin[x], varmax[x], c(varmin[x], varinit[x]),
round = -2)
})
output$ControlWidgetsofConditioningVariables <- renderUI({
if (is.null(input$ConditioningVariables)){
return()
} else {
allControls[input$ConditioningVariables]
}
})
## filter data as per selected variables and their range
newdata <- reactive({
if(!is.null(input$ConditioningVariables)) {
cond_names <- input$ConditioningVariables
conds <- lapply(setNames(cond_names, cond_names), function(x) input[[x]])
subs <- mapply(function(name, range){
if (!is.null(range))
sprintf("%1$s >= %2$f & %1$s <= %3$f", name, range[1], range[2])
}, names(conds), conds)
subs <- subs[!sapply(subs, is.null)]
if (length(subs) > 0)
filter_(iris, paste0(subs, collapse = " & "))
} else {
iris
}
})
output$data <- renderTable({ newdata() })
}
Output:

How to write a MODULE with two textInputs, in which input in one, blanks out the other and vv?

I want to write a MODULE where the client function returns a taglist with 2 textInputs. The user can enter a value in either textInput 1 or textInput 2 but not both. In other words, one textInput excludes the other, emulating a set of radio buttons.
Hence, the server function should observe the input in such a way that if the user enters a value in textInput 1, then textInput 2 is made blank and vice versa.
Also, the server function returns a dataframe with the values in the textInputs, i.e. either data.frame (one = enteredValue, two = NA) or data.frame (one = NA, two = enteredValue)
As we are planning on using this two-textInput widget in many of our shiny apps, I really want to make it a module. It seems like a simple thing to implement, but so far I have not been successful. (My experience is that observe, observeEvent, and eventReactive work differently in modules than in regular apps)
Any ideas to point me in the right direction are welcome.
I believe eventReactive and observeEvent work inside of a Shiny module. I've created a small module that basically does what you describe.
ui.R
library(shiny)
library(shinydashboard)
source("doubleField.R")
shinyUI(dashboardPage(
dashboardHeader(title = "Test"),
dashboardSidebar(disable = T),
dashboardBody(
doubleFieldUI("fields"),
fluidRow(
dataTableOutput("outputTable")
)
)
))
server.R
library(shiny)
source("doubleField.R")
shinyServer(function(input, output) {
fields <- callModule(doubleField, "fields")
output$outputTable <- renderDataTable(fields())
})
doubleField.R
library(stringr)
doubleFieldUI <- function(id) {
ns <- NS(id)
return(
tagList(
fluidRow(
column(width = 6, textInput(ns("fieldA"), "Field A")),
column(width = 6, textInput(ns("fieldB"), "Field B"))
),
fluidRow(
column(width = 2, "Output: "),
column(width = 4, textOutput(ns("outputValue")))
)
)
)
}
is_empty_string <- function(s) {
return(str_length(s) == 0)
}
doubleField <- function(input, output, session) {
valueA <- eventReactive(input$fieldA, {
if(!is_empty_string(input$fieldA)) {
ns <- session$ns
updateTextInput(session, "fieldB", value = "")
return(input$fieldA)
}
return("")
})
valueB <- eventReactive(input$fieldB, {
if(!is_empty_string(input$fieldB)) {
ns <- session$ns
updateTextInput(session, "fieldA", value = "")
return(input$fieldB)
}
return("")
})
value <- reactive({
values <- c(input$fieldA, input$fieldB)
return(values[which(!is_empty_string(values))])
})
output$outputValue <- renderText({
value()
})
result_df <- reactive({
v_A <- valueA()
v_B <- valueB()
df <- data.frame(
list(
"valueA" = ifelse(is_empty_string(v_A), NULL, v_A),
"valueB" = ifelse(is_empty_string(v_B), NULL, v_B)
)
)
return(df)
})
return(result_df);
}
I hope this helps getting you started.

How to make Shiny reactivity work with SQL database?

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