How to implement a dynamic number of slides using shinydashboardPlus' carousel? - r

I wish to use shinydashboardPlus' carousel to display a number of charts. The number of these charts can vary on a daily basis from one to ten.
A cron job runs the R script daily.
Here is a working example with a fixed number of slides, three.
library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
chart_names <- c( "http://placehold.it/900x500/39CCCC/ffffff&text=Slide+1",
"http://placehold.it/900x500/39CCCC/ffffff&text=Slide+2",
"http://placehold.it/900x500/39CCCC/ffffff&text=Slide+3")
ui <- dashboardPagePlus(
header = dashboardHeaderPlus(disable = TRUE ),
sidebar = dashboardSidebar(width = 0 ),
body = dashboardBody(
carousel(indicators = TRUE,
id = "mycarousel",
carouselItem(
tags$img(src = chart_names[1])
),
carouselItem(
tags$img(src = chart_names[2])
),
carouselItem(
tags$img(src = chart_names[3])
)
)
)
)
server <- function(input, output, session) {}
shinyApp(ui, server)
Is this an example of where do.call could be used?
constructs and executes a function call from a name or a function and a list of arguments to be passed to it.
This attempt:
do.call(carousel, as.list(c(id = "mycarousel", "carouselItem(tag$img(src = chart_names[1])")))
results in this error:
Error: $ operator is invalid for atomic vectors
How do I programmatically add a previously unknown number of slides to a shinydashboardPlus carousel?

The answer was in the doc with the .list parameter ?carousel
library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
nb_items = 5
items = Map(function(i) {carouselItem(
tags$img(src = paste0("http://placehold.it/900x500/39CCCC/ffffff&text=Slide+", i))
)}, 1:5)
ui <- dashboardPagePlus(
header = dashboardHeaderPlus(disable = TRUE ),
sidebar = dashboardSidebar(width = 0 ),
body = dashboardBody(
carousel(indicators = TRUE,
id = "mycarousel",
.list = items
)
)
)
server <- function(input, output, session) {}
shinyApp(ui, server)

Related

How to apply JS/ jQuery within the cell ids of a DT?

I would like to apply JS/Jquery within the cell ids of a DT.
I used .css() as an example, but I have other plans, so I asked the question. My intention is not to color the words, but to use other functions.
My code:
library(shiny)
library(shinydashboard)
library(DT)
header <- dashboardHeader(title = "DT")
sidebar <- dashboardSidebar(sidebarMenu(menuItem(text = "mydatatable", tabName = "dt1")))
body <- dashboardBody(
HTML(
"<head>
<script>
$(function() {
$('#stackid, #dtid').mouseover(function() {
$(this).css('color','red');
});
$('#stackid, #dtid').mouseout(function() {
$(this).css('color','#333333');
});
});
</script>
</head>"
),
tabItems(
tabItem(
tabName = "dt1",
fluidPage(
column(
width = 12,
HTML("<strong id='dtid' style='font-size:50px;'>DATATABLE</strong>"),
DTOutput(outputId = "outdt1")
)
)
)
)
)
ui <- dashboardPage(header, sidebar, body)
server <- function(input, output, session) {
df_1 <- data.frame(
x = c("<span id='stackid'>Stack</span>", "Over", "Flow"),
y = 1:3,
z = LETTERS[1:3]
)
output$outdt1 <- DT::renderDataTable({
datatable(
data = df_1,
escape = FALSE
)
})
}
shinyApp(ui, server)
I tried using JS/ jQuery inside tags$div() on server, but that didn't work either.
See that the effect is applied to dtid, as expected. But, my intention is to apply the effect within the id of the DT.

Datatables are not in the same level after hiding column names from one of them

