updateTabItems not working in module if input passed - r

I want to create a function/a module to update tabset items.
I'm aware of this and this question, but my issue relates to how the button input is handled in updateTabItems.
Here you can find an example:
library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
mod_updateTabset <- function(
input, output, session, triggerId, dashboardId, tab, parent
) {
observeEvent(triggerId, {
updateTabItems(parent, dashboardId, selected = tab)
})
}
ui <- dashboardPagePlus(
header = dashboardHeaderPlus(),
sidebar = dashboardSidebar(
sidebarMenu(
id = 'Tabs',
menuItem("Tab 01", tabName = "tab01", icon = icon("dice-one")),
menuItem("Tab 02", tabName = "tab02", icon = icon("dice-two"))
)
),
body = dashboardBody(
tabItems(
tabItem(
tabName = "tab01",
actionButton("updateButton", label = "To Tab02")
),
tabItem(
tabName = "tab02",
h4("New Tab")
)
)
)
)
server <- function(input, output, session) {
callModule(
mod_updateTabset,
"updateLink",
triggerId = input$updateButton,
dashboardId = "Tabs",
tab = "tab02",
parent = session
)
}
shinyApp(ui = ui, server = server)
I know it's working when creating mod_updateTabset_UI, shifting the actionButton to the module. That's why I suppose the issue lies in the button handling.
Still, I'd like to have a function/module which can handle all kind of links, buttons etc. to update Tab items, not just one button

For anyone who runs into the same problem: You need to use reactive() for triggerId when calling the module
callModule(
mod_updateTabset,
"updateLink",
triggerId = reactive(input$updateButton),
dashboardId = "Tabs",
tab = "tab02",
parent = session
)
The module then needs to handle a reactive value:
mod_updateTabset <- function(
input, output, session, triggerId, dashboardId, tab, parent
) {
observeEvent(triggerId(), {
updateTabItems(parent, dashboardId, selected = tab)
})
}

Related

Shiny remove extra row added by external link in navbar tab panel

I'm trying to add an external link to the tab panel title in a shiny navbar. The link itself works fine, but it moves the tab with the link into a separate row.
How can I include a link and maintain the placement of the tab in the same row as any other tabs that don't contain links?
Here is my minimalistic code:
library(shiny)
ui <- navbarPage(
title = "",
id = "navbar",
header = "",
tabsetPanel(id="tabs",
tabPanel(
title = "Tab1", value = "tab1"
),
tabPanel(
title = a("Tab2",
href = "https://www.google.com/"),
value = "tab2"
)
)
)
server <- function(input, output, session) {
}
shinyApp(ui, server)
I have tried using the HTML function to see if that for some reason gives a different result, but as expected it didn't:
tabPanel(
title = HTML("<a href = 'https://www.google.com/'>tab2</a>"),
value = "tab2"
)
I would really appreciate your advice!
If you also happen to have any idea on how to remove the title row from the navbarPage, that would also be much appreciated.
If you look at the HTML for your tabs, you can see that the tabs themselves already have a <a href ...> tag. So what you're doing is adding another one below the existing one.
A work-around is to do something like
Observe when Tab2 is pressed
Navigate to the URL
library(shiny)
ui <- navbarPage(
title = "",
id = "navbar",
header = "",
tabsetPanel(
id = "tabs",
tabPanel(title = "Tab1"),
tabPanel(title = "Tab2")
)
)
server <- function(input, output, session) {
observeEvent(input$tabs, {
print(input$tabs)
if( input$tabs == "Tab2" ) {
browseURL("https://www.google.com/")
}
})
}
shinyApp(ui, server)
One way to do this, is to use a javascript function to do the linking for us. Then we do not need to include <a href> inside the tab which is already a link!.
We can easily set up a Js function with {shinyjs} and extendShinyjs(). Then we call it in an observeEvent() when the tab is clicked.
library(shiny)
library(shinyjs)
ui <- navbarPage(
# use shinyjs
useShinyjs(),
# write JS function to open window
shinyjs::extendShinyjs(text = "shinyjs.myfun = function() { window.open('https://www.google.com/', '_self'); }",
functions = c("myfun")),
title = "",
id = "navbar",
header = "",
tabsetPanel(id="tabs",
tabPanel(
title = "Tab1", value = "tab1"
),
tabPanel(
title = "Tab2",
value = "tab2"
)
)
)
server <- function(input, output, session) {
# use observeEvent to check if user clicks tab no 2
observeEvent(input$tabs,
{
if (input$tabs == "tab2") {
shinyjs::js$myfun()
}
})
}
shinyApp(ui, server)

