Shiny bookmark - unable to restore some of user's selections - r

I have just started include bookmark functionality to my app. My app have a few selection inputs which do not seem to be restored and I couldnt figure out the problems.
The app has 2 key inputs:
The radio button on the sidebar
The date/number ranges
At the current state, the app cant seem to restore the radio button (if I switch to duration, it just doesnt work)
The simplify code is below:
library(shiny)
library(data.table)
library(tidyverse)
library(lubridate)
library(shinydashboard)
library(zoo)
library(shinyWidgets)
library(nycflights13)
flight.dt <- flights %>% mutate(flight.date =ymd(substr(time_hour,1,10)),duration=round(air_time,-2))
### --------Analyse module ---------------------------
plotUI <- function(id) {
ns <- NS(id)
tagList(
uiOutput(ns("groupmenu")),
plotOutput(ns("plot"))
)
}
plotServer <- function(id,method,carr) {
moduleServer(
id,
function(input, output, session) {
filtered.data <- reactive(flight.dt %>% filter(carrier == carr))
output$groupmenu <- renderUI({
getselection <- if (method() != "duration") c("Year Quarter"="yearqtr") else c("Duration"="dur.grp")
rng.min <- switch (method(),
"date" = min(filtered.data()$flight.date),
"duration" = max(0,min(filtered.data()$duration,na.rm = TRUE)))
rng.max <- switch(method(),
"date" = max(filtered.data()$flight.date),
"duration" = max(0,max(filtered.data()$duration,na.rm = TRUE)))
ns <- session$ns
tagList(
fluidRow(
column(2,selectInput(ns("group"), "Group by:",choices =as.list(getselection))),
conditionalPanel("input.method == 'date'",
dateRangeInput(ns("daterange"),"Date range:",start = rng.min,end = rng.max,format = "dd/mm/yyyy", separator = " - ")),
conditionalPanel("input.method == 'duration'",
numericRangeInput(ns("durrange"), label = "Duration range:",value = c(rng.min,rng.max)))
)
)
})
dt <- reactiveVal(NULL)
observeEvent(input$group,{
tmp <- filtered.data() %>% mutate(sel.method = switch(method(),"date" = flight.date,"duration" = duration))
if (input$group == "yearqtr") {
tmp$key <- paste0(year(tmp$sel.method),"-Q",quarter(tmp$sel.method))
} else if (input$group == "dur.grp") {
tmp$key <- tmp$duration
}
dt(tmp)
})
dt.sum <- reactive({
req(dt())
setDT(dt())
if (method() == "date") {
tmp <- dt()[sel.method >= input$daterange[1] & sel.method <= input$daterange[2]]
} else if (method() == "duration") {
tmp <- dt()[key >= input$durrange[1] & key <= input$durrange[2]]
}
tmp %>% group_by(key) %>% dplyr::summarise(count=n())
})
output$plot <- renderPlot({
dt.sum() %>% ggplot(aes(x = as.character(key), y = count)) + geom_col()
})
}
)
}
### UI part -----------------------
header <- dashboardHeader(title = 'Analysis')
sidebar <- dashboardSidebar(
radioButtons("method", "Select method:",c("Date" = "date","Duration" = "duration"),selected = "date"),
bookmarkButton()
)
body <- dashboardBody(uiOutput('tablist'))
ui <- function(request) {
dashboardPage(title="Analysis", header,sidebar,body)
}
### Server part ----------------------------
server = function(input, output) {
method <- reactive(input$method)
carr <- reactive(unique(flight.dt$carrier)[1:3])
ntabs <- reactive(length(carr()))
observeEvent(ntabs(),{
lapply(1:ntabs(), function (i) plotServer(paste0("count",i),method,carr()[i]))
})
output$tablist = renderUI({
addtabs <- lapply(1:ntabs(),function (i) {
tabPanel(carr()[i],plotUI(paste0("count",i)))
})
do.call(tabsetPanel, addtabs)
})
}
### Running part ----------------------------
enableBookmarking("server")
shinyApp(ui, server)

Put your ui elements you want restored within ui function. See simplified example:
library(shiny)
library(shinydashboard)
### UI part -----------------------
ui <- function(request) {
header <- dashboardHeader(title = 'Analysis')
sidebar <- dashboardSidebar(
radioButtons("method", "Select method:",c("Date" = "date","Duration" = "duration"),selected = "date"),
bookmarkButton()
)
body <- dashboardBody("BODY")
dashboardPage(title="Analysis", header,sidebar,body)
}
### Server part ----------------------------
server = function(input, output) {
}
### Running part ----------------------------
enableBookmarking("server")
shinyApp(ui, server)

