Shiny Tab scroller - r

How can I add an arrow which lets me click and go through all my tabs.
I know I can add multiple tabs in one tabbox and click thorugh each tab to see each table.
But is there a way to design the UI such that I can scroll through entire page using arrows and see next tabbox
Want to change above to this
EDIT
added reproducible code that uses modules and allows users to create as many tables based on slider
chartTableBoxUI <- function(id) {
ns <- NS(id)
div(
tags$div(DTOutput(ns("chart"))),
tags$div(DTOutput(ns("table")))
)
}
chartTableBox <- function(input, output, session) {
ns <- session$ns
vals <- reactiveValues()
observeEvent(input$chart_rows_selected,{
vals$sel<- (input$chart_rows_selected)
})
output$chart <- renderDT({
DT::datatable(
mtcars,options = list(
dom='t', pageLength = 5)
)
})
output$table <- renderDT({
DT::datatable(
mtcars[vals$sel, 1:3],options = list(dom='t')
)
})
}
library(shiny)
library(shinydashboard)
library(tidyverse)
library(highcharter)
library(DT)
library(shinyjs)
ui <- fluidPage(
fluidRow(
tags$head(
tags$link(rel="stylesheet", type="text/css",
href="https://cdnjs.cloudflare.com/ajax/libs/slick-carousel/1.9.0/slick-theme.css"),
tags$link(rel="stylesheet", type="text/css",
href="https://cdnjs.cloudflare.com/ajax/libs/slick-carousel/1.9.0/slick.css"),
tags$script(type="text/javascript",
src="https://cdnjs.cloudflare.com/ajax/libs/slick-carousel/1.9.0/slick.js"),
tags$script(HTML(
"$(document).ready(function(){
$('#tables').slick({
arrows: true,
dots:true
});
});")),
tags$style(HTML(
"#tables .slick-prev {
position:absolute;
top:65px;
left:-100px;
}
#tables .slick-next {
position:absolute;
top:95px;
left:-100px;
}
.slick-prev:before, .slick-next:before {
color:red !important;
}
.content {
margin: auto;
padding: 20px;
width: 80%;
}"))
),
sliderInput("dr", "Num of tables:",
min = 0, max = 12,
value = 2),
uiOutput("tabs")
#verbatimTextOutput("dr2")
)
)
server <- function(input, output, session) {
for(i in 1:5)
callModule(chartTableBox,i)
output$tabs <- renderUI({
num_tables<- input$dr
tags$div(class="content",
tags$div(id="tables",
lapply(1:num_tables,chartTableBoxUI)
))
})
}
shinyApp(ui, server)

