Shiny - DT - Single row selection, across several DT::tables - r

In the example below, I have 3 DT::datatables. I want the user to be able to select no more than one row from all these tables. I thence use dataTableProxy and selectRow, as per the section "Manipulate An Existing DataTables Instance" in the documentation. It works fine.
However, in my application, I have 24 (call that value N) tables. If I try to adapt the code below to my 24 tables page, I get an horrendous number of lines of code.
What is a smarter way of doing this?
In particular, how can I:
declare the observers dynamically? (answered by user5029763)
know which table (not row) has been clicked upon last? (ie. how to re write reactiveText()?)
EDIT : I copied in user5029763's answer (see below) in the code below.
DTWrapper <- function(data, pl = 5, preselec = c()){
datatable(data,
options = list(pageLength = pl, dom='t',ordering=F),
selection = list(mode = 'single', selected= preselec),
rownames = FALSE)
}
resetRows <- function(proxies, self){
for (i in 1:length(proxies)){
if (self != i){
proxies[[i]] %>% selectRows(NULL)
}
}
}
lapply(1:3, function(id) {
observe({
rownum <- input[[paste0("tab",id,"_rows_selected")]]
if (length(rownum) > 0) { resetRows(proxyList(), id) }
})
})
server = function(input, output) {
output$tab1 <- DT::renderDataTable(DTWrapper(head(mtcars[,1:3]), input$selectTop))
output$tab2 <- DT::renderDataTable(DTWrapper(head(mtcars[,1:3]), input$selectTop))
output$tab3 <- DT::renderDataTable(DTWrapper(head(mtcars[,1:3]), input$selectTop))
proxyList <- reactive({
proxies = list()
for (i in 1:3){
tableID <- paste("tab", i, sep="")
proxies[[i]] = dataTableProxy(tableID)
}
return(proxies)
})
reactiveText <- reactive({
rownum1 <- input$tab1_rows_selected
rownum2 <- input$tab2_rows_selected
rownum3 <- input$tab3_rows_selected
if (length(rownum1) > 0){return(c(rownum1, 1))}
if (length(rownum2) > 0){return(c(rownum2, 2))}
if (length(rownum3) > 0){return(c(rownum3, 3))}
})
output$txt1 <- renderText({
paste("You selected row ", reactiveText()[1]
, " from table ", reactiveText()[2], ".", sep="")
})
}
shinyApp(
ui = fluidPage(
fluidRow(column(4,DT::dataTableOutput("tab1"))
, column(4,DT::dataTableOutput("tab2"))
, column(4, DT::dataTableOutput("tab3")))
,fluidRow(column(4,textOutput("txt1")))
),
server = server
)
The textOutput is: "You selected the Xth row from the Yth table".

After edit:
You could try modules. Another way would be a lapply.
lapply(1:3, function(id) {
observe({
rownum <- input[[paste0("tab",id,"_rows_selected")]]
if (length(rownum) > 0) {
resetRows(proxyList(), id)
msg <- paste0("You selected row ", rownum, ", from table ", id, ".")
output$txt1 <- renderText(msg)
}
})
})

Related

Loop over data.frame and display result immediately in DT