Loading shiny module only when menu items is clicked

Background
Within a modular1 Shiny application, I would like to load module only when menu item on shinydashboard is clicked. If the menu item is not accessed I wouldn't like to load the module.
Basic application
app.R
# Libs
library(shiny)
library(shinydashboard)
# Source module
source("sample_module.R")
ui <- dashboardPage(
dashboardHeader(title = "Dynamic sidebar"),
dashboardSidebar(sidebarMenuOutput("menu")),
dashboardBody(tabItems(
tabItem(tabName = "tab_one", h1("Tab One")),
tabItem(tabName = "tab_two", sampleModuleUI("sampleModule"))
))
)
server <- function(input, output) {
callModule(sampleModuleServer, "sampleModule")
output$menu <- renderMenu({
sidebarMenu(
menuItem(
"Menu item 1",
icon = icon("calendar"),
tabName = "tab_one"
),
menuItem(
"Menu item 2",
icon = icon("globe"),
tabName = "tab_two"
)
)
})
}
shinyApp(ui, server)
sample_module.R
sampleModuleServer <- function(input, output, session) {
output$plot1 <- renderPlot({
plot(mtcars)
})
}
sampleModuleUI <- function(id) {
ns <- NS(id)
plotOutput(ns("plot1"))
}
Desired implementation
The desired implementation would load sample_module only when the relevant menu item is clicked. On the lines of 2:
Don't call callModule from inside observeEvent; keep it at the top level. Take the reactive expression that's returned, and use eventReactive to wrap it in the button click. And use the eventReactive from your outputs, etc.
x <- callModule(...)
y <- eventReactive(input$go, x())
output$tbl <- DT::renderDataTable(y())
Attempt
app.R (modified)
# Libs
library(shiny)
library(shinydashboard)
# Source module
source("sample_module.R")
ui <- dashboardPage(
dashboardHeader(title = "Dynamic sidebar"),
dashboardSidebar(sidebarMenuOutput("menu")),
dashboardBody(tabItems(
tabItem(tabName = "tab_one", h1("Tab One")),
tabItem(tabName = "tab_two", sampleModuleUI("sampleModule"))
))
)
server <- function(input, output) {
eventReactive(eventExpr = input$tab_two,
valueExpr = callModule(sampleModuleServer, "sampleModule")
)
output$menu <- renderMenu({
sidebarMenu(
menuItem(
"Menu item 1",
icon = icon("calendar"),
tabName = "tab_one"
),
menuItem(
"Menu item 2",
icon = icon("globe"),
tabName = "tab_two"
)
)
})
}
shinyApp(ui, server)
Problem
Application runs but the module does not load. Questions:
How to correctly call eventReactive on dashboard menu item? The tab_item does not seem to have id parameter is tabName equivalent in that context?
The linked discussion refers to refreshing one table. I'm trying to figure out example that will work with modules containing numerous interface element and elaborate server calls.
Clicking on Menu item 2 should display the content from the sample_module.R file.
1 Modularizing Shiny app code
2 Google groups: activate module with actionButton
Update
I've tried explicitly forcing module into application environment load using the following syntax:
eventReactive(eventExpr = input$tab_two,
valueExpr = callModule(sampleModuleServer, "sampleModule"),
domain = MainAppDomain
)
where
MainAppDomain <- getDefaultReactiveDomain()
Edit: Dropping Joe Cheng's top level statement:
# Libs
library(shiny)
library(shinydashboard)
# Source module
source("sample_module.R")
ui <- dashboardPage(
dashboardHeader(title = "Dynamic sidebar"),
dashboardSidebar(sidebarMenuOutput("menu")),
dashboardBody(tabItems(
tabItem(tabName = "tab_one", h1("Tab One")),
tabItem(tabName = "tab_two", sampleModuleUI("sampleModule"))
))
)
server <- function(input, output) {
observeEvent(input$tabs,{
if(input$tabs=="tab_two"){
callModule(sampleModuleServer, "sampleModule")
}
}, ignoreNULL = TRUE, ignoreInit = TRUE)
output$menu <- renderMenu({
sidebarMenu(id = "tabs",
menuItem(
"Menu item 1",
icon = icon("calendar"),
tabName = "tab_one"
),
menuItem(
"Menu item 2",
icon = icon("globe"),
tabName = "tab_two"
)
)
})
}
shinyApp(ui, server)
Furthermore, your sidebarMenu needs an id to access the selected tabs; please see the shinydashboard documentation.

