I am struggling to use the result of a reactive function as input for the UI.
Currently, I am mostly using renderUI which decreased performance as the app got more complex.
Using
DetailsList(items = filtered_Accounts(), columns = columns.top.accounts, checkboxVisibility = 2)
in the UI function did not work because it could not access the reactive?
Below is a shortened example with only two filters:
UI:
# Column Definitions for Table -----------
columns.top.accounts <- tibble(
fieldName = c("text", "occupation", "Gender", "age.floor", "Nationality","n_friends_formatted", "n_followers_formatted"),
name = c("Name", "Occupation", "Gender", "Age" , "Nationality" ,"# of Friends", "# of Followers")
)
# UI - Filters -----------
filters.descriptive <- Stack(
tokens = list(childrenGap = 10),
Label("Filter by Twitter user", className = "my_class"),
NormalPeoplePicker.shinyInput(
"selectedAccounts",
class = "my_class",
options = df.Account.Info
)
),
Slider.shinyInput("slider",
value = 0, min = 0, max = 600000, step = 1000,
label = "Minimum number of friends",
valueFormat = JS("function(x) { return x}"),
snapToStep = TRUE
)
)
# UI-Function --------------
ui <- function(input, output, session) {
filters.descriptive,
uiOutput("table.top.accounts")
}
Server:
server <- function(input, output, session) {
# ---- Reactive --------------
filtered_Accounts <- reactive({
req(input$slider)
selectedAccounts <- (
if (length(input$selectedAccounts) > 0) input$selectedAccounts
else df.Account.Info$key
)
filtered_Accounts <- df.Account.Info %>%
filter(
key %in% selectedAccounts,
n_friends >= input$slider
)
}) %>% debounce(750)
# Outputs Descriptive ------------------
output$table.top.accounts <- renderUI({
items_list <- if(nrow(filtered_Accounts()) > 0){
DetailsList(items = filtered_Accounts(), columns = columns.top.accounts, checkboxVisibility = 2)
} else {
p("No matching transactions.")
}
})
}
shinyApp(ui, server)
I believe I have to use observe ({}) here but I was not able to apply it to my case successfully.
Any help is much appreciated.
I'm trying to make the value argument for shiny::numericInput() dynamic, based on input from a user.
Both code chunks below will run, but they fail to set a dynamic initial value.
Chunk 1:
idOptions <- c("1","2","3")
ui <- shiny::fluidPage(
shiny::selectInput(inputId = "idSelection", "Identification: ", idOptions),
shiny::numericInput("num", "Number associated with id:", value=shiny::verbatimTextOutput("numberOut")),
)
server <- function(input, output) {
df <- data.frame(id = c("1","2","3"), number = c(100,227,7))
output$numberOut <- shiny::renderText({ input$idSelection })
}
shiny::shinyApp(ui, server)
Chunk 2:
idOptions <- c("1","2","3")
ui <- shiny::fluidPage(
shiny::selectInput(inputId = "idSelection", "Identification: ", idOptions),
shiny::numericInput("num", "Number associated with id:", value=shiny::verbatimTextOutput("numberOut")),
)
server <- function(input, output) {
df <- data.frame(id = c("1","2","3"), number = c(100,227,7))
dfReactive <- shiny::reactive({
dataOut <- df %>%
dplyr::filter(., id %in% input$idSelection)
return(dataOut)
})
shiny::observe({
output$numberOut <- shiny::renderText({
return(dfReactive()$number)
})
})
}
shiny::shinyApp(ui, server)
I want the initial value for shiny::numericInput to change like so:
When the user selects "1" for Identification, the initial value is 100:
When the user selects "2" for Identification, the initial value is 227:
The idea behind this is to have an appropriate initial value suggested to the user based on the identification of the input.
I'm guessing the problem might be with shiny::verbatimTextOutput("numberOut"), but I don't know a way to render a simple numeric value to pass into the value argument of shiny::numericInput.
Any thoughts?
Thanks much.
One way would be to use renderUI and do the computation on the server side:
idOptions <- c("1","2","3")
shiny::shinyApp(
ui = shiny::fluidPage(
shiny::selectInput(inputId = "idSelection", "Identification: ", idOptions),
shiny::uiOutput("num")
),
server = function(input, output) {
df <- data.frame(id = c("1","2","3"), number = c(100,227,7))
output$num <- shiny::renderUI({
shiny::numericInput("num",
"Number associated with id:",
value = df$number[as.numeric(input$idSelection)])
})
})
The alternative is to leave the input on the UI side and use updateNumericInput inside an observeEvent:
idOptions <- c("1","2","3")
shiny::shinyApp(
ui = shiny::fluidPage(
shiny::selectInput(inputId = "idSelection",
"Identification: ",
idOptions),
shiny::numericInput("num",
"Number associated with id:",
value = NULL)
),
server = function(input, output, session) {
df <- data.frame(id = c("1","2","3"),
number = c(100,227,7))
observeEvent(input$idSelection, {
updateNumericInput(session,
inputId = "num",
value = df$number[as.numeric(input$idSelection)])
})
})
I can show the output table in my Shiny app but I also wanted to have a 'delete' button next to each row in the output table so I can delete certain row and do some recalculation
I have the basic template of my Shiny app but need to add the 'delete' buttons next to each row in the output table and I have no idea... Is there a way in Shiny?
Any recommendation welcome and thanks in advance!
library(shiny)
library(data.table)
# Define list of products
products <- c("207STX",
"208STX",
"209ABC",
"210ABC")
# Create function to process shopping cart and create model input
process_cart <- function(cart_df) {
# Do some data processing
df <- copy(cart_df)
# Check if product has SmartStax
df[, STX := grepl("STX", Product)]
# Collapse into a single observation
obs_df <- data.table(total_quantity = sum(df$Quantity),
qty_stx = sum(df$Quanity[df$STX]))
return(obs_df)
}
# Run model on observation
predict_discount <- function(obs_df) {
# This is a fake model for demonstration purposes only
discount <- obs_df[, 20 * log(total_quantity) +
1.3 * qty_stx]
discount <- max(discount, 0)
return(discount)
}
# Define UI for application
ui <- fluidPage(
# Application title
titlePanel("Shopping Cart Example"),
# Sidebar
sidebarLayout(
sidebarPanel(
selectInput(inputId = "product_name",
label = "Product Name",
choices = products),
numericInput(inputId = "product_quantity",
label = "Quantity",
value = 0,
min = 0),
actionButton(inputId = "add_to_cart",
label = "Add to Cart"),
actionButton(inputId = "clear_cart",
label = "Clear Cart")
),
mainPanel(
h2("Shopping Cart"),
tableOutput(outputId = "cart_df"),
h2("Total Discount"),
textOutput(outputId = "discount_amt")
)
)
)
server <- function(input, output, session) {
# Definie initial empty table
cart_df <- data.table()
add_to_cart <- observeEvent(input$add_to_cart, {
# Update cart
new_row <- data.frame(Product = input$product_name,
Quantity = input$product_quantity)
new_df <- rbind(cart_df, new_row)
cart_df <<- new_df[, .(Quantity = sum(Quantity)), by = Product]
output$cart_df <- renderTable(cart_df)
# Create observation for prediction
obs_df <- process_cart(cart_df)
# Run model to predict discount
discount <- predict_discount(obs_df)
output$discount_amt <- renderText(sprintf("$%.2f", discount))
# Reset input
updateNumericInput(session, "product_quantity", value = 0)
})
clear_cart <- observeEvent(input$clear_cart, {
cart_df <<- data.table()
output$cart_df <- renderTable(cart_df)
})
}
# Run the application
shinyApp(ui = ui, server = server)
Here is a working demo:
library(shiny)
library(formattable)
library(glue)
initial_table <- cbind(
iris[1:10,],
data.frame(
delete = glue(
"<button rowid='{1:10}'
onclick='Shiny.setInputValue(\"removeRow\",this.getAttribute(\"rowid\"))'>Delete</button>"),
rowid = 1:10
)
)
colnames(initial_table)[ncol(initial_table)-1] <- " "
ui <- fluidPage(
dataTableOutput("deletable")
)
server <- function(input, output, session) {
mytable <- reactiveVal(initial_table)
output$deletable <- renderDataTable(
datatable(
mytable(),
escape = FALSE,
selection = "none",
options = list(
columnDefs = list(list(targets = ncol(initial_table),visible = FALSE))
)
)
)
observeEvent(input$removeRow,{
removeRow <- as.integer(input$removeRow)
tblRowRemoved <- mytable()[-which(mytable()$rowid == removeRow),]
mytable(tblRowRemoved)
})
}
shinyApp(ui, server)
I am populating a table by using Insert UI elements. I also want to delete both table entries and the inserted panels by using the remove UI elements.
I could delete the panels but as you can see in my demo App the corresponding table values are not deleted and the length of the table remains the same even after clicking the delete button.
How can I delete both the panels and their corresponding table values at the same time?
Why table values are not getting deleted?
library(shiny)
library(tidyverse)
DT <- data.frame(Year = c(1980,1985,1985,1990,1990,1995),
Events = c("Storm", "Earthquake", "Flood", "Draught",
"Earthquake", "Earthquake"),
Area_Loss = c(100, 200, 400, 500, 450,300),
Money = c(1000,2000,3000,4000,5000,6000))
ui <- fluidPage( h4("Updating InserUIs",
selectInput("events","Events",choices=as.character(DT$Events)),
tags$div(id = "Panels"),
actionButton("add","Add"),
tableOutput("table"),
verbatimTextOutput("text")
))
server <- function(session, input, output){
# Reactive values for the number of input panels
vals <- reactiveValues(btn = list(), observers = list())
observeEvent(input$add,ignoreNULL = FALSE,{
l <- length(vals$btn) +1
# Add Panels
for(i in l){
vals$btn[[i]]= insertUI(selector = "#Panels",
ui = splitLayout(id = paste0("Selection",i), where ="afterEnd",
cellWidths = rep("33.33%",3),
selectInput(paste0("year",i), "Year", choices = DT$Year,
selected = ""),
numericInput(paste0("area",i), "Area", min = 0, max = 10000,
value ="", step = 1),
numericInput(paste0("money",i), "Money", min = 0, max = 10000,
value = "", step =1),
div(id ="delete_div",actionButton(paste0("delete",i), "Delete"))
))}
# Update panels
for(i in l){
vals$observers = lapply(l, function(i)
observeEvent(input[[paste0("year",i)]],{
updateNumericInput(session,paste0("area",i),
"Area",min= 0, max= 50000,value = DT$Area_Loss
[DT$Year == input[[paste0("year",i)]]& DT$Events==
input$events] ,step = 0.1)
}))}
for(i in l){
vals$observers = lapply(l, function(i)
observeEvent(input[[paste0("year",i)]],{
updateNumericInput(session,paste0("money",i),
"Money",min= 0, max= 50000,value = DT$Money
[DT$Year == input[[paste0("year",i)]]& DT$Events==
input$events] ,step = 0.1)
}))}
# Delete Panels
for(i in l){
observeEvent(input[[paste0("delete",i)]],{
shiny::removeUI(selector = paste0("#Selection",i))
i <- length(vals$btn) - 1
})}
})
# Reactive table generated from the user inputs
Table <- reactive({
l <- 1:length(vals$btn)
for(i in l){
Year <- unlist(lapply(l, function(i)input[[paste0("year",i)]]))
Area <- unlist(lapply(l, function(i)input[[paste0("area",i)]]))
Money <- unlist(lapply(l, function(i)input[[paste0("money",i)]]))
}
DF0 <- data.frame(Event = input$events,
Year = Year,
Area_loss = Area,
Money = Money
)
DF0
})
# Visualizing the raective table
output$table <- renderTable({
Table()
})
}
shinyApp(ui,server)
Thanks all of you in advance, any suggestion will help me to progress in my app.
I think your problem can be quiet elegantly solved with modules. See comments in the code for details.
library(shiny)
library(dplyr)
DT <- data.frame(Year = c(1980,1985,1985,1990,1990,1995),
Events = c("Storm", "Earthquake", "Flood", "Draught",
"Earthquake", "Earthquake"),
Area_Loss = c(100, 200, 400, 500, 450,300),
Money = c(1000,2000,3000,4000,5000,6000))
##############################Module#############################
## a module consists of all elements which belong together
## i.e. year, area, money and delete button
## take note about the ns() construct which allows for
## namespacing and through this mechanism we can have several
## instances of this module
YAM_ui <- function(id) {
ns <- NS(id)
fluidRow(
id = id,
h3(id),
column(width = 3,
selectInput(ns("year"),
"Year",
DT$Year,
"")),
column(width = 4,
numericInput(ns("area"),
"Area",
0,
0,
10000,
1)),
column(width = 4,
numericInput(ns("money"),
"Money",
0,
0,
10000,
1)),
column(width = 1,
actionButton(ns("delete"), "Delete"))
)
}
## in the server you can access the elements simply by input$element_name
## we have one input reactive (event) which comes from the main app and
## holds the value of the event selectInput
## we return
## - a killSwitch to signal the main app to delete this module
## - a reactive which returns the data from all inputs organized in a data frame
YAM_server <- function(input, output, session, event) {
killMe <- reactiveVal(FALSE)
observe({
req(input$year)
req(event())
updateNumericInput(session,
"area",
min = 0,
max = 50000,
value = DT$Area_Loss[DT$Year == input$year &
DT$Events == event()] ,
step = 0.1)
updateNumericInput(session,
"money",
min = 0,
max = 50000,
value = DT$Money[DT$Year == input$year &
DT$Events == event()] ,
step = 0.1)
})
get_data <- reactive({
req(!is.null(input$year), !is.null(input$area), !is.null(input$money), event())
data.frame(event = event(),
year = input$year,
area = ifelse(input$area == "", NA, input$area),
money = ifelse(input$money == "", NA, input$money))
})
observeEvent(input$delete,
killMe(TRUE))
return(list(delete = killMe,
get_data = get_data))
}
##############################MainApp##############################
ui <- fluidPage(
titlePanel("Modules"),
sidebarLayout(
sidebarPanel(
h4("Updating Inserted UIs"),
selectInput("events",
"Events",
unique(DT$Events)),
actionButton("add",
"Add"),
tableOutput("table")
),
mainPanel(
tags$div(id = "Panels")
)
)
)
## in the main App we have
## - a reactive (handlers) which holds all reactives of all the modules
## - a list (observers) where we create (and delete) observers for the kill
## switch
## When we add a row, we use insertUI to create the html and callModule
## to switch on the modules server logic. We pass the event reactive to
## the module to make it available within the module.
## When we observe a press to the delete button, we remove the handler
## from the lists and remove the corresponding html via removeUI.
## The data table is then updated automatically, because we removed the handler
## and it is not seen in the loop
## To get the table all we have to do is to loop through all handlers and
## call the get_data reactive from the modules to get the data
server <- function(input, output, session) {
handlers <- reactiveVal(list())
observers <- list()
n <- 1
get_event <- reactive({
input$events
})
observeEvent(input$add, {
id <- paste0("row_", n)
n <<- n + 1
insertUI("#Panels",
"beforeEnd",
YAM_ui(id)
)
new_handler <- setNames(list(callModule(YAM_server,
id,
get_event)),
id)
handler_list <- c(handlers(), new_handler)
handlers(handler_list)
})
observe({
hds <- handlers()
req(length(hds) > 0)
new <- setdiff(names(hds),
names(observers))
obs <- setNames(lapply(new, function(n) {
observeEvent(hds[[n]]$delete(), {
removeUI(paste0("#", n))
hds <- handlers()
hds[n] <- NULL
handlers(hds)
observers[n] <<- NULL
}, ignoreInit = TRUE)
}), new)
observers <<- c(observers, obs)
})
output$table <- renderTable({
hds <- req(handlers())
req(length(hds) > 0)
tbl_list <- lapply(hds, function(h) {
h$get_data()
})
do.call(rbind, tbl_list)
})
}
shinyApp(ui, server)
I agree with #thothal that modules help when adding and removing sections of UI and the corresponding data. I've taken a lot of inspiration from their answer and come up with a slightly cleaner (IMHO) implementation.
I've only modified the final server function, where I have managed to do away with the need to keep a list of observers and have captured most of the lifecycle functionality into the add_module function
# utility to hide away the mess of updating the reactiveVal(list())
update_values <- function(values, name, value) {
vals <- values()
vals[[name]] <- value
values(vals)
}
add_module <- function(values, name, server, delete_hook = NULL, remove_selector = NULL) {
# add module server's return to values list
update_values(values, name, server)
# if module has a reactive we should monitor for deleting, do so
if (!is.null(delete_hook)) {
observeEvent(
server[[delete_hook]](), {
removeUI(selector = remove_selector) # remove the ui
update_values(values, name, NULL) # remove the server from our values list
},
ignoreInit = TRUE,
once = TRUE
)
}
}
server <- function(input, output, session) {
handlers <- reactiveVal(list())
get_event <- reactive({
input$events
})
# new
observeEvent(input$add, {
id <- paste0("row_", input$add)
insertUI("#Panels", "beforeEnd", YAM_ui(id))
add_module(
handlers,
name = id,
server = callModule(YAM_server, id, get_event),
delete_hook = "delete",
remove_selector = paste0("#", id)
)
})
# unchanged
output$table <- renderTable({
hds <- req(handlers())
req(length(hds) > 0)
tbl_list <- lapply(hds, function(h) {
h$get_data()
})
do.call(rbind, tbl_list)
})
}
shinyApp(ui, server)
My shiny app begins with a checkboxGroupInput which contains the names of three companies: A, B and C. It also has 3 hidden numeric inputs, each corresponding to a company. Potential investors may select the name of the company they wish to invest in and specifiy the amount they are willing to invest. When the name of a company is checked, the corresponding numeric input shows up. Also, when the company name is unchecked, the numeric input disappears.
The checkboxGroupInput is called company. The 3 numericInput fields are respectively called amountA, amountB and amountC and are all generated inside a uiOutput. They are hidden with the hidden function of shinyjs.
library(shiny)
library(shinyjs)
library(magrittr)
ui <- fluidPage(
useShinyjs(),
checkboxGroupInput(inputId = "company", label = "Select a company", choices = LETTERS[1:3]),
uiOutput(outputId = "amounts")
)
server <- function(input, output){
company_names <- LETTERS[1:3]
num_ids <- paste0("amount", LETTERS[1:3])
output$amounts <- renderUI({
num_inputs <- lapply(1:3, function(i){
numericInput(inputId = num_ids[i], label = paste0("Investment in ", company_names[i]), value = 0, min = 0, max = 5000)
}) %>% tagList
shinyjs::hidden(num_inputs)
})
observeEvent(eventExpr = input$company, handlerExpr = {
if(length(input$company) == 0){
for(i in num_ids){
shinyjs::hide(id = i)
}
} else {
for(i in input$company){
shinyjs::toggle(id = paste0("amount", i), condition = input$company)
}
}
})
}
shinyApp(ui = ui, server = server)
The problem with my app is that the intended dynamics between the checkboxGroupInput and the numericInput fields are not working as intended. For instance, once a numericInput is shown, it cannot be hidden anymore by unchecking the boxes. How can I handle this?
The code pasted above is fully functional. Thank you very much.
I fixed your code by explicitly show/hide the numericInput when the corresponding check box is selected/unselected. Also I change the observeEvent with observe to make sure that the observer reacts when none of the check boxes are selected.
library(shiny)
library(shinyjs)
library(magrittr)
ui <- fluidPage(
useShinyjs(),
checkboxGroupInput(inputId = "company", label = "Select a company", choices = LETTERS[1:3]),
uiOutput(outputId = "amounts")
)
server <- function(input, output){
company_names <- LETTERS[1:3]
num_ids <- paste0("amount", LETTERS[1:3])
output$amounts <- renderUI({
num_inputs <- lapply(1:3, function(i){
numericInput(inputId = num_ids[i], label = paste0("Investment in ", company_names[i]), value = 0, min = 0, max = 5000)
}) %>% tagList
shinyjs::hidden(num_inputs)
})
observe({
for(i in company_names){
if (i %in% input$company) {
shinyjs::show(id = paste0("amount", i))
} else {
shinyjs::hide(id = paste0("amount", i))
}
}
})
}
shinyApp(ui = ui, server = server)