R Shiny: Dynamic Row of Action Buttons - r

I want to have a set of two action buttons in Shiny where the inputID and number of duplicates is based off the number of rows in a data.frame. Attached below is my thought process that isn't currently functioning correct. Instead of adding a button whenever a button is pressed, I want "n" sets of buttons equal to the number of rows in a data.frame.
library(shiny)
ui <- basicPage(
fluidRow(
actionButton(inputId = "add_button",
label = "Add Button")
),
uiOutput("more_buttons")
)
server <- function(input, output){
rvs <- reactiveValues(buttons = list(actionButton(inputId = "button1",
label = 1)))
observeEvent(eventExpr = input$add_button,
handlerExpr = {
len <- length(rvs$buttons) + 1
rvs$buttons[[len]] <- actionButton(inputId = paste0("button",len),
label = len)
})
output$more_buttons <- renderUI({
do.call(fluidRow, rvs$buttons)
})
observeEvent(rvs$buttons,{
for(ii in 1:length(rvs$buttons)){
local({
i <- ii
observeEvent(eventExpr = input[[paste0("button",i)]],
handlerExpr = {print(sprintf("You clicked btn number %d",i))})
})
}
})
}
shinyApp(ui, server)

Here is a simplified version of what you want to accomplish
ui <- fluidPage(
selectInput("df", "choose a dataframe",
c("mtcars", "mpg")),
uiOutput("buttons")
)
server = function(input, output, session){
reactiveFrame = reactive({
if(input$df == "mtcars")
return(mtcars)
return(ggplot2::mpg)
})
nrowR = reactive({
nrow(reactiveFrame())
})
m <- 0
output$buttons = renderUI({
m <- m+1
do.call(
fluidPage,
lapply(
1:nrowR(),
function(i)
span(
actionButton(paste0("a", i, "-", m),paste0("a", i)),
actionButton(paste0("b", i, "-", m),paste0("b", i))
)
)
)
})
}
shinyApp(ui,server)

Related

Make Shiny SelectInput allow for multiple duplicated values to be selected