A solution without tabs, using the slick.js library. I don't know how to have the buttons side-by-side.
library(shiny)
library(DT)
ui <- fluidPage(
tags$head(
tags$link(rel="stylesheet", type="text/css",
href="//cdn.jsdelivr.net/gh/kenwheeler/slick#1.8.1/slick/slick.css"),
tags$script(type="text/javascript",
src="//cdn.jsdelivr.net/gh/kenwheeler/slick#1.8.1/slick/slick.min.js"),
tags$script(HTML(
"$(document).ready(function(){
$('#tables').slick({
// put options here
});
});"))
),
sidebarLayout(
sidebarPanel(
####
),
mainPanel(
tags$div(id="tables",
tags$div(DTOutput("table1")),
tags$div(DTOutput("table2"))
)
)
)
)
server <- function(input, output) {
output$table1 <- renderDT({
datatable(iris)
})
output$table2 <- renderDT({
datatable(mtcars)
})
}
shinyApp(ui = ui, server = server)
EDIT
I've finally managed to get grouped Previous/Next buttons:
library(shiny)
library(DT)
ui <- fluidPage(
tags$head(
tags$link(rel="stylesheet", type="text/css",
href="https://cdnjs.cloudflare.com/ajax/libs/slick-carousel/1.9.0/slick-theme.css"),
tags$link(rel="stylesheet", type="text/css",
href="https://cdnjs.cloudflare.com/ajax/libs/slick-carousel/1.9.0/slick.css"),
tags$script(type="text/javascript",
src="https://cdnjs.cloudflare.com/ajax/libs/slick-carousel/1.9.0/slick.js"),
tags$script(HTML(
"$(document).ready(function(){
$('#tables').slick({
arrows: true,
dots:true
});
});")),
tags$style(HTML(
"#tables .slick-prev {
position:absolute;
top:65px;
left:-100px;
}
#tables .slick-next {
position:absolute;
top:95px;
left:-100px;
}
.slick-prev:before, .slick-next:before {
color:red !important;
}
.content {
margin: auto;
padding: 20px;
width: 80%;
}"))
),
sidebarLayout(
sidebarPanel(
####
),
mainPanel(
tags$div(class="content",
tags$div(id="tables",
tags$div(DTOutput("table1")),
tags$div(DTOutput("table2"))
)
)
)
)
)
server <- function(input, output) {
output$table1 <- renderDT({
datatable(iris)
})
output$table2 <- renderDT({
datatable(mtcars)
})
}
shinyApp(ui = ui, server = server)
EDIT 2
Regarding your Edit, you can remove the tags$script(HTML(.... from tags$head and do:
output$tabs <- renderUI({
num_tables<- input$dr
tagList(
tags$div(class="content",
tags$div(id="tables",
lapply(1:num_tables,chartTableBoxUI)
)),
singleton(tags$script(HTML(
"$(document).ready(function(){
$('#tables').slick({
arrows: true,
dots:true
});
});")))
)
})

Related

R Shiny: Relative size of images with slickR

Using a Shiny app, I would like to implement a slider with slickR to switch from one image to the other.
I managed to implement the slider but I'm having trouble in displaying the images correctly because of their different sizes.
In the following example, the stackexchange logo is way bigger than the stackoverflow logo. When displaying them with slickR(), the bigger logo makes inroads into the first one like this:
I would also like to have the size of the pictures relative to the size of the screen.
Here is a reproducible example of the Shiny app used to generate the above image:
library(shiny)
library(slickR)
# User interface ----
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
),
mainPanel(
slickROutput("slickr", width = "auto")
)
)
)
# Server ----
server <- function(input, output) {
imgs_links <- list(
"https://upload.wikimedia.org/wikipedia/fr/9/95/Stack_Overflow_website_logo.png",
"https://upload.wikimedia.org/wikipedia/commons/6/6f/Stack_Exchange_Logo.png")
output$slickr <- renderSlickR({
photo_list <- lapply(imgs_links, function(x){
tags$div(
tags$img(src = x, width = "10%", height = "10%")
)
})
imgs <- do.call(tagList, photo_list)
slickR(imgs)
})
}
# Run the application ----
shinyApp(ui = ui, server = server)
What would be the correct way to have each image resized according the size of the screen?
I don't manage to get it with the 'slickR' package. Here is a solution which doesn't use this package, it uses the 'slick' JavaScript library. You have to download the library files and put them in the www/slick-1.8.1/slick folder.
library(shiny)
ui <- fluidPage(
tags$head(
tags$link(rel="stylesheet", type="text/css",
href="slick-1.8.1/slick/slick-theme.css"),
tags$link(rel="stylesheet", type="text/css",
href="slick-1.8.1/slick/slick.css"),
tags$script(type="text/javascript",
src="slick-1.8.1/slick/slick.js"),
tags$script(HTML(
"$(document).ready(function(){
$('#images').slick({
arrows: true,
dots:true
});
});")),
tags$style(HTML(
"#images .slick-prev {
position:absolute;
top:65px;
left:-50px;
}
#images .slick-next {
position:absolute;
top:95px;
left:-50px;
}
.slick-prev:before, .slick-next:before {
color:red !important;
font-size: 30px;
}
.content {
margin: auto;
padding: 2px;
width: 90%;
}"))
),
sidebarLayout(
sidebarPanel(
####
),
mainPanel(
tags$div(
class = "content",
tags$div(
id = "images",
tags$img(
src = "https://upload.wikimedia.org/wikipedia/fr/9/95/Stack_Overflow_website_logo.png",
width = "50vw"
),
tags$img(
src = "https://upload.wikimedia.org/wikipedia/commons/6/6f/Stack_Exchange_Logo.png",
width = "50vw"
)
)
)
)
)
)
server <- function(input, output) {
}
# Run the application
shinyApp(ui = ui, server = server)
EDIT: dynamic number of images
library(shiny)
ui <- fluidPage(
tags$head(
tags$link(rel="stylesheet", type="text/css",
href="slick-1.8.1/slick/slick-theme.css"),
tags$link(rel="stylesheet", type="text/css",
href="slick-1.8.1/slick/slick.css"),
tags$script(type="text/javascript",
src="slick-1.8.1/slick/slick.js"),
tags$style(HTML(
"#carousel .slick-prev {
position:absolute;
top:65px;
left:-50px;
}
#carousel .slick-next {
position:absolute;
top:95px;
left:-50px;
}
.slick-prev:before, .slick-next:before {
color:red !important;
font-size: 30px;
}
.content {
margin: auto;
padding: 2px;
width: 90%;
}"))
),
sidebarLayout(
sidebarPanel(
checkboxGroupInput(
"images",
"Select images",
choiceNames = c("Stackoverflow", "Stackexchange", "Asymptote"),
choiceValues = c(
"https://upload.wikimedia.org/wikipedia/fr/9/95/Stack_Overflow_website_logo.png",
"https://upload.wikimedia.org/wikipedia/commons/6/6f/Stack_Exchange_Logo.png",
"https://www.clipartmax.com/png/small/203-2038151_asymptote-vector-graphics-language-wikipedia-rh-en-asymptote.png"
)
)
),
mainPanel(
tags$div(
class = "content",
uiOutput("carousel-ui"),
)
)
)
)
server <- function(input, output) {
output[["carousel-ui"]] <- renderUI({
imgs <- lapply(input[["images"]], function(x){
tags$img(src = x, width = "50vw")
})
imgs_div <- do.call(function(...) div(id = "carousel", ...), imgs)
script <- tags$script(HTML(
"$('#carousel').slick({
arrows: true,
dots:true
});"))
do.call(tagList, list(imgs_div, script))
})
}
# Run the application
shinyApp(ui = ui, server = server)

