how to manually expand a submenu in a shiny dashboard side bar - javascript

I'm trying to manually expand a submenu in a sidebar in shiny dashboard. The updateTabItems function only works with normal menus, but not with nested menus.
Here is basic example (modified from the updateTabItems documentation) to show the problem. If I clicked on 'Switch tab', it switches the menus, but it doesn't expand the first menu that has a submenu. It seems that it only selected the submenu but doesn't expand the tree.
library(shiny)
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(title = "Simple tabs"),
dashboardSidebar(
sidebarMenu(
id = "tabs",
menuItem("Dashboard", tabName = "dashboard", icon = icon("dashboard"),
menuSubItem("Sub Menu 1",icon = icon("folder-open"), tabName = "subMenu1")
),
menuItem("Widgets", tabName = "widgets", icon = icon("th"))
),
actionButton('switchtab', 'Switch tab')
),
dashboardBody(
tabItems(
tabItem(tabName = "dashboard",
h2("Dashboard tab content")
),
tabItem(tabName = "widgets",
h2("Widgets tab content")
)
)
)
)
server <- function(input, output, session) {
observeEvent(input$switchtab, {
newtab <- switch(input$tabs,
"subMenu1" = "widgets",
"widgets" = "subMenu1"
)
updateTabItems(session, "tabs", newtab)
})
}
shinyApp(ui, server)
}
I would like manually expand the tree, select the menu and the submenu. Any suggestions are welcome. Thanks.
Update:
A working code with the complete solution is in Shiny expanding submenu items manually

I helped myself out defining some JavaScript, using the JavaScript interface extendShinyjs in shiny:
js$selectMenuItem(0)
js$selectMenuSubItem(2)
useShinyjs(),
extendShinyjs(text = jsSelectMenuItem),
extendShinyjs(text = jsSelectMenuSubItem)
select menuItem i
jsSelectMenuItem <- "shinyjs.selectMenuItem = function(i){
setTimeout(function(){
$('.treeview > a').eq(i).click();
}, 200);
}"
select menuSubItem i
jsSelectMenuSubItem <- "shinyjs.selectMenuSubItem = function(i){
setTimeout(function(){
$('.treeview-menu > li > a').eq(i).click();
}, 800);
}"

Related

update menuanchor of fullPage.js in R Shiny App from server side