I would like to allow the user to select multiple times the same choice. It implies that when the user selects some element, it should not be removed from the choices' dropdown menu.
Here is a minimal reproducible example:
library(shiny)
ui <- fluidPage(
selectInput(
inputId = "ManyDuplicated",
label = 'SelectInput',
choices = c('Hello', 'World'),
selected = NULL,
multiple = TRUE
)
)
server <- function(input, output) {
}
shinyApp(ui = ui, server = server)
How it is:
How I would like it to be:
What I tried and may be of help:
This code (https://github.com/rstudio/shiny/issues/2939#issuecomment-678269674) works perfectly for a single choice ("^" in the case). However, I can't make it work for more choices (c("^", "a"), for example).
library(shiny)
ui <- fluidPage(
selectInput("x", "choose", c("^" = 1), multiple = TRUE)
)
server <- function(input, output, session) {
observeEvent(input$x, {
choices <- seq_len(length(input$x)+1)
names(choices) <- rep("^", length(choices))
updateSelectInput(session, "x", choices = choices, selected = isolate(input$x))
})
}
shinyApp(ui, server)
With multiple choices it gets a bit more complicated
library(shiny)
my_choices <- c('Hello', 'World')
ui <- fluidPage(
selectInput(
inputId = "ManyDuplicated",
label = 'SelectInput',
choices = my_choices,
selected = NULL,
multiple = TRUE
)
)
server <- function(input, output, session) {
observeEvent(input$ManyDuplicated, {
selected_values <- input$ManyDuplicated
names(selected_values) <- gsub("\\..*", "", selected_values)
print( paste( "Current selection :",
paste( names(selected_values), collapse = ", ")))
number_of_items <- length(input$ManyDuplicated)
new_choices <- paste(my_choices, number_of_items + 1, sep = ".")
names(new_choices) <- my_choices
all_choices <- c(selected_values, new_choices )
updateSelectInput(session, "ManyDuplicated",
choices = all_choices,
selected = isolate(input$ManyDuplicated))
})
}
shinyApp(ui = ui, server = server)
shinyApp(
ui = fluidPage(
selectInput("choose", "Choose",
sort(c("a" = "a1", "b" = "b2")),
multiple = TRUE
)
),
server = function(input, output, session) {
old_choose = c()
old_choices = sort(c("a" = "a1", "b" = "b2"))
idx <- 2
observeEvent(input$choose, {
req(!identical(old_choose, input$choose))
addition <- base::setdiff(input$choose, old_choose)
if (length(addition) > 0) {
idx <<- idx + 1
new_nm <- names(old_choices[old_choices == addition])
new_val <- paste0(new_nm, idx)
choices <- c(old_choices, new_val)
names(choices) <- c(names(old_choices), new_nm)
}
missing <- base::setdiff(old_choose, input$choose)
if (length(missing) > 0) {
missing_idx <- which(old_choices == missing)
choices <- old_choices[-missing_idx]
}
choices <- sort(choices)
updateSelectInput(session, "choose",
choices = choices,
selected = input$choose
)
old_choose <<- input$choose
old_choices <<- choices
}, ignoreNULL = FALSE)
}
)

R Shiny: Update datatable with checkbox

I want to dynamically populate a table and update a list of items selected using the checkbox.
Here is my attempt. I report some random data points into a table and uncheck some of them expecting the list at the bottom of the plot to change.
The list is correctly updated only when unchecking the last item but not the others.
Any suggestions?
library(shiny)
library(DT)
ui <- fluidPage(
fluidRow(
column(4,
plotOutput("plot1", click = "plot_click"),
textInput("collection_txt",label="Foo")),
column(4,
DT::dataTableOutput("table"))
)
)
server <- function(input, output,session) {
# collect data points
x <- reactiveValues(selected = '')
y <- reactiveValues(selected = '')
observeEvent(input$plot_click, {
x$x <- c(x$x,input$plot_click$x)
y$y <- c(y$y,input$plot_click$y)
})
output$plot1 <- renderPlot({
plot(1,1, type='n')
points(x$x,y$y)
})
# populate the table
shinyInput <- function(FUN,id,num,...) {
inputs <- character(num)
for (i in seq_len(num)) {
inputs[i] <- as.character(FUN(paste0(id,i),label=NULL,...))
}
inputs
}
output$table = DT::renderDataTable({
tab <- data.frame('x'=x$x ,'y'=y$y)
DT::datatable(cbind(tab, Selected=shinyInput(checkboxInput,"srows_",nrow(tab),value=TRUE,width=1)),
options = list(orderClasses = TRUE,
drawCallback= JS(
'function(settings) {
Shiny.bindAll(this.api().table().node());}'),
dom = 't', searching=FALSE),
selection='none',escape=F)
})
# show the list of selected items
rowSelect <- reactive({
rows=names(input)[grepl(pattern = "srows_",names(input))]
paste(unlist(lapply(rows,function(i){
if(input[[i]]==T){
return(substr(i,gregexpr(pattern = "_",i)[[1]]+1,nchar(i)))
}
})))
})
observe({
updateTextInput(session, "collection_txt", value = rowSelect() ,label = "Selected:" )
})
}
shinyApp(ui, server)
You have to unbind the previously created Shiny objects before creating the new table, when you click on a point. For example with shinyjs:
library(shinyjs)
ui <- fluidPage(
useShinyjs(),
fluidRow(
......
observeEvent(input$plot_click, {
runjs("Shiny.unbindAll($('#table').find('table').DataTable().table().node());")
x$x <- c(x$x,input$plot_click$x)
y$y <- c(y$y,input$plot_click$y)
})

Getting an input list containing inputs present in the current session

I want to retrieve the list of inputs in the current shiny session.
We can retrieve the list of inputs using names(input).
I have a uiOutput and based on different conditions I am rendering different types inputs. The current problem I am facing is that when the condition changes the inputs from previous renderUI is also present in the list. Is there a way to get only the inputs in the current session?
To explain my query better I have the following sample code:
library(shiny)
ui <- fluidPage(
sliderInput(inputId = "slider",label = "", min = 1, max = 3, value = 1),
uiOutput("UI"),
actionButton(inputId = "btn", label = "Show Inputs"),
verbatimTextOutput(outputId = "textOp")
)
server <- function(input, output){
observeEvent(input$slider,{
if(input$slider == 1){
output$UI <- renderUI(
textInput("txt1",label = "Slider in position 1")
)
}else if(input$slider == 2){
output$UI <- renderUI(
textInput("txt2",label = "Slider in position 2")
)
}else{
output$UI <- renderUI(
textInput("txt3",label = "Slider in position 3")
)
}
})
observeEvent(input$btn,{
output$textOp <- renderText(
paste0(names(input), ",")
)
})
}
shinyApp(ui = ui, server = server)
In the above code when I first click on action button labelled "Show Input" I get the following text as the output:
btn, slider, txt1,
Now when I move the slider to 2 my output is as follows:
btn, slider, txt1, txt2,
Here txt1 was generated when the slider was at position 1, and this renderUI was overridden by output$UI <- renderUI(textInput("txt2",label = "Slider in position 2")). I want an input list where txt1 is not there. Is there a way to do that?
I came up with kind of a workaround, assuming you dont have any inputs that should take a value of NULL. You could set the values of the inputs, that you wish to remove, to NULL and filter for non - NULLs when you display the names.
library(shiny)
ui <- fluidPage(
tags$script("
Shiny.addCustomMessageHandler('resetValue', function(variableName) {
Shiny.onInputChange(variableName, null);
});
"
),
sliderInput(inputId = "slider",label = "", min = 1, max = 3, value = 1),
uiOutput("UI"),
actionButton(inputId = "btn", label = "Show Inputs"),
verbatimTextOutput(outputId = "textOp")
)
server <- function(input, output, session){
observeEvent(input$slider,{
for(nr in 1:3){
if(nr != input$slider) session$sendCustomMessage(type = "resetValue", message = paste0("txt", nr))
}
})
output$UI <- renderUI(
textInput(paste0("txt", input$slider), label = paste0("Slider in position ", input$slider))
)
global <- reactiveValues()
observe({
inp = c()
for(name in names(input)){
if(!is.null(input[[name]])){
inp <- c(inp, name)
}
}
isolate(global$inputs <- inp)
})
output$textOp <- renderText({
global$inputs
})
}
shinyApp(ui = ui, server = server)

Showing selection from a lapply selectInput R shiny

I want to show the user what they selected in a table. I have the following:
library(shiny)
ui<-shinyUI(fluidPage(fluidRow(column(width = 4,
numericInput("assets", label = "Choose How Many Attributes to Produce in the Map:", value="1"),
uiOutput("variants"),
uiOutput("variants2")
)
)))
server <-shinyServer( function(input, output, session) {
df <- iris
output$variants <- renderUI({
numAssets <- as.integer(input$assets)
lapply(1:(numAssets), function(i) {
list(selectInput (paste0("choose_columns", i),
"Choose Attribute",
sort(unique(names(df)), decreasing = FALSE),
selected=""))
})
})
output$variants2 <- renderUI({
numAssets <- as.integer(input$assets)
lapply(1:(numAssets), function(j) {
var <- input[[paste0("choose_columns", j)]]
selectInput (paste0("choose_attribute", j),
paste0("Choose Attribute Value of ", var),
sort(unique(df[ ,var]), decreasing = FALSE),
selected="")
})
})
})
shinyApp(ui, server)
Can the user see in a table/dataframe the selection(s) from 'Choose Attribute' and 'Choose Attribute Value of Petal.Length'? I've tried something like this:
output$tableofselections <- renderUI({
numAssets <- as.integer(input$assets)
for (j in 1:(numAssets)){
x =input[[paste0("choose_columns",j)]]
}
tagList(
helpText(paste0(x))) })

Dynamic number of actionButtons tied to unique observeEvent

I'd like to generate a dynamic number of actionButtons, and then have each generated button print its number to the console. This is my best attempt so far, but I still can't get the observeEvent for each of the first 10 buttons to recognize the button clicks. How do I tie the buttons to an observeEvent?
library(shiny)
ui <- basicPage(
fluidRow(
actionButton(inputId = "add_button",
label = "Add Button")
),
uiOutput("more_buttons")
)
server <- function(input, output){
rvs <- reactiveValues(buttons = list(actionButton(inputId = "button1",
label = 1)))
observeEvent(eventExpr = input$add_button,
handlerExpr = {
len <- length(rvs$buttons) + 1
rvs$buttons[[len]] <- actionButton(inputId = paste0("button",len),
label = len)
})
output$more_buttons <- renderUI({
do.call(fluidRow, rvs$buttons)
})
# This is the part that doesn't work
for(ii in 1:10){
observeEvent(eventExpr = input[[paste0("button",ii)]],
handlerExpr = print(ii))
}
}
shinyApp(ui, server)
Your really close, just wrap the observeEvent part in local.
library(shiny)
ui <- basicPage(
fluidRow(
actionButton(inputId = "add_button",
label = "Add Button")
),
uiOutput("more_buttons")
)
server <- function(input, output){
rvs <- reactiveValues(buttons = list(actionButton(inputId = "button1",
label = 1)))
observeEvent(eventExpr = input$add_button,
handlerExpr = {
len <- length(rvs$buttons) + 1
rvs$buttons[[len]] <- actionButton(inputId = paste0("button",len),
label = len)
})
output$more_buttons <- renderUI({
do.call(fluidRow, rvs$buttons)
})
observeEvent(rvs$buttons,{
for(ii in 1:length(rvs$buttons)){
local({
i <- ii
observeEvent(eventExpr = input[[paste0("button",i)]],
handlerExpr = {print(sprintf("You clicked btn number %d",i))})
})
}
})
}
shinyApp(ui, server)
Let the inputIds of the buttons to follow a pattern like "button1", "button2", "button3", use regex to isolate those inputIds from the 'input' object in the observeEvent trigger, and convert the result to a list:
observeEvent(
lapply(
names(input)[grep("button[0-9]+",names(input))],
function(name){
input[[name]]
}
),
{
code to run when any button with inputId matching the regex is pressed
}
)

Resources