In the shiny app below after hiding the column names from the 1st table they are not in the same level with the 2nd. How can I bring them back to the same level by bringing one up or the other lower?
library(shiny)
library(shinydashboard)
library(DT)
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(
),
dashboardBody(
actionButton("act","Submit"),
tags$hr(),
splitLayout(
#1st table from the left.This comes from the DT package DTOutput calls the table and table is the unique id which we use in server part to activate it
DTOutput("table", width = "100%"),
#The second table with unique id table2
DTOutput("table2", width = "100%"),
#here I set the width of each one
cellWidths = c("285px",
"285px"
),
#and the right gap margin
)
)
)
server <- function(input, output, session) {
output$table<-renderDataTable(
{
datatable(head(iris),
options = list(
headerCallback = JS(
"function(thead, data, start, end, display){",
" $(thead).remove();",
"}"),
dom = 't'
)
)
}
)
output$table2<-renderDataTable(
{
datatable(head(iris),
options = list(
dom = 't'
)
)
}
)
}
shinyApp(ui, server)

shiny: better way to create tables in loop across tab panels

I have to create a Shiny/ShinyDashboard app which basically creates a bunch of tables for various teams. Users will select their team from the sidebar and then they will have several tab panels to choose from depending on the data. See here:
Now the requirement is that I have to split the data for each tab panel into distinct datatables and -because of the data- I have to generate this dynamically.
I came up with the following code (reprex down here) but since I'm quite new to Shiny, I wondered if:
I could split UI and data code even more
there is frankly a better way to do this
library(shiny)
library(shinydashboard)
library(datasets)
library(dplyr)
library(DT)
cars <- mtcars
irises <- iris
cars$team <- sample(c("Team1", "Team2"), nrow(cars), replace = TRUE)
irises$team <-
sample(c("Team1", "Team2"), nrow(irises), replace = TRUE)
# UI
ui <- dashboardPage(
dashboardHeader(title = "Teams"),
dashboardSidebar(sidebarMenu(
menuItem("Team 1",
tabName = "tab_team1",
icon = icon("dashboard")),
menuItem("Team 2",
tabName = "tab_team2",
icon = icon("dashboard"))
)),
dashboardBody(tabItems(
tabItem(tabName = "tab_team1",
fluidRow(
tabBox(
title = "",
width = "100%",
tabPanel(title = "A",
uiOutput("Team1_content_A")),
tabPanel(title = "B",
uiOutput("Team1_content_B"))
)
)),
tabItem(tabName = "tab_team2",
fluidRow(
tabBox(
title = "",
width = "100%",
tabPanel(title = "A",
uiOutput("Team2_content_A")),
tabPanel(title = "B",
uiOutput("Team2_content_B"))
)
))
))
)
server <- function(input, output, session) {
lapply(1:2, function(i) {
t <- paste0("Team", i)
table <- cars %>%
filter(team == t)
output[[paste0(t, "_content_A")]] <- renderUI({
lapply(sort(unique(table$gear)), function(i) {
id <- paste0(t, "_content_A_", i)
output[[id]] <-
DT::renderDataTable(datatable(table[table$gear == i, ]))
fluidRow(
box(
width = "100%",
title = paste0("Gears: ", i),
status = "info",
solidHeader = TRUE,
collapsible = TRUE,
DT::dataTableOutput(id)
)
)
})
})
table2 <- irises %>%
filter(team == t)
output[[paste0(t, "_content_B")]] <- renderUI({
lapply(sort(unique(table2$Species)), function(i) {
id <- paste0(t, "_content_B_", i)
output[[id]] <-
DT::renderDataTable(datatable(table2[table2$Species == i, ]))
fluidRow(
box(
width = "100%",
title = paste0("Species: ", i),
status = "info",
solidHeader = TRUE,
collapsible = TRUE,
DT::dataTableOutput(id)
)
)
})
})
})
}
shinyApp(ui, server)
Echo to #Limey, I would also suggest to use shiny modules https://mastering-shiny.org/scaling-modules.html. There are two reasons.
Reduce unnecessary computation. Currently the computation is run for all the four panels (team1_tabA, team1_tabB, team2_tabA, team2_tabB) at the same time. Ideally, as you add more features or data in the future, you would want to only run the necessary computation when certain action is performed. (i.e. when user click team1_tabA, only the required tables is calculated, no need to calculate tables for other tabs.). Modules can help achieve it.
More flexible control over UI and Server. Currently your app has the same server function and outputs for all the four panels, it works for now. But if in the future you want the four panels to have different layout and outputs, the current coding style might prompt you to write more complex and repeated code. And modules can help you get rid of the repeat and help with more flexible control over the UI and server.
Here is a modularized version of your shiny app. I encountered some issues with using namespace (NS(id)) in the dynamic UI (renderUI), and thanks to the feedback from #YBS Why the shiny dynamic UI + modules does not give the desired output?, the problem is solved, and the modularized shiny is able to run.
## module UI
tab_ui <- function(id) {
ns <- NS(id) ## namespace function
uiOutput(ns("content"))
}
## module Server
tab_server <- function(id, data, Team, var) {
moduleServer(id, function(input, output, session) {
ns <- session$ns ## call namespace in the server
table <- reactive({
data %>% filter(team == Team)
})
output$content <- renderUI({
lapply(sort(unique(table()[[var]])), function(i) {
idd <- paste0("content_", i)
output[[idd]] <-
DT::renderDataTable(datatable(table()[table()[[var]] == i, ]))
fluidRow(
box(
width = "100%",
title = paste0(var, " ", i),
status = "info",
solidHeader = TRUE,
collapsible = TRUE,
DT::dataTableOutput(ns(idd)) ## !!! need to use namespace
)
)
})
})
})
}
## library
library(shiny)
library(shinydashboard)
library(datasets)
library(dplyr)
library(DT)
## data
cars <- mtcars
irises <- iris
cars$team <- sample(c("Team1", "Team2"), nrow(cars), replace = TRUE)
irises$team <-
sample(c("Team1", "Team2"), nrow(irises), replace = TRUE)
## UI
ui <- dashboardPage(
dashboardHeader(title = "Teams"),
dashboardSidebar(sidebarMenu(
menuItem("Team 1",
tabName = "tab_team1"
),
menuItem("Team 2",
tabName = "tab_team2"
)
)),
dashboardBody(tabItems(
tabItem(
tabName = "tab_team1",
fluidRow(
tabBox(
title = "",
width = "100%",
tabPanel(
title = "A",
tab_ui("team1_tabA") ## module ui
),
tabPanel(
title = "B",
tab_ui("team1_tabB") ## module ui
)
)
)
),
tabItem(
tabName = "tab_team2",
fluidRow(
tabBox(
title = "",
width = "100%",
tabPanel(
title = "A",
tab_ui("team2_tabA") ## module ui
),
tabPanel(
title = "B",
tab_ui("team2_tabB") ## module ui
)
)
)
)
))
)
## server
server <- function(input, output, session) {
# module server
tab_server("team1_tabA", data = cars, Team = "Team1", var = "gear")
tab_server("team1_tabB", data = irises, Team = "Team1", var = "Species")
tab_server("team2_tabA", data = cars, Team = "Team2", var = "gear")
tab_server("team2_tabB", data = irises, Team = "Team2", var = "Species")
}
shinyApp(ui, server)