I have a simple shiny app that holds a dataset as a reactive value.
Once a button is pressed, a function should be applied to each row and the result is added as another variable to that dataset.
The dataset is also shown as a DT.
The result variable should be rendered as soon as the computation for that row is finished.
At the moment, the loop/apply that applies the function to each row finishes and only afterwards the results are displayed.
As the function can run for a long time, I want the DT to be updated as soon as a run is finished, not when all runs finish.
I understand that this means I need to use promises/future so that the main shiny code block spawns new processes which do not block in this case the main thread from updating the values. Correct?
However, I am not able to get it to work.
Here is a small MWE using a simple for loop
library(shiny)
library(DT)
ui <- fluidPage(
actionButton("run", "RUN"),
hr(),
DT::dataTableOutput("table")
)
calc_fun <- function(val) {
Sys.sleep(0.5)
val * 10
}
server <- function(input, output, session) {
set.seed(123)
data_res <- reactiveVal(data.frame(id = 1:10, val = rnorm(10), val10 = NA))
observe({
for (i in seq(nrow(data_res()))) {
print(paste("Looking at row", i))
d <- data_res()
d[i, "val10"] <- calc_fun(val = d[i, "val"])
data_res(d)
}
}) %>% bindEvent(input$run)
# This should be rendered whenever a round in the for-loop has finished
# at the moment it is only run once the loop is finished
output$table <- DT::renderDataTable(data_res())
}
shinyApp(ui, server)
Thanks to #ismirsehregal, I came up with the following solution which uses futures to start the calculation in the background, which in turn write the current status to a file.
Shiny then reactively reads the file and updates the values.
The full MWE looks like this:
library(shiny)
library(DT)
library(future)
library(promises)
library(qs) # for fast file read/write, replace with csv if needed
plan(multisession)
ui <- fluidPage(
actionButton("run", "RUN"),
hr(),
textOutput("prog"),
uiOutput("status"),
hr(),
fluidRow(
column(6,
h2("Current Status"),
DT::dataTableOutput("table")
),
column(6,
h2("Data in File"),
tableOutput("file_data")
)
)
)
calc_fun <- function(val) {
Sys.sleep(runif(1, 0, 2))
val * 10
}
# main function that goes through the rows and starts the calculation
# note that the output is saved to a .qs file to be read in by another reactive
do_something_per_row <- function(df, outfile) {
out <- tibble(id = numeric(0), res = numeric(0))
for (i in seq(nrow(df))) {
v <- df$val[i]
out <- out %>% add_row(id = i, res = calc_fun(v))
qsave(out, outfile)
}
return(out)
}
# create a data frame of tasks
set.seed(123)
N <- 13
tasks_init <- tibble(id = seq(N), val = round(rnorm(N), 2), status = "Open", res = NA)
server <- function(input, output, session) {
# the temporary file to communicate over
outfile <- "temp_progress_watch.qs"
unlink(outfile)
data <- reactiveVal(tasks_init) # holds the current status of the tasks
data_final <- reactiveVal() # holds the results once all tasks are finished
output$prog <- renderText(sprintf("Progress: 0 of %i (0.00%%)", nrow(data())))
output$status <- renderUI(div(style = "color: black;", h3("Not yet started")))
# on the button, start the do_something_per_row function as a future
observeEvent(input$run, {
# if a file exists => the code runs already
if (file.exists(outfile)) return()
print("Starting to Run the code")
output$status <- renderUI(div(style = "color: orange;", h3("Working ...")))
d <- data()
future({do_something_per_row(d, outfile)}, seed = TRUE) %...>% data_final()
print("Done starting the code, runs now in the background! freeing the session for interaction")
# return(NULL) # hide future
})
observe({
req(data_final())
output$status <- renderUI(div(style = "color: green;", h3("Done")))
print("All Done - Results came back from the future!")
})
output$file_data <- renderTable(req(df_done()))
output$table <- DT::renderDataTable({
# no need to fire on every refresh, this is handled automatically later
DT::datatable(isolate(data())) %>%
formatStyle("status", color = styleEqual(c("Open", "Done"), c("white", "black")),
backgroundColor = styleEqual(c("Open", "Done"), c("red", "green")))
})
dt_proxy <- DT::dataTableProxy("table")
# look for changes in the file and load it
df_done <- reactiveFileReader(300, session, outfile, function(f) {
r <- try(qread(f), silent = TRUE)
if (inherits(r, "try-error")) return(NULL)
r
})
observe({
req(df_done())
open_ids <- data() %>% filter(status == "Open") %>% pull(id)
if (!any(df_done()$id %in% open_ids)) return()
print(paste("- new entry found:", paste(intersect(df_done()$id, open_ids), collapse = ", ")))
rr <- data() %>% select(-res) %>% left_join(df_done(), by = "id") %>%
mutate(status = ifelse(is.na(res), "Open", "Done"))
data(rr)
DT::replaceData(dt_proxy, rr)
# replace the progress text
txt <- sprintf("Progress: % 4i of % 4i (%05.2f%%)",
nrow(df_done()), nrow(data()), 100 * (nrow(df_done()) / nrow(data())))
output$prog <- renderText(txt)
})
}
shinyApp(ui, server)
or as a picture:

Why is my check box button non responsive in shinny app?

