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)
Related
Is there anyway to change the fill colour of the verbatimTextOutput? Basically I want this to stand out from the other sections. The below is an illustration figure to show why it doesn't stand out with the default settings. And at the bottom is a simple example with 1 verbatimTextOutput
library(shiny)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
verbatimTextOutput("test"),
width = 2
),
mainPanel(
"",
width = 8
))
)
server <- function(input, output, session) {
output$test = renderText("Hi")
}
shinyApp(ui, server)
You can have your custom CSS for the pre elements (verbatimTextOutput). You can add CSS as .css file or inline. Below is an example using an inline CSS.
library(shiny)
ui <- fluidPage(
tags$head(
tags$style(HTML("
/* this will affect all the pre elements */
pre {
color: red;
background-color: #5ef4fb;
}
/* this will affect only the pre elements under the class myclass */
.myclass pre {
color: black;
background-color: #d6860f;
font-weight: bolder;
}"))
),
sidebarLayout(
sidebarPanel(
verbatimTextOutput("test1"),
div(class = "myclass",
verbatimTextOutput("test2")
),
width = 2
),
mainPanel(
"",
width = 8
))
)
server <- function(input, output, session) {
output$test1 = renderText("Hi")
output$test2 = renderText("Hello")
}
shinyApp(ui, server)
I would like to have both a persistent sidebar (as in shinydashboard layout) and a navigation bar with tabs (as in shiny::navbarPage layout). I came across this answer that seems to correspond to what I want.
The problem is that inputs in the sidebar are not persistent through tabs, i.e when switching tabs, the inputs in the sidebar are not displayed anymore (at the contrary of shinydashboard sidebar for example). Here's an example I cannot really minimize more since a lot of it is CSS:
library(shiny)
library(bootstraplib)
# boot dash layout funs ---------------------------------------------------
boot_side_layout <- function(...) {
div(class = "d-flex wrapper", ...)
}
boot_sidebar <- function(...) {
div(
class = "bg-light border-right sidebar-wrapper",
div(class = "list-group list-group-flush", ...)
)
}
boot_main <- function(...) {
div(
class = "page-content-wrapper",
div(class = "container-fluid", ...)
)
}
# css ---------------------------------------------------------------------
css_def <- "
body {
overflow-x: hidden;
}
.container-fluid, .container-sm, .container-md, .container-lg, .container-xl {
padding-left: 0px;
}
.sidebar-wrapper {
min-height: 100vh;
margin-left: -15rem;
padding-left: 15px;
padding-right: 15px;
-webkit-transition: margin .25s ease-out;
-moz-transition: margin .25s ease-out;
-o-transition: margin .25s ease-out;
transition: margin .25s ease-out;
}
.sidebar-wrapper .list-group {
width: 15rem;
}
.page-content-wrapper {
min-width: 100vw;
padding: 20px;
}
.wrapper.toggled .sidebar-wrapper {
margin-left: 0;
}
.sidebar-wrapper, .page-content-wrapper {
padding-top: 20px;
}
.navbar{
margin-bottom: 0px;
}
.navbar-collapse {
font-size: 1.1rem
}
#media (max-width: 768px) {
.sidebar-wrapper {
padding-right: 0px;
padding-left: 0px;
}
}
#media (min-width: 768px) {
.sidebar-wrapper {
margin-left: 0;
position: fixed;
}
.page-content-wrapper {
min-width: 0;
width: 100%;
}
.wrapper.toggled .sidebar-wrapper {
margin-left: -15rem;
}
}
"
# app ---------------------------------------------------------------------
ui <- tagList(
tags$head(tags$style(HTML(css_def))),
bootstrap(),
navbarPage(
collapsible = TRUE,
title = "",
tabPanel(
"Statistics",
boot_side_layout(
boot_sidebar(
selectInput(
"variables",
"Variables",
NULL
)
),
boot_main(
fluidRow(
dataTableOutput("statistics")
)
)
)
),
tabPanel(
"Plots",
boot_side_layout(
boot_sidebar(
),
boot_main(
)
)
)
)
)
server <- function(input, output, session) {
output$statistics <- renderDataTable(mtcars[10, 10])
}
shinyApp(ui, server)
How can I make these inputs persistent through sidebar? (If somebody knows of another simple way to mix persistent sidebar with navbar, please show it as well).
Why not using a sidebarLayout with a navbarPage in mainPanel?
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
selectInput("select", "Select", c("a", "b", "c"))
),
mainPanel(
navbarPage(
"App Title",
tabPanel("Plot"),
tabPanel("Summary"),
tabPanel("Table")
)
)
)
)
shinyApp(ui, server)
EDIT
Or something like this?
library(shiny)
library(ggplot2)
ui <- fluidPage(
div(
style = "display: flex; flex-direction: column;",
div( #~~ Main panel ~~#
navbarPage(
"Old Faithful Geyser Data",
tabPanel(
"Plot",
plotOutput("ggplot")
),
tabPanel("Summary"),
tabPanel("Table")
)
),
wellPanel( #~~ Sidebar ~~#
style = "width: 300px;",
sliderInput("bins", "Number of bins:", min = 1, max = 50, value = 30),
)
)
)
server <- function(input, output) {
output[["ggplot"]] <- renderPlot({
x <- faithful[, 2]
bins <- seq(min(x), max(x), length.out = input$bins + 1)
hist(x, breaks = bins, col = 'darkgray', border = 'white')
})
}
shinyApp(ui = ui, server = server)
EDIT
Like this to have the sidebar on the left:
library(shiny)
library(shinyjs)
library(ggplot2)
CSS <- "
.sidebar {
min-width: 300px;
margin-right: 30px;
}
#sidebar {
width: 300px;
}
"
ui <- fluidPage(
useShinyjs(),
tags$head(tags$style(HTML(CSS))),
div( #~~ Main panel ~~#
navbarPage(
"Old Faithful Geyser Data",
tabPanel(
"Plot",
div(
style = "display: flex;",
div(class = "sidebar"),
plotOutput("ggplot")
)
),
tabPanel(
"Summary",
div(
style = "display: flex;",
div(class = "sidebar"),
verbatimTextOutput("summary")
)
),
tabPanel(
"Table",
div(
style = "display: flex;",
div(class = "sidebar"),
tableOutput("table")
)
),
id = "navbar"
)
),
wellPanel( #~~ Sidebar ~~#
id = "sidebar",
sliderInput("bins", "Number of bins:", min = 1, max = 50, value = 30),
)
)
server <- function(input, output) {
output[["ggplot"]] <- renderPlot({
x <- faithful[, 2]
bins <- seq(min(x), max(x), length.out = input$bins + 1)
hist(x, breaks = bins, col = 'darkgray', border = 'white')
})
output[["summary"]] <- renderPrint({
list(a = 1:10, b = 1:10)
})
output[["table"]] <- renderTable({
iris[1:10,]
})
observeEvent(input[["navbar"]], {
selector <-
sprintf("$('div.tab-pane[data-value=\"%s\"] div.sidebar')", input[["navbar"]])
runjs(paste0(selector, ".append($('#sidebar'));"))
})
}
shinyApp(ui = ui, server = server)
EDIT
Here is an improvement of the above way. I've made some convenient functions tabPanel2 and sidebar to help the user. And I use fluidRow and column instead of using a display: flex;. This allows to have a sidebar width relative to the screen size. The example below also shows how to not include the sidebar in a tab (simply use tabPanel and not tabPanel2.
library(shiny)
library(shinyjs)
library(ggplot2)
tabPanel2 <- function(title, ..., value = title, icon = NULL, sidebarWidth = 4){
tabPanel(
title = title,
fluidRow(
column(
width = sidebarWidth,
class = "sidebar"
),
column(
width = 12 - sidebarWidth,
...
)
)
)
}
sidebar <- function(...){
div(
style = "display: none;",
tags$form(
class = "well",
id = "sidebar",
...
)
)
}
ui <- fluidPage(
useShinyjs(),
div( #~~ Main panel ~~#
navbarPage(
"Old Faithful Geyser Data",
tabPanel2(
"Plot",
plotOutput("ggplot")
),
tabPanel2(
"Summary",
verbatimTextOutput("summary")
),
tabPanel(
"Table",
fluidRow(
column(
width = 4,
wellPanel(
tags$fieldset(
tags$legend(h3("About")),
p("This app is cool")
)
)
),
column(
width = 8,
tableOutput("table")
)
)
),
id = "navbar"
)
),
sidebar( #~~ Sidebar ~~#
sliderInput("bins", "Number of bins:", min = 1, max = 50, value = 30)
)
)
server <- function(input, output) {
output[["ggplot"]] <- renderPlot({
x <- faithful[, 2]
bins <- seq(min(x), max(x), length.out = input$bins + 1)
hist(x, breaks = bins, col = 'darkgray', border = 'white')
})
output[["summary"]] <- renderPrint({
list(a = 1:10, b = 1:10)
})
output[["table"]] <- renderTable({
iris[1:10,]
})
observeEvent(input[["navbar"]], {
selector <-
sprintf("$('div.tab-pane[data-value=\"%s\"] div.sidebar')", input[["navbar"]])
append <- "selector.append($('#sidebar'));"
js <- sprintf("var selector=%s; if(selector.length){%s;}", selector, append)
runjs(js)
})
}
shinyApp(ui = ui, server = server)
I'm finishing up my dashboard atm, and I'm trying to show a tweet on my page. I'm using the tweetrmd package to do this, but it doesn't seem to work
here is part of my UI code
library(tidyverse)
library(shiny)
library(rtweet)
library(tweetrmd)
screenshot <- tweet_screenshot(tweet_url("Metro", "1251153881209307136"))
# UI
list(
ui <- tagList(
includeCSS("style.css"),
navbarPage("#Corona",
windowTitle = "#Corona",
tabPanel("Twitter",
sidebarLayout(
sidebarPanel(
h2("Algemene twitter data", align = "left"),
),
mainPanel(
tabsetPanel(
id = "Tabs",
tabPanel(
title = "Kranten",
h3("Frequentie tweets over corona door populaire kranten", align = "center"),
plotOutput("plot1")%>% withSpinner(color="#dca108"),
div(img(src= screenshot, align = "center"), style="text-align: center;", id= "screenshot"),
), )
)
)
))
)
)
Question is: can I make the tweet_screenshot function work in a shiny app (default is rmarkdown) and how?
If I check out the screenshot object it shows this:
(screenshot <- tweet_screenshot(tweet_url("Metro", "1251153881209307136")))
file://C:\Users\jolien\AppData\Local\Temp\RtmpKeTPxU\file47383c65585c.html screenshot completed
Thanks in advance
A solution using twitframe.com:
library(shiny)
tweet <- "https://twitter.com/Twitter/status/1144673160777912322"
url <- URLencode(tweet, reserved = TRUE)
src <- paste0("https://twitframe.com/show?url=", url)
js <- '
$(window).on("message", function(e) {
var oe = e.originalEvent;
if (oe.origin !== "https://twitframe.com")
return;
if (oe.data.height && oe.data.element.id === "tweet"){
$("#tweet").css("height", parseInt(oe.data.height) + "px");
}
});'
ui <- fluidPage(
fluidRow(
tags$head(
tags$script(HTML(js)),
tags$style(HTML(
"
.content {
margin: auto;
padding: 20px;
width: 60%;
}"))
),
uiOutput("frame")
)
)
server <- function(input, output, session) {
output[["frame"]] <- renderUI({
tagList(
tags$div(
class = "content",
tags$div(tags$iframe(
id = "tweet",
border=0, frameborder=0, height=50, width=550,
src = src
))
),
singleton(tags$script(HTML(
"$(document).ready(function(){
$('iframe#tweet').on('load', function() {
this.contentWindow.postMessage(
{ element: {id:this.id}, query: 'height' },
'https://twitframe.com');
});
});")))
)
})
}
shinyApp(ui, server)
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)
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
});
});")))
)
})