is there any way in R, shinydashboard, to render multiple images in the dashboard body based on the selectinput option?
Here are my codes:
library(shiny)
library(shinydashboard)
images_a <- list.files("input/plots 1/", pattern = ".png") # 6 'png' images are in the *input/plots 1* folder
images_b <- list.files("input/plots 1/", pattern = ".jpg") # 5 'jpg' images are in the *input/plots 1* folder
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(selectInput(inputId = "image_type", label = "Image type", choices = c("png", "jpg"), selected = "png")),
dashboardBody()
)
server <- function(input, output) {
}
shinyApp(ui, server)
Thank you!
Use lapply( ) to loop through in renderImage( )
download.file("http://dehayf5mhw1h7.cloudfront.net/wp-content/uploads/sites/38/2016/01/18220900/Getty_011816_Bluepenguin.jpg",
destfile = "Bowie.png")
download.file("http://3.bp.blogspot.com/_cBH6cWZr1IU/TUURNp7LADI/AAAAAAAABsY/76UhGhmxjzY/s640/penguin+cookies_0018.jpg",
destfile = "Cookie.png")
function(input, output) {
output$img1 <- renderImage({ #This is where the image is set
if(input$var == "Bowie"){
list(src = "Bowie.png", height = 240, width = 300)
}
else if(input$var == "Cookie"){
list(src = "Cookie.png", height = 240, width = 300)
}
else if(input$var == "Renesme"){
list(src = "Renesme.png", height = 240, width = 300)
}
else if(input$var == "Mango"){
list(src = "Mango.png", height = 240, width = 300)
}
})
Related
I have a shiny app to load pictures and I should be able to select some of the images by clicking on them and the selected images will be recorded.
I want a function that I can select and mark pictures the same way you mark photos in the gallery of a phone.
Currently, I made an app that the selected images are replaced by an empty icon. Here is what I have tried:
ui <-fluidPage(column(
width=9,
align="center",
imageOutput(outputId = "img1", click = clickOpts(id = "img1_click", clip = FALSE),width = 150,height = 150,inline = TRUE)
,imageOutput(outputId = "img2", click = clickOpts(id = "img2_click", clip = FALSE),width = 150,height = 150,inline = TRUE)
))
server <- function(input, output, session) {
empty_img="/empty.jpeg"
vals=reactiveValues(img=list.files("/images/"))
vals2=reactiveValues(img=list.files("/images/"))
empty_img_to_normal_value=reactiveValues(m=1:length(vals$img))
output$img1 <- renderImage({
list(src = vals$img[1], width = "200", height = "200") } ,deleteFile = FALSE)
observeEvent(input$img1_click, {
if(empty_img_to_normal_value$m[1]==1){
vals$img[1]=empty_img
empty_img_to_normal_value$m[1]=0
}else{
vals$img[1]=vals2$img[1]
empty_img_to_normal_value$m[1]=1
}
})
output$img2 <- renderImage({
list(src = vals$img[2], width = "200", height = "200")} ,deleteFile = FALSE)
observeEvent(input$img2_click, {
if(empty_img_to_normal_value$m[2]==1){
vals$img[2]=empty_img
empty_img_to_normal_value$m[2]=0
}else{
vals$img[2]=vals2$img[2]
empty_img_to_normal_value$m[2]=1
}
})
}
Following our comments, I made a proper answer.
# list of images URLs, replace them with your images
lst_urls <- list("data/Rplot1.png", "data/Rplot1.png", "data/Rplot1.png", "data/Rplot1.png",
"data/Rplot5.png","data/Rplot5.png","data/Rplot5.png","data/Rplot5.png")
img_w <- "100%"
img_h <- 200
mod_img_UI <- function(id) {
ns <- NS(id)
tagList(
tags$style(".checkbox{margin-bottom: -40px;}"),
column(
width =2,
checkboxInput(
inputId = ns("select_img"), label = NULL
),
imageOutput(
outputId = ns("img"), width = img_w, height = img_h, inline = TRUE
)
)
)
}
mod_img_SERVER <- function(input, output, session, img_url){
ns <- session$ns
output$img <- renderImage({
list(src = img_url,
alt = "This is alternate text",
width = img_w,
height = img_h,
contentType = "image/png")
}, deleteFile = FALSE)
return(input$select_img)
}
ui <- fluidPage(
uiOutput("images")
)
server <- function(input, output, session) {
output$images <- renderUI({
lapply(
1:length(lst_urls),
function(i) {
mod_img_UI(id = paste0("img", i))
}
)
})
observe({
selected_imgs <- lapply(
1:length(lst_urls),
function(i) {
callModule(
module = mod_img_SERVER,
session = session,
id = paste0("img", i),
img_url = lst_urls[[i]]
)
}
)
print(paste("You picked :",lst_urls[unlist(selected_imgs)]))
})
}
shinyApp(ui, server)
i got stuck at some point while trying to use downloadHandler to download Plotly images. I just cannot figure out further how to get the image from temp directory...
Here is a sample code:
library(shiny)
library(plotly)
library(rsvg)
library(ggplot2)
d <- data.frame(X1=rnorm(50,mean=50,sd=10),X2=rnorm(50,mean=5,sd=1.5),Y=rnorm(50,mean=200,sd=25))
ui <-fluidPage(
title = 'Download Plotly',
sidebarLayout(
sidebarPanel(
helpText(),
downloadButton('download'),
tags$script('
document.getElementById("download").onclick = function() {
var plotly_svg = Plotly.Snapshot.toSVG(
document.querySelectorAll(".plotly")[0]
);
Shiny.onInputChange("plotly_svg", plotly_svg);
};
')
),
mainPanel(
plotlyOutput('regPlot'),
plotlyOutput('regPlot2')
)
)
)
server <- function(input, output, session) {
output$regPlot <- renderPlotly({
p <- plot_ly(d, x = d$X1, y = d$X2,mode = "markers")
p
})
output$regPlot2 <- renderPlotly({
p <- plot_ly(d, x = d$X1, y = d$X2,mode = "markers")
p
})
observeEvent(input$plotly_svg, priority = 10, {
png_gadget <- tempfile(fileext = ".png")
png_gadget <- "out.png"
print(png_gadget)
rsvg_png(charToRaw(input$plotly_svg), png_gadget)
})
output$download <- downloadHandler(
filename = function(){
paste(paste("test",Sys.Date(),sep=""), ".png",sep="")},
content = function(file) {
temp_dir <- tempdir()
tempImage <- file.path(temp_dir, 'out.png')
file.copy('out.png', tempImage, overwrite = TRUE)
png(file, width = 1200, height = 800, units = "px", pointsize = 12, bg = "white", res = NA)
dev.off()
})
}
shinyApp(ui = ui, server = server)
Additionally i am not sure how can i choose which of the plotly images should be downloaded. Thanks for any tips and help!
Info:
--> I have tried using webshot, however if I zoom or filter in any way plot, unfortunatelly webshot does not mirror it
--> i am not using the available plotly panel for download, because it is not working using IE
The OP has edited his/her post to add a requirement:
--> I have tried using webshot, however if I zoom or filter in any way plot, unfortunatelly webshot does not mirror it
Below is a Javascript solution, which doesn't need additional libraries. I'm not fluent in Javascript and I'm not sure the method is the most direct one: I'm under the impression that this method creates a file object from a url and then it creates a url from the file object. I will try to minimize the code.
library(shiny)
library(plotly)
d <- data.frame(X1 = rnorm(50,mean=50,sd=10),
X2 = rnorm(50,mean=5,sd=1.5),
Y = rnorm(50,mean=200,sd=25))
ui <-fluidPage(
title = 'Download Plotly',
sidebarLayout(
sidebarPanel(
helpText(),
actionButton('download', "Download")
),
mainPanel(
plotlyOutput('regPlot'),
plotlyOutput('regPlot2'),
tags$script('
function download(url, filename, mimeType){
return (fetch(url)
.then(function(res){return res.arrayBuffer();})
.then(function(buf){return new File([buf], filename, {type:mimeType});})
);
}
document.getElementById("download").onclick = function() {
var gd = document.getElementById("regPlot");
Plotly.Snapshot.toImage(gd, {format: "png"}).once("success", function(url) {
download(url, "plot.png", "image/png")
.then(function(file){
var a = window.document.createElement("a");
a.href = window.URL.createObjectURL(new Blob([file], {type: "image/png"}));
a.download = "plot.png";
document.body.appendChild(a);
a.click();
document.body.removeChild(a);
});
});
}
')
)
)
)
server <- function(input, output, session) {
regPlot <- reactive({
plot_ly(d, x = d$X1, y = d$X2, mode = "markers")
})
output$regPlot <- renderPlotly({
regPlot()
})
regPlot2 <- reactive({
plot_ly(d, x = d$X1, y = d$X2, mode = "markers")
})
output$regPlot2 <- renderPlotly({
regPlot2()
})
}
shinyApp(ui = ui, server = server)
EDIT
I was right. There's a shorter and cleaner solution:
tags$script('
document.getElementById("download").onclick = function() {
var gd = document.getElementById("regPlot");
Plotly.Snapshot.toImage(gd, {format: "png"}).once("success", function(url) {
var a = window.document.createElement("a");
a.href = url;
a.type = "image/png";
a.download = "plot.png";
document.body.appendChild(a);
a.click();
document.body.removeChild(a);
});
}
')
EDIT
To select the plot to download, you can do:
sidebarLayout(
sidebarPanel(
helpText(),
selectInput("selectplot", "Select plot to download", choices=list("plot1","plot2")),
actionButton('download', "Download")
),
mainPanel(
plotlyOutput('regPlot'),
plotlyOutput('regPlot2'),
tags$script('
document.getElementById("download").onclick = function() {
var plot = $("#selectplot").val();
if(plot == "plot1"){
var gd = document.getElementById("regPlot");
}else{
var gd = document.getElementById("regPlot2");
}
Plotly.Snapshot.toImage(gd, {format: "png"}).once("success", function(url) {
var a = window.document.createElement("a");
a.href = url;
a.type = "image/png";
a.download = "plot.png";
document.body.appendChild(a);
a.click();
document.body.removeChild(a);
});
}
')
)
)
1) Install the webshot package.
2) Install phantom.js:
library(webshot)
install_phantomjs()
See ?install_phantomjs for the details.
3) Now you can use the export function of the plotly package:
library(shiny)
library(plotly)
d <- data.frame(X1 = rnorm(50,mean=50,sd=10),
X2 = rnorm(50,mean=5,sd=1.5),
Y = rnorm(50,mean=200,sd=25))
ui <-fluidPage(
title = 'Download Plotly',
sidebarLayout(
sidebarPanel(
helpText(),
downloadButton('download')
),
mainPanel(
plotlyOutput('regPlot'),
plotlyOutput('regPlot2')
)
)
)
server <- function(input, output, session) {
regPlot <- reactive({
plot_ly(d, x = d$X1, y = d$X2, mode = "markers")
})
output$regPlot <- renderPlotly({
regPlot()
})
regPlot2 <- reactive({
plot_ly(d, x = d$X1, y = d$X2, mode = "markers")
})
output$regPlot2 <- renderPlotly({
regPlot2()
})
output$download <- downloadHandler(
filename = function(){
paste0(paste0("test", Sys.Date()), ".png")
},
content = function(file) {
export(regPlot(), file=file)
})
}
shinyApp(ui = ui, server = server)
You can save to the svg format. See ?export for the explanations.
Instead of using webshot, you should consider to try webshot2. See my detailed answer to the similar case.
# Webshot and phantomjs have been previously installed.
library(webshot2)
I'm trying to shift elements out of the way for rendered images not to overlap with anything (trying to do it dynamically so that any size page fits and just pushed everything out of the way sort of)... Pretty new to this whole thing. Thank you in advance!
library(shiny)
library(webshot)
ui <- fluidPage(
titlePanel(
fluidRow ( align = "center", h3("Screens"))
),
sidebarLayout(
#Side panel lay out to include variant, gene and disease info relevant to interpretation
sidebarPanel(width=3,
h5("Screens")),
mainPanel(
textInput("screen1", h5("Screenshot1"),
value = "http://example.com/", width = "100%", placeholder = NULL),
imageOutput("screen1"),
textInput("screen2", h5("Screenshot2"),
value = "http://example.com/", width = "100%", placeholder = NULL),
imageOutput("screen2")
)))
server <- function(input, output, session) {
output$screen1 <- renderImage({
webshot(input$screen1, zoom = 1,
file = "screen1.png")
list(src = "screen1.png",
contentType = 'image/png')
})
output$screen2 <- renderImage({
webshot(input$screen2 , zoom = 1,
file = "screen2.png")
list(src = "screen2.png",
contentType = 'image/png')
})
}
shinyApp(ui = ui, server = server)
I have an app that shows data as well as a picture based on user input. I have the following code in my ui:
selectInput("var",
label = "Choose a penguin to display",
choices = c("Bowie", "Cookie",
"Mango", "Renesme"),
selected = "Bowie"),
dateRangeInput("dates",
"Date range",
start = "2017-06-16",
end = as.character(Sys.Date())),
imageOutput("img1")
),
mainPanel(plotOutput("plot")
)
)
))
And the following in my server:
output$plot <- renderPlot({
penguin <- switch(input$var,
"Bowie" = filter(date_swim, penguin == 'Bowie'),
"Cookie" = filter(date_swim, penguin == 'Cookie'),
"Mango" = filter(date_swim, penguin == 'Mango'),
"Renesme" = filter(date_swim, penguin == 'Renesme'))
getSwim(min = input$dates[1],
max = input$dates[2],
p = penguin)
})
output$img1 <- renderImage({ #This is where the image is set
if(input$var == "Bowie"){
img(src = "Bowie.png", height = 240, width = 300)
}
else if(input$var == "Cookie"){
img(src = "Cookie.png", height = 240, width = 300)
}
else if(input$var == "Renesme"){
img(src = "Renesme.png", height = 240, width = 300)
}
else if(input$var == "Mango"){
img(src = "Mango.png", height = 240, width = 300)
}
})
})
When I run, where the image should be I see the error message:
character argument vector expected.
I think this is a bit misleading in the docs but for RenderImage() you want to use list() function and not img(). I reworked your server.R file a bit:
download.file("http://dehayf5mhw1h7.cloudfront.net/wp-content/uploads/sites/38/2016/01/18220900/Getty_011816_Bluepenguin.jpg",
destfile = "Bowie.png")
download.file("http://3.bp.blogspot.com/_cBH6cWZr1IU/TUURNp7LADI/AAAAAAAABsY/76UhGhmxjzY/s640/penguin+cookies_0018.jpg",
destfile = "Cookie.png")
function(input, output) {
output$img1 <- renderImage({ #This is where the image is set
if(input$var == "Bowie"){
list(src = "Bowie.png", height = 240, width = 300)
}
else if(input$var == "Cookie"){
list(src = "Cookie.png", height = 240, width = 300)
}
else if(input$var == "Renesme"){
list(src = "Renesme.png", height = 240, width = 300)
}
else if(input$var == "Mango"){
list(src = "Mango.png", height = 240, width = 300)
}
})
I am just learning R Shiny and have been playing around with the various examples in the gallery. For the "Image Output" example:
http://shiny.rstudio.com/gallery/image-output.html
I was wondering how I might be able to include an image headline when I select either the chainring or smiley radio button. For example after selecting "smiley" I would like the title "Smiley" to display below the image. Thank you for your help. Below is the code that is also included in the link above. (Some of it was intentionally deleted for clarity). Thank you
library(png) # For writePNG function
shinyServer(function(input, output, session) {
# A temp file to save the output.
# This file will be automatically removed later by
# renderImage, because of the deleteFile=TRUE argument.
outfile <- tempfile(fileext = ".png")
# Generate the image and write it to file
x <- matrix(rep((0:(width-1))/(width-1), height), height,
byrow = TRUE)
y <- matrix(rep((0:(height-1))/(height-1), width), height)
pic <- gauss2d(x, y, input$r)
writePNG(pic, target = outfile)
# Return a list containing information about the image
list(src = outfile,
contentType = "image/png",
width = width,
height = height,
alt = "This is alternate text")
}, deleteFile = TRUE)
# image2 sends pre-rendered images
output$image2 <- renderImage({
if (is.null(input$picture))
return(NULL)
if (input$picture == "face") {
return(list(
src = "images/face.png",
contentType = "image/png",
alt = "Face"
))
} else if (input$picture == "chainring") {
return(list(
src = "images/chainring.jpg",
filetype = "image/jpeg",
alt = "This is a chainring"
))
}
}, deleteFile = FALSE)
})
shinyUI(fluidPage(
titlePanel("Client data and query string example"),
fluidRow(
column(4, wellPanel(
sliderInput("r", "Radius :", min = 0.05, max = 1,
value = 0.2, step = 0.05),
radioButtons("picture", "Picture:",
c("chainring", "face"))
)),
column(4,
imageOutput("image1", height = 300),
imageOutput("image2")
)
)
Does this help?
ui.R
library(shiny)
shinyUI(fluidPage(
titlePanel("Image title"),
sidebarLayout(
sidebarPanel(
sliderInput("obs", "Number of observations:",
min = 0, max = 1000, value = 500)
),
mainPanel(
imageOutput("myImage"),
uiOutput("text")
)
)
))
server.R
library(shiny)
shinyServer(function(input, output) {
output$myImage <- renderImage({
outfile <- tempfile(fileext='.png')
png(outfile, width=400, height=300)
hist(rnorm(input$obs), main = "")
dev.off()
list(src = outfile,
contentType = 'image/png',
width = 400,
height = 300,
alt = "This is alternate text")
}, deleteFile = TRUE)
histogramTitle <- reactive({
paste("<h5>", input$obs, " observation used to create the histogram</h5>", sep = "")
})
output$text <- renderUI({
HTML(as.character(histogramTitle()))
})
})