So I have this shiny app which includes a checkbox button:
library(bold)
library(stringr)
library(readr)
library(shiny)
library(shinyWidgets)
grades2<-function(groups,inputz,coordz){
taxon<-bold_seqspec(taxon=groups, format = "tsv")
taxon2<-taxon[taxon$species_name!=""|is.na(taxon$species_name),]
taxon2<-taxon2[!(taxon2$bin_uri == "" | is.na(taxon2$bin_uri)), ]
taxon2$base_number=str_count(taxon2$nucleotides, pattern="[A-Z]")
taxon2<-taxon2[taxon2$base_number>=inputz,]
if (coordz==TRUE){
taxon2<-taxon2[!(is.na(taxon2$lat)) | taxon2$country!="",]
}else{
taxon2<-taxon2
}
assign('taxon2',taxon2,envir=.GlobalEnv)
}
ui <- navbarPage(title=tags$h3("APP"),tabPanel(column(12,align="center",tags$h4("Download"),tags$br(),
sliderInput("seqsize", "Mininum number of base pairs for sequences in reference library:",min = 0, max = 1000, value = 500),textOutput("SliderText"),
checkboxInput("rmvpaises", "Remove records without data on country of origin or latitude", TRUE),
textInputAddon(inputId="taxa2",addon=icon("search"),width="500px",label=tags$h5(tags$strong("Enter the name of the taxonomic group or groups separated by commas, without spaces:")),placeholder="Example: Carnivora,Ursidae,Artiodactyla,Soricomorpha"),
downloadButton("downloadData_2","Download"))))
server <- function(input, output){
#sliderValues <- reactive({as.integer(input$seqsize)})
#output$values <- renderText({
# sliderValues()
#})
taxaInput_2 <- reactive({grades2(unlist(strsplit(input$taxa2, ",")),as.integer(input$seqsize),input$rmvpaises)})
output$downloadData_2 <- downloadHandler(
filename = function() {
paste(input$taxa2,sep_out=",", ".tsv")
},
content = function(file) {
shiny::withProgress(
value=10,
{
shiny::incProgress(10/10)
write_tsv(taxaInput_2(), file)
}
)
}
)
output$value <- renderText({ input$rmvpaises })
}
shinyApp(ui=ui,server=server)
For some reason while using the app, the check box is non-responsive. It doesn't change.
The input of the check box is being used in the initial function "grades2" and it is the "coordz" argument.
Thank you so much for any answer
You're missing the non-optional argument title for tabPanel. Consequently, it's using the column UI element as the title for the tab which I'm assuming is doing weird stuff with the z-index.
You need an observer to update the checkboxInput on the server side. The checkbox works fine in this code
grades2<-function(groups,inputz,coordz){
taxon<-bold_seqspec(taxon=groups, format = "tsv")
taxon2<-taxon[taxon$species_name!=""|is.na(taxon$species_name),]
taxon2<-taxon2[!(taxon2$bin_uri == "" | is.na(taxon2$bin_uri)), ]
taxon2$base_number=str_count(taxon2$nucleotides, pattern="[A-Z]")
taxon2<-taxon2[taxon2$base_number>=inputz,]
if (coordz) {
taxon2<-taxon2[!(is.na(taxon2$lat)) | taxon2$country!="",]
}else{
taxon2<-taxon2
}
assign('taxon2',taxon2,envir=.GlobalEnv)
}
ui <- navbarPage(title=tags$h3("APP"),tabPanel(value="Panel1" , column(12,align="center",tags$h4("Download"),tags$br(),
sliderInput("seqsize", "Mininum number of base pairs for sequences in reference library:",min = 0, max = 1000, value = 500),textOutput("SliderText"),
checkboxInput("rmvpaises", "Remove records without data on country of origin or latitude", TRUE),
textInputAddon(inputId="taxa2",addon=icon("search"),width="500px",label=tags$h5(tags$strong("Enter the name of the taxonomic group or groups separated by commas, without spaces:")),placeholder="Example: Carnivora,Ursidae,Artiodactyla,Soricomorpha"),
downloadButton("downloadData_2","Download"))))
server <- function(input, output, session){
#sliderValues <- reactive({as.integer(input$seqsize)})
#output$values <- renderText({
# sliderValues()
#})
observe({
updateCheckboxInput(session, "rmvpaises", value=input$rmvpaises)
})
taxaInput_2 <- reactive({grades2(unlist(strsplit(input$taxa2, ",")),as.integer(input$seqsize),input$rmvpaises)})
output$downloadData_2 <- downloadHandler(
filename = function() {
paste(input$taxa2,sep_out=",", ".tsv")
},
content = function(file) {
shiny::withProgress(
value=10,
{
shiny::incProgress(10/10)
write_tsv(taxaInput_2(), file)
}
)
}
)
output$value <- renderText({ input$rmvpaises })
}
shinyApp(ui=ui,server=server)

