I have a Shiny app with a Plotly plot of time-series data. I want the user to be able to pan the x (time) axis, but keeping a consistent window of one day. To do this, I need to get the current x-axis range after each resize.
Why am I not just using a rangeSlider? Because I have about 25,000 data points, and using a rangeSlider requires loading all of the data into the plot when the app is initialized, which slows things down considerably.
You can use event_data with plotly_relayout. The official plotly documentation has a demonstration.
Here's a small example showing the xlimits from a plotly timeseries. Note that plotly_relayout will return NULL when the plot is initially rendered, dimensions of plot upon user resizing page, and TRUE when user autoscales plot by double-clicking.
library(shiny)
library(plotly)
ui <- fluidPage(
fluidRow(column(width = 6,
br(),
plotlyOutput("plot")),
column(width = 6,
br(), br(),
htmlOutput("xlims"),
br(),
h4("Verbatim plotly `relayout` data"),
verbatimTextOutput("relayout")))
)
server <- function(input, output, session) {
# create the plotly time series
output$plot <- renderPlotly({
today <- Sys.Date()
tm <- seq(0, 600, by = 10)
x <- today - tm
y <- rnorm(length(x))
p <- plot_ly(x = ~x, y = ~y, mode = 'lines',
text = paste(tm, "days from today"), source = "source")
})
# print the xlims
output$xlims <- renderText({
zoom <- event_data("plotly_relayout", "source")
# if plot just rendered, event_data is NULL
# if user double clicks for autozoom, then zoom$xaxis.autorange is TRUE
# if user resizes page, then zoom$width is pixels of plot width
if(is.null(zoom) || names(zoom[1]) %in% c("xaxis.autorange", "width")) {
xlim <- "default of plot"
} else {
xmin <- zoom$`xaxis.range[0]`
xmax <- zoom$`xaxis.range[1]`
xlim <- paste0("Min: ", xmin, "<br>Max: ", xmax)
}
paste0("<h4>X-Axis Limits:</h4> ", xlim)
})
# print the verbatim event_data for plotly_relayout
output$relayout <- renderPrint({event_data("plotly_relayout", "source")})
}
shinyApp(ui, server)
Related
I am trying to make a shiny app in R using Plotly plots.
I am trying to create zoom functionality in the backend of a shiny app, responsive to a click event on a plotly graph (i.e. when a point is clicked, zoom in on that point). However, the only solution I have found so far is to completely re-layout the plotly object with new view ranges.
For large plots, this is incredibly slow because shiny re-renders the entire plot, and is much slower than plotly's built-in zoom functionality on the front end (the plotly user interface buttons at the top right) when the number of data points is large. Is there a way to use the plotly zoom functionality in the backend so that the whole plotly object doesn't have to re-render to zoom?
Example:
library(plotly)
library(shiny)
ui <- fluidPage(
plotlyOutput("scatter")
)
server <- function(input, output) {
zoom_vals = reactiveValues(xrange=NA,yrange=NA)
# Plot scatter plot
output$scatter <- renderPlotly({
data <- data.frame(x=sample.int(1000,100), y = sample.int(1000,100))
x_axis = list(range = zoom_vals$xrange)
y_axis = list(range = zoom_vals$yrange)
plot_ly(data, x = ~x, y = ~y) %>% layout(xaxis=x_axis, yaxis=y_axis)
})
# Catch plot click
observeEvent(event_data("plotly_click"),{
d<-event_data("plotly_click")
zoom_vals$xrange <- c((d$x- 1),(d$x+ 1))
zoom_vals$yrange <- c((d$y- 1),(d$y- 1))
})
}
shinyApp(ui, server)
You can modify (no re-rendering) an exisiting plotly object in shiny via plotlyProxyInvoke.
To change the axis range we'll need the relayout method:
library(plotly)
library(shiny)
ui <- fluidPage(plotlyOutput("scatter"))
server <- function(input, output) {
# Plot scatter plot
output$scatter <- renderPlotly({
data <- data.frame(x = sample.int(1000, 100), y = sample.int(1000, 100))
plot_ly(data, x = ~ x, y = ~ y, type = "scatter", mode = "markers")
})
scatterProxy <- plotlyProxy("scatter")
# Catch plot click
observeEvent(event_data("plotly_click"), {
d <- event_data("plotly_click")
xrange <- c((d$x - 100), (d$x + 100))
yrange <- c((d$y - 100), (d$y + 100))
plotlyProxyInvoke(scatterProxy, "relayout", list(xaxis = list(range = xrange), yaxis = list(range = yrange)))
})
}
shinyApp(ui, server)
In ShinyApp, I want to plot a graph whose name has an interactive input value. So in the ui.R side, the user chooses an input value from 0, 1 or 2. And in the server.R side, I want the App to plot a graph whose name is either pl0, pl1 or pl2. That is to say, if the user chooses 0 as an input value, the App plots a graph pl0, so does the same for pl1 for input 1, and for pl2 and input 2. I am using plotly library for plotting graphs.
I have tried print(), plot(), return(), but neither of them worked.
Any solution or advice would be appreciated. Thank you very much!
Here is my ui.R
library(shiny)
shinyUI(fluidPage(
# Application title
titlePanel("Star Cluster Simulations"),
# Sidebar with a slider input for time
sidebarLayout(
sidebarPanel(
sliderInput(inputId = "time",
label = "Select time to display a snapshot",
min = 0,
max = 2,
value = 0)
),
# Show a plot of the generated distribution
mainPanel(
plotlyOutput("distPlot")
)
)
))
And here is my server.R
library(shiny)
library(plotly)
# load data
for(i in 0:2) {
infile <- paste0("Data/c_0", i, "00.csv")
a <- read.csv(infile)
b <- assign(paste0("c_0", i, "00"), a)
names(a) <- paste0("c_0", i, "00")
pl <- plot_ly(b, x = ~x, y = ~y, z = ~z, color = ~id) %>%
add_markers() %>%
layout(scene = list(xaxis = list(title = 'x'),
yaxis = list(title = 'y'),
zaxis = list(title = 'z')))
assign(paste0("pl", i), pl)
}
# shinyServer
shinyServer(function(input, output) {
output$distPlot <- renderPlotly({
# this doesn't work
print(paste0("pl", input$time))
})
})
I can't test this since your question isn't reproducible (i.e. doesn't include data), but one way to switch between text values (i.e. the values returned from Shiny inputs) and R objects is by making a reactive expression that uses the switch function. You can call the reactive expression (in the case below, plot.data()) inside renderPlotly (or any other render function) to switch between datasets.
shinyServer(function(input, output) {
plot.data <- reactive({
switch(paste0("pl", input$time),
"pl0" = pl0,
"pl1" = pl1,
"pl2" = pl2)
})
output$distPlot <- renderPlotly({
plot.data()
})
})
I want to see if I can create a line chart in a Shiny app that:
Draws a vertical line through, and
Labels
the data point closest to the x-value of the mouse hover point on each geom_line(), something like a combination of these two charts:
Vertical Line through Mouse Hover Point
Data Label for Point at x-value of Mouse Hover Point
This is my first attempt at making my ggplot graph interactive. I've run into some strange behavior that I'm hoping someone can explain to me. My reproducible example is below. It creates two series and plots them with geom_line(). I'm a few steps from my desired endstate (explained above), but my immediate questions are:
How can I get rid of the vertical line when the mouse is outside the bounds of the plot? Everything I've tried (like passing NULL to xintercept if input$plot_hover is NULL) causes the plot to error out.
Why, when the mouse is inside the bounds of the plot, does the geom_vline bounce all over the place? Why does it go back to x = 0 when the mouse stops moving?
Thank You.
library(shiny)
library(ggplot2)
library(tidyr)
library(dplyr)
ui <- fluidPage(
titlePanel("Interactive Plot"),
sidebarLayout(
sidebarPanel(
sliderInput("points",
"Number of points:",
min = 10,
max = 50,
value = 25),
textOutput(outputId = "x.pos"),
textOutput(outputId = "y.pos"),
textOutput(outputId = "num_points")
),
mainPanel(
plotOutput("distPlot", hover = hoverOpts(id = "plot_hover",
delay = 100,
delayType = "throttle")))))
server <- function(input, output) {
# Create dataframe and plot object
plot <- reactive({
x <- 1:input$points
y1 <- seq(1,10 * input$points, 10)
y2 <- seq(20,20 * input$points, 20)
df <- data.frame(x,y1,y2)
df <- df %>% gather(key = series, value = value, y1:y2)
ggplot(df,aes(x=x, y=value, group=series, color=series)) +
geom_line() +
geom_point() +
geom_vline(xintercept = ifelse(is.null(input$plot_hover),0,input$plot_hover$x))
})
# Render Plot
output$distPlot <- renderPlot({plot()})
# Render mouse position into text
output$x.pos <- renderText(paste0("x = ",input$plot_hover$x))
output$y.pos <- renderText(paste0("y = ",input$plot_hover$y))
}
# Run the application
shinyApp(ui = ui, server = server)
A suggested solution to fix the issue is to use reactiveValues and debounce instead of throttle.
The issue
distPlot depends on the input$plot_hover$x which changes continuously, or gets reset to null.
Suggested solution
use values <- reactiveValues(loc = 0) to hold the value of input$plot_hover$x and initiate it with zero or any value you want.
use observeEvent, to change the value of loc whenever input$plot_hover$x changes
observeEvent(input$plot_hover$x, {
values$loc <- input$plot_hover$x
})
use debounce instead of throttle to suspend events while the cursor is moving.
I am printing input$plot_hover$x and values$loc to show you the difference.
Note: I made some changes in the code, just to break things down.
library(shiny)
library(ggplot2)
library(tidyr)
library(dplyr)
library(shinySignals)
ui <- fluidPage(
titlePanel("Interactive Plot"),
sidebarLayout(
sidebarPanel(
sliderInput("points",
"Number of points:",
min = 10,
max = 50,
value = 25),
textOutput(outputId = "x.pos"),
textOutput(outputId = "y.pos"),
textOutput(outputId = "num_points")
),
mainPanel(
plotOutput("distPlot", hover = hoverOpts(id = "plot_hover",
delay = 100,
delayType = "debounce")))))
server <- function(input, output) {
# Create dataframe and plot object
plot_data <- reactive({
x <- 1:input$points
y1 <- seq(1,10 * input$points, 10)
y2 <- seq(20,20 * input$points, 20)
df <- data.frame(x,y1,y2)
df <- df %>% gather(key = series, value = value, y1:y2)
return(df)
})
# use reactive values -------------------------------
values <- reactiveValues(loc = 0)
observeEvent(input$plot_hover$x, {
values$loc <- input$plot_hover$x
})
# if you want to reset the initial position of the vertical line when input$points changes
observeEvent(input$points, {
values$loc <- 0
})
# Render Plot --------------------------------------
output$distPlot <- renderPlot({
ggplot(plot_data(),aes(x=x, y=value, group=series, color=series))+
geom_line() +
geom_point()+
geom_vline(aes(xintercept = values$loc))
})
# Render mouse position into text
output$x.pos <- renderText(paste0("values$loc = ",values$loc))
output$y.pos <- renderText(paste0("input$plot_hover$x = ",input$plot_hover$x ))
}
# Run the application
shinyApp(ui = ui, server = server)
I have a randomly generated data.frame. The user can modify a slider to choose the number of points. Then I plot this data.frame.
I want to add a button than when clicked, it performs a modification in the previous randomly generated data.frame (but without regenerating the data.frame). The modification is a voronoid relaxation, and it should be performed once per each time the button is clicked and the graph generated.
Until now, I have not achieved anything similar...
ui.R
library(shiny)
# Define UI for application that draws a histogram
shinyUI(fluidPage(
# Application title
titlePanel("Map Generator:"),
# Sidebar with a slider input for the number of bins
sidebarLayout(
sidebarPanel(
p("Select the power p to generate 2^p points."),
sliderInput("NumPoints",
"Number of points:",
min = 1,
max = 10,
value = 9),
actionButton("GenPoints", "Generate"),
actionButton("LloydAlg", "Relaxe")
),
# Show a plot of the generated distribution
mainPanel(
plotOutput("distPlot",height = 700, width = "auto")
)
)
))
server.R
library(shiny)
library(deldir)
shinyServer(function(input, output) {
observeEvent(input$NumPoints,{
x = data.frame(X = runif(2^input$NumPoints,1,1E6),
Y = runif(2^input$NumPoints,1,1E6))
observeEvent(input$LloydAlg, {
x = tile.centroids(tile.list(deldir(x)))
})
output$distPlot <- renderPlot({
plot(x,pch = 20,asp=1,xlim=c(0,1E6),ylim = c(0,1E6))
})
})
})
Of course there is something that I must be doing wrong, but I am quite new into shiny I can't figure it out what I am doing wrong...
This should work (even though I am pretty sure this could be improved):
shinyServer(function(input, output) {
library(deldir)
data = data.frame(
X = runif(2^9, 1, 1E6),
Y = runif(2^9, 1, 1E6)
)
rv <- reactiveValues(x = data)
observeEvent(input$GenPoints, {
rv$x <- data.frame(
X = runif(2^input$NumPoints,1,1E6),
Y = runif(2^input$NumPoints,1,1E6)
)
})
observeEvent(input$LloydAlg, {
rv$x = tile.centroids(tile.list(deldir(rv$x)))
})
output$distPlot <- renderPlot({
plot(rv$x,pch = 20,asp=1,xlim=c(0,1E6),ylim = c(0,1E6))
})
})
So first I initialize the points to plot. I use runif(2^9, 1, 1E6) because the starting value of the sliderInput is 9 all the time.
I also removed the observeEvent from the sliderInput and moved it to the GenPoints actionButton.
I've been working on an animated slider project in Shiny and I nearly have what I am after, but not quite. Instead of displaying each successive graph in the animated sequence, it appears to be showing the graph with all of the data (non sequenced). I'm not quite sure where my error is but I suspect it is in the reactive function call or the renderPlot function call in the server section. I've tried searching the Web and I've tried placing different code blocks in different locations but I can not seem to get the animation to work in Shiny. Eventually I want to change the numeric months (1,2,3...) to date objects for more clarity but I'll tackle that one after the animation is working.
Please note - I HAVE been able to get a successful motion chart for this data using googleVic, gvisMotionChart and Shiny but I found with that approach I do not have control of the bubble chart colors or the bubble size (I want a constant size that is much smaller than google's bubble chart default size due to overlap). So, I am hoping to accomplish this animation with R's base graphics or with ggplot.
Here is small set of data to represent what I am using:
d1 <- data.table( id = 1:21,
Region = rep(c("R1","R2","R3"), each=7),
Month = 1,
Spend = round(runif(21,100,500)),
Age = round(runif(21,72,100)),
Color = rep(c("#E69F00","#D55E00","#009E73"),each=7))
d2 <- copy(d1)
d2[,Month:=Month+1][,Age:=Age+1][,Spend:=Spend+round(runif(21,0,4))]
d3 <- copy(d2)
d3[,Month:=Month+1][,Age:=Age+1][,Spend:=Spend+round(runif(21,0,4))]
d4 <- copy(d3)
d4[,Month:=Month+1][,Age:=Age+1][,Spend:=Spend+round(runif(21,0,4))]
d5 <- copy(d4)
d5[,Month:=Month+1][,Age:=Age+1][,Spend:=Spend+round(runif(21,0,4))]
d6 <- copy(d5)
d6[,Month:=Month+1][,Age:=Age+1][,Spend:=Spend+round(runif(21,0,4))]
d7 <- copy(d6)
d7[,Month:=Month+1][,Age:=Age+1][,Spend:=Spend+round(runif(21,0,4))]
d8 <- copy(d7)
d8[,Month:=Month+1][,Age:=Age+1][,Spend:=Spend+round(runif(21,0,4))]
dat <- rbindlist(list(d1,d2,d3,d4,d5,d6,d7,d8))
Here is an animated GIF to show what the animation would look like with base graphics
saveGIF({
for(i in 1:8){
plot(dat[Month==i,Age],dat[Month==i,Spend],col=dat[Month==i,Color],
pch=16, xlim=c(min(dat$Age)*.95,max(dat$Age)*1.1),
ylim=c(min(dat$Spend)*.95,max(dat$Spend)*1.1),
xlab="Age in Months",ylab="Dollars", las=1, cex.axis=.7)
legend("topright",inset=.05,c("Reg 1","Reg 2","Reg 3"),
pch=16,col=c("#E69F00","#D55E00","#009E73"),
cex=.8)
ani.pause()
}
}, interval = 0.25, ani.width = 750, ani.height = 550)
This is my current nonworking Shiny code
library(shiny)
library(ggplot2)
# Shiny app with slider and animation
# ui section
ui = fluidPage(
# Title
titlePanel("Spend vs Age by Region"),
# Sidebar with slider and controls for animation
sidebarLayout(
# sidebar with slider
sidebarPanel(
# Slider with looping
sliderInput("theMonth", "Month", 1, 8, 1, step = 1,
animate=animationOptions(interval=1000, loop = T,
playButton = T, pauseButton = T))
),
# Show the animated graph
mainPanel(
plotOutput(outputId="case_age_plot")
)
)
)
# server section
server = function(input, output) {
# Reactive expression to create data frame and graph
aniGraph <- reactive({
# subset the data frame into the portion that has the data for the
# graph in the animation sequence
dat[Month==input$theMonth,]
# create the graph
plot(dat[,Age],dat[,Spend],col=dat[,Color],
pch=16, xlim=c(min(dat$Age)*.95,max(dat$Age)*1.1),
ylim=c(min(dat$Spend)*.95,max(dat$Spend)*1.1),
xlab="Age in Months",ylab="Dollars", las=1, cex.axis=.7)
legend("topright",inset=.05,c("Reg 1","Reg 2","Reg 3"),
pch=16,col=c("#E69F00","#D55E00","#009E73"),cex=.8)
})
# Show the graph
output$case_age_plot <- renderPlot({
aniGraph()
})
}
# run the app
runApp(list(ui = ui, server = server))
If anyone has a solution or thoughts I would be grateful.
the problem was that you didn't save the subset of dat. I slightly modified your code to get the same animation as in gif animation.
library(shiny)
library(ggplot2)
# Shiny app with slider and animation
# ui section
ui = fluidPage(
# Title
titlePanel("Spend vs Age by Region"),
# Sidebar with slider and controls for animation
sidebarLayout(
# sidebar with slider
sidebarPanel(
# Slider with looping
sliderInput("theMonth", "Month", 1, 8, 1, step = 1,
animate=animationOptions(interval=1000, loop = T,
playButton = T, pauseButton = T))
),
# Show the animated graph
mainPanel(
plotOutput(outputId="case_age_plot")
)
)
)
# server section
server = function(input, output) {
# Reactive expression to create data frame and graph
aniGraph <- reactive({
# subset the data frame into the portion that has the data for the
# graph in the animation sequence
# Save subset of 'dat' and pass it to the plot
dat_sub <- dat[Month==input$theMonth,]
# create the graph
plot(dat_sub[,Age],dat_sub[,Spend],col=dat_sub[,Color],
pch=16, xlim=c(min(dat$Age)*.95,max(dat$Age)*1.1),
ylim=c(min(dat$Spend)*.95,max(dat$Spend)*1.1),
xlab="Age in Months",ylab="Dollars", las=1, cex.axis=.7)
legend("topright",inset=.05,c("Reg 1","Reg 2","Reg 3"),
pch=16,col=c("#E69F00","#D55E00","#009E73"),cex=.8)
})
# Show the graph
output$case_age_plot <- renderPlot({
aniGraph()
})
}
# run the app
runApp(list(ui = ui, server = server))
I wanted my graph to just animate without a slider. With a duckduck search I found Dan Mohamed's article at https://nhsrcommunity.com/animating-a-graph-over-time-in-shiny/ which pointed me to reactiveTimer(). Here is a condensed version of my implementation.
propagator <- 0
ui <- fluidPage( . . . )
server <- function(input, output) {
autoInvalidate <- reactiveTimer()
observe( {autoInvalidate()} )
output$orb <- renderPlot({
autoInvalidate()
propagator <<- propagator + 1
. . .
})
}