I'm trying to make a dynamically generated navbar based on the session user id.
I have a data table that maps the session user to a list of that user's clients. I want the app to produce a navbar where each tabPanel is for each client that user has. I'm not sure how I can easily do that since navbarPage() doesn't take a list argument.
Below is my example
library(shiny)
data <- data.frame(user=c("emily", "emily"), clients=c("client1", "client2"))
CreateCustomNavbarContent <- function(data) {
l <- lapply(data$clients, function(client) {
tabPanel(client,
h2(client))
})
renderUI({
l
})
}
shinyApp(
ui <- fluidPage(
uiOutput("custom_navbar")
),
server <- function(input, output) {
output$custom_navbar <- renderUI({
## commented below doesn't work
# navbarPage(
# CreateCustomNavbarContent(data)
# )
navbarPage("",
tabPanel("client1",
h2("client1")
),
tabPanel("client2",
h2("client2")
)
)
})
}
)
You could achieve what you want with do.call, so we can pass a list of arguments as separate arguments. Below is a working example, I gave emily a companion called John so you can validate that the code does what you want ;)
Hope this helps!
library(shiny)
data <- data.frame(user=c("Emily", "Emily","John","John"), clients=c("client1", "client2","client3","client4"))
ui = fluidPage(
selectInput('select_user','Select user:',unique(data$user)),
uiOutput('mytabsetpanel')
)
server = function(input, output, session){
output$mytabsetpanel = renderUI({
myTabs = lapply(data$clients[data$user==input$select_user], tabPanel)
do.call(tabsetPanel, myTabs)
})
}
shinyApp(ui,server)
Related
I’m looking for some help with a simple Shiny app with a modularised design please. I think the problem is a name space issue so the example below is set out as a simplified version of my actual project.
The aim is for ‘tab_3’ on the tabsetPanel to only show when the ‘View Tab_3’ is checked, which works fine. I would like to update the tabsetPanel however to also select ‘tab_3’ when ‘View Tab_3’ is checked and this is not firing as desired.
I can get the tabsetPanel to also select ‘tab_3’ when ‘View Tab_3’ is checked if I wrap the tabsetPanel’s id in a namespace function, id = ns("tab_a_tha"), however then I lose the show/hide functionality of ‘tab_3’.
My hunch is that the solution lies within providing a namespace to the toggle function but I haven’t found any clues on how to approach it.
library(shiny)
library(shinyjs)
inner_moduleUI <- function(id){
ns <- NS(id)
tagList(
fluidRow(checkboxInput(ns("chckbx"), "View Tab_3", value = F)),
tabsetPanel(
id = "tab_a_tha",
# id = ns("tab_a_tha"),
tabPanel('tab_1'),
tabPanel('tab_2'),
tabPanel('tab_3')
)
)
}
inner_module <- function(input, output, session){
observeEvent(input$chckbx, {
toggle(condition = input$chckbx, selector = "#tab_a_tha li a[data-value=tab_3]")
if(input$chckbx == T){
updateTabsetPanel(session, 'tab_a_tha', selected = 'tab_3')
}
})
}
ui <- fluidPage(
useShinyjs(),
uiOutput('main_ui')
)
server <- function(input, output, session) {
output$main_ui <- renderUI({inner_moduleUI('inner_ns') })
callModule(inner_module, 'inner_ns')
}
shinyApp(ui = ui, server = server)
you are right the problem is with the namespace. The trick is that you can access the namespace function also in the server part of a module with session$ns.
Using this and wrapping the tap id in the ns function. We can use paste0 to generate the new selector of the toggle function. We get something like this:
library(shiny)
library(shinyjs)
inner_moduleUI <- function(id){
ns <- NS(id)
tagList(
fluidRow(checkboxInput(ns("chckbx"), "View Tab_3", value = F)),
tabsetPanel(
id = ns("tab_a_tha"),
# id = ns("tab_a_tha"),
tabPanel('tab_1'),
tabPanel('tab_2'),
tabPanel('tab_3')
)
)
}
inner_module <- function(input, output, session){
observeEvent(input$chckbx, {
toggle(condition = input$chckbx, selector = paste0("#",session$ns("tab_a_tha")," li a[data-value=tab_3]"))
if(input$chckbx == T){
updateTabsetPanel(session, 'tab_a_tha', selected = 'tab_3')
}
})
}
ui <- fluidPage(
useShinyjs(),
uiOutput('main_ui')
)
server <- function(input, output, session) {
output$main_ui <- renderUI({inner_moduleUI('inner_ns') })
callModule(inner_module, 'inner_ns')
}
shinyApp(ui = ui, server = server)
I'm trying to updateSelectInput on a selectInput from the parent namespace inside a sub-module. In the module function, I'm inside the namespace as far as I understand, and therefore I can't access and update the selectInput from the parent namespace. How can I solve this?
library(shiny)
library(shinydashboard)
moduleUI <- function(id) {
ns <- NS(id)
box(
title=actionLink(ns("link"),"This is a link"),
plotOutput(ns("plot"))
)
}
module <- function(input, output,session,number) {
output$plot <- renderPlot({
plot(number)
})
observeEvent(input$link,{
print(paste0("Number is: ",number))
updateSelectInput(session,"selectInput",selected=number) #Doesn't work
})
}
ui <-
dashboardPage(
dashboardHeader(title="Title"),
dashboardSidebar(
selectInput("selectInput","Choose one option",choices=seq(1,10),selected=1)
),
dashboardBody(
moduleUI("5"),
moduleUI("10")
)
)
server <- function(session,input, output) {
callModule(module=module,id="5",5)
callModule(module=module,id="10",10)
}
shinyApp(ui = ui, server = server)
Took me a while, but I found a way to get the sub-module to update the super-module.
Shiny is designed so that access to other modules must be done via module arguments or returned values. We can not pass the widget ID between modules, but we can pass the session information of the parent.
library(shiny)
moduleUI <- function(id) {
ns <- NS(id)
uiOutput(ns("my_link"))
}
module <- function(input, output, session, number, parent) {
output$my_link <- renderUI({
actionLink(session$ns("link"), paste0("This is a link to ", number))
})
observeEvent(input$link,{
updateSelectInput(session = parent,"selectInput",selected = number) ### use parent session
})
}
ui <- fluidPage(
selectInput("selectInput","Choose one option",choices=seq(1,10),selected=1),
moduleUI("5"),
moduleUI("10")
)
server <- function(session,input, output) {
callModule(module = module, id = "5", 5, parent = session) ### pass session information
callModule(module = module, id = "10", 10, parent = session) ### pass session information
}
shinyApp(ui = ui, server = server)
In particular note that:
we pass the current session information when the sub-module is called
we use the parent session when updating the input selector
I think the ideal would be to get the sub-module to observe and update the super-module. However, I can only offer a solution in line with my comment above: having one observer per sub-module in the super-module. This will rapidly get cumbersome if you have many sub-modules.
library(shiny)
library(shinydashboard)
moduleUI <- function(id) {
ns <- NS(id)
box(
title=actionLink(ns("link"),"This is a link"),
plotOutput(ns("plot"))
)
}
module <- function(input, output,session,number) {
current = reactiveValues()
current$return_value = 0
returnvalue <- reactive(current$return_value)
output$plot <- renderPlot({
plot(number)
})
observeEvent(input$link,{
print(paste0("Number is: ",number))
current$return_value = current$return_value + 1
})
return(list(rv = returnvalue, num = number))
}
ui <-
dashboardPage(
dashboardHeader(title="Title"),
dashboardSidebar(
selectInput("inputID","Choose one option",choices=seq(1,10),selected=1),
actionButton("button","Knap")
),
dashboardBody(
moduleUI("5"),
moduleUI("10")
)
)
server <- function(session,input, output) {
val1 <- callModule(module=module,id="5",5)
val2 <- callModule(module=module,id="10",10)
observeEvent(val1$rv(),{
updateSelectInput(session,inputId="inputID",selected=val1$num)
})
observeEvent(val2$rv(),{
updateSelectInput(session,inputId="inputID",selected=val2$num)
})
}
shinyApp(ui = ui, server = server)
Key changes from Tobias's question:
sub-modules have different names
separate observer for each sub-module
sub-module contains a return_value that gets updated every time the link is clicked. This ensures the observer in the super-module has a change to observe.
sub-module returns a list with two values: return_value as described above, and the value to update the UI with.
I am using renderUI to optionally present a Table or Plot based on user selection of the visualization option. I am also using Shiny modules to present the same thing on multiple tabs. While I have gotten Shiny modules to work wonderfully in another app, I am struggling to get it to work with renderUI.
Here is a minimal piece of code that I came up with that shows the problem where nothing gets displayed on either tabs:
myUI <- function(id) {
ns <- NS(id)
fluidRow(
uiOutput(ns('myFinalText'))
)
}
ui <- fluidPage(
tabBox(id = 'myBox', width = 12,
tabPanel('Tab1',
fluidRow(
myUI('tab1')
)),
tabPanel('Tab2',
fluidRow(
myUI('tab2')
))
)
)
myTextFunc <- function(input, output, session, text) {
output$myFinalText <- renderUI({
output$myText <- renderText({text})
textOutput('myText')
})
}
server <- function(input, output, session) {
callModule(myTextFunc, 'tab1', session = session, 'Hello Tab1')
callModule(myTextFunc, 'tab2', session = session, 'Hello Tab2')
}
shinyApp(ui = ui, server = server)
Any thoughts on what else I should be doing to make this work?
Replacing the Shiny module UI function and server functions as follows makes it work fine.
myUI <- function(id) {
ns <- NS(id)
fluidRow(
textOutput(ns('myFinalText'))
)
}
myTextFunc <- function(input, output, session, text) {
output$myFinalText <- renderText({
text
})
}
You can get the namespace from the session object. Change myTextFunc in the initial app like this:
myTextFunc <- function(input, output, session, text) {
ns <- session$ns
output$myFinalText <- renderUI({
output$myText <- renderText({text})
textOutput(ns('myText'))
})
}
You shouldn't call output$ function from another output$ function - it's against Shiny design patterns.
output$myFinalText <- renderUI({
output$myText <- renderText({text})
textOutput(ns('myText'))
})
If you want to know, why it is very bad practice, watch Joe Cheng tutorial about 'Effective reactive programming' from this site: https://www.rstudio.com/resources/webinars/shiny-developer-conference/.
You should use rather reactiveValues or reactive expressions instead. What exactly you should use is dependent from what do you want to achieve, so it's hard to say without detailed example, but according to Joe Cheng everything can be accomplished without nesting outputs or observers.
Sorry for answering my own question...but for others looking for a similar solution, this may be of help.
Here is how I solved for the need to inherit Shiny module namespace on the server side to dynamically render UI. IF there is a better way to solve, please comment or post.
tab1NS <- NS('tab1')
tab2NS <- NS('tab2')
myUI <- function(ns) {
tagList(
fluidRow(
radioButtons(ns('type'), 'Select Visual:',
choices = c('Table' = 'table',
'Plot' = 'plot'))
),
fluidRow(
uiOutput(ns('myCars'))
)
)
}
ui <- fluidPage(
tabBox(id = 'myBox', width = 12,
tabPanel('Tab1',
fluidRow(
myUI(tab1NS)
)),
tabPanel('Tab2',
fluidRow(
myUI(tab2NS)
))
)
)
myTextFunc <- function(input, output, session, cars, ns) {
getMyCars <- reactive({
if (input$type == 'table') {
output$table <- renderDataTable({datatable(cars)})
dataTableOutput(ns('table'))
} else{
output$plot <- renderPlot({
plot(cars$wt, cars$mpg)
})
plotOutput(ns('plot'))
}
})
output$myCars <- renderUI({
getMyCars()
})
}
server <- function(input, output, session) {
callModule(myTextFunc, 'tab1', session = session,
mtcars[mtcars$am == 1, ], tab1NS)
callModule(myTextFunc, 'tab2', session = session,
mtcars[mtcars$am == 0, ], tab2NS)
}
shinyApp(ui = ui, server = server)
Replacing your functions with this renderUI equivalent also works:
myUI <- function(id) {
ns <- NS(id)
fluidRow(
uiOutput(ns('myFinalText'))
)
}
myTextFunc <- function(input, output, session, text) {
output$myFinalText <- renderUI({
text
})
}
Although this obviously does not capture the complexity of what you are really doing. There's something not right about using output$... and textOutput within the renderUI like that. I don't think that is necessary - you don't actually have to use the textOutput function to include text in your output.
EDIT: It occurs to me that the problem has to do with namespaces and modules. When you do output$myText <- renderText(text), the result ends up in the namespace of tab1 or tab2. For example, try changing your textOutput to
textOutput('tab1-myText')
and watch what happens. I think this is why having output$.. variables in your renderUI is problematic. You can access inputs via callModule and that should take care of any namespace issues.
I'm trying to create an dynamic amount of datatables inside a tabsetPanel argument. Thanks to various different posts here I came to this 'not working solution'.
The tables are rendered and accesed correctly but the tabsetPanel fails to create and I'm wondering how I can make this work, any help appreciated:
library(DT)
# for simplification this is not dynamic but created without hardcoded variable calls.
portalData <- lapply(1:10,function(x)data.frame(rnorm(5,1))
names(portalData) <- 1:10
shinyApp(
ui = pageWithSidebar(
headerPanel("Dynamic number of tables inside tabpanels"),
sidebarPanel(
),
mainPanel(
uiOutput("tables")
)
),
server = function(input, output) {
observe({
output$tables <- renderUI({
names_list <- lapply(seq_along(portalData), function(i){
tablename <- paste(names(portalData)[i])
tabPanel(dataTableOutput(tablename))
})
do.call(tabsetPanel,do.call(tagList, names_list))
})
for(i in 1:length(portalData)){
local({
i2 <- i
output[[names(portalData)[i2]]] <- renderDataTable({portalData[[i2]]})
})
}
})
})
I'm very new to shiny and am having some trouble and have been searching all day, so hopefully someone can help me. Once an action button (actionButton, on UI) is selected by a user, I would like the server script to call a function (evenReactive in server) I wrote (myfunction, see below) that uses the input items from the UI and gets the right parameters I need to run myfunction and produce a n X2 data matrix that will be plotted as a table (renderTable in server, below). The data is a n X 2 matrix.
I have some sample code below. It's not the entre code, so you will not see the UI with the inputs I am putting in my function, or the server parts associated. But, it is the part I am trying to fix. I hope that's ok. I don't need the renderText, but when I take it out I get an error. Sorry for the formatting. Copy and pasting changed it a bit.
library(shiny)
ui <- shinyUI(fluidPage
(column(4,actionButton("gobutton", "Run"),verbatimTextOutput("ntext1")),
column(4, DT::dataTableOutput("table",width = "75%"))))
library(shiny)
shinyServer(function(input, output, session)
ntext1 <- eventReactive(input$gobutton, {
if (input$gobutton==1){
data=myfunction(input$checkbox,input$dateRange)}
})
output$ntext1 <- renderText({ntext1()})
output$table <- DT::renderDataTable(DT::datatable({
data
})
))
myfunction <-function(All,date1,date2,source_cd,tran_cd,airline_list,mag_level) {
print(All); print(date1); print(date2); print(source_cd);print(tran_cd);print(airline_list);print(mag_level)
setwd("C:/Users/TRomano/Documents/Projects/TrendAnalysis/Data")
data = read.csv("Airlines.csv",header = TRUE)
return(data)
}
For this type of problem I like to make use of reactiveValues()that are designed to store data in a reactive way.
Here is a simple app (single app, not split into server & ui) that demonstrates what I think you are trying to do
library(shiny)
library(DT)
ui <- shinyUI(
fluidPage(
column(width = 4,
actionButton("gobutton", "Run")
column(width = 4,
DT::dataTableOutput("table",
width = "75%"))))
server <- shinyServer(function(input, output, session){
rv <- reactiveValues()
rv$data <- NULL
observe({ ## will 'observe' the button press
if(input$gobutton){
print("here") ## for debugging
rv$data <- myfunction() ## store the data in the reactive value
rv$data
}
})
output$table <- DT::renderDataTable({
## The data has been stored in our rv, so can just return it here
rv$data
})
})
myfunction <- function(){
data <- data.frame(id = c(1,2,3),
val = letters[1:3])
return(data)
}
shinyApp(ui, server)
library(shiny)
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(title = "Company Name"),
dashboardSidebar(sidebarMenu(
menuItem("Results Table", tabName = "ResultsTable", icon = icon
("ResultsTable")),
dashboardBody(
tabItems(
tabItem(tabName tabItem(tabName = "ResultsTable",
fluidPage(
headerPanel(
fluidRow(
column(4,
selectInput("sour",
"Source Type:",
c("All",
unique(as.character(data_source_cd)))), offset=2
),
column(4,
selectInput("tran",
"Transaction Type:",
c("All",
unique(as.character(tran_cd)))))),
# Create a new row for the table.
fluidRow(column(8, DT::dataTableOutput("table",width = "75%"),offset = 2))))))
library(shiny)
shinyServer(function(input, output, session) {
ntext1 <- eventReactive(input$gobutton, {
if (input$dateRange[2]<input$dateRange[1]){print("You selected the date range option;however, the end date entered occurs before the starting date")}else{
output$ntext1 <- renderText({print("Analysis complete...")});
observe({
if(input$gobutton){
rv$data <- myfunction() }
})
output$table <- DT::renderDataTable(DT::datatable({
data <- rv$data
if (input$sour != "All") {
data <- data[data[,5] == input$sour,]
}else{data}
if (input$tran != "All") {
data <-data[data[,6] == input$tran,]
}else{data}
}))
}})
Once an action button is selected on the main page of my dashboard(not shown), myfunction runs analysis with the inputs from the main dashboard page. On another tab, a table will show once the analysis is complete. There are drop down menus (input$tran, input$sour) that will reduce what is in the table depending on what the user selects. If there are any errors in the input, a warning of text comes up on the main dashboard page and the tab with the table will not be created until the correct inputs are selected.
The observe function allowed me to run my function and the output data of the function set to a variable I could later use to create the table (shown).
THis is my first time posting. Any questions feel free to ask.