Display downloadButton() based on certain condtions in a shiny adashboard

I have the shiny dashboard below in which if I give a name except of the default consent.name,then the password makis and press the Get started actionbutton an rmd output is generated. Then the user can press 'Generate report' in order to download this as pdf. Basically what I want to do is to display the 'Generate report' downloadButton() only when the report is created and displayed in the body because otherwise it has no meaning and is confusing. I tried to applied the observeEvent() method which I used for the report creation as well but it does not work and the downloadButton() is always there.
library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
library(shinyjs)
library(knitr)
mytitle <- paste0("Life, Death & Statins")
dbHeader <- dashboardHeaderPlus(
titleWidth = "0px",
tags$li(a(
div(style = "margin-left:-15px;margin-bottom:-83px;margin-top:-15px;padding: 0px 1190px 0px 0px ; width: 290px;",
img(src = 'download.png', height = "125px",width="232px")),
div(style="display: inline;margin-top:-35px; padding: 0px 90px 0px 1250px ;font-size: 58px ;color: black;font-family:Times-New Roman;font-weight: bold; width: 500px;",HTML(mytitle)),
div(style="display: inline;margin-top:25px; padding: 0px 0px 0px 1250px;vertical-align:top; width: 150px;", actionButton("well", "Welcome"))
),
class = "dropdown")
)
shinyApp(
ui = dashboardPagePlus(
header = dbHeader,
sidebar = dashboardSidebar(width = "0px",
sidebarMenu(id = "sidebar", # id important for updateTabItems
menuItem("Welcome", tabName = "well", icon = icon("house"))
) ),
body = dashboardBody(
useShinyjs(),
tags$script(HTML("$('body').addClass('fixed');")),
tags$head(tags$style(".skin-blue .main-header .logo { padding: 0px;}")),
tabItems(
tabItem("well",
fluidRow(),
tags$hr(),
tags$hr(),
fluidRow(
column(5,),
column(6,
fluidRow(column(3,textInput("name", label = ("Name"), value = "consent.name"))),
fluidRow(
column(5,),
column(6,passwordInput("pwd", "Enter the Database browser password")
)),
actionButton("button", "Get started",style='padding:4px; font-size:140%'),
fluidRow(
column(3,
downloadButton("report", "Generate report",style='padding:4px; font-size:180%')
),
column(6,
uiOutput('markdown')
)))))
)
)
),
server<-shinyServer(function(input, output,session) {
hide(selector = "body > div > header > nav > a")
observeEvent(input$button,{
if (input$name=="consent.name"){
return(NULL)
}
else{
if(input$pwd=="makis"){
output$markdown <- renderUI({
HTML(markdown::markdownToHTML(knit('ex.rmd', quiet = TRUE)))
})
}
else{
return(NULL)
}
}
})
observeEvent(input$button,{
if (input$name=="consent.name"){
return(NULL)
}
else{
if(input$pwd=="makis"){
output$report <- downloadHandler(
# For PDF output, change this to "report.pdf"
filename = "report.pdf",
content = function(file) {
tempReport <- file.path(tempdir(), "ex.Rmd")
file.copy("ex.Rmd", tempReport, overwrite = TRUE)
rmarkdown::render(tempReport, output_file = file,
envir = new.env(parent = globalenv())
)
}
)
}
else{
return(NULL)
}
}
})
}
)
)
Using the renderXXX functions inside observers is not recommended.
Here is a way:
library(shiny)
library(markdown)
library(rmarkdown)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
passwordInput("pwd", "Password"),
conditionalPanel(
condition = "output.passwordOK",
actionButton("button", "Generate report"),
),
conditionalPanel(
condition = "output.reportDone",
downloadButton("dwnld", "Download report")
)
),
mainPanel(
uiOutput("preview")
)
)
)
server <- function(input, output, session){
# indicator report has been generated
reportDone <- reactiveVal(FALSE)
output[["reportDone"]] <- reactive({
reportDone()
})
outputOptions(output, "reportDone", suspendWhenHidden = FALSE)
# indicator password is right
passwordOK <- eventReactive(input[["pwd"]], {
input[["pwd"]] == "darwin"
})
output[["passwordOK"]] <- reactive({
passwordOK()
})
outputOptions(output, "passwordOK", suspendWhenHidden = FALSE)
# generate report preview on button click
HTMLreport <- eventReactive(input[["button"]], {
req(passwordOK())
reportDone(TRUE)
HTML(markdownToHTML("www/ex.Rmd", output = NULL))
})
output[["preview"]] <- renderUI({
HTMLreport()
})
# download handler
output[["dwnld"]] <- downloadHandler(
filename = "report.html",
content = function(file){
render("www/ex.Rmd", output_file = file)
}
)
}
shinyApp(ui, server)

