I have a static png file of several thousand pixels height and width, and I would like to visualize parts of if by interactively zooming in and out of it in an RStudio Shiny website. What is the best way to have this working in a way that is relatively well performing?
You can use any of a number of javascript libraries. I chose https://github.com/elevateweb/elevatezoom to use in this example:
library(shiny)
runApp(
list(ui = fluidPage(
tags$head(tags$script(src = "http://www.elevateweb.co.uk/wp-content/themes/radial/jquery.elevatezoom.min.js")),
actionButton("myBtn", "Press Me for zoom!"),
uiOutput("myImage"),
singleton(
tags$head(tags$script('Shiny.addCustomMessageHandler("testmessage",
function(message) {
$("#myImage img").elevateZoom({scrollZoom : true});
}
);'))
)
)
, server = function(input, output, session){
output$myImage <- renderUI({
img(src = "http://i.stack.imgur.com/RWd7T.png?s=128&g=1", "data-zoom-image" ="http://i.stack.imgur.com/RWd7T.png?s=128&g=1")
})
observe({
if(input$myBtn > 0){
session$sendCustomMessage(type = 'testmessage',
message = list())
}
})
}
)
)
Related
I am trying to increase and decrease the number of UI elements based on user input. This MRE code kind of works but it is leaving behind the UI label when I use removeUI, which I did not expect. Any ideas on how to make the label go away along with the input box?
## Only run this example in interactive R sessions
if (interactive()) {
# Define UI
ui <- fluidPage(
numericInput(inputId = "assessors",label = "Number of Assessors",value = 1,min = 1,step = 1),
textInput(inputId = "assessor1",label = "Assessor 1 Columns")
)
# Server logic
server <- function(input, output, session) {
tot_app<-0
observeEvent(input$assessors, {
num<-input$assessors
if(num>tot_app){#add
adds<-seq(tot_app+1,num)
for(i in adds){
here<-paste0("#assessor",i-1)
insertUI(
selector = here,
where = "afterEnd",
ui = textInput(paste0("assessor", i),
paste0("Assessor ",i," columns"))
)
}
tot_app<<-num
} else if(num<tot_app){#subtract
subs<-seq(num+1,tot_app)
for(i in subs){
removeUI(selector = paste0("#assessor",i))
}
tot_app<<-num
}
})
}
# Complete app with UI and server components
shinyApp(ui, server)
}
As in the help example, it works if you use use this syntax:
removeUI(selector = paste0("div:has(> #assessor",i,")"))
i have some problem with fileInput for R Shiny. Size limit is set to 5MB per default.
Since the files i have to work with are very large (>50GB), I only need the datapath and or name of the file. Unfortunatly fileInput wants to upload the complete file or at least it is loading the file somehow and tells me that the file is too big after i have reached the 5MB limit.
How can I only hand over the path to my app without uploading the file?
ui.R
library(shiny)
# Define UI ----
shinyUI(fluidPage(
h1("SAS Toolbox"),
tabsetPanel(
tabPanel("SASFat",
sidebarPanel(h2("Input:"),
actionButton("runSASFat","Run Job",width="100%",icon("paper-plane"),
style="color: #fff; background-color: #337ab7; border-color: #2e6da4"),
wellPanel(
#tags$style(".shiny-file-input-progress {display: none}"),
fileInput("FEInp","Pfad FE input Deck:"),
fileInput("FERes","Pfad FE Results:")
),
wellPanel(
checkboxGroupInput("options1","Auswertung:",c("Grundmaterial","Schweissnähte")),
conditionalPanel(condition="$.inArray('Schweissnähte',input.options1) > -1",
sliderInput("filter", "Filter:", 0.75, min = 0, max = 1))
),
wellPanel(
radioButtons("solver", "Solver:", c("Ansys","Abaqus", "Optistruct")),
conditionalPanel(condition="input.solver == 'Ansys'",selectInput("lic", "Lizenz",c("preppost","stba","meba")))
),
wellPanel(
checkboxGroupInput("options2","Optionen:",c("Schreibe LCFiles"))
)
),
mainPanel(br(),h2("Output:"),width="30%")
),
tabPanel("Nietauswertung"),
tabPanel("Spannungskonzept EN12663")
)
))
server.R
# Define server logic ----
shinyServer(function(input, output) {
observeEvent(input$runSASFat, {
FEInp <- input$FEInp
FERes <- input$FERes
opt1 <- input$options1
opt2 <- input$options2
filter <- input$filter
solver <- input$solver
lic <- input$lic
write(c(FEInp$datapath,FERes$datapath,opt1,opt2,filter,solver,lic),"ghhh.inp")
})
})
Thanks in advance
Michael
Thanks for the example #MichaelBird. I adapted your code to let users cancel the request without choosing a file (your app crashed after canceling):
This by the way only works on the PC hosting the shiny app.
library(shiny)
ui <- fluidPage(
titlePanel("Choosing a file example"),
sidebarLayout(
sidebarPanel(
actionButton("filechoose",label = "Pick a file")
),
mainPanel(
textOutput("filechosen")
)
)
)
server <- function(input, output) {
path <- reactiveVal(value = NULL)
observeEvent(input$filechoose, {
tryPath <- tryCatch(
file.choose()
, error = function(e){e}
)
if(inherits(tryPath, "error")){
path(NULL)
} else {
path(tryPath)
}
})
output$filechosen <- renderText({
if(is.null(path())){
"Nothing selected"
} else {
path()
}
})
}
shinyApp(ui = ui, server = server)
An alternative way would be to increase the maximum file size for uploads:
By default, Shiny limits file uploads to 5MB per file. You can modify
this limit by using the shiny.maxRequestSize option. For example,
adding options(shiny.maxRequestSize = 30*1024^2) to the top of app.R
would increase the limit to 30MB.
See this RStudio article.
Here is an example of using file.choose() in a shiny app to obtain the local path of the file (and hence the file name):
library(shiny)
ui <- fluidPage(
# Application title
titlePanel("Choosing a file example"),
sidebarLayout(
sidebarPanel(
actionButton("filechoose",label = "Pick a file")
),
mainPanel(
textOutput("filechosen")
)
)
)
server <- function(input, output) {
path <- reactiveValues(
pth=NULL
)
observeEvent(input$filechoose,{
path$pth <- file.choose()
})
output$filechosen <- renderText({
if(is.null(path$pth)){
"Nothing selected"
}else{
path$pth
}
})
}
# Run the application
shinyApp(ui = ui, server = server)
Is this what you're after?
I would ask. Does Shiny do like always-refreshing the code after input ?
First I code this in ui :
box( ##title="Quality Attributes",
selectInput("att_ViewChart", width = '100%',label="Quality Attributes",
##multiple = TRUE,
choices=list(
"-",
"Suitability",
"Security",
)
)
),
dataTableOutput("tabelstatus")
Then I code this in server :
server = function(input, output) {
withProgress(message = "AAAAA",{
DateStatus_Sui<-c(1,2,3,4,NA,5,6,NA,7)
TimeStatus_Sui<-c(11,22,33,44,NA,55,66,NA,88)
status_Sui<-c(11,22,44,55,66,77,88)
jumlah<-7
})
if(input$att_ViewChart=="Suitability"){
Date<-DateStatus_Sui[!is.na(DateStatus_Sui)]
Time<-TimeStatus_Sui[!is.na(TimeStatus_Sui)]
Status<-status_Sui
Observation<-1:jumlah
#output
tabelstatus<-data.frame(Observation,Date,Time,Status)
output$tabelstatus<-renderDataTable(tabelstatus)
}
I hope when I run the app. Shiny will process the code (shown by progress bar 'AAAAA') And after that, if I choose Suitability it will do a little more process and then show the table . But I found that the progress bar appears again. Seems to me it re-runs the code from the beginning. How to fix this? Thank you
In the abscence of a fully reproducible example, I'm guessing this is what you're trying to do (i.e, make the table reactive according to your input$att_ViewChart):
library(shiny)
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(),
dashboardBody(
box( selectInput("att_ViewChart", width = '100%',label="Quality Attributes",
choices=c("-","Suitability","Security"))),
dataTableOutput("tablestatus")
)
)
server = function(input, output) {
withProgress(message = "AAAAA",{
DateStatus_Sui<-c(1,2,3,4,NA,5,6,NA,7)
TimeStatus_Sui<-c(11,22,33,44,NA,55,66,NA,88)
status_Sui<-c(11,22,44,55,66,77,88)
jumlah<-7
})
## make your table reactive on `input$att_ViewChart`
output$tablestatus <- renderDataTable({
if(input$att_ViewChart=="Suitability"){
Date<-DateStatus_Sui[!is.na(DateStatus_Sui)]
Time<-TimeStatus_Sui[!is.na(TimeStatus_Sui)]
Status<-status_Sui
Observation<-1:jumlah
tablestatus <- data.frame(Observation,Date,Time,Status)
}else{
tablestatus <-data.frame()
}
return(tablestatus)
})
}
shinyApp(ui = ui, server = server)
I have a question about updating a text output in a shiny app.
In an observer, I make several computations, and, between each of them, I want to show informations in a text output.
I tried several things, but the only thing it is showing is the last information :
library(shiny)
ui <- fluidPage(
headerPanel("Hello !"),
mainPanel(
actionButton("bouton", "Clic !"),
textOutput("texte")
)
)
server <- function(input,output, session){
observeEvent(input$bouton, {
output$texte = renderText("Initialization...")
Sys.sleep(1)
output$texte = renderText("Almost ready...")
Sys.sleep(3)
output$texte = renderText("Ok !")
})
}
runApp(list(ui=ui,server=server), launch.browser = TRUE)
Or :
library(shiny)
ui <- fluidPage(
headerPanel("Hello !"),
mainPanel(
actionButton("bouton", "Clic !"),
textOutput("texte")
)
)
server <- function(input,output, session){
rv = reactiveValues()
rv$mess = ""
observeEvent(input$bouton, {
rv$mess = "Initialization..."
Sys.sleep(1)
rv$mess = "Almost ready..."
Sys.sleep(3)
rv$mess = "Ok !"
})
observe({
output$texte <<- renderText(rv$mess)
})
}
runApp(list(ui=ui,server=server))
Edit : in these two examples, it shows nothing until the last message "OK !"
Where am I wrong ?
Thanks for your help !
Thanks to Eugene, this is my working piece of code (server only) :
server <- function(input,output, session){
rv = reactiveValues()
rv$mess = ""
observeEvent(input$bouton, {
withProgress({
setProgress(message = "Initialization...")
Sys.sleep(1)
setProgress(message = "Almost ready...")
Sys.sleep(3)
setProgress(message = "Ok !")
Sys.sleep(2)
})
})
}
You might consider achieving this with shiny's progress indicators by:
wrapping everything in your observer in withProgress, and
using setProgress( message = "some message" ) where you use rv$mess and output$texte
However, the progress indicator will show up in the top-right (or elsewhere if you modify the css) and not in your output box.
http://shiny.rstudio.com/articles/progress.html
In my R shiny app, I would like to adjust the height of my d3heatmap (see package d3heatmap) as a function of the number of rows of my data frame; there is an argument height in the d3heatmapOutput to specify that.
However, my data frame is computed on the server side, so how can I pass its number of rows from the server side to the ui side?
Here is the example reflecting what I would like to do:
runApp(shinyApp(
ui = fluidRow(
selectInput("am", "Automatic (0) or manual (1) transmission?",
choices = c(0,1)),
# How can I have the 'height' argument equal to 'output$height'?
# I cannot use 'textOutput("height")' since it gives html code, not a value.
d3heatmapOutput("heatmap", height = "400px")
),
server = function(input, output) {
mtcars2 = reactive({
mtcars[which(mtcars$am == input$am),]
})
output$height <- renderText({
paste0(15*nrow(mtcars2()), "px")
})
output$heatmap <- renderD3heatmap({
d3heatmap(mtcars2(), scale = "column")
})
}
))
Thank you.
You can use uiOutput in ui.R and renderUI in server.R to dynamically add the d3heatmapOutput:
library(shiny)
library(d3heatmap)
runApp(shinyApp(
ui = fluidRow(
selectInput("am", "Automatic (0) or manual (1) transmission?",
choices = c(0,1)),
uiOutput("ui_heatmap")
),
server = function(input, output) {
mtcars2 = reactive({
mtcars[which(mtcars$am == input$am),]
})
output$ui_heatmap <- renderUI({
d3heatmapOutput("heatmap", height = paste0(15*nrow(mtcars2()), "px"))
})
output$heatmap <- renderD3heatmap({
d3heatmap(mtcars2(), scale = "column")
})
}
))
You can then set the height of the heatmap in the server side of the app.