How to add/remove input fields dynamically by a button in shiny - dynamic

I've been trying to find a solution how to add and remove input fields with a button in shiny. I don't have a source code since I haven't made that much progress, but this jQuery example (http://www.mkyong.com/jquery/how-to-add-remove-textbox-dynamically-with-jquery/) gives a good idea on what I'm trying to accomplish. Is this possible in shiny or should I use shinyjs to do this? Thank you in advance!

EDIT: I read the jQuery example a bit more, and added a code snippet doing what I think you were looking for.
I don't know jQuery, so I couldn't make much out of the example link. I took a guess on what you wanted, but I think the key idea is the use of renderUI and uiOutput even if my suggestion here misses the point.
To toggle a ui element:
If you specifically don't want to use shinyjs, you could do something like this:
library(shiny)
ui <- shinyUI(fluidPage(
actionButton("btn", "Toggle Textbox"),
textOutput("btn_val"),
uiOutput("textbox_ui")
))
server <- shinyServer(function(input, output, session) {
output$btn_val <- renderPrint(print(input$btn))
textboxToggle <- reactive({
if (input$btn %% 2 == 1) {
textInput("textin", "Write something:", value = "Hello World!")
}
})
output$textbox_ui <- renderUI({ textboxToggle() })
})
shinyApp(ui, server)
To add and remove elements:
After reading a bit of the jQuery example, I think this is similar to what you were looking for:
library(shiny)
ui <- shinyUI(fluidPage(
sidebarPanel(
actionButton("add_btn", "Add Textbox"),
actionButton("rm_btn", "Remove Textbox"),
textOutput("counter")
),
mainPanel(uiOutput("textbox_ui"))
))
server <- shinyServer(function(input, output, session) {
# Track the number of input boxes to render
counter <- reactiveValues(n = 0)
observeEvent(input$add_btn, {counter$n <- counter$n + 1})
observeEvent(input$rm_btn, {
if (counter$n > 0) counter$n <- counter$n - 1
})
output$counter <- renderPrint(print(counter$n))
textboxes <- reactive({
n <- counter$n
if (n > 0) {
lapply(seq_len(n), function(i) {
textInput(inputId = paste0("textin", i),
label = paste0("Textbox", i), value = "Hello World!")
})
}
})
output$textbox_ui <- renderUI({ textboxes() })
})
shinyApp(ui, server)
The problem with this approach is that each time you press the add or remove button, all of the input boxes get re-rendered. This means that any input you might have had on them disappears.
I think you could get around that by also saving the current input values of the input boxes into a reactiveValues object, and setting the values from the object as the starting values of the re-rendered input boxes by using the value option in textInput. I'll leave the implementation of that for now, though.

Thank you #Mikko Marttila for your answer. I was able to use it for my purpose. Also, referring to the issue of all input boxes getting re-rendered here I found a solution worked from this answer. You can save all user inputs using reactiveValuesToList(), then call the reactive list accordingly to set every value to the corresponding user's input in the lapply() statement.
library(shiny)
ui <- shinyUI(fluidPage(
sidebarPanel(
actionButton("add_btn", "Add Textbox"),
actionButton("rm_btn", "Remove Textbox"),
textOutput("counter")
),
mainPanel(uiOutput("textbox_ui"))
))
server <- shinyServer(function(input, output, session) {
# Track the number of input boxes to render
counter <- reactiveValues(n = 0)
# Track all user inputs
AllInputs <- reactive({
x <- reactiveValuesToList(input)
})
observeEvent(input$add_btn, {counter$n <- counter$n + 1})
observeEvent(input$rm_btn, {
if (counter$n > 0) counter$n <- counter$n - 1
})
output$counter <- renderPrint(print(counter$n))
textboxes <- reactive({
n <- counter$n
if (n > 0) {
isolate({
lapply(seq_len(n), function(i) {
textInput(inputId = paste0("textin", i),
label = paste0("Textbox", i),
value = AllInputs()[[paste0("textin", i)]])
})
})
}
})
output$textbox_ui <- renderUI({ textboxes() })
})
shinyApp(ui, server)
EDIT: I wrapped the lapply() statement in isolate() because it gets annoying when boxes are being re-rendered as you're trying to type in the field

