Change text in boxSidebar tooltip - shiny

I am using boxSidebar for my non-english shiny app, and would really like to replace the 'More' text that appears on hovering over the icon. Can anyone help me with a solution for this?
Alternatively, I was thinking to remove it by using shinyjs::hide(), but the ID seems to change on every hover so I do not know if that's an option here.
minimum example:
library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
shinyApp(
ui = dashboardPage(
header = dashboardHeader(),
body = dashboardBody(
box(
title = "Hover icon",
sidebar = boxSidebar(
id = "mycardsidebar",
p("Sidebar Content")
)
)
),
sidebar = dashboardSidebar()
),
server = function(input, output, session) {
}
)

We can use {htmltools} to do the work:
library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
library(htmltools)
library(magrittr)
shinyApp(
ui = dashboardPage(
header = dashboardHeader(),
body = dashboardBody(
box(
title = "Hover icon",
sidebar = boxSidebar(
id = "mycardsidebar",
p("Sidebar Content")
)
) %>% {
tagQuery(.)$
find("#mycardsidebar")$
removeAttrs("data-original-title")$
addAttrs(`data-original-title`="whatever")$
allTags()
}
),
sidebar = dashboardSidebar()
),
server = function(input, output, session) {
}
)
change whatever to your text.

Related

Shinydashboard. How to unselect menuItem?

I have this code:
library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
shinyApp(
ui = dashboardPage(
header = dashboardHeader(userOutput("user")),
sidebar = dashboardSidebar(shinyjs::useShinyjs(),uiOutput("sidebarpanel")),
body = dashboardBody(uiOutput("body")),
title = "DashboardPage"
),
server = function(input, output) {
output$user <- renderUser({
dashboardUser(
name = "Divad Nojnarg",
image = "https://adminlte.io/themes/AdminLTE/dist/img/user2-160x160.jpg",
title = "shinydashboardPlus",
subtitle = "Author",
footer = p("The footer", class = "text-center"),
fluidRow(
actionButton("personalInfo","Personal Info")
)
)
})
observeEvent(input$personalInfo, {
output$body <- renderUI({h4("Personal Info Dahsboard (no menuItem)")})
})
output$sidebarpanel <- renderUI({
sidebarMenu(id="tabs",
menuItem("Dashboard 1", tabName = "dashboard1", icon = icon("dashboard"))
,menuItem("Dashboard 2", tabName = "dashboard2", icon = icon("dashboard"))
)
})
output$body <- renderUI({
tabItems(
tabItem(tabName ="dashboard1",
fluidRow(box(width = 12, h4("Dashboard 1 (menuItem)"))))
,tabItem(tabName ="dashboard2",
fluidRow(box(width = 12, h4("Dashboard 2 (menuItem)"))))
)
})
}
)
I would like to do two things:
First: When I click on "Personal Info" button, then, prevent the menuItem to be shadowed (I assume I need to remove the class "selected" or "active" or something like that)
Second: I want to fix this: After pressing "Personal Info" button, the menuItems do not work:
As already shown in my earlier answer here we can use a hidden menuItem to modify the body content independent from the visibly selected menuItem.
Furthermore, I'd recommend to stop using renderUI in this scenario. In general it is slower to re-render a UI element instead of updating an existing element (here we can switch to the hidden menuItem via updateTabItems - however, this applies also to e.g. using updateSelectInput instead of renderUI({selectInput(...)})). In this context you should also question whether you really need the to create the dashboardUser on the server side.
If you really need a server side generated dashboardSidebar you still should not use renderUI - There are the renderMenu() / sidebarMenuOutput() functions available for this. Please see the related docs here.
library(shiny)
library(shinyjs)
library(shinydashboard)
library(shinydashboardPlus)
shinyApp(
ui = dashboardPage(
header = dashboardHeader(userOutput("user")),
sidebar = dashboardSidebar(shinyjs::useShinyjs(),
sidebarMenu(id="tabs",
menuItem("Tab 1", tabName = "tab1", icon = icon("dashboard")),
menuItem("Tab 2", tabName = "tab2", icon = icon("dashboard")),
hidden(menuItem("Personal Tab", tabName = "personal_tab", icon = icon("dashboard")))
)),
body = dashboardBody(useShinyjs(),
tabItems(
tabItem(tabName ="tab1",
fluidRow(box(width = 12, h4("Tab 1 (menuItem)")))),
tabItem(tabName ="tab2",
fluidRow(box(width = 12, h4("Tab 2 (menuItem)")))),
tabItem(tabName ="personal_tab",
fluidRow(box(width = 12, h4("Personal Info Dahsboard (no menuItem)"))))
)
),
title = "DashboardPage"
),
server = function(input, output, session) {
output$user <- renderUser({
dashboardUser(
name = "Divad Nojnarg",
image = "https://adminlte.io/themes/AdminLTE/dist/img/user2-160x160.jpg",
title = "shinydashboardPlus",
subtitle = "Author",
footer = p("The footer", class = "text-center"),
fluidRow(
actionButton("personalInfo","Personal Info")
)
)
})
observeEvent(input$personalInfo, {
shinydashboard::updateTabItems(session, inputId = "tabs", selected = "personal_tab")
})
}
)