How to read & display time in Navbar of Shiny R Dashboard

I want to display Last Updated time in the navbar of shiny R. For that I'm storing the last updated time in csv file which I will be using to read in the server.R but I'm unable to figure out how to display that time on the rightmost side of the navbar. Any help would be highly appreciated. Thank You
shinyUI(
navbarPage(
title = 'Welcome',
tabPanel('Overview',
tabsetPanel(
tabPanel('Forward',
fluidRow(
DT::dataTableOutput("view_fwd"),width = 6
)
),
tabPanel('Reverse',
fluidRow(
DT::dataTableOutput("view_rvo"),width = 6
))
))
library(shiny)
ui <- fluidPage(
navbarPage(
title = 'Welcome',
tabPanel('Overview',
tabsetPanel(
tabPanel('Forward',
fluidRow(
DT::dataTableOutput("view_fwd"),width = 6
)
),
tabPanel('Reverse',
fluidRow(
DT::dataTableOutput("view_rvo"),width = 6
))
)),
tabPanel(tags$ul(class='nav navbar-nav',
style = "padding-left: 550px;", htmlOutput("time"))) # here you output time, need to positions on the left side by 550px
)
)
# Define server logic
server <- function(input, output) {
output$time <- renderUI({
as.character(strptime(Sys.time(), "%Y-%m-%d %H:%M:%S", tz = "EET"))
})
}
# Run the application
shinyApp(ui = ui, server = server)
With some css and Javascript you can let the time float to the right and disable click events on that tab. You would need the package shinyjs for it.
library(shiny)
library(shinyjs)
jscode <- '
shinyjs.init = function() {
$(".nav").on("click", ".disabled", function (e) {
e.preventDefault();
return false;
});
}
'
ui <- fluidPage(
tags$head(tags$style(HTML("
.navbar-nav {
float: none;
}
.navbar ul > li:nth-child(2) {
float: right;
}
.navbar ul > li:nth-child(2) {
color: black !important;
}
"))),
useShinyjs(),
extendShinyjs(text = jscode, functions = "init"),
navbarPage(
title = 'Welcome',
tabPanel('Overview',
tabsetPanel(
tabPanel('Forward',
fluidRow(
DT::dataTableOutput("view_fwd"),width = 6
)
),
tabPanel('Reverse',
fluidRow(
DT::dataTableOutput("view_rvo"),width = 6
))
)),
tabPanel(tags$ul(class='nav navbar-nav',
style = "padding-left: 5px; float: right;", htmlOutput("time")))
)
)
# Define server logic
server <- function(input, output) {
observe({
toggleClass(condition = input$foo,
class = "disabled",
selector = ".navbar ul > li:nth-child(2)")
})
output$time <- renderUI({
as.character(strptime(Sys.time(), "%Y-%m-%d %H:%M:%S", tz = "EET"))
})
}
# Run the application
shinyApp(ui = ui, server = server)

Hide helptext() according to if condition in a shiny app

I have a simple shiny app:
library(shiny)
ui <- navbarPage(
"Application",
tabPanel("General",
sidebarLayout(
sidebarPanel(
),
mainPanel(
wellPanel(
tags$style(type="text/css",
".shiny-output-error { visibility: hidden; }",
".shiny-output-error:before { visibility: hidden; }"
),
uiOutput("c1"),
uiOutput("num8"),
uiOutput("help1")
)
)
)
)
)
server <- function(input, output,session) {
output$c1<-renderUI({
checkboxInput("ch1",
h5("Person ID"), value = FALSE)
})
output$num8<-renderUI({
if(input$ch1==T){
textInput("nm8",
h6("Column"),
value = 1)
}
else{
output$help1<-renderUI({
helpText("Click Person ID")
})
}
})
}
shinyApp(ui, server)
What I want to achieve is hide the helptext "Click Person ID" when the tickbox is clicked. I have used an if condition for this but while the numeric input is hidden when it has to the helptext is always there.
I see a renderUI() wrapped in a renderUI(). That might get you into trouble. You could seperate them instead, then it will work.
output$num8<-renderUI({
if(input$ch1 == TRUE){
textInput("nm8",
h6("Column"),
value = 1)
}
})
output$help1<-renderUI({
if(input$ch1 == FALSE){
helpText("Click Person ID")
}
})
Full code will read:
library(shiny)
ui <- navbarPage(
"Application",
tabPanel("General",
sidebarLayout(
sidebarPanel(
),
mainPanel(
wellPanel(
tags$style(type="text/css",
".shiny-output-error { visibility: hidden; }",
".shiny-output-error:before { visibility: hidden; }"
),
uiOutput("c1"),
uiOutput("num8"),
uiOutput("help1")
)
)
)
)
)
server <- function(input, output,session) {
output$c1<-renderUI({
checkboxInput("ch1",
h5("Person ID"), value = FALSE)
})
output$num8<-renderUI({
if(input$ch1 == TRUE){
textInput("nm8",
h6("Column"),
value = 1)
}
})
output$help1<-renderUI({
if(input$ch1 == FALSE){
helpText("Click Person ID")
}
})
}
shinyApp(ui, server)

Dashboard body does not resize with change in DT length

The dashboard page will not expand when more rows are shown from the DTOutput. The output is visible, but looks like it is no longer contained within the dashboard page.
ui <- function() {
dashboardPage(
dashboardHeader(),
dashboardSidebar(),
dashboardBody(
mainPanel(width = 12,
fluidRow(DTOutput(outputId = "table"))
)))}
server <- function(input, output) {
data <- data.frame(1:100)
output$table <- renderDT(
data
)
}
shinyApp(ui = ui, server = server)
Screenshot of issue.
The gray background for the dashboard page ends around row 15.
This can be fixed by adding some CSS to the document:
section.content {
overflow-y: hidden;
}
MWE:
library(shiny)
library(shinydashboard)
library(DT)
library(htmltools)
ui <- function() {
dashboardPage(
dashboardHeader(),
dashboardSidebar(),
dashboardBody(
tags$head(tags$style("section.content { overflow-y: hidden; }")),
mainPanel(width = 12,
fluidRow(DTOutput(outputId = "table"))
)))}
server <- function(input, output) {
data <- data.frame(1:100)
output$table <- renderDT(
data
)
}
shinyApp(ui = ui, server = server)

Resources