Instead of re-rendering the entire list of inputs, try the following
I keep track of all the ids that are created, I remove the last one created, and I reuse the ids of the deleted ones.
I start with an initial box (there is no real need for that, but I guess in a real work scenario you would expect at least 1 textBox to appear and increase thereafter). It is straightforward to start without the initial box.
Also, I keep track of the values of the textInput boxes that are currently active, in a reactive List. You would definitely need this
Lastly, I think for the two reactiveValues I have [inserted and counter], one of them is possibly redundant, but hey...
Hope it helps!
library(shiny)
ui <- fluidPage(
actionButton("insertBtn", "Insert"),
actionButton("deleteBtn", "Delete"),
h4("My boxes"),
# Initial box here to start with. Not needed but it is nice to have one :)
div(id = "box-1", textInput(inputId = "box-1", label = "box-1")),
div(id = "placeholder"),
h4('Box contents'),
verbatimTextOutput("my_inputs")
)
server <- function(input, output, session) {
## keep track of elements inserted and a counter of the elements
rv <- reactiveValues(
inserted = c("box-1"),
counter = 1
)
observeEvent(input$insertBtn, {
rv$counter <- rv$counter+1
serial <- rv$counter
id <- paste0('box-', serial)
rv$inserted <- c(rv$inserted, id)
insertUI(
selector = '#placeholder',
## wrap element in a div with id for ease of removal
ui = div(id = id,
textInput(inputId = id, label = paste0("box-", serial))
)
)
})
observeEvent(input$deleteBtn, {
req(rv$counter>0)
# removes the last one
id_to_remove <- rv$inserted[length(rv$inserted)]
removeUI(
## pass it in as JQuery selector
selector = paste0('#', id_to_remove)
)
rv$inserted <- rv$inserted[-length(rv$inserted)]
rv$counter <- rv$counter - 1
})
my_inputs <- reactive({
req(rv$inserted) # need to have some inputs
l <- reactiveValuesToList(input)
# regex of the union of all inputs. Note the starting input box-1
ids_regex <- paste(c("box-1", rv$inserted), collapse = "|")
l[grepl(ids_regex, names(l))]
})
output$my_inputs <- renderPrint({
my_inputs()
})
}
shinyApp(ui, server)
Many thanks to
this post
and this
and these SO posts one, two

Related

RShiny Limit for Dropdown [duplicate]

I have written a simple example of what I am doing. I have 3000 numbers that I want to show in a selectInput. The numbers have to be in a reactive function, since in my original work, the data is from a file.
My problem is that when I run the app it only appears 1000 numbers, not the entire data (3000 numbers).
I have seen this post Updating selection of server-side selectize input with >1000 choices fails but I don't know how can I do it using uiOutput and renderUI.
Can anyone help me?
Thanks very much in advance
The code:
library(shiny)
ui <- fluidPage(
titlePanel("Numbers"),
sidebarLayout(
sidebarPanel(
uiOutput('selectUI')
),
mainPanel(
)
)
)
server <- function(input, output) {
num <- reactive({
data = c(1:3000)
return(data)
})
output$selectUI <- renderUI({
selectInput(inputId = 'options', "Select one", choices = num())
})
}
# Run the application
shinyApp(ui = ui, server = server)
Use selectizeInput instead of selectInput with the argument options = list(maxOptions = 3000).
Thanks to Stéphane Laurent's answer, the example will be solved like this:
library(shiny)
ui <- fluidPage(
titlePanel("Numbers"),
sidebarLayout(
sidebarPanel(
selectizeInput(inputId = "options", label = "Select one", choices=character(0)),
),
mainPanel(
)
)
)
server <- function(input, output, session) {
num <- reactive({
data = c(1:3000)
return(data)
})
observe({
updateSelectizeInput(
session = session,
inputId = "options",
label = "Select one",
choices= num(), options=list(maxOptions = length(num())),
server = TRUE)
})
}
# Run the application
shinyApp(ui = ui, server = server)
This code will work if you have more than 3000 entries. It will show you ALL the choices that you have. However, if you have a long list of choices (e.g. 60000) it will decrease the speed of your app.

How do I dynamically change label text color of R Shiny radioButtons widget when users select an option?