Wrong display - How to fit well a selectinput in a shinydashboard header and style it

I want to put a selectInput inside the dashboardHeaderPlus but this makes that the header extends itself out of bounds, messing even with the sidebar as it's shown in the image:
What it's intended to happen, is making the selectInput look like the Facebook search bar, which means centered without affecting the header and styled with a magnifying glass icon if it's possible. Just like this:
Image: Actual output / Intended output
library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
library(shinyWidgets)
MenuProfesor <- function(){
selectInput(inputId = "Search",
label = NULL,
selected = FALSE,
multiple = FALSE,
choices = c('1','2','3','4'))
}
header <- dashboardHeaderPlus(
title = 'Planificación UAI',
enable_rightsidebar = FALSE,
left_menu = tagList( MenuProfesor())
)
ui <- dashboardPage(
header,
dashboardSidebar(),
dashboardBody()
)
server <- function(input, output, session) {
}
shinyApp(ui, server)
Does this work for you?:
library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
library(shinyWidgets)
header <- dashboardHeaderPlus(
title = 'Planificación UAI',
tags$li(class = "dropdown",
tags$li(class = "dropdown", div(searchInput(
inputId = "search",
label = NULL,
placeholder = "Search...",
btnSearch = icon("search"),
btnReset = icon("remove"),
width = "100%"
), style= "width: 25%; margin-left: auto; margin-right: auto; margin-top:-43px; margin-bottom:-10px;"))),
enable_rightsidebar = FALSE,
fixed = TRUE
)
ui <- dashboardPage(
header,
dashboardSidebar(),
dashboardBody()
)
server <- function(input, output, session) {}
shinyApp(ui, server)
Result:
Also you might want to check this related question.

Inserting a pivot table inside a shinyBS popover in R shiny

The given R shiny script creates popoup based on clicking of a button in which the text is displayed.
library(shiny)
library(shinyBS)
CR1_BS<-paste("i. This is line 1",
"ii. This is line 2",
"iii. This is line 3", sep = "<br>")
ui <- fluidPage(
actionButton("CR1_S1", "Button"),
bsPopover(id="CR1_S1",title="x",content=CR1_BS ,"right",options =
list(container = "body")))
server <- function(input, output){}
shinyApp(ui, server)
My requirement is to fit the below rpivotTable in the popup upon clicking of the button.
library(rpivotTable)
rpivotTable(mtcars,rows="gear",cols = c("cyl","carb"),width = "100%",
height = "400px")
Something like this do?
rm(list = ls())
library(shiny)
library(shinyBS)
library(rpivotTable)
shinyApp(
ui =
fluidPage(
sidebarLayout(
sidebarPanel(actionButton("CR1_S1", "Button")),
mainPanel(
bsModal("modalExample", "Your Table", "CR1_S1", size = "large",rpivotTableOutput("test"))
)
)
),
server =
function(input, output, session) {
output$test <- rpivotTable::renderRpivotTable({
rpivotTable(mtcars,rows="gear",cols = c("cyl","carb"),width = "100%", height = "400px")
})
}
)

To enable and disable sidebar toggle button using a action button

