Display different image as title of shiny dashboard based on different tabpanels - r

Is it possible to display different image as title of the shiny dashboard based on the tabPanel() that you use. I want different image for the tab 'Front' and different for the tab 'Data'.
# app.R ##
library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
library(DT)
library(shinyWidgets)
library(shinyjs)
dbHeader <- dashboardHeaderPlus(
enable_rightsidebar = TRUE,
rightSidebarIcon = "gears",
fixed = T,
title = tags$a(href='http://mycompanyishere.com',
tags$img(src='logo.png'))
)
ui <- dashboardPagePlus(
dbHeader,
dashboardSidebar(),
dashboardBody(
useShinyjs(),
tags$hr(),
tabsetPanel(
id ="tabA",
type = "tabs",
tabPanel("Front",icon = icon("accusoft")),
tabPanel("Data", icon = icon("table")
)
)
),
rightsidebar = rightSidebar()
)
server <- function(input, output) {
observe({
if (input$tabA == "Front") {
hide(selector = "body > div.wrapper > header > nav > div:nth-child(4) > ul")
addClass(selector = "body", class = "sidebar-collapse")
removeClass(selector = "body", class = "control-sidebar-open")
} else {
show(selector = "body > div.wrapper > header > nav > div:nth-child(4) > ul")
removeClass(selector = "body", class = "sidebar-collapse")
addClass(selector = "body", class = "control-sidebar-open")
}
})
}
shinyApp(ui = ui, server = server)

So one way to achieve this is by using shinyjs and modify CSS in Shiny reactive output.
In order to do so, I've first "borrowed" this function
# This part is from the link below and will be used to modify CSS in reactive part
# https://stackoverflow.com/questions/31425841/css-for-each-page-in-r-shiny
modifyStyle <- function(selector, ...) {
values <- as.list(substitute(list(...)))[-1L]
parameters <- names(values)
args <- Map(function(p, v) paste0("'", p,"': '", v,"'"), parameters, values)
jsc <- paste0("$('",selector,"').css({", paste(args, collapse = ", "),"});")
shinyjs::runjs(code = jsc)
}
And then using two functions below (inside observe() function in server side part) I've modified CSS in the reactive output using CSS code:
# Show one picture.
# NOTE:if using your own picture modify the path inside url().. See the code below.
modifyStyle(".logo img ", "content" = "url(https://dotunroy.files.wordpress.com/2015/05/happy-people.jpg)")
# Show another picture
modifyStyle(".logo img ", "content" = "url(test.png)")
Note that, in order for me to show that the code works, first I needed to have some pictures. So I've saved one picture inside my www directory (the picture is called test.png (see the above code)). And another is available from this link https://dotunroy.files.wordpress.com/2015/05/happy-people.jpg.
So the whole code looks like this (again, in order for you to display images, replace the path of my images inside url() with your own)
library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
library(DT)
library(shinyWidgets)
library(shinyjs)
# Modify the CSS style of a given selector
# This part is from
# https://stackoverflow.com/questions/31425841/css-for-each-page-in-r-shiny
modifyStyle <- function(selector, ...) {
values <- as.list(substitute(list(...)))[-1L]
parameters <- names(values)
args <- Map(function(p, v) paste0("'", p,"': '", v,"'"), parameters, values)
jsc <- paste0("$('",selector,"').css({", paste(args, collapse = ", "),"});")
shinyjs::runjs(code = jsc)
}
dbHeader <- dashboardHeaderPlus(
enable_rightsidebar = TRUE,
rightSidebarIcon = "gears",
fixed = T,
title = tags$a(href='http://mycompanyishere.com',
# Modify the width and the height of the image as you like
tags$img(src='test.png', width ="50%", height = "70%"))
)
ui <- dashboardPagePlus(
dbHeader,
dashboardSidebar(),
dashboardBody(
useShinyjs(),
tags$hr(),
tabsetPanel(
id ="tabA",
type = "tabs",
tabPanel("Front",icon = icon("accusoft")),
tabPanel("Data", icon = icon("table")
)
)
),
rightsidebar = rightSidebar()
)
server <- function(input, output) {
observe({
if (input$tabA == "Front") {
hide(selector = "body > div.wrapper > header > nav > div:nth-child(4) > ul")
addClass(selector = "body", class = "sidebar-collapse")
removeClass(selector = "body", class = "control-sidebar-open")
modifyStyle(".logo img ", "content" = "url(https://dotunroy.files.wordpress.com/2015/05/happy-people.jpg)")
# shinyjs::toggleClass(selector = "head", class = "logo",
# condition = (input$tabA == "Front"))
} else {
show(selector = "body > div.wrapper > header > nav > div:nth-child(4) > ul")
removeClass(selector = "body", class = "sidebar-collapse")
addClass(selector = "body", class = "control-sidebar-open")
modifyStyle(".logo img ", "content" = "url(test.png)")
}
})
}
shinyApp(ui = ui, server = server)
And the output is:
UPDATE
Note that if you want to modify the width and the height of the image, just add these two parameters in CSS, i.e.
# Add a custom number of the percentage to width and height parameters
modifyStyle(".logo img ", "content" =
"url(https://dotunroy.files.wordpress.com/2015/05/happy-people.jpg)",
"width" = "100%", "height" = "100%")