Move rows from one DT to other DTs using action buttons in R Shiny

UPDATE
I am trying to make an app using shiny and DT, similar to the accepted answer from Shree here. I would like, thou, to have the following additions to it:
Extend the solution from Shree, so that items from the DT on the left (source) can be moved to more than one table on the right and back and be extensible, so that I can decide how many tables I want to put on the right. That is, different items from the table on the left can go in a different table on the right.
In addition, to have double arrow buttons next to each table on the right, so that all items in a table can be added or removed by click on the double arrow buttons, not only the single arrow buttons for moving just selected variables, like here, but still be able to decide whether to display them or not.
Tables on the right to be visible even when empty.
Can someone help with these?
As already mentioned shiny modules are an elegant way to solve this issue. You have to pass in some reactives for receiving rows and you have to return some reactives to send rows / tell the main table that it should remove the rows it just sent.
A fully working example looks as follows:
library(shiny)
library(DT)
receiver_ui <- function(id, class) {
ns <- NS(id)
fluidRow(
column(width = 1,
actionButton(ns("add"),
label = NULL,
icon("angle-right")),
actionButton(ns("add_all"),
label = NULL,
icon("angle-double-right")),
actionButton(ns("remove"),
label = NULL,
icon("angle-left")),
actionButton(ns("remove_all"),
label = NULL,
icon("angle-double-left"))),
column(width = 11,
dataTableOutput(ns("sink_table"))),
class = class
)
}
receiver_server <- function(input, output, session, selected_rows, full_page, blueprint) {
## data_exch contains 2 data.frames:
## send: the data.frame which should be sent back to the source
## receive: the data which should be added to this display
data_exch <- reactiveValues(send = blueprint,
receive = blueprint)
## trigger_delete is used to signal the source to delete the rows whihc just were sent
trigger_delete <- reactiveValues(trigger = NULL, all = FALSE)
## render the table and remove .original_order, which is used to keep always the same order
output$sink_table <- renderDataTable({
dat <- data_exch$receive
dat$.original_order <- NULL
dat
})
## helper function to move selected rows from this display back
## to the source via data_exch
shift_rows <- function(selector) {
data_exch$send <- data_exch$receive[selector, , drop = FALSE]
data_exch$receive <- data_exch$receive[-selector, , drop = FALSE]
}
## helper function to add the relevant rows
add_rows <- function(all) {
rel_rows <- if(all) req(full_page()) else req(selected_rows())
data_exch$receive <- rbind(data_exch$receive, rel_rows)
data_exch$receive <- data_exch$receive[order(data_exch$receive$.original_order), ]
## trigger delete, such that the rows are deleted from the source
old_value <- trigger_delete$trigger
trigger_delete$trigger <- ifelse(is.null(old_value), 0, old_value) + 1
trigger_delete$all <- all
}
observeEvent(input$add, {
add_rows(FALSE)
})
observeEvent(input$add_all, {
add_rows(TRUE)
})
observeEvent(input$remove, {
shift_rows(req(input$sink_table_rows_selected))
})
observeEvent(input$remove_all, {
shift_rows(req(input$sink_table_rows_current))
})
## return the send reactive to signal the main app which rows to add back
## and the delete trigger to remove rows
list(send = reactive(data_exch$send),
delete = trigger_delete)
}
ui <- fluidPage(
tags$head(tags$style(HTML(".odd {background: #DDEBF7;}",
".even {background: #BDD7EE;}",
".btn-default {min-width:38.25px;}",
".row {padding-top: 15px;}"))),
fluidRow(
actionButton("add", "Add Table")
),
fluidRow(
column(width = 6, dataTableOutput("source_table")),
column(width = 6, div(id = "container")),
)
)
server <- function(input, output, session) {
orig_data <- mtcars
orig_data$.original_order <- seq(1, NROW(orig_data), 1)
my_data <- reactiveVal(orig_data)
handlers <- reactiveVal(list())
selected_rows <- reactive({
my_data()[req(input$source_table_rows_selected), , drop = FALSE]
})
all_rows <- reactive({
my_data()[req(input$source_table_rows_current), , drop = FALSE]
})
observeEvent(input$add, {
old_handles <- handlers()
n <- length(old_handles) + 1
uid <- paste0("row", n)
insertUI("#container", ui = receiver_ui(uid, ifelse(n %% 2, "odd", "even")))
new_handle <- callModule(
receiver_server,
uid,
selected_rows = selected_rows,
full_page = all_rows,
## select 0 rows data.frame to get the structure
blueprint = orig_data[0, ])
observeEvent(new_handle$delete$trigger, {
if (new_handle$delete$all) {
selection <- req(input$source_table_rows_current)
} else {
selection <- req(input$source_table_rows_selected)
}
my_data(my_data()[-selection, , drop = FALSE])
})
observe({
req(NROW(new_handle$send()) > 0)
dat <- rbind(isolate(my_data()), new_handle$send())
my_data(dat[order(dat$.original_order), ])
})
handlers(c(old_handles, setNames(list(new_handle), uid)))
})
output$source_table <- renderDataTable({
dat <- my_data()
dat$.original_order <- NULL
dat
})
}
shinyApp(ui, server)
Explanation
A module contains the UI and the server and thanks to the namespacing techniques, names need only to be unique within one module (and each module must later have also a unique name). The module can communicate with the main app via reactives which are either passed to callModule (please note that I am still using the old functions as I have not yet updated my shiny library), or which are returned from the server function.
In the main app, we have a button, which dynamically inserts the UI and calls callModule to activate the logic. observers are also generated in the same call to make the server logic work.
To get double arrow buttons, you can use:
actionButton("add_all", label = NULL, icon("angle-double-right"),
lib = "font-awesome")
Note that ?icon links to the fontawesome page, which provides double arrow icons: https://fontawesome.com/icons?d=gallery&q=double%20arrow&m=free.
To remove all items you can just switch to the default state:
observeEvent(input$remove_all, {
mem$selected <- select_init
mem$pool <- pool_init
})
where the default state was defined as:
pool_init <- data.frame(data = LETTERS[1:10])
select_init <- data.frame(data = "")
To add all rows you can basically just switch the states:
mem$selected <- pool_init
mem$pool <- select_init
Note that i use an (almost) empty data.frame to ensure that a datatable is shown even if it is empty. That is not very elegant as it has an empty string in it. There might be better ways for that. E.g. if you add a row and deselect it again, so that the table is empty it shows No data available in table. That actually looks better.
Full reproducible example:
library(shiny)
library(DT)
ui <- fluidPage(
br(),
splitLayout(cellWidths = c("40%", "10%", "40%", "10%"),
DTOutput("pool"),
list(
br(),br(),br(),br(),br(),br(),br(),
actionButton("add", label = NULL, icon("arrow-right")),
br(),br(),
actionButton("remove", label = NULL, icon("arrow-left"))
),
DTOutput("selected"),
list(
br(),br(),br(),br(),br(),br(),br(),
actionButton("add_all", label = NULL, icon("angle-double-right"),
lib = "font-awesome"),
br(),br(),
actionButton("remove_all", label = NULL, icon("angle-double-left"),
lib = "font-awesome")
)
)
)
pool_init <- data.frame(data = LETTERS[1:10])
select_init <- data.frame(data = "")
server <- function(input, output, session) {
mem <- reactiveValues(
pool = pool_init, selected = select_init
)
observeEvent(input$add, {
req(input$pool_rows_selected)
mem$selected <- rbind(isolate(mem$selected), mem$pool[input$pool_rows_selected, , drop = F])
mem$selected <- mem$selected[sapply(mem$selected, nchar) > 0, , drop = FALSE]
mem$pool <- isolate(mem$pool[-input$pool_rows_selected, , drop = F])
})
observeEvent(input$remove, {
req(input$selected_rows_selected)
mem$pool <- rbind(isolate(mem$pool), mem$selected[input$selected_rows_selected, , drop = F])
mem$pool <- mem$pool[sapply(mem$pool, nchar) > 0, , drop = FALSE]
mem$selected <- isolate(mem$selected[-input$selected_rows_selected, , drop = F])
})
observeEvent(input$add_all, {
mem$selected <- pool_init
mem$pool <- data.frame(data = "")
})
observeEvent(input$remove_all, {
mem$selected <- select_init
mem$pool <- pool_init
})
output$pool <- renderDT({
mem$pool
})
output$selected <- renderDT({
mem$selected
})
}
shinyApp(ui, server)
Concerning the requirements for multiple tables, please see my comment.
To generalise to an arbitrary number of tables, I'd use a module. The module would contain the GUI and logic for a single DT. It would have arguments for the "input DT" (the table from which rows are received) and the "output DT" (the table to which rows are sent). Either or both could be NULL. The GUI would display the DT and have a widgets to initiate the various "send rows" commands. See here for more details on modules.
As for your inability to remove rows from the source table: I'm not overly familiar with DT, but I believe you need to use a proxy: as this page says "After a table has been rendered in a Shiny app, you can use the proxy object returned from dataTableProxy() to manipulate it. Currently supported methods are selectRows(), selectColumns(), selectCells(), selectPage(), and addRow().".