I am looking for a code snippet using which, I can enable/disable sidebar toggle button in shinydashboard header.
library(shiny)
library(shinydashboard)
library(shinyjs)
ui <- shinyUI(dashboardPage(
dashboardHeader(),
dashboardSidebar(),
dashboardBody(
useShinyjs()
)
))
server <- shinyServer(function(input, output, session) {
addClass(selector = "body", class = "sidebar-collapse") # Hide Side Bar
})
shinyApp(ui = ui, server = server)
Let me know if anybody can help???
If you use the shinyjs package, you can show or hide the sidebar toggle with a quick line of JavaScript.
library(shiny)
library(shinydashboard)
library(shinyjs)
ui <- shinyUI(dashboardPage(
dashboardHeader(),
dashboardSidebar(),
dashboardBody(
useShinyjs(),
actionButton("hide","Hide toggle"),
actionButton("show","Show toggle")
)
))
server <- shinyServer(function(input, output, session) {
observeEvent(input$hide,{
shinyjs::runjs("document.getElementsByClassName('sidebar-toggle')[0].style.visibility = 'hidden';")
})
observeEvent(input$show,{
shinyjs::runjs("document.getElementsByClassName('sidebar-toggle')[0].style.visibility = 'visible';")
})
})
shinyApp(ui = ui, server = server)
The JavaScript itself just refers to the first element with class sidebar-toggle (i.e. the menu button), and toggles the visibility depending on which button the user presses.
I have found a solution to this...If someone is stuck with same problem, can refer to below solution:
library(shiny)
library(shinydashboard)
library(shinyjs)
ui <- shinyUI(dashboardPage(
dashboardHeader(),
dashboardSidebar( tags$head(
tags$script(
HTML(#code for hiding sidebar tabs
"Shiny.addCustomMessageHandler('manipulateMenuItem1', function(message)
{
var aNodeList = document.getElementsByTagName('a');
for (var i = 0; i < aNodeList.length; i++)
{
if(aNodeList[i].getAttribute('data-toggle') == message.toggle && aNodeList[i].getAttribute('role') == message.role)
{
if(message.action == 'hide')
{
aNodeList[i].setAttribute('style', 'display: none;');
}
else
{
aNodeList[i].setAttribute('style', 'display: block;');
};
};
}
});"
)
)
)
),
dashboardBody(
useShinyjs(),
actionButton("h1","Hide toggle"),
actionButton("h2","Show toggle")
)
))
server <- shinyServer(function(input, output, session) {
observeEvent(input$h1,{
session$sendCustomMessage(type = "manipulateMenuItem1", message = list(action = "hide",toggle = "offcanvas", role = "button"))
})
observeEvent(input$h2,{
session$sendCustomMessage(type = "manipulateMenuItem1", message = list(action = "show",toggle = "offcanvas", role = "button"))
})
})
shinyApp(ui = ui, server = server)

How to display a modal dialog if users click a link?

I'd like to display a modal dialog if users click a link. Currently, the modal dialog works if users click on the action button.
Any ideas are appreciated. Thanks.
## app.R ##
server <- function(input, output) {
observeEvent(input$act_guide, {
showModal(modalDialog(
h5("Data Guidelines"),
tags$ol(
tags$li("Must have Resp_ID as the first column, occasion_ID as second and dependent variable as the third"),
tags$li("Must have no missing value in any fields")
), easyClose = TRUE, footer = NULL)
)
})
}
ui <- fluidPage(
h4("Data guidelines"),
br(),
actionButton("act_guide", "Click Here!")
)
shinyApp(ui = ui, server = server)
You can use actionLink instead of actionButton to trigger the pop-up as shown below.
library(shiny)
library(shinyBS)
if(interactive()){
shinyApp(
ui <- fluidPage(
h4("Data guidelines"),
br(),
actionLink(inputId = "link1", label = "Click Here!")
),
server = function(input, output, session){
observeEvent(input$link1, {
showModal(modalDialog(
h5("Data Guidelines"),
tags$ol(
tags$li("Must have Resp_ID as the first column, occasion_ID as second and dependent variable as the third"),
tags$li("Must have no missing value in any fields")
), easyClose = TRUE, footer = NULL)
)
})
}
)
}
An alternate way is to use bsModal inside ui.R to trigger the pop-up as shown below:
library(shiny)
library(shinyBS)
if(interactive()){
shinyApp(
ui <- fluidPage(
h4("Data guidelines"),
br(),
actionLink(inputId = "link1", label = "Click Here!"),
bsModal(id = "modal1", title = "Test Modal", trigger = "link1",
h5("Data Guidelines"),
tags$ol(
tags$li("Must have Resp_ID as the first column, occasion_ID as second and dependent variable as the third"),
tags$li("Must have no missing value in any fields")
), easyClose = TRUE, footer = NULL)
),
server = function(input, output, session){
}
)
}