Related

shinydashboardPlus/dashboardUser. Collapse User box

I adapted the code from here.
This is my code:
library(shiny)
library(shinyWidgets)
library(shinydashboard)
library(shinydashboardPlus)
shinyApp(
ui = dashboardPage(
header = dashboardHeader(userOutput("user")),
sidebar = dashboardSidebar(),
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("btn1","Click")
)
)
})
observeEvent(input$btn1, { #Not triggering
output$body <- renderUI({print("Clicked")})
})
}
)
What I want is the user box (what is in red) not to remain active (I mean, to make it to disappear) when I click on the button.
Any suggestion?
One workaround to do this is to use shinyjs::hide() and shinyjs::show(). Targeting the action button inside the user is easy. The tricky part is to get the dashboard user to show up again when the dropdown menu is clicked. For this we can rewrite the dashboardUser() function and add an action link with id instead of the "normal" link. See comments in code:
library(shiny)
library(shinyWidgets)
library(shinydashboard)
library(shinydashboardPlus)
library(shinyjs)
dashboardUser
myDashboardUser <- function (..., name = NULL, image = NULL, title = NULL, subtitle = NULL,
footer = NULL)
{
if (!is.null(title)) {
line_1 <- paste0(name, " - ", title)
}
else {
line_1 <- name
}
if (!is.null(subtitle)) {
user_text <- shiny::tags$p(line_1, shiny::tags$small(subtitle))
user_header_height <- NULL
}
else {
user_text <- shiny::tags$p(line_1)
user_header_height <- shiny::tags$script(
shiny::HTML("$(\".user-header\").css(\"height\", \"145px\")")
)
}
userTag <- shiny::tagList(
shiny::tags$head(
shiny::tags$script("$(function() {\n
$('.dashboard-user').on('click', function(e){\n
e.stopPropagation();\n
});\n
});\n
")),
# we need to add an id and the class `action-button` to this link
shiny::tags$a(id = "user_dropdown",
href = "#",
class = "dropdown-toggle action-button",
`data-toggle` = "dropdown",
shiny::tags$img(src = image,
class = "user-image",
alt = "User Image"),
shiny::tags$span(class = "hidden-xs",
name)
),
shiny::tags$ul(class = "dropdown-menu dashboard-user",
shiny::tags$li(class = "user-header",
if (!is.null(user_header_height)) user_header_height,
shiny::tags$img(src = image,
class = "img-circle",
alt = "User Image"),
user_text),
if (length(list(...)) > 0)
shiny::tags$li(class = "user-body", ...),
if (!is.null(footer))
shiny::tags$li(class = "user-footer", footer)
)
)
userTag
}
}
shinyApp(
ui = dashboardPage(
header = dashboardHeader(userOutput("user")),
sidebar = dashboardSidebar(),
body = dashboardBody(
# make ShinyJs available
useShinyjs(),
uiOutput("body")
),
title = "DashboardPage"
),
server = function(input, output) {
output$user <- renderUser({
myDashboardUser(
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("btn1","Click")
)
)
})
# use shinyjs::hide on button and also remove class open from user menue
observeEvent(input$btn1, {
hide(selector = ".dropdown-menu.dashboard-user")
removeClass(id = "user", class = "open")
})
# use shinyjs::show on new link
observeEvent(input$user_dropdown, {
show(selector = ".dropdown-menu.dashboard-user")
})
}
)
As I realized that by clicking anywhere, the user box disappear, I have just used a piece of javascript code to simulate clicking over "body" element:
jscode<-
'var evt = document.createEvent("MouseEvents");
evt.initMouseEvent("click", true, true, window,
0, 0, 0, 0, 0, false, false, false, false, 0, null);
var cb = document.getElementById("body");
var simulateClick = cb.dispatchEvent(evt);'
My final version:
library(shiny)
library(shinyWidgets)
library(shinydashboard)
library(shinydashboardPlus)
shinyApp(
ui = dashboardPage(
header = dashboardHeader(userOutput("user")),
sidebar = dashboardSidebar(),
body = dashboardBody(useShinyjs(), 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("btn1","Click")
)
)
})
observeEvent(input$btn1, { #Not triggering
output$body <- renderUI({print("Clicked")})
jscode<-
'var evt = document.createEvent("MouseEvents");
evt.initMouseEvent("click", true, true, window,
0, 0, 0, 0, 0, false, false, false, false, 0, null);
var cb = document.getElementById("body");
var simulateClick = cb.dispatchEvent(evt)';
runjs(jscode)
})
}
)

