R Shiny - Editing a data table inside a dynamically created bsModal - html

The app below contains an actionButton Add data that inserts a UI element each time it is clicked. Each UI element is a box that contains one selectInput Select data and an actionButton Edit that opens a modal when clicked.
Each modal contains:
A data table with two columns: Parameter and Value (this column is editable).
An actionButton Apply, which applies any changes made to the Value
column.
When the user selects a dataset inside box x, a reactiveValue is created to store the corresponding parameters in a data.frame x_paramset (where x is the id of the box inserted via insertUI) and add a val column which has the same value as default (see list at the top of code below). I then use renderDataTable to add the Value column (which contains the numericInput) - this data table is displayed inside the modal.
To update the data.frame to apply any changes the user may have made in the modal, I use an observeEvent that listens for the Apply button and updates the val column in the data.frame x_paramset with the values inside the numericInputs in the Value column.
Here is the app (the bsModal has been commented out and replaced with a shinyWidgets::dropdownButton):
library(shiny)
library(shinydashboard)
library(shinyjs)
library(shinyWidgets)
library(DT)
library(tidyverse)
all = list(p1 = list(a = list(id = "a", default = 10)),
p2 = list(x = list(id = "x", default = 20)))
# UI ----------------------------------------------------------------------
ui<-fluidPage(shinyjs::useShinyjs(),
tags$head(
tags$script("
$(document).on('click', '.dropdown-shinyWidgets li button', function () {
$(this).blur()
Shiny.onInputChange('lastClickId',this.id)
Shiny.onInputChange('lastClick',Math.random())
});
")
),
box(title = "Add data",
column(width = 12,
fluidRow(
tags$div(id = 'add')
),
fluidRow(
actionButton("addbox", "Add data")
))
)
)
# SERVER ------------------------------------------------------------------
server <- function(input, output, session) {
rvals = reactiveValues()
getInputs <- function(pattern){
reactives <- names(reactiveValuesToList(input))
name = reactives[grep(pattern,reactives)]
}
observeEvent(input$addbox, {
lr = paste0('box', input$addbox)
insertUI(
selector = '#add',
ui = tags$div(id = lr,
box(title = lr,
selectizeInput(lr, "Choose data:", choices = names(all)),
shinyWidgets::dropdownButton(inputId = paste0(lr, "_settings"),
circle = F, status = "success", icon = icon("gear"), width = "1000px",
tooltip = tooltipOptions(title = "Click to edit"),
tags$h4(paste0("Edit settings for Learner", lr)),
hr(),
DT::dataTableOutput( paste0(lr, "_paramdt") ),
bsButton(paste0(lr, "_apply"), "Apply")
) # end dropdownButton
)
) #end tags$div
) # end inserUI
# create reactive dataset
rvals[[ paste0(lr, "_paramset") ]] <- reactive({
do.call(rbind, all[[ input[[lr]] ]]) %>%
cbind(., lr) %>%
as.data.frame %>%
mutate(val = default)
}) # end reactive
# render DT in modal
output[[ paste0(lr, "_paramdt") ]] <- renderDataTable({
DT <- rvals[[ paste0(lr, "_paramset") ]]() %>%
mutate(
Parameter = id,
Value = as.character(numericInput(paste0(lr,"value",id), label = NULL, value = default))) %>%
select(Parameter:Value)
datatable(DT,
selection = 'none',
#server = F,
escape = F,
options = list(preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); } ')))
}) # end renderDT
# Apply changes
observeEvent(input$lastClick, {
# replace old values with new
rvals[[ paste0(lr, "_paramset") ]](rvals[[ paste0(lr, "_paramset") ]]() %>%
mutate(
val = input$box1valuea
)
)
}) # end apply changes observeEvent
}) #end observeEvent
}
shinyApp(ui=ui, server=server)
I encounter errors when I try the following:
Add data >> Edit >> make some change to numericInput >> Apply - this
resets the numericInput inside the modal back to its default whereas
I would like the user-specified value to persist upon applying
changes or closing the modal.
The app crashes when I try:
Add data >> Edit >> Apply >> close modal >> Add data OR
Click Add data twice and then click Edit in either box.
I am not sure where my server logic is failing. I know Shiny does not support "persistent use" modals (https://github.com/rstudio/shiny/issues/1590) but I was wondering if there was a workaround? I am also not sure what inside the insertUI observeEvent is causing the app to crash in the cases described above. Any help you can offer would be greatly appreciated!

Related

How define Server for Copy/Paste regions as input in R/Shiny?

I have a shiny which can be used to overlap between query regions and a given data table (e.g. DF). I put two options for uploading query data 1) as .bed format and 2) inserting data as copy/paste.
The shiny works well with uploading .bed file but I am not sure how can I define Server for copy/paste (text) data.
Thank you in advance for any suggestion!
DF<- data.table(chr=c("chr1","chr2"),start=c(10,20),end=c(20,30))%>% setkey(chr, start, end)
text<- data.table(chr=c("chr1","chr2"),start=c(15,25),end=c(15,30))%>% setkey(chr, start, end)
ui <- fluidPage(
sidebarLayout(
sidebarPanel (
p(strong ("Find overlap between query file and data"),style = "color:blue;"),
br(),
selectInput("choose","Choose file source",choices = c("file","text"),selected = "file"),
conditionalPanel("input.choose=='file'",
fileInput("query.file", "Upload genomic coordinates in .bed
format:",multiple = F,accept = ".bed")),
conditionalPanel("input.choose=='text'",
textAreaInput("query.text", "Enter genomic coordinates:")),
actionButton("run", "run"),
width = "2"),
mainPanel(
dataTableOutput("DFtable"),
dataTableOutput("overlap_table"))
)
)
server <- function (input, output, session) {
## Read user .bed file
user_query.file <- reactive({
req(input$query.file)
ext <- tools::file_ext(input$query.file$name)
switch(ext,
bed = fread(input$query.file$datapath,header=F)%>%
dplyr::rename (chr =V1, start=V2, end=V3) %>% setkey(chr, start, end)%>% unique()
)
})
## overlapping between query file and table
overlap <- eventReactive(input$run, {
req(input$run)
withProgress(message = 'Analysis in progress', value = 0, {
query.overlap<- foverlaps(user_query.file() ,DF, nomatch = 0) %>%
unique()
})
})
## output
output$DFtable<- renderDataTable({ DF })
output$overlap_table <- renderDT({overlap () })
}
shinyApp(ui, server)
Desire out put using TEXT input option:
chr start end i.start i.end
chr1 15 15 10 20
chr2 25 30 20 30
Not sure on how your copied text looks like, but assuming something like:
chr,start,end
chr1,10,20
chr4,34,56
All you need is to parse the text contents of the UI input and assigned it to DF variable. Your run event handler could look like:
## overlapping between query file and table
overlap <- eventReactive(input$run, {
req(input$run)
#Requiring text input and parsing it
req(input$query.text)
DF <- data.table(read.csv(text=input$query.text)) %>% setkey(chr, start, end)
withProgress(message = 'Analysis in progress', value = 0, {
query.overlap<- foverlaps(text ,DF, nomatch = 0) %>%
unique()
})
})
Then when clicking on the run button, the analysis is executed and the overlap reactive value is updated. If the comparison is always between file and text provided, you should also include a req(user_query.file()) to ensure the file has been provided and correctly parsed.

Shiny R: How to make a Leaflet legend horizontal

I'm trying to make a horizontal legend in a Shiny app with a Leaflet map.
I can change the display to display: flex; using CSS which makes the legend horizontal but what I'm aiming at is something like:
0% - a palette of colors - 100%
edit and NOT -color- 0% -color- 10% - color- 20% etc.
I don't see a way to do that in CSS and I can't find enough info about addLegend to find a solution,
Here's a reprex:
library(leaflet)
library(RColorBrewer)
ui <- bootstrapPage(
tags$style(type = "text/css", "html, body {width:100%;height:100%}"),
leafletOutput("map", width = "100%", height = "100%"),
absolutePanel(top = 10, right = 10,
sliderInput("range", "Magnitudes", min(quakes$mag), max(quakes$mag),
value = range(quakes$mag), step = 0.1
),
selectInput("colors", "Color Scheme",
rownames(subset(brewer.pal.info, category %in% c("seq", "div")))
),
checkboxInput("legend", "Show legend", TRUE)
)
)
server <- function(input, output, session) {
# Reactive expression for the data subsetted to what the user selected
filteredData <- reactive({
quakes[quakes$mag >= input$range[1] & quakes$mag <= input$range[2],]
})
# This reactive expression represents the palette function,
# which changes as the user makes selections in UI.
colorpal <- reactive({
colorNumeric(input$colors, quakes$mag)
})
output$map <- renderLeaflet({
# Use leaflet() here, and only include aspects of the map that
# won't need to change dynamically (at least, not unless the
# entire map is being torn down and recreated).
leaflet(quakes) %>% addTiles() %>%
fitBounds(~min(long), ~min(lat), ~max(long), ~max(lat))
})
# Incremental changes to the map (in this case, replacing the
# circles when a new color is chosen) should be performed in
# an observer. Each independent set of things that can change
# should be managed in its own observer.
observe({
pal <- colorpal()
leafletProxy("map", data = filteredData()) %>%
clearShapes() %>%
addCircles(radius = ~10^mag/10, weight = 1, color = "#777777",
fillColor = ~pal(mag), fillOpacity = 0.7, popup = ~paste(mag)
)
})
# Use a separate observer to recreate the legend as needed.
observe({
proxy <- leafletProxy("map", data = quakes)
# Remove any existing legend, and only if the legend is
# enabled, create a new one.
proxy %>% clearControls()
if (input$legend) {
pal <- colorpal()
proxy %>% addLegend(position = "bottomright",
pal = pal, values = ~mag
)
}
})
}
shinyApp(ui, server)```
It does not look like it's possible to manipulate the leaflet legend as it's rendered as an <svg> element and a few other <divs>. I came up with a potential solution that involved generating a new legend using tags$ul and tags$li.
I wrote a new function called legend which generates the html markup for a legend using colorNumeric and some set of values (using quakes$mag in this example). The markup is an unordered list <ul>. All list items are generated dynamically based on the number of bins specified (the default is 7). The code used to generate a sequence of colors is adapted from the R Leaflet package: https://github.com/rstudio/leaflet/blob/master/R/legend.R#L93.
Left and right titles can be specified by using the input arguments left_label and right_label. Background colors are defined using the style attribute. All other styles are defined using tags$style.
Here's an example (some of the code is clipped for readability).
legend(
values = quakes$mag,
palette = "BrBG",
title = "Magnitude",
left_label = "0%",
right_label = "100%"
)
#
# <span class="legend-title">Magnitude</span>
# <ul class="legend">
# <li class="legend-item ..."> 0%</li>
# <li class="legend-item ..." style="background-color: #543005; ..."></li>
# ...
To render the legend into the app, you will need to create an output element in the UI. I used absolutePanel to position the legend into the bottom right corner and defined a uiOutput element.
absolutePanel(
bottom = 20, right = 10, width: "225px;",
uiOutput("map_legend")
)
In the server, I replaced the code in the if (input$colors) with:
if (inputs$colors) {
output$map_legend <- renderUI({
legend(...)
})
}
I also added a condition to render a blank element should the option be unticked. Here's a screenshot followed by the example.
The only thing I couldn't figure out is how to link the legend color scale with the circles.
Hope this helps! Let me know if you have any questions.
Screenshot
Example
library(shiny)
library(leaflet)
library(RColorBrewer)
# manually create a legend
legend <- function(values, palette, title, left_label, right_label, bins = 7) {
# validate args
stopifnot(!is.null(values))
stopifnot(!is.null(palette))
stopifnot(!is.null(title))
stopifnot(!is.null(left_label))
stopifnot(!is.null(right_label))
# generate color palette using Bins (not sure if it's the best approach)
# #reference:
# https://github.com/rstudio/leaflet/blob/c19b0fb9c60d5caf5f6116c9e30dba3f27a5288a/R/legend.R#L93
pal <- colorNumeric(palette, values)
cuts <- if (length(bins) == 1) pretty(values, n = bins) else bins
n <- length(cuts)
r <- range(values, na.rm = TRUE)
# pretty cut points may be out of the range of `values`
cuts <- cuts[cuts >= r[1] & cuts <= r[2]]
colors <- pal(c(r[1], cuts, r[2]))
# generate html list object using colors
legend <- tags$ul(class = "legend")
legend$children <- lapply(seq_len(length(colors)), function(color) {
tags$li(
class = "legend-item legend-color",
style = paste0(
"background-color:", colors[color]
),
)
})
# add labels to list
legend$children <- tagList(
tags$li(
class = "legend-item legend-label left-label",
as.character(left_label)
),
legend$children,
tags$li(
class = "legend-item legend-label right-label",
as.character(right_label)
)
)
# render legend with title
return(
tagList(
tags$span(class = "legend-title", as.character(title)),
legend
)
)
}
# ui
ui <- tagList(
tags$head(
tags$style(
"html, body {
width: 100%;
height: 100%;
}",
".legend-title {
display: block;
font-weight: bold;
}",
".legend {
list-style: none;
padding: 0;
display: flex;
justify-content: center;
align-items: center;
}",
".legend-item {
display: inline-block;
}",
".legend-item.legend-label {
margin: 0 8px;
}",
".legend-item.legend-color {
width: 24px;
height: 16px;
}"
)
),
bootstrapPage(
leafletOutput("map", width = "100%", height = "100%"),
absolutePanel(
top = 10, right = 10,
sliderInput("range", "Magnitudes", min(quakes$mag), max(quakes$mag),
value = range(quakes$mag), step = 0.1
),
selectInput("colors", "Color Scheme",
rownames(subset(brewer.pal.info, category %in% c("seq", "div")))
),
checkboxInput("legend", "Show legend", TRUE)
),
absolutePanel(
bottom = 20,
right = 10,
width = "225px",
uiOutput("map_legend"),
)
)
)
server <- function(input, output, session) {
# Reactive expression for the data subsetted to what the user selected
filteredData <- reactive({
quakes[quakes$mag >= input$range[1] & quakes$mag <= input$range[2],]
})
# This reactive expression represents the palette function,
# which changes as the user makes selections in UI.
colorpal <- reactive({
colorNumeric(input$colors, quakes$mag)
})
output$map <- renderLeaflet({
# Use leaflet() here, and only include aspects of the map that
# won't need to change dynamically (at least, not unless the
# entire map is being torn down and recreated).
leaflet(quakes) %>%
addTiles() %>%
fitBounds(~min(long), ~min(lat), ~max(long), ~max(lat))
})
# Incremental changes to the map (in this case, replacing the
# circles when a new color is chosen) should be performed in
# an observer. Each independent set of things that can change
# should be managed in its own observer.
observe({
pal <- colorpal()
leafletProxy("map", data = filteredData()) %>%
clearShapes() %>%
addCircles(radius = ~10^mag/10, weight = 1, color = "#777777",
fillColor = ~pal(mag), fillOpacity = 0.7, popup = ~paste(mag)
)
})
# Use a separate observer to recreate the legend as needed.
observe({
if (input$legend) {
output$map_legend <- renderUI({
# build legend
legend(
values = filteredData()[["mag"]],
palette = as.character(input$colors),
title = "Mag",
left_label = "0%",
right_label = "100%"
)
})
}
if (!input$legend) {
output$map_legend <- renderUI({
tags$div("")
})
}
})
}
shinyApp(ui, server)

Creating Tabs with the name selected from select input function in shiny

I want to form tabs dynamically in my app i.e when i will select choices from my drop down menu and as soon as i select one option a tab with the same name should appear.The options which select input is showing is coming from my database.To made the scenario clear i am attaching sample app which is showing tabs dynamically and i later on i will attach my code
Here us sample app:
library(shiny)
ui <- (fluidPage(
titlePanel("Demonstration of renderUI in shiny - Dymanically creating the tabs based on user inputs"),
sidebarLayout(
sidebarPanel(
# Numeric input to enter the number of tabs needed
numericInput("n", 'Enter the number of tabs needed', 1)
),
mainPanel(
uiOutput('tabs')
)
)
))
server <- (function(input,output){
output$tabs = renderUI({
Tabs <- lapply(paste("tab no.", 1:input$n, sep=" "), tabPanel)
do.call(tabsetPanel, Tabs)
})
})
shinyApp(ui, server)
Here tabs are increasing according to numbers incremented and decremented, i have drop down menu which will show tuples of my database table which are as shown here
| name |
+----------------------+
| aaa |
| kart |
and here is my code with error:
library("shiny")
library("shinydashboard")
library("pool")
library("DBI")
pool <- dbPool(drv = RMySQL::MySQL(),dbname = "demo",host = "db.cr7dht.us-east-2.rds.amazonaws.com",username = "kak",password = "1278", port = 3306)
mychoices = dbGetQuery(pool,"select available_scenario from sc;")
ui <- (fluidPage(
titlePanel("Demonstration of renderUI in shiny - Dymanically creating the tabs based on user inputs"),
sidebarLayout(
sidebarPanel(
selectInput('n', "available scenarios", choices = mychoices, multiple = TRUE),
verbatimTextOutput("selected")
),
mainPanel(
uiOutput('tabs')
)
)
))
server <- (function(input,output,session){
output$tabs = renderUI({
observe({
updateSelectInput(
session, "n", choices = mychoices
)
})
Tabs <- lapply(paste("tab name", 1:input$choices, sep=" "), tabPanel)
do.call(tabsetPanel, Tabs)
})
})
shinyApp(ui, server)
First of all you don't want a tabpannel if n is NULL so I added the is.null check. Secondly remove the 1: when you are generating the tabs. the paste function will automatically convert your inpu$n to multiple characters string. No need to insert a range.
In addition, you don't need to put the updateSelectInput in your renderUI function.
Working example
mychoices = 1:10
ui <- (fluidPage(
titlePanel("Demonstration of renderUI in shiny - Dymanically creating the tabs based on user inputs"),
sidebarLayout(
sidebarPanel(
selectInput('n', "available scenarios", choices = mychoices, multiple = TRUE),
verbatimTextOutput("selected")),
mainPanel(
uiOutput('tabs')
)
)
))
server <- (function(input,output,session){
output$tabs = renderUI({
if(!is.null(input$n)){
Tabs <- lapply(paste("tab name", input$n, sep=" "), tabPanel)
do.call(tabsetPanel, Tabs)}
})
})

Shiny checkboxGroupInput with Choices Generated From ggplot

I'm trying to create a checkbox for which the choices are plots created through ggplot. In the result, the UI looks like the HTML code itself instead of evaluating the HTML code to show the chart. Any ideas how I can get the checkboxGroupInput to show ggplots?
Sample code below -
runApp(shinyApp(
ui = fluidPage(
headerPanel("Plot check box"),
mainPanel(
uiOutput("plotscheckboxes")
)
),
server = function(input, output, session) {
output$plot1 = renderPlot({
ggplot(mtcars)+geom_point(aes(x=mpg,y=mpg))
})
output$plot2 = renderPlot({
ggplot(mtcars)+geom_point(aes(x=mpg,y=mpg))
})
output$plotscheckboxes = renderUI({
plotlist = list(
plotOutput('plot1'),
plotOutput('plot2')
)
plotlist2 = do.call(tagList, plotlist)
# this just produces a list with 1,2, some sort of underlying value for the checkboxGroup
finaloptionlist = lapply(
seq(length(plotlist2)),
function(x) x
)
# the names of the list are what get used in the options so setting the names accordingly as the HTML code of the ggplot rendering
names(finaloptionlist) = sapply(plotlist2, function(x) paste(x, collapse = "\n"))
checkboxGroupInput("checkGroup", label = h3("Checkbox group"),
choices = finaloptionlist,
selected = 1)
})
}
))

Hide renderPrint Pre Tag Output from Shiny Application in R

I am developing a Shiny application in R. For certain pieces of renderPrint output I would like the shiny user interface to display nothing. Kind of like the hidden option for pre or div tags in HTML5 example shown below:
http://www.w3schools.com/tags/tryit.asp?filename=tryhtml5_global_hidden
Below is my shiny example code. A brief explanation: you can use a drop down menu to select one of two variables (factor variable or continuous variable). If you select the factor variable I want to show the caption and the table output. If you select the continuous variable I don't want to see anything. Right now, the caption disappears if you insert a blank string "" as the return to renderText. However, I don't know how to get renderPrint to show nothing. I've tried:
"". Doesn't work as it returns the actual blank string
NULL. Doesn't work as it returns the string NULL
invisible(). Best so far, but still doesn't work as it returns the grey formatted box.
Goal is to just display nothing. Shiny ui.r and server.r code given below:
library(shiny)
##
## Start shiny UI here
##
shinyUI(pageWithSidebar(
headerPanel("Shiny Example"),
sidebarPanel(
wellPanel(
selectInput( inputId = "variable1",label = "Select First Variable:",
choices = c("Binary Variable 1" = "binary1",
"Continuous Variable 1" = "cont1"),
selected = "Binary Variable 1"
)
)
),
mainPanel(
h5(textOutput("caption2")),
verbatimTextOutput("out2")
)
))
##
## Start shiny server file and simulated data here
##
binary1 <- rbinom(100,1,0.5)
cont1 <- rnorm(100)
dat <- as.data.frame(cbind(binary1, cont1))
dat$binary1 <- as.factor(dat$binary1)
dat$cont1 <- as.numeric(dat$cont1)
library(shiny)
shinyServer(function(input, output) {
inputVar1 <- reactive({
parse(text=sub(" ","",paste("dat$", input$variable1)))
})
output$caption2 <- renderText({
if ( (is.factor(eval(inputVar1()))==TRUE) ) {
caption2 <- "Univariate Table"
} else {
if ( (is.numeric(eval(inputVar1()))==TRUE) ) {
caption2 <- ""
}
}
})
output$out2 <- renderPrint({
if ( (is.factor(eval(inputVar1()))==TRUE) ) {
table(eval(inputVar1()))
} else {
if ( (is.numeric(eval(inputVar1()))==TRUE) ) {
invisible()
}
}
})
})
A few questions...
Why does renderText handle hidden/invisible presentation different than renderPrint? Is it because the former outputs text as pre tag; whereas, the latter displays formatted output in div tag?
To those HTML experts (upfront, I am not one)...what option would be best to get my output to display nothing? Is the hidden option embedded in a pre or div tag best (I know it doesn't work in IE browsers). Should I try something else? CSS options, etc?
Assuming hidden is the best way to go (or that I get an answer to 2. above), how do I pass this option/argument through the renderPrint function in shiny? Or would I need to use a different shiny function to achieve this functionality?
Btw...My R version is: version.string R version 3.0.1 (2013-05-16) and I am using shiny version {R package version 0.6.0}. Thanks in advance for your help.
I am not sure that I have understood your question, but try the following:
here is the Ui first:
library(shiny)
ui <- fluidPage(pageWithSidebar(
headerPanel("Shiny Example"),
sidebarPanel(
wellPanel(
selectInput(inputId = "variable1",label = "Select First Variable:",
choices = c("Binary Variable 1" = "binary1",
"Continuous Variable 1" = "cont1"),
selected = "Binary Variable 1"
)
)
),
mainPanel(
h5(textOutput("caption2")),
verbatimTextOutput("out2", placeholder=TRUE)
)
))
Start shiny Server file and simulated data here:
binary1 <- rbinom(100,1,0.5)
cont1 <- rnorm(100)
dat <- as.data.frame(cbind(binary1, cont1))
dat$binary1 <- as.factor(dat$binary1)
dat$cont1 <- as.numeric(dat$cont1)
server <- (function(input, output) {
inputVar1 <- reactive({
parse(text=sub(" ","",paste("dat$", input$variable1)))
})
output$caption2 <- renderText({
if ((is.factor(eval(inputVar1()))==TRUE) ) {
caption2 <- "Univariate Table"
} else {
if ((is.numeric(eval(inputVar1()))==TRUE) ) {
caption2 <- "Continous"
}
}
})
output$out2 <- renderPrint({
if ((is.factor(eval(inputVar1()))==TRUE) ) {table(eval(inputVar1()))}
})
})
And finally:
shinyApp(ui = ui, server = server)