I am building a Shiny App where users have to complete several mandatory questions in the form of radioButtons, numericInputs, and textInputs in order to generate an output. To highlight which questions still need to be completed, I would like the label text to initially be rendered as "red", but then switch to "black" once a value has been selected and/or inputted into the widgets.
library(shiny)
ui <- fluidPage(
sidebarPanel(
radioButtons("my_radio_button", tags$p("Choose an Option", style = "color:red;"), choices = c("Option 1", "Option 2"), selected = character(0)),
)
)
server <- function(input, output, session) {
observeEvent(input$val, {
x <- input$my_radio_button
if (x == "Option 1" | x == "Option 2") {
## MAKE "Choose an Option" LABEL TURN BLACK
}
})
}
shinyApp(ui, server)
I found this example on stack exchange (R shiny conditionally change numericInput background colour) where they conditionally changed the background colour of the widget, but I don't know enough about programming to modify it to change the label text instead.
Any help would be greatly appreciated. Thanks!
You can use shinyjs
add shinyjs::useShinyjs() to the beginning of ui
add an id to the label param of the radioButtons ui element. I've used r_label in the example below
Observe for changes to input$my_radio_button, which trigger calls to shinyjs::html()
Full code below:
library(shiny)
library(shinyjs)
ui <- fluidPage(
shinyjs::useShinyjs(),
sidebarPanel(
radioButtons("my_radio_button",
label=tags$p("Choose an Option", style = "color:red;", id="r_label"),
choices = c("Option 1", "Option 2"), selected = character(0)),
)
)
server <- function(input, output, session) {
observeEvent(input$my_radio_button, {
shinyjs::html("r_label", "<p style='color:black'>Choose an Option</p>")
})
}
shinyApp(ui, server)

Shiny: insertTab with modules

I am trying to insert tabs dynamically calling the insertTab() function within a module. For some reason my approach does not work. I guess the problem is how I pass the tabsetPanel id and the value of an existing tabPanel (next to which a tab should be added) to the module.
actionButUI = function(id, label=NULL) {
ns = NS(id)
tagList(
actionButton(ns("button"), label = label)
)
}
actionBut = function(input, output, session, tabsetPanel_id, target) {
observeEvent(input$button, {
insertTab(
inputId = tabsetPanel_id(),
tabPanel(
"Dynamic", "This a dynamically-added tab"
),
target = target
)
})
}
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
actionButUI("append_tab", "Insert Tab")
),
mainPanel(
tabsetPanel(id = "tabs",
tabPanel("Hello", "This is the hello tab"),
tabPanel("Bar", "This is the bar tab")
)
)
)
)
server <- function(input, output, session) {
callModule(actionBut, "append_tab", reactive({input$tabs}), "Bar")
}
shinyApp(ui, server)
There seems to be an issue with namespaces. The followig modification fixes the issue
tabsetPanel(id = "append_tab-tabs",
tabPanel("Hello", "This is the hello tab"),
tabPanel("Bar", "This is the bar tab"))
The insertTab function tries to add a ui element in the module namespace rather than the global one. If you look at the source code of insertTab you'll see the line
inputId <- session$ns(inputId)
which causes this behavior.
Another way is to pass the session variable from the main app to insetTab rather than the module's session.
actionBut = function(input, output, session, tabsetPanel_id = "tabs", target) {
## do some environment hacking: Get the `session` variabe from the
## environment that invoked `callModule`.
parentSession <- get("session", envir = parent.frame(2))
observeEvent(input$button, {
insertTab(
inputId = tabsetPanel_id,
tabPanel(
"Dynamic", "This a dynamically-added tab"
),
target = target,
session = parentSession
)
})
}
This approach can get quite messy however if you work with nested modules.
An alternative to the InsertTab function, you can follow Ramnath solution here.
I have made it into modules.
library(shiny)
#---- Module Add dynamic tab ---
SidebarUi <- function(id) {
ns <- NS(id)
uiOutput(ns("sidebar"))
}
MainpanelUi <- function(id) {
ns <- NS(id)
uiOutput(ns("mainpanel"))
}
DynamicTabserver <- function(input, output, session) {
ns <- session$ns
output$sidebar <- renderUI({
actionButton(ns("nTabs"), label = "Add tab")
})
output$mainpanel <- renderUI({
uiOutput(ns('mytabs'))
})
output$mytabs <- renderUI({
nTabs = input$nTabs
myTabs = lapply(paste('Tab', 0:nTabs), tabPanel)
do.call(tabsetPanel, myTabs)
})
}
#---- App.R ---
ui = pageWithSidebar(headerPanel('Dynamic Tabs'),
sidebarPanel(SidebarUi("tabdemo")),
mainPanel(MainpanelUi("tabdemo")))
server = function(input, output, session) {
callModule(DynamicTabserver, "tabdemo")
}
shinyApp(ui, server)

Avoid re-loading datasets within a reactive in shiny