Call updateTabItems from inside Shiny module

In my shiny app I have lots of valueBoxes, each representing a tabItem in the sidebar of the shinydashboard. When clicking on the valueBox the page should move to the correct tab.
Instead of copypasting the code lots of times I wrote a reusable module which renders the valueBox and changes the class of the valueBox into an actionButton. In the server part I have included an observeEvent which calls updateTabItems when the valueBox is clicked. But when clicked nothing happens. It seems that the module cannot manipulate the dashboard sidebar.
library(shiny)
library(shinydashboard)
value_box_output <- function(.id) {
ns <- NS(.id)
valueBoxOutput(ns("overview.box"))
}
value_box <- function(input, output, session, .value, .subtitle, .tab.name) {
ns <- session$ns
output$overview.box <- renderValueBox({
box1 <- valueBox(
.value,
.subtitle,
href = "#",
width = NULL
)
box1$children[[1]]$attribs$class <- "action-button"
box1$children[[1]]$attribs$id <- ns("button")
box1
})
observeEvent(input$button, {
print("clicked")
updateTabItems(session, inputId = "tabs", selected = .tab.name)
})
}
ui <- dashboardPage(
dashboardHeader(title = "Title"),
dashboardSidebar(
sidebarMenu(
id = "tabs",
menuItem("Overview", tabName = "Overview"),
menuItem("Tab 1", tabName = "Tab_1")
)
),
dashboardBody(
tabItems(
tabItem("Overview", value_box_output("tab")),
tabItem("Tab_1")
)
)
)
server <- function(input, output, session) {
callModule(value_box,
"tab",
.value = 33,
.subtitle = "Tab 1",
.tab.name = "Tab_1")
}
shinyApp(ui, server)
You can find the answer in this post: Accessing parent namespace inside a shiny module
Basically, in updateTabItems() inside a moulde, you need to call the parent's session, not the session of the modul.
Thus, add a variable for your session to callModule() and call it in updateTabItems().

Shiny module access output outside namespace