Shiny.i18n not translate the modal dialoge rendered within module

I want to translate parts of my UI in a modularized shiny app. As I summarized my simplified code,
in the first module I have no problem with i18n as it is enters to the module 1 with argument i18n and
translation works well in registerUI(based on recommendation here). But my problem is with the UI of module 2 (M2UI) which this function
itself called within the server of module 1 (register) to return a modal dialogue. But i18n not detected and translation not works on displayed new modal. Any suggestions why this happens? thanks in advance...
I edited my example and it is now completely reproducible. Translation csv files are available here. Just copy them in "translations" forlder. And, the modules should be copied to "modules" folder.
## CSV translation files are available at : https://github.com/Appsilon/shiny.i18n/tree/master/examples/data
# Copy "translation_it.csv" and "translation_pl.csv" files to "translations" folder
###### make modules and copy them into folder "modules"
source("modules/register.R")
source("modules/M2.R")
#####
library(shiny)
library(shiny.i18n)
library(shinydashboard)
i18n <- Translator$new(translation_csvs_path = "translations")
i18n$set_translation_language("en")
shiny.i18n::usei18n(i18n)
############################ UI
header <- dashboardHeader(title = i18n$t('Hello Shiny!'), titleWidth = 400 ,
tags$li( fluidRow(
shiny.i18n::usei18n(i18n),
div(style="display: inline-block;vertical-align:top; font-size: 10px; height=30px;width: 150px;",selectInput(
inputId='selected_language',
label=i18n$t('Change language'),
choices = i18n$get_languages(),
selected = i18n$get_key_translation()
))
),
class = "dropdown")
)
# Sidebar Menu ------------------------------------------------------------
sidebar <- dashboardSidebar(width = 220,
sidebarMenu(
menuItem( i18n$t("Hello Shiny!"), tabName = "diary", icon = icon("align-justify")),
menuItem("Help", tabName = "help", icon = icon("table")),
#menuItem("Data analysis", tabName = "descriptive", icon = icon("chart-bar")),
menuItem("About", tabName = "about", icon = icon("info-circle"))
)
)
body <- dashboardBody(
tabItems(
tabItem("diary",
# includeMarkdown("Introduction.Rmd"),
# includeMarkdown("Contact.Rmd")
titlePanel(i18n$t("Hello Shiny!")),
sidebarLayout(
sidebarPanel(
sliderInput("bins",
i18n$t("Number of bins:"),
min = 1,
max = 50,
value = 30)
),
mainPanel(
plotOutput("distPlot"),
actionButton("test","test"),
p(i18n$t("This is description of the plot."))
)
),
tags$style(type = "text/css", ".recalculating {opacity: 1.0;}"), # Prevents gray screen during Sys.sleep()
),
tabItem("help",
),
tabItem("about",
)
)
)
ui <- dashboardPage(title = 'Coronavirus', header, sidebar, body, skin='blue')
#################################### SERVER
server <- function(input, output,session) {
observeEvent(input$selected_language, {
update_lang(session, input$selected_language)
})
shiny::observeEvent(input$test, {
registerUI(id = "REG",reg_title=i18n$t("Hello Shiny!"),i18n=i18n ) #This ID should be mached with ID in server
})
callModule(register,id = "REG", title= i18n$t("Hello Shiny!"), i18n=i18n )
output$distPlot <- renderPlot({
x <- faithful[, 2]
bins <- seq(min(x), max(x), length.out = input$bins + 1)
hist(x, breaks = bins,
col = "darkgray", border = "white",
main = i18n$t("Histogram of x"), ylab = i18n$t("Frequency"))
})
}
shinyApp(ui = ui, server = server)
registerUI <- function(id, reg_title=NULL ,i18n) {
ns <- shiny::NS(id)
shiny.i18n::usei18n(i18n)
showModal(tags$div( modalDialog(title = "" ,size="s",
shiny::div(id =ns("regpanel"),
shiny::wellPanel(
shiny::tags$h2(reg_title, class = "text-center", style = "padding-top: 0;"),
shinyjs::disabled(shiny::textInput(ns("user_name1"), value= "", shiny::tagList(shiny::icon("user"), "suggested user name"))) ,#
shiny::actionButton(ns("regSubmit"), i18n$t("Submit") , class = "btn-primary", style = "color: white;")
)
)
),
easyClose = TRUE, footer = NULL ))
}
###### Module 1
register <- function(input, output, session ,title,i18n) {
ns <- session$ns
shiny::observeEvent(input$regSubmit, {
shiny.i18n::usei18n(i18n)
removeModal()
M2UI(id = ns("M2") ,reg_title=i18n$t("Hello Shiny!" ),i18n=i18n )
})
callModule(M2,id = "M2" , title= i18n$t("Hello Shiny!"),i18n=i18n)
}
###### Module 2
M2UI <- function(id, reg_title=NULL,i18n ) {
ns <- shiny::NS(id)
shiny.i18n::usei18n(i18n)
showModal(modalDialog(title = reg_title ,size="s",
shiny::wellPanel(
shiny::actionButton(ns("Finish"), i18n$t("Hello Shiny!" ) )
)
, easyClose = TRUE, footer = NULL ) )
}
M2 <- function(input, output, session ,title,i18n) {
ns <- session$ns
shiny::observeEvent(input$Finish, {
removeModal()
})
}
Did you try the latest dev version? You have to update it through the dev package. I am pretty sure it was fixed there. The problem regarded a missing callback through shiny session.
Your exampe works on my setup.