In Shiny/R why my lis with purrr::map()t is not working in module?

This is my module file:
library(semantic.dashboard)
example_UI <- function(id) {
ns <- NS(id)
tagList(
# 1:5 %>% map(~ list(menu = list(paste0(.x)),
# content =list(paste0(.x))))
list(menu = list('B'),
content = list('B')),
list(menu = list('C'),
content = list('C')),
list(menu = list('A'),
content = list('A')),
list(menu = list('A'),
content = list('A')),
list(menu = list('A'),
content = list('A'))
)
}
example_Server <- function(id) {
moduleServer(
id,
function(input, output, session) {
}
)
}
When I run the code without using the purrr::map() function the panels labels are created well.
But when I try to create the panel labels with purrr::map() function it is not created
Bellow Is my shiny App
ui <- dashboardPage(
dashboardHeader(color = "blue"),
dashboardSidebar(side = "left", size = "thin", color = "teal",
sidebarMenu(
menuItem(tabName = "tab1", "Tab 1"))),
dashboardBody(tabItems(
tabItem(tabName = "tab1",
tabBox(
collapsible = FALSE,
title = "Pull",
color = "black",
width = 16,
tabs = example_UI('question')
)
)))
)
server <- function(input, output) {
}
shinyApp(ui, server)
What am I doing wrong?
Your map() function returns a list() of length 5. It does not return five separate lists like you are using when calling tagList() without the map. In order to expand that single list into different paraemters, you can use !!!. For example
tagList(
!!!(1:5 %>% map(~ list(menu = list(paste0(.x)),
content =list(paste0(.x))))
))

too many scrollbars Shiny rhandsontable

I'm using rhandsontable with dqshiny to display a large table in an app.
I put some code below. In this code, there are maybe 4 scroll-bars. 2 in the table and 2 on the outer page.
I only want 2 scroll-bars, can someone help? I have been messing with the CSS for hours to try and get the filters to show but also have scrollbars.
library(shiny)
library(rhandsontable)
library(shinythemes)
library(shinyjs)
library(dqshiny)
df = data.frame(hello1 = seq(100), stringsAsFactors = FALSE)
df2 = df
for(i in 1:30){
df = cbind(df, df2)
}
names(df) = paste0(names(df), seq(20))
shinyApp(
ui = fluidPage(
theme = shinytheme("cerulean"),
navbarPage("sample Rhandsontable Page", selected = "tab01",
id = "navbar",
position = "fixed-top",
tags$style(type="text/css", "body {padding-top: 70px;}"),
tags$head(
tags$style(
#"body {overflow-y: scroll;}"
"body {overflow: visible;}"
)
),
tags$head(
tags$style(type = "text/css", ".container-fluid {padding-left:0px;
padding-right:0px; margin-right:0px; margin-left:0px;}")
),
useShinyjs(),
tabPanel("tab01",
tags$head(tags$style("#randomTable-filters {overflow:visible !important;}")),
tags$style('#randomTableTags * { white-space: nowrap}'),
tags$style('.shiny-html-output * {width = 100% }'),
div(id='randomTableTags', style="overflow: visible;",
dq_handsontable_output("randomTable")
)
)
)
),
server = function(input, output, session) {
dq_render_handsontable(
"randomTable",
df,
filters = "T",
page_size = c(500L, 1000L),
width_align = TRUE,
horizontal_scroll = FALSE,
table_param = list(highlightRow = TRUE, autoColumnSize = TRUE),
)
}
)
here is an image of the output:
If you have trouble with dqshiny, you can run:
library(devtools)
devtools::install_github('daqana/dqshiny', upgrade = 'always')
Solution 1: You can add this in your css file. It should be applicable to all handsontable in your app.
.handsontable {
overflow: hidden;
}
Solution 2: You can use stretcH in your code to avoid extra scroll bars.
rhandsontable(data,stretchH = "all",stretchV = "all")

