I'm creating a small app with shiny to show simulation results based on user input with plot_ly() (need plotly for animation). It utilizes navbarpage() to show a home page (where I explain the rationale) and a simulation page (where the app is actually displayed).
To create the homepage, I created a .Rmd file and knitted to html. Unfortunately, it appears that includeHTML() and renderPlotly() have some sort of javascript conflict and so plotly will not render. Double unfortunately, I know almost nothing about HTML or javascript.
A simple (almost reprex) version:
# Define UI for application that draws a histogram
ui <- fluidPage(
navbarPage("RCV", position = "fixed-top", collapsible = TRUE,
tabPanel("Home",
includeHTML("www/yourFav.html")),
tabPanel("Simulation",
plotlyOutput("plot")
)
)
# Define server logic required to draw a histogram
server <- function(input, output, session){
output$plot <- renderPlotly({
plot_ly(data = cars,
x = ~mgp,
y = ~wt)
})
}
Any suggestions you have will be well received!
Best,
Brennan
includeHTML is intended to be used for HTML fragments. Use an iframe for a full HTML page. The HTML file must be in the www subfolder, and you have to pass it to the src argument of tags$iframe without the www/ prefix.
library(shiny)
library(plotly)
ui <- fluidPage(
navbarPage("RCV", position = "fixed-top", collapsible = TRUE,
tabPanel("Home",
tags$iframe(src = "rcv_homePage.html",
width = "600", height = "500",
style = "margin-top: 70px;")),
tabPanel("Simulation",
plotlyOutput("plot")
)
)
)
server <- function(input, output, session){
output$plot <- renderPlotly({
plot_ly(data = cars,
x = ~mgp,
y = ~wt)
})
}
shinyApp(ui, server)
Related
I have an issue with the waiter which I need for an app built with R shiny.
The example below (based on the fantastic website on the waiter package by John Coene: https://waiter.john-coene.com/#/waiter/examples#on-render) helps me illustrate my issue.
The app is made of two tabPanels, the first one which shows a table, and the second one that shows a chart. The table and the chart will appear after some waiting time, and the waiter spinner should, in the meantime, appear in the middle of the rendering areas of both tabPanels.
However, what actually happen is that the waiter spinner only shows up in the middle of the rendering area of the tabPanel I open first, whereas in the other tabPanel it is stuck in the top-left corner of the page.
Many thanks in advance for whoever can help me fix this problem!
library(shiny)
library(highcharter)
library(shinythemes)
library(waiter)
ui <- fluidPage(
theme = shinytheme("cyborg"),
useWaiter(),
actionButton("draw", "render stuff"),
fluidPage(
tabsetPanel(
tabPanel("Table", tableOutput("table")),
tabPanel("Chart", highchartOutput("hc"))
)
)
)
server <- function(input, output){
# specify the id
w <- Waiter$new(id = c("hc", "table"))
dataset <- reactive({
input$draw
w$show()
Sys.sleep(8)
head(cars)
})
output$table <- renderTable(dataset())
output$hc <- renderHighchart({
hchart(dataset(), "scatter", hcaes(speed, dist))
})
}
shinyApp(ui, server)
I would recommend you use shinycssloaders instead. The reason is that loaders' positions in waiter are calculated by current visible height and width. However, there is no visible position in the second tab or the hidden tabs, so waiter can't add the loader to the right spot. There is no fix we can do here. This is a feature that waiter doesn't support currently.
library(shiny)
library(highcharter)
library(shinythemes)
library(shinycssloaders)
ui <- fluidPage(
theme = shinytheme("cyborg"),
actionButton("draw", "render stuff"),
fluidPage(
tabsetPanel(
tabPanel("Table", withSpinner(tableOutput("table"), type = 3, color.background = "#060606", color = "#EEEEEE")),
tabPanel("Chart", withSpinner(highchartOutput("hc"), type = 3, color.background = "#060606", color = "#EEEEEE"))
)
)
)
server <- function(input, output){
dataset <- reactive({
input$draw
Sys.sleep(4)
head(cars)
})
output$table <- renderTable(dataset())
output$hc <- renderHighchart({
hchart(dataset(), "scatter", hcaes(speed, dist))
})
}
shinyApp(ui, server)
My shiny app generates a number of useful graphs. I would like to allow the user to download the graphs in various formats.
I have done this before for a single graph using How to save plots that are made in a shiny app as a guide. However, I am ending up creating more repeated code for each additional plot. I am not a programmer, but it really seems like I should be able to write one function to do this since I am just passing parameters to downloadHandler and ggsave, but I can't figure it out.
The MRE below represents a page with, say, ten different graphs. Is there a way to write a single function that receives the plot ID from a button (like a tag or something?) and the format from the selectInput to pass those parameters to downloadHandler and ggsave to save each of those graphs in the selected format? The function at the bottom shows my thinking, but I don't know where to go from here or if that is even the right direction.
Thanks!
library(shiny)
library(ggplot2)
# Define UI for application that draws a histogram
ui <- fluidPage(
# Application title
titlePanel("Old Faithful Geyser Data"),
# Sidebar with a slider input for number of bins
sidebarLayout(
sidebarPanel(
sliderInput("bins",
"Number of bins:",
min = 1,
max = 50,
value = 30)
),
# Show plots and download buttons
mainPanel(
plotOutput("distPlot"),
fluidRow(
column(3,
downloadButton("dl_plot1")
),
column(3,
selectInput("plot1_format",label = "Format",choices = c("SVG","PDF","JPEG","PNG"),width = "75px")
)
),
plotOutput("scat_plot"),
column(3,
downloadButton("dl_plot2")
),
column(3,
selectInput("plot2_format",label = "Format",choices = c("SVG","PDF","JPEG","PNG"),width = "75px")
)
)
)
)
# Define server logic required to draw a histogram and scatterplot
server <- function(input, output) {
output$distPlot <- renderPlot({
x <- faithful$waiting
binwidth<-(max(x)-min(x))/input$bins
p<-ggplot(faithful,aes(waiting))+
geom_histogram(binwidth = binwidth)
p
})
output$scat_plot<-renderPlot({
p<-ggplot(faithful,aes(x=waiting,y=eruptions))+
geom_point()
p
})
downloadPlot <- function(plot_name,file_name,file_format){#concept code
downloadHandler(
filename=function() { paste0(file_name,".",file_format)},
content=function(file){
ggsave(file,plot=plot_name,device=file_format)
}
)
}
}
# Run the application
shinyApp(ui = ui, server = server)
To achieve your desired result without duplicating code you could (or have to) use a Shiny module. Basically a module is a pair of an UI function and a server function. For more on modules I would suggest to have a look at e.g. Mastering shiny, ch. 19.
In the code below I use a module to take care of the download part. The job of downloadButtonUI and downloadSelectUI is to add a download button and a selectInput for the file format. The downloadServer does the hard work and saves the plot in the desired format.
Note: Besides the download module I moved the code for the plots to reactives so that the plots could be passed to the downloadHandler or the download module.
EDIT: Added a fix. We have to pass the reactive (e.g. dist_plot without parentheses) to the download server and use plot() inside the downloadServer instead to export the updated plots.
library(shiny)
library(ggplot2)
# Download Module
downloaButtondUI <- function(id) {
downloadButton(NS(id, "dl_plot"))
}
downloadSelectUI <- function(id) {
selectInput(NS(id, "format"), label = "Format", choices = c("SVG", "PDF", "JPEG", "PNG"), width = "75px")
}
downloadServer <- function(id, plot) {
moduleServer(id, function(input, output, session) {
output$dl_plot <- downloadHandler(
filename = function() {
file_format <- tolower(input$format)
paste0(id, ".", file_format)
},
content = function(file) {
ggsave(file, plot = plot())
}
)
})
}
# Define UI for application that draws a histogram
ui <- fluidPage(
# Application title
titlePanel("Old Faithful Geyser Data"),
# Sidebar with a slider input for number of bins
sidebarLayout(
sidebarPanel(
sliderInput("bins",
"Number of bins:",
min = 1,
max = 50,
value = 30
)
),
# Show plots and download buttons
mainPanel(
plotOutput("distPlot"),
fluidRow(
column(3, downloaButtondUI("distPlot")),
column(3, downloadSelectUI("distPlot"))
),
plotOutput("scat_plot"),
fluidRow(
column(3, downloaButtondUI("scatPlot")),
column(3, downloadSelectUI("scatPlot"))
),
)
)
)
server <- function(input, output) {
dist_plot <- reactive({
p <- ggplot(faithful, aes(waiting)) +
geom_histogram(bins = input$bins)
p
})
scat_plot <- reactive({
p <- ggplot(faithful, aes(x = waiting, y = eruptions)) +
geom_point()
p
})
output$distPlot <- renderPlot({
dist_plot()
})
output$scat_plot <- renderPlot({
scat_plot()
})
downloadServer("distPlot", dist_plot)
downloadServer("scatPlot", scat_plot)
}
shinyApp(ui = ui, server = server)
#>
#> Listening on http://127.0.0.1:4092
In shiny you can add images from disk using the line below. I also found that a tag called figcaption or caption can be used to add captions to the images. But, unfortunately, I couldn't find an example on how to structure figcaption. How can I add captions right under multiple images in a shiny app? The code below stacks the captions one under the other instead of placing them under each figure respectively.
ui = navbarPage("Project Eddy", theme = shinytheme("sandstone"),
div((img(src = "Study_Area.png", height = '640px', width = '480px'),img(src = "Picture1.png", height = '640px', width = '480px'),img(src = "Picture2.png", height = '640px', width = '480px')),
div(tags$figcaption("Figure 1: Ed), tags$figcaption("Figure 2: Edd), tags$figcaption("Figure 3: Eddy")),
This turned out to be trickier than I expected. Looking at the spec for the <figcaption> HTML element, it needs to be the first or last element of the parent <figure> tag. Shiny's renderPlot() function doesn't wrap its image in a <figure> tag. Maybe there's a way of coercing renderPlot() to do this, but I couldn't find it. I resorted to using renderUI() and manually constructing the necessary nested tags.
Here's a working example:
library(shiny)
library(tidyverse)
ui <- fluidPage(
uiOutput("all")
)
server <- function(input, output, session) {
d1 <- tibble(x=runif(10), y=runif(10))
d2 <- tibble(x=runif(10), y=runif(10))
output$all <- renderUI({
tagList(
uiOutput("plot1"),
uiOutput("plot2")
)
})
output$plot1 <- renderUI({
tags$figure(
htmltools::plotTag(
d2 %>% ggplot() + geom_point(aes(x=x, y=y)),
alt="Plot 1"
),
tags$figcaption("This is plot 1"))
})
output$plot2 <- renderUI({
tags$figure(
htmltools::plotTag(
d2 %>% ggplot() + geom_point(aes(x=x, y=y)),
alt="Plot 2"
),
tags$figcaption("This is plot 2"))
})
}
shinyApp(ui = ui, server = server)
I am maintaining my code for a big and bulky shiny dashboard, and I noticed that the click-event functionality doesn't reset anymore.
After stripping it down to a minimal working example, and comparing to solutions from https://stackoverflow.com/a/44543204/11703379 and https://community.plot.ly/t/reseting-click-events/2718, I come to conclusion that there must have been a change in either plotly, or shinyjs libraries, which disable this feature.
By halting the execution at the plot, I see that the plot object does carry the source attribute correctly.
library(plotly)
library(shiny)
library(shinyjs)
ui <- fluidPage(
useShinyjs(),
plotlyOutput("plot"),
extendShinyjs(text = "shinyjs.resetClick = function() { Shiny.onInputChange('.clientValue-plotly_click-plot', 'null'); }"),
actionButton("reset", "Reset click"),
verbatimTextOutput("click")
)
server <- function(input, output, session) {
observeEvent(input$reset, js$resetClick())
output$click <- renderPrint(event_data("plotly_click", source = "plot" ))
output$plot <- renderPlotly(
plot_ly(mtcars, x = ~mpg, y = ~wt,
type="scatter",
mode="markers",
source = "plot") %>%
event_register("plotly_click")
)
output$click <- renderPrint({
d <- event_data(source = "plot","plotly_click")
if (is.null(d)) "No click" else d
})
}
shinyApp(ui, server)
Can anyone confirm this?
I am using plotly version 4.9.0,
and shinyjs version 1.0.
Seems like .clientValue- is not necessary anymore. Probably a change in plotly, but I am not sure about it.
Change .clientValue-plotly_click-plot to plotly_click-plot and it should work.
Output:
I want to increase the size of highchart on clicking the zoom button. I tried using the code below to increase the size but so far I have not been able to achieve what I want to do. I actually wanted the highchart to expand and occupy the full page on clicking the zoom button. I have written the following code so far but it does not seem to work. Can anyone tell me what I am doing wrong?
require(shiny)
require(rCharts)
ui <- fluidPage(
tags$script('Shiny.addCustomMessageHandler("ZoomPlot", function(variableName){
document.getElementById(variableName).style.height = "1000px";
});
'),
headerPanel("Test app"),
actionButton("test", "Zoom"),
div(class = "chart-container", showOutput("viz", "highcharts"))
)
server <- shinyServer(function(input, output, session) {
output$viz <- renderChart2({
a <- highchartPlot(Sepal.Length ~ Sepal.Width, data=iris)
a
})
observeEvent(input$test,{
session$sendCustomMessage(type = 'ZoomPlot', message = "viz")
})
})
shinyApp(ui, server)
You can do it using only server side like
server <- shinyServer(function(input, output, session) {
hh=reactive({
if(input$test>0 ) {1000}else{400}
})
output$viz <- renderChart2({
a <- highchartPlot(Sepal.Length ~ Sepal.Width, data=iris)
a$set(height = hh()
)
a
})
})