Avoid overlapping text in sliderTextInput

I am using sliderTextInput from the shinyWidgets package. I am having trouble making the labels readable.
To begin with, they are too small, which I have fixed using css. However, now the labels overlap so it is hard to read them.
I would like to be able to do one or both of the following:
Angle the text at 45 or 90 degrees so labels don't overlap.
Reduce the number of labels so there is more space between them. I tried doing this in the choices = argument but that then stops those options from being selected. I think this might be to do with this relating to text rather than numbers, so that might make this impossible.
I have tried using sliderInput instead, but that presents different issues. I almost got it working using this answer, but the additional problem is that I have the input server side, fed in as a uiOutput, which is something I can't change because it's important for a different element. This approach doesn't work with the linked solution - I end up with nice enough labels but the breaks are daily rather than monthly.
Here is a pared down example:
Using sliderTextInput (labels overlapping)
library(shinydashboard)
library(shinyWidgets)
library(shiny)
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(),
dashboardBody(
tags$head(tags$style(type = "text/css", ".irs-grid-text {font-size: 12pt !important;")),
fluidRow(
box(uiOutput("month_selection"))
)
)
)
server <- function(input, output) {
output$month_selection <- renderUI({
sliderTextInput(
inputId = "month_select",
label = "",
grid = TRUE,
force_edges = TRUE,
choices = seq(from = as.Date("2017-01-01"), to = as.Date("2019-12-31"),by = 30)
)
})
}
shinyApp(ui, server)
Using sliderInput (doesn't run)
library(shinydashboard)
library(shinyWidgets)
library(shiny)
monthStart <- function(x) {
x <- as.POSIXlt(x)
x$mday <- 1
as.Date(x)
}
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(),
dashboardBody(
tags$head(tags$style(type = "text/css", ".irs-grid-text {font-size: 12pt !important;")),
fluidRow(
box(uiOutput("month_selection"))
)
)
)
server <- function(input, output) {
output$month_selection <- renderUI({
sliderInput(
inputId = "month_select",
label = "",
min = as.Date("2017-01-01"),
max = as.Date("2019-12-31"),
value = as.Date("2019-12-31"),
timeFormat = "%b %Y",
animate = TRUE
)
})
sliderMonth <- reactiveValues()
observe({
sliderMonth$Month <- as.character(monthStart(input$month_select))
})
}
shinyApp(ui, server)
> Warning: Error in as.POSIXlt.default: do not know how to convert 'x' to class “POSIXlt”
Solution (credits go to Victor Perrier) taken from the shinyWidgets issue created by the asker.
Text can be roteted with nothing more than CSS. The class .irs-grid-text identifies the labels of the sliderTextInput widget. With transform the text can be rotated so that it does not overlap.
library(shinydashboard)
library(shinyWidgets)
library(shiny)
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(),
dashboardBody(
tags$head(tags$style(
type = "text/css",
".irs-grid-text {font-size: 12pt !important; transform: rotate(-90deg) translate(-30px);"
)),
fluidRow(
box(uiOutput("month_selection"), height = "200px")
)
)
)
server <- function(input, output) {
output$month_selection <- renderUI({
sliderTextInput(
inputId = "month_select",
label = "",
grid = TRUE,
force_edges = TRUE,
choices = seq(from = as.Date("2017-01-01"), to = as.Date("2019-12-31"), by = 30)
)
})
}
shinyApp(ui, server)

Resources