Related

Warning: Error in [[<-.data.frame: replacement has 1 row, data has 0

My objective is to plot some graphs based on the data uploaded by users. Users can select how it is plotted. It works but there are warnings showing in the console. I think the issue lies with how the server module looks up values in the UI module but the UI module is not yet initalised. How can I get rid of the warnings? Thanks
Sample data:
fwrite(data.table(
age.band = c("45-54","55-64","55-64","55-64","55-64","45-54","35-44","25-34"),
gender = c("MALE","FEMALE","FEMALE","FEMALE","FEMALE","FEMALE","MALE","FEMALE"),
event = c("13/04/2022","8/04/2022","20/05/2021","12/02/2022","19/02/2021","19/03/2022","16/03/2021","19/03/2021"),
cause = c('Cancer','Cancer','Cancer','Mental Illness','Cancer','Musculoskeletal','Mental Illness','Musculoskeletal'),
type= c('Type1','Type1','Type1','Type2','Type2','Type2','Type2','Type2'),
rate = rep(1,8),
status = rep("accepted",8)
),"sample.csv",row.names=F)
Here is my code:
### UI and server to load data
loadDataUI <- function(id,label = "Upload",buttonLabel = "Browse") {
ns <- NS(id)
tagList(
fileInput(ns("file"),label=label,buttonLabel=buttonLabel,accept = c('.csv'),placeholder = "No file selected")
)
}
loadData <- function(id) {
moduleServer(
id,
function(input, output, session) {
userFile <- reactive({
shiny::validate(need(input$file, message = FALSE))
input$file
})
dt <- reactive({fread(userFile()$datapath)})
return(dt)
}
)
}
### UI and server to plot data
edaUI <- function(id,cat.option) {
ns <- NS(id)
tagList(
box(
dropdown(
selectInput(inputId = ns('category'),
label = 'Category',
choices = cat.option,selected = "all"),
dateRangeInput(ns("eventdaterange"), "Loss date range",
start = Sys.Date()-10,
end = Sys.Date()+10)
),
highchartOutput(ns("hc_init"))
)
)
}
eda <- function(id,filtered.data,measure){
moduleServer(
id,
function(input, output, session) {
observeEvent(filtered.data(), {
updateDateRangeInput(session,"eventdaterange",
start = min(filtered.data()$event),
end = max(filtered.data()$event))
})
output$hc_init <- renderHighchart({
tmp <- filtered.data() %>%
filter(event >= input$eventdaterange[1],event <= input$eventdaterange[2]) %>%
mutate(event.date = as.character(as.yearqtr(event)))
if (input$category == "all") {
tmp %>% group_by(event.date) %>%
summarise(measure=sum(!!sym(measure))) %>%
hchart("line", hcaes(x = event.date, y = measure)) %>%
hc_title(text="Chart")
} else {
tmp %>%
group_by(cat = !!sym(input$category),event.date) %>%
summarise(measure=sum(!!sym(measure))) %>% ungroup() %>%
arrange(cat,event.date) %>%
hchart("line", hcaes(x = event.date, y = measure,group = cat)) %>%
hc_title(text="Chart")
}
})
}
)
}
### Main UI and server
ui <- function() {
fluidPage(useShinydashboard(),
navbarPage(
tabPanel(
title = "Data analysis",
sidebarLayout(
sidebarPanel(
width = 2,
loadDataUI("input","","Upload data"),
awesomeRadio(
inputId = "benefit",
label = strong("Select type"),
choices = c("Type1", "Type2"),
selected = NULL,inline = TRUE,checkbox = FALSE)
),
mainPanel(
width = 10,edaUI("dt1",cat.option=c("all","age.band","gender"))
)
)
)
)
)
}
server <- function(input, output, session) {
data <- loadData("input")
filtered_data <- reactive({
date.cols <- c("event")
data()[type == input$benefit][,(date.cols):= lapply(.SD, dmy),.SDcols = date.cols]
})
eda("dt1",filtered_data,measure="rate")
}
shinyApp(ui = ui, server = server)

How to get the selected argonTab in a Shiny App

Can someone show me how to get the tabName of the selected argonTab in an argonTabSet please, in a shiny app. I need it for downstream data subsetting.
The example below follows, somewhat, my actual app, where I call argonTabSet with do.call. The tabnames in my real app can vary so I am looking for something without hard coding them. The app is modularised, though I can’t get any values to return with input$t_brnd if I also wrap the argonTabSet id in ns().
library(shiny)
library(argonR)
library(argonDash)
mod_price_ov_UI <- function(id) {
ns <- NS(id)
tagList(
uiOutput(ns('ot_cat_brnd_rtlr'))
, uiOutput(ns('selected_tab'))
)
}
mod_price_ov <- function(id){
moduleServer(id,function(input, output, session) {
output$ot_cat_brnd_rtlr <- renderUI({
ns <- session$ns
brands <- paste0('brand_', 1:4)
tagList(
do.call(argonTabSet, c(
# id = ns('t_brnd'),
id ='t_brnd',
lapply(1:length(brands), function(i) {
argonTab(
tabName = brands[i],
active = ifelse(i == 1, T, F)
)
})
))
)
})
output$selected_tab <- renderUI({
input$t_brnd
})
})
}
shiny::shinyApp(
ui = argonDashPage(
body = argonDashBody(mod_price_ov_UI('ov'))
),
server = function(input, output, session) {
mod_price_ov('ov')
}
)
UPDATE
A comment (which seems to have been deleted) asked for an example closer to the actual use case, which I present below. I may need to revise the question title as the example now illustrates my actual issue. I thought that getting the tabname would ultimately help me get to this point.
The table category_tally starts with an overall summary total. I require to provide some functionality (with a radiobutton ‘Brand Stats ’ for example) where the user can update the total filtered by the brand in the selected tabname (also reflected in the selected datatable) , and back again, if the button equals ‘NO’.
I can only seem to get the button to work on the last tab, not the first 3.
library(shiny)
library(argonR)
library(argonDash)
library(magrittr)
library(tidyverse)
library(DT)
set.seed(1234)
mod_price_ov_UI <- function(id) {
ns <- NS(id)
tagList(
tableOutput(ns('category_tally')),
uiOutput(ns('ot_cat_brnd_rtlr')))
}
mod_price_ov <- function(id){
moduleServer(
id,
function(input, output, session) {
toy_rtcv <- reactive({tibble(
category = sample(paste0('cat_' , 1:3), 100, replace = T)
, brand = sample(paste0('brand_', 1:4), 100, replace = T)
)})
output$category_tally <- renderTable({toy_rtcv() %>% summarise(total = n())})
output$ot_cat_brnd_rtlr <- renderUI({
ns <- session$ns
brands <- toy_rtcv() %>% select(brand) %>% distinct() %>% pull(brand)
tagList(
do.call(argonTabSet, c(id= 't_brnd', lapply(1:length(brands), function(i) {
argonTab(
tabName = brands[i]
, active = ifelse(i == 1, T, F)
, radioButtons(ns(paste0('rdio_cat_brnd_rtlr', brands[i]))
, 'Brand Stats'
, choices = c('YES', 'NO')
, selected = 'NO'
, inline = T
)
, dataTableOutput(ns(paste0('ot_retailer_', brands[i])))
)}))))})
observe({
brands <- toy_rtcv() %>% select(brand) %>% distinct() %>% pull(brand)
lapply(1:length(brands), function(i) {
output[[paste0('ot_retailer_', brands[i])]] = renderDataTable({
toy_rtcv() %>%
filter(brand == brands[i])
})})})
observe({
brands <- toy_rtcv() %>% select(brand) %>% distinct() %>% pull(brand)
lapply(1:length(brands), function(i){
if(is.null(input[[paste0('rdio_cat_brnd_rtlr', brands[i])]]))
return(NULL)
if(input[[paste0('rdio_cat_brnd_rtlr', brands[i])]] == 'YES'){
output$category_tally <- renderTable({
toy_rtcv() %>%
filter(brand == brands[i]) %>%
summarise(total = n())})
} else {
output$category_tally <- renderTable({
toy_rtcv() %>%
summarise(total = n())
})}})})})
}
shiny::shinyApp(
ui = argonDashPage(
body = argonDashBody(mod_price_ov_UI('ov'))
),
server = function(input, output, session) {mod_price_ov('ov')}
)

Error while creating tables dynamically in R shiny

I have a dataframe which I want to filter and create tables based on years in this case. I have 4 years now.So I would like to create 4 new tables and show them seperately on the shiny app.I do get the part of looping and pass the filter variables but how can that create 4 new tables and show them in the UI. I am able to get dynamic tabpanels but the library(shiny)
library(shinyWidgets)
library(shinydashboard)
library(DT)
sidebar <- dashboardSidebar(
sidebarMenu(id = "tab",
menuItem("1", tabName = "1")
)
)
body <- ## Body content
dashboardBody(box(
uiOutput('mytabs')
))
ui <- dashboardPage(dashboardHeader(title = "Scorecard"),
sidebar,
body)
# Define the server code
server <- function(input, output,session) {
df <- data.frame(structure(list(`Mazda` = c(21000,20000,21500,24000), `Honda` = c(21500,20500,22000,24500)
, Sales = c(2017,2015,2016,2014)
)
, class = "data.frame", row.names = c(NA, -4L)))
toAdd <- as.vector(df$Sales)
for(i in length(toAdd)){
print(length(toAdd))
output[[paste0("datatable_",i)]] <- DT::renderDataTable({
df %>% filter(Sales == toAdd[i])
})
#}
# for(i in 1:length(toAdd)){
output$mytabs <- renderUI({
nTabs = length(toAdd)
# create tabPanel with datatable in it
myTabs = lapply(seq_len(nTabs), function(i) {
tabPanel(paste0("dataset_",toAdd[i]),
DT::dataTableOutput(paste0("datatable_",i))
)
})
do.call(tabsetPanel, myTabs)
})
}
}
shinyApp(ui = ui, server = server)
You have to use local, and don't put renderUI inside the loop:
for(i in 1:length(toAdd)){
local({
ii <- i
output[[paste0("datatable_",ii)]] <- DT::renderDataTable({
df %>% filter(Sales == toAdd[ii])
})
})
}
output$mytabs <- renderUI({
nTabs = length(toAdd)
# create tabPanel with datatable in it
myTabs = lapply(seq_len(nTabs), function(i) {
tabPanel(paste0("dataset_",toAdd[i]),
DT::dataTableOutput(paste0("datatable_",i))
)
})
do.call(tabsetPanel, myTabs)
})

R - Shiny Conditional Input

I am trying to get input choices dependent on previous input.
require(shiny)
require(dplyr)
dat <- data.frame(id1 = c(rep("A",5),rep("B",5)),
id2 = c(rep("C",3),rep("D",3),rep("E",4)),
id3 = c(rep("F",2),rep("G",3),rep("H",5)), stringsAsFactors=FALSE)
ui <- shinyUI(fluidPage(
sidebarPanel(
selectInput('id1', 'ID1', choices = unique(dat$id1)),
selectInput("id2", "ID2", choices = unique(dat$id2)),
selectInput("id3", "ID3", choices = unique(dat$id3))
)
)
)
server <- function(input, output,session) {
observeEvent(
{
input$id1
},{
input$id2
temp <- dat %>% filter(id1%in%input$id1)
updateSelectInput(session,"id2",choices = unique(temp$id2))
}
)
}
shinyApp(ui = ui, server = server)
This works for Input 1 and 2, however if i add another Input to observeEvent, the app chrashes. E.g:
server <- function(input, output,session) {
observeEvent(
{
input$id1
},{
input$id2
temp <- dat %>% filter(id1%in%input$id1)
updateSelectInput(session,"id2",choices = unique(temp$id2))
},{
input$id3
temp <- dat %>% filter(id1%in%input$id1 & id2%in%input$id2)
updateSelectInput(session,"id3",choices = unique(temp$id3))
}
)
}
How can I pass further Inputs to observeEvent ?
Update: I found a solution for the problem. I wrapped the Inputs in a reactive function, split the Output and passed it to the corresponding observeEvent functions.
server <- function(input, output,session) {
change <- reactive({
unlist(strsplit(paste(c(input$id1,input$id2,input$id3),collapse="|"),"|",fixed=TRUE))
})
observeEvent(input$id1,{
temp <- dat %>% filter(id1 %in% change()[1])
updateSelectInput(session,"id2",choices = unique(temp$id2))
}
)
observeEvent(input$id2,{
temp <- dat %>% filter(id1 %in% change()[1] & id2 %in% change()[2])
updateSelectInput(session,"id3",choices = unique(temp$id3))
}
)
}

How to call a shiny module from a shiny module?

How do I call a shiny module from within a shiny module with passing selections from the first module?
As an example I wrote a app to show the Star Wars subjects from dplyr in a DT::data table (module StarWars). The related films from the same data set should be shown in another DT::data table in another sub tab (module Films).
I pass the table selected subject in a reactive value sw_rows_selected_rct from module StarWars to module Films but browser() statement in module Films is not passed.
# Test call of modules inside modules
library(tidyverse)
#' Shiny StarWars module
#'
ui_Films <-
function(id,
title = id,
...,
value = title,
icon = NULL) {
ns <- shiny::NS(id)
tab <- tabPanel(title,
h4("StarWars Films"),
DT::dataTableOutput(outputId = ns("Films")))
}
ui_StarWars <-
function(id,
title = id,
...,
value = title,
icon = NULL) {
ns <- shiny::NS(id)
tab <- tabPanel(title,
DT::dataTableOutput(outputId = ns("StarWars")),
tabsetPanel(ui_Films(
id = ns("Films"), title = "...by Films"
)))
}
ui <- shinyUI(navbarPage(
"Call Modules in Modules test",
ui_StarWars("StarWars", title = "StarWars")
))
Films <-
function(input,
output,
session,
sw_data,
sw_selection) {
ns <- session$ns
sw_films_rct <- observe({
req(sw_data, is.data.frame(sw_selection))
browser() # not reached!!!
sw_films_rct <-
sw_data %>% {
if (is_null(sw_selection))
.
else
filter(., name == sw_selection$name)
}
})
output$StarWarsFilms <- DT::renderDataTable({
req(is.data.frame(sw_films_rct))
DT::datatable(sw_films_rct,
selection = 'single',
options = list(pageLength = 5))
})
}
StarWars <-
function(input, output, session, sw_data) {
sw_rows_selected_rct = reactiveVal()
ns <- session$ns
sw_rows_selected_rct = observeEvent(input$StarWars_rows_selected, {
req(sw_data, input$StarWars_rows_selected != 0)
browser()
sw_data[input$StarWars_rows_selected, ]
})
md_films <- callModule(
module = Films,
id = "Films",
sw_data = sw_data,
sw_selection = sw_rows_selected_rct
)
output$StarWars <- DT::renderDataTable({
req(is.data.frame(sw_data))
DT::datatable(sw_data,
selection = 'single',
options = list(pageLength = 5))
})
}
server <- shinyServer(function(input, output, session) {
sw_data_rct = reactive({
dplyr::starwars %>% mutate(films = NULL,
vehicles = NULL,
starships = NULL)
})
md_StarWars = callModule(module = StarWars,
id = "StarWars",
sw_data = sw_data_rct())
})
# Run the application
shinyApp(ui = ui, server = server)
Your code had a few errors. Remember, observe and observeEvents don't have return values. Set the value of your reactives through the nameofReactive(newValue). Your initial goal is possible if you give the reactive to the module, not the current value of the reactive, so that it can change throughout the course of using the app. In the module, you then have to you the value of the reactive, by using () on the reactive. Oh, and your last output had the wrong name (output$Films should be correct). Here is the working app:
library(tidyverse)
#' Shiny StarWars module
#'
ui_Films <-
function(id, title = id, ..., value = title, icon = NULL) {
ns <- shiny::NS(id)
tab <- tabPanel(title,
h4("StarWars Films"),
DT::dataTableOutput(outputId = ns("Films"))
)
}
ui_StarWars <-
function(id, title = id, ..., value = title, icon = NULL) {
ns <- shiny::NS(id)
tab <- tabPanel(title,
DT::dataTableOutput(outputId = ns("StarWars")),
tabsetPanel(
ui_Films(id = ns("Films"), title = "...by Films"))
)
}
ui <- shinyUI(
navbarPage(
"Call Modules in Modules test",
ui_StarWars("StarWars", title = "StarWars")
)
)
Films <-
function(input, output, session, sw_data, sw_selection) {
ns <- session$ns
sw_films_rct <- reactiveVal()
observe({
sw_films_rct(sw_data() %>% {if(is_null(sw_selection())) . else filter(., name == sw_selection()$name)})
})
output$Films <- DT::renderDataTable({
req(is.data.frame(sw_films_rct()))
DT::datatable(sw_films_rct(),
selection = 'single',
options = list(pageLength = 5))
})
}
StarWars <-
function(input, output, session, sw_data) {
sw_rows_selected_rct= reactiveVal()
ns <- session$ns
observeEvent(input$StarWars_rows_selected, {
req(sw_data(), input$StarWars_rows_selected != 0)
sw_rows_selected_rct(sw_data()[input$StarWars_rows_selected,])
})
md_films <- callModule(module = Films, id = "Films",
sw_data= sw_data,
sw_selection= sw_rows_selected_rct)
output$StarWars <- DT::renderDataTable({
req(is.data.frame(sw_data()))
DT::datatable(sw_data(),
selection = 'single',
options = list(pageLength = 5))
})
}
server <- shinyServer(function(input, output, session) {
sw_data_rct= reactive({dplyr::starwars %>% mutate(films = NULL, vehicles = NULL, starships = NULL)})
md_StarWars= callModule(module = StarWars, id = "StarWars", sw_data = sw_data_rct)
})
# Run the application
shinyApp(ui = ui, server = server)

Resources