I am using the fullPage package to create a Shiny App and I am facing the following issue : I would like to update from the server side the labels of the menu that are first defined in the pagePiling function of the ui part.
I have seen in the HTML code that the field that I should update is the one here below, but I don't know how to change it/access it in the server part of my app.
<ul id="tocMenu">
<li data-menuanchor="test_page">
temp_title
</li>
</ul>
I have the impression that this sould be achievable with javascript, but I don't know a lot about js ; among others, I have tried so far the following stuff :
library(fullPage)
library(shiny)
library(shinyjs)
library(shinyWidgets)
shinyApp(
ui = pagePiling(
shinyjs::useShinyjs(),
center = TRUE,
sections.color = c(
"#CFE2F3"
),
menu = c(
"temp_title" = "test_page"
),
pageSection(
menu="test_page",
pickerInput("title", multiple = F, selected=NULL,
choices = c("Title 1", "Title 2")),
)
),
server = function(input, output) {
observeEvent(input$title, {
# runjs("$('#fullpage').fullpage({
# anchors: ['test'],
# menu: '#tocMenu'});")
runjs(paste0('document.getElementById("test_page").innerHTML = "', input$title, '";'))
} )
}
)
If anyone could help, I would be very grateful !
Thanks
The problem is that you use getElementById() but the menu title doesn't have an id, it has an href tag:
Therefore, you should use querySelectorAll() instead and specify the characteristics of the element you want to select (here, it's an element a that has href="#test_page"). Finally, this function returns a list of elements (this list only contains 1 element here), so you need to use [0] to select it.
Here's your example fixed:
library(fullPage)
library(shiny)
library(shinyjs)
library(shinyWidgets)
shinyApp(
ui = pagePiling(
shinyjs::useShinyjs(),
center = TRUE,
sections.color = c(
"#CFE2F3"
),
menu = c(
"temp_title" = "test_page"
),
pageSection(
menu="test_page",
pickerInput("title", multiple = F, selected=NULL,
choices = c("Title 1", "Title 2")),
)
),
server = function(input, output) {
observeEvent(input$title, {
# runjs("$('#fullpage').fullpage({
# anchors: ['test'],
# menu: '#tocMenu'});")
runjs(paste0('document.querySelectorAll("a[href=\'#test_page\']")[0].innerHTML = "', input$title, '";'))
} )
}
)

Add pickerInput in header of R Shiny fullPage.js

I am building a R Shiny App with the package fullPage ; I would like to have in the header (=appearing on all pages) a pickerInput that allows the user to select the language.
Could anyone help to achieve this ?
What I was able to do, is only to have this element on the 1st page, but I would like to have it on all pages, ideally in the header, at the same level as the ''menu'' (next to ''First'' and ''Second'' in the minimal example here below).
library(shiny)
library(fullPage)
ui <- fullPage(
menu=c("First"="first",
"Second" ="second"),
fullSection(
menu = "first",
center = TRUE,
pickerInput(
inputId = "lang_select",
label = "Language",
choices = c("ENG", "FR"),
options = list(
style = "btn-primary")
),
h1("Callbacks")
),
fullSection(
menu = "second",
center = TRUE,
h3("Slice"),
verbatimTextOutput("slide")
)
)
server <- function(input, output){
}
shinyApp(ui, server)

How the change attributes of UI elements with JavaScript in Shiny?

I know there is this server side method called renderUI, but it makes updating the UI extremely slow in some cases, so I am now relying on the JavaScript.
My problem is a follows. I would like to update the title attribute of material_card from shinymaterial package. I would like to see the title to change, every time I select an alternative from a separate dropdown menu.
So far my list of UI components contain tags$script() object, which is supposed to observe the changes in the selectInput (goes with id "dropdown").
My code looks as follows:
library(shinymaterial)
library(shiny)
ui <- material_page(
titlePanel("Soon to be working JavaScript example!"),
sidebarLayout(
sidebarPanel(
selectInput(
"dropdown",
"Dropdown menu",
c('Hat','Shoes','Jacket')),
tags$script('
$(document).on("shiny:inputchanged", function(event) {
if (event.name === "dropdown") {
if(input.dropdown === "Jacket") {
//Even this alert is not working, possibly because input.name is not recognized. :(
alert("You chose Jacket, now the material card title will be changed to: Jacket selected");
//What am I supposed to put here to update the material_card title?
} else {
//...and here as well...
}
});'
),
material_card(
depth=5,
title = 'This value needs to be changed according what was chosen in the dropdown menu!')
),
mainPanel(
h5('Nothing here!')
)
)
)
server <- function(input, output) {
#The server is empty, as it should. :)
}
shinyApp(ui = ui, server = server)
I managed to get the alert working without the if(input.dropdown === "Jacket") validation, but this validation is not working: Most likely input.dropdown is not even recognized, although it works nicely with conditional panel.
Furthermore, I am even more lost with the logic: How should I actually use JavaScript to update the material_card title, after the change in selectInput (dropdown) value has been observed?
library(shinymaterial)
library(shiny)
ui <- material_page(
titlePanel("Soon to be working JavaScript example!"),
sidebarLayout(
sidebarPanel(
selectInput(
"dropdown",
"Dropdown menu",
c('Hat','Shoes','Jacket')),
tags$script(HTML('
$(document).on("shiny:inputchanged", function(event) {
if (event.name === "dropdown") {
if(event.value === "Jacket") {
alert("You chose Jacket, now the material card title will be changed to: Jacket selected");
$("#mycard>span.card-title").html("Here is the new card title");
} else {
//...and here as well...
}
}
});')
),
material_card(
depth=5,
title = 'This value needs to be changed according what was chosen in the dropdown menu!',
id = "mycard"
)
),
mainPanel(
h5('Nothing here!')
)
)
)
shinyApp(ui, server = function(input,output){})
A shiny UI-only solution:
library(shinymaterial)
library(shiny)
dropdownChoices <- c('Hat','Shoes','Jacket')
ui <- material_page(
titlePanel("Soon to be working JavaScript example!"),
sidebarLayout(
sidebarPanel(
selectInput(
"dropdown",
"Dropdown menu",
dropdownChoices),
material_card(
depth = 5,
title = lapply(dropdownChoices, function(i){
conditionalPanel(sprintf('input.dropdown == "%s"', i), i)
})
)),
mainPanel(
h5('Nothing here!')
)
)
)
server <- function(input, output) {}
shinyApp(ui = ui, server = server)

how to get closed dropdown of hamburger menu when an option has been selected in Shiny

I have a collapsible navbar menu in R Shiny. When the menu has collapsed and I click on the Hamburger button, the options appear. When I click on one of the options, another panel is (rightly) chosen, but the menu stays open.
Is it possible to make it so (with css?) that the 'dropdown menu' (i.e. list of options) closes as soon as I have chosen one of the options?
The code looks like this:
library(shiny)
ui <- tagList(
navbarPage(
title = NULL, id = "navBar", collapsible = TRUE,
tabPanel(title = "Panel1", uiOutput('panel1')),
tabPanel(title = "Panel2", uiOutput('panel2')),
tabPanel(title = "Panel3", uiOutput('panel3'))
)
)
server <- function(input, output, session) {
output$panel1 <- renderUI({p("This is panel 1")})
output$panel2 <- renderUI({p("This is panel 2")})
output$panel3 <- renderUI({p("This is panel 3")})
}
shinyApp(ui = ui, server = server)
You could listen on the navbarPage with input$navBar (your id in navbarPage()) and trigger the changes via javascript.
observeEvent(input$navBar, {
runjs('
var elem = document.getElementsByClassName("navbar-collapse")[0]
elem.setAttribute("aria-expanded", "false");
elem.setAttribute("class", "navbar-collapse collapse");
')
})
Reproducible example:
library(shiny)
library(shinyjs)
ui <- tagList(
useShinyjs(),
navbarPage(
title=NULL, id = "navBar", collapsible = TRUE,
tabPanel(title = "Panel1", uiOutput('panel1')),
tabPanel(title = "Panel2", uiOutput('panel2')),
tabPanel(title = "Panel3", uiOutput('panel3'))
)
)
server <- function(input, output, session) {
output$panel1 <- renderUI({p("This is panel 1")})
output$panel2 <- renderUI({p("This is panel 2")})
output$panel3 <- renderUI({p("This is panel 3")})
observeEvent(input$navBar, {
runjs('
var elem = document.getElementsByClassName("navbar-collapse")[0]
elem.setAttribute("aria-expanded", "false");
elem.setAttribute("class", "navbar-collapse collapse");
')
})
}
shinyApp(ui = ui, server = server)

Dynamic popover or tooltip in shinyBS

The idea
I have a box() in a shiny app. The box() includes a title argument (which in turn includes an icon) and a selectInput()element. On hoover over the icon I wanted to have a tooltip (using tipify()) or a popover (using popify()) which title or content argument (or both) would be generated depending on selectInput() input.
The problem
Neither tipify() nor popify() correcctly implement textOutput() as their title or content argument. They need a character string so I tried to use a reactiveValues() element as a function argument but it also failed.
The question
Can tooltip or popover content be made dynamic by just using r? How could this be done?
I suspect it can be done with JavaScript but I have little knowledge of it.
The code
Attempt 1 - failed - displays code not actual text
library("shiny")
library("shinydashboard")
library("shinyBS")
ui <- fluidPage(
box(
title = span("My box",
tipify(el = icon(name = "info-circle", lib = "font-awesome"), title = textOutput("TIP"))),
selectInput(
inputId = "SELECT",
label = NULL,
choices = c("Option1" = "Option1",
"Option2" = "Option2"
),
multiple = FALSE
)
)
)
server <- function(input, output, session){
output$TIP <- renderText({"Helo world!"})
}
shinyApp(ui, server)
Attempt 2 - failed - cannot create UI as TIP (reactiveValues()) is not yet defined
library("shiny")
library("shinydashboard")
library("shinyBS")
ui <- fluidPage(
box(
title = span("My box",
tipify(el = icon(name = "info-circle", lib = "font-awesome"), title = TIP$a)),
selectInput(
inputId = "SELECT",
label = NULL,
choices = c("Option1" = "Option1",
"Option2" = "Option2"
),
multiple = FALSE
)
)
)
server <- function(input, output, session){
TIP <- reactiveValues(a = "Hello world!")
}
shinyApp(ui, server)
Here is a similar question but it does not solve the problem described here.
What could be done is creating the title entirely in the server side. This way you have no problem making it dynamic. This could give you this kind of app:
library("shiny")
library("shinydashboard")
library("shinyBS")
ui <- fluidPage(
box(
title = uiOutput("title"),
selectInput(
inputId = "SELECT",
label = NULL,
choices = c("Option1" = "Option1",
"Option2" = "Option2"
),
multiple = FALSE
)
)
)
server <- function(input, output, session){
TIP <- reactiveValues()
observe({
TIP$a <- ifelse(input$SELECT =="Option1","Hello World","Hello Mars")
})
output$title <- renderUI({span("My box",
tipify(el = icon(name = "info-circle", lib = "font-awesome"), title = TIP$a))})
}
shinyApp(ui, server)
Hope it helps.

Categories

Resources