I have a shiny app that requires the input from one of several files. A simplified example would be:
library(shiny)
x <- matrix(rnorm(20), ncol=2)
y <- matrix(rnorm(10), ncol=4)
write.csv(x, 'test_x.csv')
write.csv(y, 'test_y.csv')
runApp(list(ui = fluidPage(
titlePanel("Choose dataset"),
sidebarLayout(
sidebarPanel(
selectInput("data", "Dataset", c("x", "y"), selected="x")
),
mainPanel(
tableOutput('contents')
)
)
)
, server = function(input, output, session){
myData <- reactive({
inFile <- paste0("test_", input$data, ".csv")
data <- read.csv(inFile, header=FALSE)
data
})
output$contents <- renderTable({
myData()
})
}))
In reality, the files I read in are much large, so I would like to avoid reading them in each time input$data changes, if it has already been done once. For example, by making the matrices mat_x and mat_y available within the environment, and then within myData testing:
if (!exists(paste0("mat_", input$data))) {
inFile <- paste0("test_", input$data, ".csv")
data <- read.csv(inFile, header=FALSE)
assign(paste0("mat_", input$data), data)
}
Is there a way to do this, or do I have to create a separate reactive for mat_x and mat_y and using that within myData? I actually have 9 possible input files, but each user may only want to use one or two.
You could do something like
myData <- reactive({
data <- fetch_data(input$data)
data
)}
fetch_data <- function(input) {
if (!exists(paste0("mat_", input))) {
inFile <- paste0("test_", input, ".csv")
data <- read.csv(inFile, header=FALSE)
assign(paste0("mat_", input), data)
} else {
data <- paste0("mat_", input)
}
return (data)
}

Calculating the load time of page elements using Rcurl? (R)

I started playing with the idea of testing a webpage load time using R. I have devised a tiny R code to do so:
page.load.time <- function(theURL, N = 10, wait_time = 0.05)
{
require(RCurl)
require(XML)
TIME <- numeric(N)
for(i in seq_len(N))
{
Sys.sleep(wait_time)
TIME[i] <- system.time(webpage <- getURL(theURL, header=FALSE,
verbose=TRUE) )[3]
}
return(TIME)
}
And would welcome your help in several ways:
Is it possible to do the same, but to also know which parts of the page took what parts to load? (something like Yahoo's YSlow)
I sometime run into the following error -
Error in curlPerform(curl = curl,
.opts = opts, .encoding = .encoding) :
Failure when receiving data from the
peer Timing stopped at: 0.03 0 43.72
Any suggestions on what is causing this and how to catch such errors and discard them?
Can you think of ways to improve the above function?
Update: I redid the function. It is now painfully slow...
one.page.load.time <- function(theURL, HTML = T, JavaScript = T, Images = T, CSS = T)
{
require(RCurl)
require(XML)
TIME <- NULL
if(HTML) TIME["HTML"] <- system.time(doc <- htmlParse(theURL))[3]
if(JavaScript) {
theJS <- xpathSApply(doc, "//script/#src") # find all JavaScript files
TIME["JavaScript"] <- system.time(getBinaryURL(theJS))[3]
} else ( TIME["JavaScript"] <- NA)
if(Images) {
theIMG <- xpathSApply(doc, "//img/#src") # find all image files
TIME["Images"] <- system.time(getBinaryURL(theIMG))[3]
} else ( TIME["Images"] <- NA)
if(CSS) {
theCSS <- xpathSApply(doc, "//link/#href") # find all "link" types
ss_CSS <- str_detect(tolower(theCSS), ".css") # find the CSS in them
theCSS <- theCSS[ss_CSS]
TIME["CSS"] <- system.time(getBinaryURL(theCSS))[3]
} else ( TIME["CSS"] <- NA)
return(TIME)
}
page.load.time <- function(theURL, N = 3, wait_time = 0.05,...)
{
require(RCurl)
require(XML)
TIME <- vector(length = N, "list")
for(i in seq_len(N))
{
Sys.sleep(wait_time)
TIME[[i]] <- one.page.load.time(theURL,...)
}
require(plyr)
TIME <- data.frame(URL = theURL, ldply(TIME, function(x) {x}))
return(TIME)
}
a <- page.load.time("http://www.r-bloggers.com/", 2)
a
your getURL call will only do one request and get the source HTML for the web page. It won't get the CSS or Javascript or other elements. If this is what you mean by 'parts' of the web page then you'll have to scrape the source HTML for those parts (in SCRIPT tags, or css references etc) and getURL them separately with timing.
Perhaps Spidermonkey from Omegahat could work.
http://www.omegahat.org/SpiderMonkey/