I am creating an R Shiny application primarily using checkboxGroupInput where for each checkbox name I check, the corresponding table should display in the main UI panel. I have linked each checkbox option to its corresponding table (already in my previous script) in the "choices" argument of checkboxGroupInput. I use eventReactive to make a working button and renderTable to produce the appropriate tables. However, what displays in the main panel when I click the button is a list of each cell in the table rather than the table itself. This list of values looks a bit like this:
list(CUI = "C05372341", LAT = "ENG", TS = "P", LUI = "L0883457", STT = "PF", SUI = "S13423408", ISPREF = "N", AUI = "A10344304", SAUI = "21823712", SCUI = "1341953", SDUI = NA, SAB = "LKDHDS", TTY = "IN", CODE = "139433", STR = "Pramlintide", SRL = "0", SUPPRESS = "Y", CVF = "4354")
I would like this to have been printed in table form.
When I simply use renderTable({table_name}) on any given one of the tables, the table prints in the main panel how I would like it to. However, when I use eventReactive, name that variable, and renderTable on that variable, that is when the list of table values prints instead. Any ideas?
library(shiny)
ui <- fluidPage(
titlePanel("RxNorm Diabetic Drug Mapping based on Epocrates Classes"),
sidebarLayout(
sidebarPanel(
checkboxGroupInput("drugs", "Drug Class", choices = list("ALPHA GLUCOSIDASE INHIBITORS" = agi, "AMYLIN MIMETICS" = pramlintide, "BIGUANIDES" = biguanides, "DOPAMINE AGONISTS" = bromocriptine, "DPP4 INHIBITORS" = dpp4, "GLP1 AGONISTS" = glp1, "INSULINS" = insulins, "MEGLITINIDES" = meglitinides, "SGLT2 INHIBITORS" = sglt2, "SULFONYLUREAS" = sulfonylureas, "THIAZOLIDINEDIONES" = thiazolidinediones)),
actionButton("button", "Retrieve Data")
),
mainPanel(
tableOutput("results")
)
)
)
server <- function(input, output) {
table_reactive <- eventReactive(input$button, {
input$drugs
})
output$results <- renderTable({
table_reactive()
})
}
shinyApp(ui = ui, server = server)
In your choices:
choices = list("ALPHA GLUCOSIDASE INHIBITORS" = agi, "AMYLIN MIMETICS" = pramlintide ...), it's not valid if agi and pramlintide ... are pointing to tables. choices values can only be string.
You shouldn't pass variable as values in checkboxGroupInput. Instead you should pass the table name as string.
To answer your questions:
Please see the demos below:
If your tables are saved as separate variables, you should use sym() and eval_tidy() in rlang package to convert string to varaible.
library(shiny)
library(rlang)
ui <- fluidPage(
fluidRow(
checkboxGroupInput(
inputId = "checkgroup",
label = "Select Table",
choices = list(iris = "iris", mtcars = "mtcars")
),
actionButton(
inputId = "confirm",
label = "Confirm Table(s)"
)
),
fluidRow(
tags$div(id = "tables")
)
)
server <- function(input, output, session) {
observeEvent(input$confirm,{
removeUI(selector = "#tables > *",multiple = TRUE)
req(length(input$checkgroup) > 0)
for(table_name in input$checkgroup){
table_id <- paste0("mytable",table_name)
insertUI(
selector = "#tables",
ui = dataTableOutput(table_id)
)
output[[table_id]] <- renderDataTable(eval_tidy(sym(table_name)))
}
})
}
shinyApp(ui, server)
Related
I have a shiny app where the user uploads a csv file. Then, using the column names from the csv file, I create sortable bucket list. I would like drag the column name from the first rank list and have it cloned (i.e. not depleted). I tried to use the options parameter in add_rank_list() setting pull='clone', but that did not work. Any idea on how to do this? Below is my code, and some fake data can be accessed here.
library(shiny)
library(shinyjs)
library(sortable)
ui <- fluidPage(
titlePanel("App"),
sidebarLayout(
sidebarPanel(
useShinyjs(),
fileInput(inputId = "file1", label = "Select a .csv file",
accept = c("text/csv", "text/comma-separated-values,text/plain",".csv")
),
uiOutput("show_button")
),
mainPanel(
DT::dataTableOutput("table")
)
),
fluidRow(uiOutput("buckets"))
)
server <- function(input, output) {
# input csv file
input_file <- reactive({
if (is.null(input$file1)) {
return("")
}
# actually read the file
read.csv(file = input$file1$datapath)
})
# button to hide/show table
## only show when table is loaded
output$show_button = renderUI({
req(input$file1)
actionButton(inputId = "button", label = "show / hide table")
})
## observe the button being pressed
observeEvent(input$button, {
shinyjs::toggle("table")
})
# output table
output$table <- DT::renderDataTable({
# render only if there is data available
req(input_file())
# reactives are only callable inside an reactive context like render
data <- input_file()
data
})
# Drag and Drop Col names
output$buckets = renderUI(
{
# create list of colnames
req(input$file1)
data = input_file()
cols = colnames(data)
# create bucket list
bucket_list(
header = "Drag the items in any desired bucket",
group_name = "bucket_list_group",
orientation = "horizontal",
add_rank_list(
text = "Drag from here",
labels = as.list(cols),
input_id = "rank_list_1",
css_id = "list1",
options = sortable_options(
group = list(
pull = "clone",
name = "list_group1",
put = FALSE))
),
add_rank_list(
text = "to here",
labels = NULL,
input_id = "rank_list_2",
css_id = "list2",
options = sortable_options(group = list(name = "list_group1")))
)
})
}
# Run the application
shinyApp(ui = ui, server = server)
I want to create a shny app that creates a interactive treemap.
The treemap should contain up to three layers, depending on user's choice.
The user can specify one, two or three layers, choosing from a dropdown list for each layer.
Hitting an actioButton, the map should be produced.
The ui part
ui <- fluidPage(
# Application title
navbarPage("Ist-Analyse Biodiversitätsmonitoring in Deutschland",
#####
tabPanel("Treemap", fluid = T,
sidebarLayout(
sidebarPanel(
radioButtons(inputId = "status",
label = "Programm - Status",
choices = c("Alle" = "Alle",
"laufend" = "laufend",
"in Erprobung" = "in Erprobung",
"in Entwicklung" = "in Entwicklung",
"beendet" = "beendet"),
selected = c("Alle")
),
br(),
selectInput(inputId = "level1",
label = "Ebene 1",
choices = Auswahl$Titel[Auswahl$use_treemaps == 1],
selected = Auswahl$Titel[Auswahl$use_treemaps == 1][1]),
br(),
selectInput(inputId = "level2",
label = "Ebene 2",
choices = Auswahl$Titel[Auswahl$use_treemaps == 1],
selected = c(''),
br(),
selectInput(inputId = "level3",
label = "Ebene 3",
choices = c('',
Auswahl$Titel[Auswahl$use_treemaps == 1]),
selected = c('')),
actionButton(inputId = "submit",
label = "Los!",
icon = icon("table")
)
),
mainPanel(
d3tree3Output(outputId = "treemap",
width = "100%",
height = "400px"),
)
)
)
)
)
The server part
server <- function(input, output) {
### determine, how many levels to drill down
## therefore, I bind together the selected levels (1 to 4) in tab "Treemap"
treemap_reactive <- eventReactive(input$submit, {
#####
drill_levels<- c(input$level1,
input$level2,
input$level3)
## then, depending on lenght(drill_levels), the treemaps
## are composed to the defined level of depth
drill_levels<- drill_levels[-c(which(drill_levels=''))]
treemap<-treemap(groups.1,
index=drill_levels,
vSize="value",
type="index",
na.rm=T,
draw=F)
d3tree3(treemap,
rootname = c("Treemap")
)
}
)
output$treemap <- renderD3tree3({
treemap_reactive()
}
)
}
# Run the application
shinyApp(ui = ui, server = server)
The group.1 datatset is the dataset containing the information to be visualized.
If I start the app, choose my levels (either one, two or tree) and hit the actionButton
I get an error "can't find object 'drill_levels'"
However, if I run the code with pre-defining 'drill_levels' in the R global envronment, the code works exactly as I expected.
So the problem seems to be that the variable 'drill_levels' is not created inside the eventReactive() function.
Does someone have an idea how to solve the issue?
I am building a Shiny App where users can filter out certain projects. I want the project names to appear in the dropdown only if they appear within a certain date range.
I've been able to populate the selectize menu and have been able to make it so users can select all or remove all projects (from the answer to a question I asked previously). However, now that I'm trying to make these names reactive to the date, the observeEvent code from my previous question crashes. I tried to wrap it in a reactive expression, but then nothing happens.
How do I make my projects filterable by date while still keeping the select all and remove all functionality?
library(shiny)
library(plotly)
library(shinyjs)
library(shinydashboard)
library(shinyWidgets)
library(dplyr)
library(htmltools)
library(lubridate)
ui = fluidPage(
tabsetPanel(
tabPanel("View 1", fluid = TRUE,
sidebarLayout(
sidebarPanel(
h4("Select Your Desired Filters"),
div(id = "inputs",
dateRangeInput(
inputId = "date_filter",
label = "Filter by Month and Year",
start = today(),
end = (today() + 90),
min = "2021-04",
max = NULL,
format = "yyyy-mm",
startview = "month",
weekstart = 0,
language = "en",
separator = " to ",
width = NULL,
autoclose = TRUE
),
br()),
h5("Include/Exclude Specific Projects"),
selectizeInput(inputId = "filter_by_project",
label = "Filter by Project",
choices = sort(unique(test$project)),
multiple = TRUE,
selected = sort(unique(test$project))),
actionButton(inputId = "remove_all",
label = "Unselect All Projects", style = "color: #FFFFFF; background-color: #CA001B; border_color: #CA001B"),
actionButton(inputId = "add_all",
label = "Select All Projects", style = "color: #FFFFFF; background-color: #CA001B; border_color: #CA001B")
),
mainPanel(
)
)
)
)
)
server = function(input, output, session) {
#Here's the dataset
test <- tibble(project = c("Justin", "Corey","Sibley"),
date = ymd(c("2021-04-20", "2021-04-01", "2021-05-05")),
april_2021 = c(10, 100, 101),
may_2021 = c(1, 4, 7))
#I want users to be able to filter the list of projects by date, which should update the selectize options
test <- reactive({
test %>%
dplyr::filter(date >= input$date_filter[1],
date <= input$date_filter[2])
})
observeEvent(input$remove_all, {reactive({
updateSelectizeInput(session,"filter_by_project",choices=sort(unique(test()$project)),
selected=NULL, options = list(placeholder="Please Select at Least One Project")
)
})
})
observeEvent(input$add_all, {reactive({
updateSelectizeInput(session,"filter_by_project",choices=sort(unique(test()$project)), selected=sort(unique(test()$project)) )
})
})
}
shinyApp(ui = ui, server = server)
You have to major problems. First is using the same name for your input data.frame and for your reactive element. You've called them both test which causes confusion as to whether you are trying to use the data.frame or the reactive object. You should use different names. The second problem is you do not need to use reactive() for your observeEvents() calls. You just need to put the code you want to run in a block.
Fixing these problems, your server functon should look more like this
server = function(input, output, session) {
#Here's the dataset
testdata <- tibble(project = c("Justin", "Corey","Sibley"),
date = ymd(c("2021-04-20", "2021-04-01", "2021-05-05")),
april_2021 = c(10, 100, 101),
may_2021 = c(1, 4, 7))
#I want users to be able to filter the list of projects by date, which should update the selectize options
test <- reactive({
testdata %>%
dplyr::filter(date >= input$date_filter[1],
date <= input$date_filter[2])
})
observeEvent(input$remove_all, {
updateSelectizeInput(session,"filter_by_project", choices=sort(unique(test()$project)),
selected=NULL, options = list(placeholder="Please Select at Least One Project")
)
})
observeEvent(input$add_all, {
updateSelectizeInput(session,"filter_by_project", choices=sort(unique(test()$project)), selected=sort(unique(test()$project)) )
})
}
I'm trying to set up a ShinyApp which can access to a PostGreSQL/PostGIS database and perform reactive queries according to user inputs via selectInput widget.
I succeed to perform it with single inputs following this example (https://www.cybertec-postgresql.com/en/visualizing-data-in-postgresql-with-r-shiny/). My working code (sorry for non reprex example, but I cannont provide my database login for security purpose).
pool <- dbPool(drv = dbDriver("PostgreSQL", max.con = 100), user = "user", password = "pswd", host = "000.000.00.000", port = 5432, dbname = "db_name", idleTimeout = 3600000)
typology <- dbGetQuery(pool, "SELECT type FROM table GROUP BY type")
all_typo <- sort(unique(typology$type))
area_agripag <- dbGetQuery(pool, "SELECT area_name FROM table GROUP BY area_name")
all_area <- sort(unique(area_agripag$area_name))
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
selectInput(
inputId = "area",
label = "Select a district",
choices = all_area,
selected = 'district_1',
multiple = FALSE,
selectize = FALSE
),
selectInput(
inputId = "typo",
label = "Select a type",
choices = all_typo,
selected = 'type1',
multiple = FALSE,
selectize = FALSE
)
),
mainPanel(
tabsetPanel(
tabPanel("graph", plotOutput("plot")),
tabPanel("Table", dataTableOutput("table"))
)
)
)
)
server <- function(input, output, session) {
selectedData <- reactive({
req(input$area)
req(input$typo)
query <- sqlInterpolate(ANSI(),
"SELECT year, SUM(surface)
FROM table
WHERE area_name = ?area_name
AND type = ?type
GROUP BY year;",
area_name = input$area, type = input$typo)
outp <- as.data.frame(dbGetQuery(pool, query))
})
output$table <- DT::renderDataTable({
DT::datatable( data = selectedData(),
options = list(pageLength = 14),
rownames = FALSE)
})
output$plot <- renderPlot({
ggplot( data = selectedData(), aes(x = year, y = sum)) + geom_point()
})
}
shinyApp(ui = ui, server = server)
What I want to do is editing the reactive query in the server part in order to allow multiple selectInput. I should add IN operator instead of = in the sql query :
selectedData <- reactive({
req(input$area)
req(input$typo)
query <- sqlInterpolate(ANSI(),
"SELECT year, SUM(surface)
FROM table
WHERE area_name IN (?area_names)
AND type IN (?types)
GROUP BY year;",
area_names = input$area, types = input$typo)
outp <- as.data.frame(dbGetQuery(pool, query))
})
Next I know I should format the area_names / types vector returned by a multiple selectInput with some automatic regular expression. I want to wrap each elements of the vector with '', in order to accord with the SQL syntax.
For example, I want to transfrom the following multiple input$area vector :
area1 area2 area3
to
'area1', 'area2', 'area3'
In order to store it in the area_names sqlInterpolate argument.
Anyone has an idea how to perform this? Thanks to all contributions.
I print the output as textOutput, but i guess you can pick up the idea for whatever you want for :-)
#
# This is a Shiny web application. You can run the application by clicking
# the 'Run App' button above.
#
# Find out more about building applications with Shiny here:
#
# http://shiny.rstudio.com/
#
library(shiny)
# Define UI for application that draws a histogram
ui <- fluidPage(
# Application title
titlePanel("Old Faithful Geyser Data"),
# Sidebar with a slider input for number of bins
sidebarLayout(
sidebarPanel(
sliderInput("bins",
"Number of bins:",
min = 1,
max = 50,
value = 30),
selectizeInput("mult", label = "Chooose", choices = c("area1", "area2", "area3"), selected = "area1", multiple = TRUE)
),
# Show a plot of the generated distribution
mainPanel(
textOutput("text")
)
)
)
# Define server logic required to draw a histogram
server <- function(input, output) {
output$text <- renderText({
output <- ""
print(length(input$mult))
for(i in 1:length(input$mult)) {
if(i == length(input$mult)) {
output <- paste0(output, "'", input$mult[[i]], "'")
} else {
output <- paste0(output, "'", input$mult[[i]], "', ")
}
}
output
})
}
# Run the application
shinyApp(ui = ui, server = server)
Explanation: The input$multis a vector which lengths depends on how many inputs are selected. I initialize an empty output and start the loop.
paste0 will convert the input to a string and add a comma, except for the last iteration, where we do not want a comma. The double brackets extract the value by indexing. Hope this gets clear below:
x <- c(3,5,7)
paste0(x[[1]], " and ", x[[2]], " and ", x[[3]])
1] "3 and 5 and 7"
The [[i]] will change its value every iteration. Check out this to get a feeling for it.
https://www.r-bloggers.com/how-to-write-the-first-for-loop-in-r/
At the end, we just return the final string :-)
So after 2 days I figured out the problem. The mistake was sticking to sqlInterpolate for creating the SQL query. Using some renderPrint function to visualize the generated query, I noticed that some inopportune double quote was showing up in my query.
It appears that sqlInterpolate have been created to prevent security breach trough sql injection attacks (https://shiny.rstudio.com/articles/sql-injections.html), not allowing to use multiple input.
Thanks to parameterized queries (https://db.rstudio.com/best-practices/run-queries-safely) I was able to implement multiple in the query using sql_glue function.
Here are the usefull links for next ones :
glue documentation (https://glue.tidyverse.org/reference/glue_sql.html)
some similar topic (https://community.rstudio.com/t/using-multiple-r-variables-in-sql-chunk/2940/13)
similar with dbQuoteIdentifier function (How to use dynamic values while executing SQL scripts in R)
And the final code :
library(RPostgreSQL)
library(gdal)
library(leaflet)
library(shiny)
library(tidyverse)
library(sp)
library(rgeos)
library(rgdal)
library(DT)
library(knitr)
library(raster)
library(sf)
library(postGIStools)
library(rpostgis)
library(shinydashboard)
library(zip)
library(pool)
library(rjson)
library(reprex)
library(glue)
pool <- dbPool(drv = dbDriver("PostgreSQL", max.con = 100), user = "username", password = "pswd", host = "000.000.00.000", port = 5432, dbname = "database", idleTimeout = 3600000)
typology <- dbGetQuery(pool, "SELECT type FROM table GROUP BY type")
all_typo <- sort(unique(typology$type))
area_table <- dbGetQuery(pool, "SELECT area FROM tableGROUP BY area")
all_area <- sort(unique(area_table$area ))
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
selectInput(
inputId = "area",
label = "Select a district",
choices = all_area,
selected = 'area1',
multiple = TRUE,
selectize = FALSE
),
selectInput(
inputId = "typo",
label = "Select a type",
choices = all_typo,
selected = 'type1',
multiple = TRUE,
selectize = FALSE
)
),
mainPanel(
tabsetPanel(
tabPanel("graph", plotOutput("plot")),
tabPanel("Table", dataTableOutput("table"))
)
)
)
)
server <- function(input, output, session) {
selectedData <- reactive({
req(input$area)
req(input$typo)
query <- glue::glue_sql(
"SELECT year, SUM(surface)
FROM table
WHERE area IN ({area_name*})
AND type IN ({type*})
GROUP BY year;",
area_name = input$area,
type = input$typo,
.con = pool)
outp <- as.data.frame(dbGetQuery(pool, query))
outp
})
output$table <- DT::renderDataTable({
DT::datatable( data = selectedData(),
options = list(pageLength = 14),
rownames = FALSE)
})
output$plot <- renderPlot({
ggplot( data = selectedData(), aes(x = year, y = sum)) + geom_point()
})
}
shinyApp(ui = ui, server = server)
I'm a Shiny newbie and was trying to get something simple working, but unable to :(
Here is a part of my ui.R
sidebarLayout(
sidebarPanel(
radioButtons("market",
"Choose a Region to build the Sales file:",
c("North America & ANZ" = "NA", "Europe" = "EU"), inline = TRUE),
conditionalPanel(
condition = "input.market == 'NA'",
radioButtons("Locale",
"Choose a locale to see the sales Calendar:",
c("US and Canada" = "US_CA", "ANZ" = "ANZ"), inline = TRUE),
numericInput("sale_num", "Choose a Sale Number from the Table below",1,width = '100px' )
),
conditionalPanel(
condition = "input.market == 'EU'",
radioButtons("Locale",
"Choose a locale to see the sales Calendar:",
c("UK" = "UK", "FR and RoE" = "FR_ROE","DE,AT & CH" = "DACH"), inline = TRUE),
numericInput("sale_num", "Choose a Sale Number from the Table below",1,width = '100px' )),
dataTableOutput("sales"))
),
Here is my server.R
server <- shinyServer(function(input, output) {
output$sales <- renderDataTable({
saleTable(input$Locale)
},options = list(autoWidth = FALSE,searching = FALSE,pageLength=10))
})
When a change in the market radio button is triggered, the Locale radio does not update and hence the sales output table still has stale values and is not reflected by any change in Locale values.
I know I'm supposed to use something like UpdateRadiobuttons, but I'm not sure how. :(
saleTable is just a function in my Rscript that produces a data table.
Please help!
Thanks in advance!
Please post a minimal example, i.e. your function saleTable. Don't use the same input ID twice in your app, it's bad style and will not work in most cases. Here are two solutions: First one is bad style, second one better style.
1) Rename the second Locale to Locale2 and put this in your output$sales:
output$sales <- renderDataTable({
if(input$market == 'NA') data <- input$Locale
else if(input$market=="EU") data <- input$Locale2
saleTable(data)
}, options = list(autoWidth = FALSE,searching = FALSE,pageLength=10))
)
2) Create the second output as UIOutput and make it dependent on the first one:
ui <- shinyUI(
sidebarLayout(
sidebarPanel(
radioButtons("market",
"Choose a Region to build the Sales file:",
c("North America & ANZ" = "NA", "Europe" = "EU"), inline = TRUE),
uiOutput("Locale")),
mainPanel(dataTableOutput("sales"))))
server <- function(input, output, session) {
output$Locale <- renderUI({
if(input$market == "NA") myChoices <- c("US and Canada" = "US_CA", "ANZ" = "ANZ")
else myChoices <- c("UK" = "UK", "FR and RoE" = "FR_ROE","DE,AT & CH" = "DACH")
radioButtons("Locale","Choose a locale to see the sales Calendar:",
choices <- myChoices,
inline = TRUE)
})
output$sales <- renderDataTable({
saleTable(input$Locale)
},options = list(autoWidth = FALSE,searching = FALSE,pageLength=10))
}
shinyApp(ui = ui, server = server)
Based on the expressed interest in using updateRadioButtons, I put together a simple example with two radio buttons and a table output.
The first radio button input does not change. The second radio button input depends on the value of the first input. The table displayed is the mtcars data frame filtered by the values of the two radio button groups.
Using observeEvent ensures the value of the carb radio input updates each time the cyl radio input is changed. This will also trigger when the application is first launched and is why we do not see the default, dummy, choice "will be replaced" for the carb radio input.
Make sure to include session as one of the Shiny server function arguments. All of Shiny's update*Input functions require you pass a session object to them.
I hope this proves useful.
library(shiny)
shinyApp(
ui = fluidPage(
fluidRow(
column(
width = 4,
radioButtons(
inputId = "cyl",
label = "Choose number of cylinders:",
choices = unique(mtcars$cyl),
selected = unique(mtcars$cyl)[1]
),
radioButtons(
inputId = "carb",
label = "Choose number of carburetors:",
choices = "will be replaced"
)
),
column(
width = 8,
tableOutput(
outputId = "mtcars"
)
)
)
),
server = function(input, output, session) {
observeEvent(input$cyl, {
newChoices <- sort(unique(mtcars[mtcars$cyl == input$cyl, ]$carb))
updateRadioButtons(
session = session,
inputId = "carb",
choices = newChoices,
selected = newChoices[1]
)
})
output$mtcars <- renderTable({
req(input$cyl, input$carb)
mtcars[mtcars$cyl == input$cyl & mtcars$carb == input$carb, ]
})
}
)