Say I wanted to use a custom image or shapefile in an interactive environment (like R Shiny) such as this image of a paper airplane:
I would also be willing to draw the image myself in the program to allow for full control.
But the overall goal would be to allow a user to drag the edges of the image and the program could keep track of the size of the changes for each dimension (say wingspan of the paper airplane)
Would Shiny be a possibility here, or do I need to use another program? I would also want some statistics of the changes available to the user.
Does anyone have any similar examples of such a thing, or can point me in the right direction?
Like i wrote in the comment you could use the shinyjqui package and read the session info of the user.
A reproducible example can be found below:
library(shiny)
library(shinyjqui)
library(ggplot2)
server <- function(input, output, session){
global <- reactiveValues(width = 400, height = 400)
observe({
print(session)
if(!is.null(session$clientData[["output_plot1_height"]])){
global$height <- session$clientData[["output_plot1_height"]]
global$width <- session$clientData[["output_plot1_width"]]
}
})
output$plot1 <- renderImage({
outfile <- tempfile(fileext='.png')
png(outfile, width = global$width, height = global$height)
hist(rnorm(200))
dev.off()
list(src = outfile)
}, deleteFile = TRUE)
output$clientdataText <- renderText({
paste("height is ", global$height, "width is", global$width)
})
}
ui <- fluidPage(
verbatimTextOutput("clientdataText"),
jqui_resizabled(plotOutput("plot1"))
)
shinyApp(ui, server)
Related
I was wondering if there is a short solution (with a package?) to add a download button to non-ggplots in shiny, since my app produces many plots.
Thank you.
shinyscreenshot is a great package for screenshot shiny apps. You can create an image of the entire page of just specific elements like plots. The screenshotButton() function will create a button to save any element in your app.
A possible workaround is to create a function to make the plot or plots and call it inside a downloadHandler.
App
library(shiny)
mk_plot <- function(file, plots = NULL) {
jpeg(file) # open
par(mfrow=c(2,2))
plot(rnorm(30))
plot(rnorm(30))
# plot code
dev.off() # close
}
shinyApp(ui, server)
ui <- fluidPage(
downloadLink("downloadData", "Download")
)
server <- function(input, output) {
data <- mtcars
output$downloadData <- downloadHandler(
filename = function() {
paste("data-", Sys.Date(), ".jpeg", sep = "")
},
content = function(file) {
mk_plot(file)
}
)
}
shinyApp(ui, server)
I have an issue about this code.
observeEvent(input$next, {
output$mark1 <- renderImage({
return(NULL)
}, deleteFile = FALSE)
})
This code is from the server file on shiny. And the UI file, the code is
imageOutput(
outputId = 'mark1',
inline = TRUE
)
My expectation is, if I click 'next', then the image 'mark1' should disappear.
But I got an error message saying:
Warning: Error in basename: a character vector argument expected
Welcome to SO! Please provide a reprex the next time - this will help to get help.
renderImage needs to return a list with at least a src slot. From the help of renderImage
The expression expr must return a list containing the attributes for the img object on the client web page. For the image to display, properly, the list must have at least one entry, src, which is the path to the image file.
So you have to find a way how to tell shiny not to render the image at all when your button is pressed. A neat way to do so is to use req like in the example below. The button render shows the pic and whenever you press delete it goes away. This is due to the fact that req silently raises an error, which tells shiny not to proceed in the observer/render* function and thus not to show the picture in the first place.
library(shiny)
ui <- fluidPage(imageOutput("pic"),
actionButton("go", "Render Print"),
actionButton("delete", "Remove Pic"))
server <- function(input, output, session) {
toggle_pic <- reactiveVal(FALSE)
observeEvent(input$go, toggle_pic(TRUE), ignoreInit = TRUE)
observeEvent(input$delete, toggle_pic(FALSE), ignoreInit = TRUE)
output$pic <- renderImage({
req(toggle_pic())
outfile <- tempfile(fileext = ".png")
# Generate a png
png(outfile, width=400, height=400)
hist(rnorm(100))
dev.off()
# Return a list
list(src = outfile,
alt = "This is alternate text")
}, deleteFile = TRUE)
}
shinyApp(ui, server)
EDIT: solved with magick - thank you guys a lot :) Updated version in the GitHub repo, for anyone who's interested in the story of the reindeer.
I'm quite new to R and just got to know R Shiny. Yet, I am trying to do a reindeer generator. Basic principle: Combine different layers of images in order to create your personal reindeer. E.g. switch coat colours with buttons while the outlines still stay in place on top. Ideally, it should look something like this in the end (a preview I sketched with GIMP):
preview of the reindeer generator
I manage to get the images into Shiny and switch between two coats with radio buttons, for a start.
However, I don't have a clue how to display the images at the same time at the very same location so the outlines will be an extra layer on top of the coat.
You can see the issue here:
grey coat selected
brown coat selected
Here is my code. Since the file name is partly generated by the radio button input, I left the paths like that.
library(shiny)
ui <- fluidPage(
titlePanel("R-eindeer"),
sidebarLayout(
sidebarPanel(
radioButtons("check1","coat colour", choices = c("grey","brown"))
),
mainPanel(
imageOutput("reindeer_coat"),
imageOutput("reindeer_outline")
)
)
)
server <- function(input,output){
getImage <- reactive({
list(src = paste0("./coat/reindeer_", input$check1, ".png"),
width = 500,
height = 500)
})
output$reindeer_coat <- renderImage({
getImage()
}, deleteFile = FALSE)
output$reindeer_outline <- renderImage({
return(list(src = "./outlines/reindeer_outline.png",
width = 500,
height = 500,
contentType = 'image/png'))
}, deleteFile = FALSE)
}
shinyApp(ui = ui, server = server)
I would appreciate any help. Even with that issue solved, there's still a long way to go - but maybe I can learn quick enough to get stuff done until Christmas ;-)
PS: You can find all the folders, image layers and additional information in the Git repo I just created. Also, even if you can't solve my question: feel free to use the images and pass on the Christmas spirit. Reindeer content should always be free. Link to GitHub repo
As mentioned in the comments, magick can do this for you! Specifically, image_mosaic will overlay images.
Try this out:
library(shiny)
library(magick)
ui <- fluidPage(
titlePanel("R-eindeer"),
sidebarLayout(
sidebarPanel(
radioButtons("check1","coat colour", choices = c("grey","brown"))
),
mainPanel(
imageOutput("reindeer")
)
)
)
server <- function(input,output){
get_image <- function(type, color) {
image_read(file.path(type, paste0(color, ".png")))
}
output$reindeer <- renderImage({
# load the images
coat <- get_image("coat", paste0("reindeer_", input$check1))
outline <- get_image("outlines", "reindeer_outline")
# make the reindeer: overlay in order
reindeer <- c(coat, outline)
# create a temp file
tmpfile <- reindeer %>%
image_mosaic() %>%
image_flatten() %>%
image_write(tempfile(fileext='jpg'), format = 'jpg')
# render the file
return(list(src = tmpfile,
height = 300,
width = 300,
alt = "Your reindeer",
contentType = "image/jpg"))
}, deleteFile = TRUE)
}
shinyApp(ui = ui, server = server)
I'm creating an web-app with Shiny in R. I have a dataset which I plot on the map. Using a checkboxGroupInput widget users are able to select categories they want to see on the map (or not). However, the dataset changes over time and not all categories are always available. To make clear which are available in the current set and which are not, I want to format the available categories as bold.
So far I've not been able to get a checkboxGroupInput widget to show with bold labels by the checkboxes. Is there a way to do that? I want some labels to be bold and others not. Also, using updateCheckboxGroupInput I'm able to change the options (i.e. show only available categories), but that not what I want/need.
I have tried for example:
x <- list("<b>A</b>"=1, "<b>B</b>"=2, "C"=3)
checkboxGroupInput(inputId="test", label="this is a test", choices=x)
But such an approach only displays the formatting tags as text in the user interface. Solutions using the HTML() function of Shiny doesn't seem to work either, or... I'm doing it wrong.
Any ideas?
Here is a simple Shiny interface example using the approach described above (which does not work):
library("shiny")
x <- list("<b>A</b>"=1, "<b>B</b>"=2, "C"=3)
server = function(input, output) {}
ui = fluidPage(
checkboxGroupInput(inputId="test", label="this is a test", choices=x)
)
runApp(list(ui = ui, server = server))
The next example DOES work, but it is a solution when initializing the checkbox group. Enabling the observe function in the server part shows that the same solution does not work for updateCheckboxGroupInput. That makes sense, since that function does not return HTML code. I don't know how to access the output of that update function, or how to solve it otherwise.
library("shiny")
x <- list("<b>A</b>"=1, "<b>B</b>"=2, "C"=3)
y <- list("<b>D</b>"=1, "<b>E</b>"=2, "F"=3)
server = function(input, output, session) {
# observe({
# input$test
# gsub(">", ">", gsub("<", "<", updateCheckboxGroupInput(session, "test", choices=y)))
# })
}
ui = fluidPage(
gsub(">", ">", gsub("<", "<", checkboxGroupInput(inputId="test", label="this is a test", choices=x)))
)
runApp(list(ui = ui, server = server))
For now I found a solution. Not really elegant, and probably prone to errors, but it works. I found out that the < and > characters are escaped for HTML purposes by the htmltools function called escapeHtml. By temporarily replacing that function before the updateCheckboxGroupInput is called, by a dummy function, the text is not escaped. After the updateCheckboxGroupInput is called, htmlEscape of course needs to be restored.
An example that works. After launching the app, you need to check the first box to see it work:
library("shiny")
x <- list("<b>A</b>"=1, "<b>B</b>"=2, "C"=3)
y <- list("<b>D</b>"=1, "<b>E</b>"=2, "F"=3)
server = function(input, output, session) {
observe({
value <- input$test
if (length(value) > 0 && value == 1) {
## save htmlEscape function and replace htmlEscape
saved.htmlEscape <- htmltools::htmlEscape
assignInNamespace("htmlEscape", function(x, attribute) return(x), "htmltools")
updateCheckboxGroupInput(session, "test", label="OK", choices=y)
## restore htmlEscape function
assignInNamespace("htmlEscape", saved.htmlEscape, "htmltools")
}
})
}
ui = fluidPage(
checkboxGroupInput(inputId="test", label="this is a test", choices=x)
)
runApp(list(ui = ui, server = server))
I'm trying to take my Shiny apps and break them into smaller files to make collaborating via git with coworkers much easier. This question helped me figure out how to source() in files to my server.r by using source(...,local=T). Now I'm trying to do the same thing with my UI layer.
Consider this toy Shiny app:
library(shiny)
ui <- bootstrapPage(
plotOutput("test"),
numericInput("n","Number of points",value=100,min=1)
)
server <- function(input, output, session) {
output$test = renderPlot({
x = rnorm(input$n)
y = rnorm(input$n)
plot(y~x)
})
}
shinyApp(ui, server)
This app does what you would expect, one overly-wide graph of 100 random data points. Now, what if I want to move just the plotOutput to a separate file (the real use case is in moving whole tabs of UI to separate files). I make a new file called tmp.R and it has:
column(12,plotOutput("test"),numericInput("n","Number of points",value=100,min=1))
The reason for wrapping it in the column statement is because the comma's can't just be hanging out. Now I update my UI to:
library(shiny)
ui <- bootstrapPage(
source("tmp.R",local=T)
)
server <- function(input, output, session) {
output$test = renderPlot({
x = rnorm(input$n)
y = rnorm(input$n)
plot(y~x)
})
}
shinyApp(ui, server)
Now, the word "TRUE" is just hanging out at the bottom of the page.
How do I eliminate this word from showing up? Why is it there?
Try source("tmp.R",local = TRUE)$value maybe