Automatic scrolling based on recent output in Shiny

This question builds on this previous question R Shiny: keep old output.
I would like to view the output at the top of the page. How to automatically scroll the output to the top of the page?
library(shiny)
library(broom)
library(dplyr)
library(shinyjs)
library(shinydashboard)
header <- dashboardHeader(title = "My Dashboard")
sidebar <- dashboardSidebar(
sidebarMenu(
checkboxGroupInput(inputId = "indep",
label = "Independent Variables",
choices = names(mtcars)[-1],
selected = NULL),
actionButton(inputId = "fit_model",
label = "Fit Model"),
numericInput(inputId = "model_to_show",
label = "Show N most recent models",
value = 20)
)
)
body <- dashboardBody(
includeScript("www/scrolldown.js"),
tags$head(includeCSS('www/style.css')),
htmlOutput("model_record")
)
ui <- dashboardPage(header, sidebar, body)
server <-
shinyServer(function(input, output, session){
Model <- reactiveValues(
Record = list()
)
observeEvent(
input[["fit_model"]],
{
fit <-
lm(mpg ~ .,
data = mtcars[c("mpg", input[["indep"]])])
#Model$Record <- c(Model$Record, list(fit))
#Last result up
Model$Record <- c(list(fit),Model$Record)
}
)
output$model_record <-
renderText({
tail(Model$Record, input[["model_to_show"]]) %>%
lapply(tidy) %>%
lapply(knitr::kable,
format = "html") %>%
lapply(as.character) %>%
unlist() %>%
paste0(collapse = "<br/><br/>")
})
})
shinyApp(ui, server)
style.css file:
.sidebar {
color: #FFF;
position: fixed;
width: 220px;
white-space: nowrap;
overflow: visible;
}
.main-header {
position: fixed;
width:100%;
}
.content {
padding-top: 60px;
}
EDIT:
Javascript added based on Waldi's answer:
scrolldown.js
$(document).on('shiny:value', function(event) {
// Scroll down after model update
if (event.target.id === 'model_record') {
window.scrollTo(0,document.body.scrollHeight);
}
});
View Video Screenshot Gif
As mentionned in the comments, you can set a javascript trigger on model_record tag:
create the js script under www/scrolldown.js :
$(document).on('shiny:value', function(event) {
// Scroll down after model update
if (event.target.id === 'model_record') {
window.scrollTo(0,document.body.scrollHeight);
}
});
include the script in the UI:
library(shiny)
library(broom)
library(dplyr)
library(shinyjs)
library(shinydashboard)
header <- dashboardHeader(title = "My Dashboard")
sidebar <- dashboardSidebar(
sidebarMenu(
checkboxGroupInput(inputId = "indep",
label = "Independent Variables",
choices = names(mtcars)[-1],
selected = NULL),
actionButton(inputId = "fit_model",
label = "Fit Model"),
numericInput(inputId = "model_to_show",
label = "Show N most recent models",
value = 20)
)
)
body <- dashboardBody(
includeScript("www/scrolldown.js"),
tags$head(includeCSS('www/style.css')),
htmlOutput("model_record"),
div(style="height: 90vh;")
)
ui <- dashboardPage(header, sidebar, body)
server <-
shinyServer(function(input, output, session){
Model <- reactiveValues(
Record = list()
)
observeEvent(
input[["fit_model"]],
{
fit <-
lm(mpg ~ .,
data = mtcars[c("mpg", input[["indep"]])])
Model$Record <- c(Model$Record, list(fit))
}
)
output$model_record <-
renderText({
tail(Model$Record, input[["model_to_show"]]) %>%
lapply(tidy) %>%
lapply(knitr::kable,
format = "html") %>%
lapply(as.character) %>%
unlist() %>%
paste0(collapse = "<br/><br/>")
})
})
shinyApp(ui, server)
Now the scrollbar moves down after each model update... but you have to scroll up to find the fit model button : this can be changed by using a fixed sidebar css.
Finally, to show only the last model on top, building on #Tonio Liebrand suggestion, you can add a div with 90% of viewport height so that it automatically adapts to screen size.
Thanks for clarifying concerning my question in the comments. I think now i understand what you are attempting to achieve.
I think one challenge you might face is that the sidebar wont scroll down as well. I am not sure that it is desired.
Potential solution:
You could add a placeholder that ensures that your latest modell output will be on top if you scroll down. It could be just an empty div:
div(style="height: 850px;")
This is more of a draft as we should ensure first that the spec is fully understood. Enhancements would be to scale this div to the size of the users screen.
Reproducible example:
library(shiny)
library(broom)
library(dplyr)
library(shinyjs)
library(shinydashboard)
header <- dashboardHeader(title = "My Dashboard")
js_code <- "$(document).on('shiny:value', function(event) {
// Scroll down after model update
if (event.target.id === 'model_record') {
window.scrollTo(0,document.body.scrollHeight);
}
});"
sidebar <- dashboardSidebar(
sidebarMenu(
checkboxGroupInput(inputId = "indep",
label = "Independent Variables",
choices = names(mtcars)[-1],
selected = NULL),
actionButton(inputId = "fit_model",
label = "Fit Model"),
numericInput(inputId = "model_to_show",
label = "Show N most recent models",
value = 20)
)
)
body <- dashboardBody(
tags$script(js_code),
htmlOutput("model_record"),
div(style="height: 850px;")
)
ui <- dashboardPage(header, sidebar, body)
server <-
shinyServer(function(input, output, session){
Model <- reactiveValues(
Record = list()
)
observeEvent(
input[["fit_model"]],
{
fit <-
lm(mpg ~ .,
data = mtcars[c("mpg", input[["indep"]])])
Model$Record <- c(Model$Record, list(fit))
}
)
output$model_record <-
renderText({
tail(Model$Record, input[["model_to_show"]]) %>%
lapply(tidy) %>%
lapply(knitr::kable,
format = "html") %>%
lapply(as.character) %>%
unlist() %>%
paste0(collapse = "<br/><br/>")
})
})
shinyApp(ui, server)