Extracting values of input widgets after updating dynamic UI using renderUI()

I have successfully updated UI dynamically through renderUI(). I have a long list of inputs to choose from. The check boxes are used to dynamically add numeric inputs. So, to implement this, I used lapply. However, I have used values of selected check boxes in checkboxgroup itself to populate IDs of the dynamically added numerical input instead of using paste(input, i) in lapply.
ui code snippet :
checkboxGroupInput(inputId = "checkboxgrp", label = "Select types",
choices = list("ELECTAPP","NB W $","PUR","MANUAL LTR","REDEMPTION","NB W TRANSFER","NB WOUT $","OUTPUT")),
...
fluidRow(column(12, verbatimTextOutput("value")))
...
uiOutput("numerics")
server code snippet :
renderUI({
numInputs <- length(input$checkboxgrp)
if(numInputs==0){
wellPanel("No transaction selected")
}
else{
lapply(1:numInputs, function(i){
x[i]=input$checkboxgrp[i]
list(numericInput(input$checkboxgrp[i], min = 0, label = input$checkboxgrp[i],
value= input[[x[i]]] ))
})
}
})
output$value <- renderPrint({
numInputs <- length(input$checkboxgrp)
lapply(1:numInputs, function(i){
print(input[[x[i]]]) ## ERROR
})
})
I have used input[[x[i]]] as to instantiate value to be retained after adding or removing a numeric input. But, I want to extract values from input$x[i] or input[[x[i]]] into a vector for further use which I'm unable to do.
*ERROR:Must use single string to index into reactivevalues
Any help is appreciated.
EDIT
using 3 different ways of extracting values from input generate 3 different errors:
Using print(input$x[i]) # ERROR
NULL
NULL
NULL
NULL
[[1]]
NULL
[[2]]
NULL
[[3]]
NULL
[[4]]
NULL
Using print(input[[x[i]]]) # ERROR
Must use single string to index into reactivevalues
Using print('$'(input, x[i])) # ERROR
invalid subscript type 'language'
If I understand you correctly, you want to access values of dynamically generated widgets and then just print them out.
In my example below, which should be easy to generalise, the choices are the levels of the variable Setosa from the iris dataset.
The IDs of the generated widgets are always given by the selected values in checkboxGroupInput. So, input$checkboxgrp says to shiny for which level of setosa there should be generated a widget. At the same time input$checkboxgrp gives IDs of generated widgets. That's why you don't need to store the IDs of "active" widgets in other variable x (which is probably a reactive value).
To print the values out you can do the following:
output$value <- renderPrint({
activeWidgets <- input$checkboxgrp
for (i in activeWidgets) {
print(paste0(i, " = ", input[[i]]))
}
})
This line print(input[[x[i]]]) ## ERROR yields an error because x[i] (whatever it is) is not a vector with a single value but with multiple values.
Full example:
library(shiny)
ui <- fluidPage(
titlePanel("Old Faithful Geyser Data"),
sidebarLayout(
sidebarPanel(
checkboxGroupInput("checkboxgrp", "levels", levels(iris$Species))
),
mainPanel(
fluidRow(
column(6, uiOutput("dynamic")),
column(6, verbatimTextOutput("value"))
)
)
)
)
server <- function(input, output) {
output$dynamic <- renderUI({
numInputs <- length(input$checkboxgrp)
if(numInputs==0){
wellPanel("No transaction selected")
}
else{
lapply(1:numInputs, function(i){
x[i]=input$checkboxgrp[i]
list(numericInput(input$checkboxgrp[i], min = 0, label = input$checkboxgrp[i],
value= input[[x[i]]] ))
})
}
})
output$value <- renderPrint({
activeWidgets <- input$checkboxgrp
for (i in activeWidgets) {
print(paste0(i, " = ", input[[i]]))
}
})
}
shinyApp(ui = ui, server = server)
Edit:
You could tweak the lapply part a little bit (mind <<- operator :) )
else{
activeWidgets <- input$checkboxgrp
val <- 0
lapply(activeWidgets, function(i){
val <<- val + 1
list(numericInput(i, min = 0, label = i,
value = val ))
})
}
Edit 2 In response to a comment:
server <- function(input, output) {
output$dynamic <- renderUI({
numInputs <- length(input$checkboxgrp)
if(numInputs==0){
wellPanel("No transaction selected")
}
else{
activeWidgets <- input$checkboxgrp
val <- 0
lapply(activeWidgets, function(i){
val <<- val + 1
list(numericInput(i, min = 0, label = i,
value = val ))
})
}
})
allChoices <- reactive({
# Require that all input$checkboxgrp and
# the last generated numericInput are available.
# (If the last generated numericInput is available (is not NULL),
# then all previous are available too)
# "eval(parse(text = paste0("input$", input$checkboxgrp))))" yields
# a value of the last generated numericInput.
# In this way we avoid multiple re-evaulation of allChoices()
# and errors
req(input$checkboxgrp, eval(parse(text = paste0("input$", input$checkboxgrp))))
activeWidgets <- input$checkboxgrp
res <- numeric(length(activeWidgets))
names(res) <- activeWidgets
for (i in activeWidgets) {
res[i] <- input[[i]]
}
res
})
output$value <- renderPrint({
print(allChoices())
})
}