I need my Shiny module to hide/show a div outside of the namespace. I tried passing the div id to the module server function and using shinyjs to show/hide it but that is not working. I'm not getting an error, it just doesn't show/hide the div.
I know the Shiny module documentation says modules cannot access outputs outside the namespace. The docs do, though, give a way for the module to access inputs outside the namespace using reactives.
Does anyone know if there is a way for a Shiny module to access an output outside the namespace?
Here is what I'm trying to do:
### ui.R ###
header <- dashboardHeader(
title = a(href = 'http://google.com')
)
dashboardPage(
skin = 'black',
header,
dashboardSidebar(
sidebarMenu( id='tabs',
menuItem('Edit Existing Client', tabName = 'client-info')
)),
dashboardBody(
useShinyjs(),
fluidRow(
tabItems(
tabItem(tabName = "client-info",
div(selectClientModuleUI("clientinfons")),
div(id='editclientinfo', uiOutput('editclientstuff'))
)
)
)
)
)
### server.R ###
shinyServer(function(session,input, output) {
output$editclientstuff <- renderUI({
div(
fluidRow(
column(6,
textInput('editname', "Display name", value ='Testing name')
),
column(6,
numericInput('editastart','Start', value ='3')
)
)
)
})
callModule(selectClientModule, 'clientinfons', 'editclientinfo')
shinyjs::hide(id='editclientstuff')
})
### in global.R ###
selectClientModuleUI <- function(id){
ns <- NS(id)
clientlist = c(0, 1, 2)
names(clientlist) = c('Choose client', 'Fred', 'Kim')
div(
selectInput(ns('selectclient'), 'Select client to edit', choices = clientlist, selected = NULL, multiple = FALSE)
)
}
selectClientModule <- function(input, output, session, divtoshow = ''){
observeEvent(input$selectclient, {
if (!is.null(input$selectclient) && input$selectclient > 0){
print(paste0("showing ", divtoshow))
shinyjs::show(divtoshow)
}
})
}
That is possible by giving the value as a reactive (not as the value of the reactive) to the module. You can change the reactive Value in the module and return the reactive from the Module to the app (note, return the reactive itself, not its value). The following app switches the 'divtoshow' in the main app from inside the module. If nothing is selected, it's hidden, otherwise it's shown (note, I adjusted you code a little so it's working as a stand-alone app):
library(shinydashboard)
library(shinyjs)
# Module
selectClientModuleUI <- function(id){
ns <- NS(id)
clientlist = c(0, 1, 2)
names(clientlist) = c('Choose client', 'Fred', 'Kim')
div(
selectInput(ns('selectclient'), 'Select client to edit', choices = clientlist, selected = NULL, multiple = FALSE)
)
}
selectClientModule <- function(input, output, session, divtoshow){
observeEvent(input$selectclient, {
if (input$selectclient > 0){
print(paste0("showing editclientinfo"))
divtoshow("editclientinfo") # set the div to show to "editclientinfo", this will be visible outside the module
}else{
divtoshow("") # set the div to show to "", if nothing was chosen
}
})
# return the div to show as reactive to the main app
return(divtoshow)
}
# Main App
ui <- shinyUI(
dashboardPage(
skin = 'black',
dashboardHeader(
title = a(href = 'http://google.com')
),
dashboardSidebar(
sidebarMenu( id='tabs',
menuItem('Edit Existing Client', tabName = 'client-info')
)),
dashboardBody(
useShinyjs(),
fluidRow(
tabItems(
tabItem(tabName = "client-info",
div(selectClientModuleUI("clientinfons")),
div(id='editclientinfo', uiOutput('editclientstuff'))
)
)
)
)
))
server <- shinyServer(function(session,input, output) {
output$editclientstuff <- renderUI({
div(
fluidRow(
column(6,
textInput('editname', "Display name", value ='Testing name')
),
column(6,
numericInput('editastart','Start', value ='3')
)
)
)
})
# store the div to show in a reactive
divtoshow <- reactiveVal('')
# divtoshow can be changed in side this module, so it's a return value
divtoshow <- callModule(selectClientModule, 'clientinfons', divtoshow)
# observe the value of divtoshow and toggle the corresponding div
observeEvent(divtoshow(), {
if(divtoshow() == "editclientinfo"){
shinyjs::show("editclientinfo")
}else{
shinyjs::hide("editclientinfo")
}
})
})
shinyApp(ui, server)

R Shinydashboard dynamic menuItem

I'm trying to generate multiple menuItems dynamically, may be simple, but I'm not getting the right idea.
library(shiny)
library(shinydashboard)
port_tables<-c("tab1","tab2","tab3","tab4") # These are from a DB connection in the original code
function(input, output) {
output$smenu1 <- renderMenu({
sidebarMenu( id = "tabs",
h4("Tables",style="color:yellow;margin-left:20px;"),
paste("menuItem(\"",port_tables,"\",tabName=\"",port_tables,"\",icon=icon('th'))",collapse=",")
)
})
)
The menuItems from the paste function doesn't resolve( I get the result of paste function on the sidebar). I tried eval, eval(parse(paste(...))), both didn't work - what am I missing?
I couldn't quite make out what you're asking for, but here's an example of something with a dynamic menu.
library(shiny)
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(title = "Dynamic Menu"),
dashboardSidebar(
sidebarMenuOutput(outputId = "dy_menu")
),
dashboardBody(
tabItems(
tabItem(tabName = "main",
textInput(inputId = "new_menu_name",
label = "New Menu Name"),
actionButton(inputId = "add",
label = "Add Menu")
)
)
)
)
server <- function(input, output, session){
output$dy_menu <- renderMenu({
menu_list <- list(
menuItem("Add Menu Items", tabName = "main", selected = TRUE),
menu_vals$menu_list)
sidebarMenu(.list = menu_list)
})
menu_vals = reactiveValues(menu_list = NULL)
observeEvent(eventExpr = input$add,
handlerExpr = {
menu_vals$menu_list[[length(menu_vals$menu_list) + 1]] <- menuItem(input$new_menu_name,
tabName = input$new_menu_name)
})
}
shinyApp(ui, server)
I changed the code as follows and it worked :
library(shiny)
library(shinydashboard)
port_tables<-c("tab1","tab2","tab3","tab4") # These are from a DB connection in the original code
text1<-paste("menuItem(\"",port_tables,"\",tabName=\"",port_tables,"\",icon=icon('th'))")
text2<-paste("sidebarMenu(id = 'tabs',textInput('port', 'Enter port:'),h4('Tables',style='color:yellow;margin-left:20px;'),",paste(text1,collapse=","),paste(")"))
function(input, output) {
output$smenu1 <- renderMenu({
eval(parse(text=text2))
})
)
So, the key is put the whole content of sidebarMenu in a text field and evaluate it

Resources