How to render two uiOutput in order not synchronistically in Shiny?

when input$variable change
uiOutput(1) and uiOutput(2) are rendered at the same time?
Is there any way render step by step not synchronistically?
The following is the steps I want.
1) input variable change
2) uiOutput(1) rendering
3) uiOutput(2) rendering
when input variable change shiny page is not working properly.
but after resizing the page window, the screen appears correctly.
Each time I change the input value, i have to recalibrate the page size.
ui.R
library(shiny)
library(shinydashboard)
sidebar <- dashboardSidebar(
radioButtons(inputId = "sidebar_data_sell",
label = "",
choices = c("Sell-in" = "sell_in", "Sell-out" = "sell_out"),
selected = "sell_out",
inline = TRUE),
uiOutput("summary_sidebar_ui")
)
ui <- dashboardPage(
dashboardHeader(title = h5("Hi")),
sidebar,
uiOutput("dashboard_body")
)
server.R
convertMenuItem <- function(mi, tabName) {
mi$children[[1]]$attribs['data-toggle'] = "tab"
mi$children[[1]]$attribs['data-value'] = tabName
mi
}
out_product_main <- function() {
list(
fluidPage(h5("product")))
}
product_items <- function() {
list(
selectInput("product_product_sell",
"product",
choices = list("product1" = "prd1", "product2" = "prd2"),
selected = c("prd1"))
)
}
in_overview_main <- function() {
list(
fluidPage(h5("overview")))
}
overview_items <- function() {
list(
radioButtons("overview_period_sell",
"period",
choices = c("year","month"),
inline = TRUE,
selected = "month")
)
}
shinyServer(function(input, output) {
output$summary_sidebar_ui <- renderUI({
if (input$sidebar_data_sell == "sell_in")
{
sidebarMenu(id = "summary_item",
convertMenuItem(menuItem("Overview",
tabName = "in_overview",
icon = icon("signal", lib = 'font-awesome'),
overview_items()),
tabName = 'in_overview'))
}
else{
sidebarMenu(id = "p_analysis_item",
convertMenuItem(menuItem("Product",
tabName = "out_product",
icon = icon("product-hunt", lib='font-awesome'),
product_items()),
tabName = 'out_product')
)
}
})
output$dashboard_body <- renderUI({
if (input$sidebar_data_sell == "sell_in") {
dashboardBody(tabItems(tabItem("in_overview", in_overview_main())))
}
else {
dashboardBody(tabItems(tabItem("out_product", out_product_main())))
}
})
})

Resources