R shiny: How to build dynamic UI (text input)

I'm trying to build dynamic textInput with R shiny. The user should write in a text field then push an add button to fill another field. However, each time I push the button all the fields become empty, It's like if I must define how many fields I want in advance. Any help will be very appreciated.
Thank you
Here is my code:
library(shiny)
shiny::runApp(list(
ui = pageWithSidebar(
headerPanel("test"),
sidebarPanel(
helpText("Alternatives list"),
verbatimTextOutput("summary")
),
mainPanel(
actionButton("obs","add"),
htmlOutput("selectInputs")
)
)
,
server = function(input,output){
observe({
if (input$obs == 0)
return()
isolate({
output$selectInputs <- renderUI({
if(!is.null(input$obs))
print("w")
w <- ""
for(i in 1:input$obs) {
w <- paste(w,textInput(paste("a",i,sep=""),paste("a",i,sep="")))
}
HTML(w)
})
output$summary <- renderPrint({
print("your Alternative are:")
for(i in 1:input$obs) {
print(
input[[sprintf("a%d",i)]]
)
}
})
outputOptions(output, 'selectInputs', suspendWhenHidden=FALSE)
})
})
}))
Your problem is that you regenerate all the buttons (so the input$aX) each time you click on the button. And they are generated without value by default, that's why when you read them they are all nulls.
For example you can see your mistake if you supress the loop in your output$selectInputs code : (But now it only allow you to set each aX only 1 time.)
output$selectInputs <- renderUI({
if(!is.null(input$obs))
print("w")
w <- ""
w <- paste(w, textInput(paste("a", input$obs, sep = ""), paste("a", input$obs, sep = "")))
HTML(w)
})
Keeping your code (then keeping the regeneration of all the buttons), you should add to the value argument of each textInput his "own value" (in reality, the value of the old input with the same id) value = input[[sprintf("a%d",i)]] :
output$selectInputs <- renderUI({
w <- ""
for(i in 1:input$obs) {
w <- paste(w, textInput(paste("a", i, sep = ""), paste("a", i, sep = ""), value = input[[sprintf("a%d",i)]]))
}
HTML(w)
})

Resources