I have a problem with the joined plot of an updatable line and static markers in R plotly. The line plot is updated via a drop down menu button, which works well on its own. The additional dots in the add_markers function are also correct when the plot is first initialized.
But after the first update, the markers are cut off (to the left side of the plot where the line starts) and remaining markers are modified (y values are different to initial ones).
For the example here the button function is simplified, but the result shows the same strange behavior.
`
sample_df <- tibble::tibble(quarter_date = rep(c("2022-06-30","2022-09-30","2022-12-31"),3),
forecast_value = runif(9,min = 10,max = 16),
forecast_date = c(rep("2022-07-23",3),rep("2022-08-26",3),rep("2022-09-15",3)))
marks = tibble::tibble(dates = c("2022-05-21","2022-06-15","2022-07-02","2022-07-26","2022-08-27"),
values = c(11,13,12,15,14))
create_buttons <- function(df, date_id) {
lapply(
date_id,
FUN = function(date_id,df) {
button <- list(
method = 'restyle',
args = list('y', list(df %>%
dplyr::filter(forecast_date == date_id) %>%
dplyr::pull(forecast_value))),
label = sprintf('Forecast # %s', date_id)
)
},
df
)
}
plotly::plot_ly(x = ~quarter_date) %>%
plotly::add_trace(data = sample_df %>%
dplyr::filter(forecast_date == max(forecast_date)),
#x = ~period_date,
y = ~forecast_value,
type = 'scatter',
mode = 'markers+lines',
name = 'forecasts') %>%
plotly::layout(
title = "Drop down menue",
yaxis = list(title = "y"),
updatemenus = list(
list(
y =1,
x = 0.9,
buttons = create_buttons(sample_df, unique(sample_df$forecast_date))
)
)) %>%
plotly::add_markers(data = marks,
x = ~dates,
y = ~values)
`
I have tried to set a wide xrange, used a second y2 axis and different approaches in the button calculation but nothing works as intended.
Does anyone have a clue why the add_markers is not working correctly after updating the line plot? Any ideas are highly appreciated!
Adding markers aren't the issue. The issue comes from the restyle. When you restyle the plot without designating that you only meant to change one trace, you changed all traces.
The solution is actually quite simple, you just need one more argument in your args call-- the trace number in a list: list(0) in this case. I've commented out your original args call, so you can see the change.
To make this repeatable, I added set.seed(46) before the creation of sample_df.
create_buttons <- function(df, date_id) {
lapply(
date_id,
FUN = function(date_id, df) {
button <- list(
method = 'restyle',
args = list('y', list(df %>% filter(forecast_date == date_id) %>%
pull(forecast_value)), list(0)),
# args = list('y', list(df %>%
# filter(forecast_date == date_id) %>%
# pull(forecast_value))),
label = sprintf('Forecast # %s', date_id)
)
},
df
)
}
Now when you run your plot, you will see that your marker data remains visible.
I have a xts object that has dates as values, I'm using ggplot2 and shiny app for show the result.
But I want to change the default names of the tooltip when the mouse is on the line.
From:
index: 2020-03-19
value: 70
To:
Date: 2020-03-19
Cantidad: 70
Code for XTS:
data<-rnorm(10)
dates <- seq(as.Date("2016-01-01"), length =10, by = "days")
xtsMyData <- xts(x = data, order.by = dates)
Plot:
r <- ggplot(tidy(xtsMyData), aes(x=index,y=value, color=series, type = 'scatter', mode = 'lines')
) + geom_line(size=2)
The result is:
I'm triyng the following code:
r <- ggplot(tidy(xtsMyData), aes(x=index,y=value, color=series, type = 'scatter', mode = 'lines')
) + geom_line(size=2)
return(ggplotly(r, tooltip = **c("x","y", "series" )**) %>% plotly::config(displayModeBar = T) %>%
layout(legend = list(orientation = "h", x = 0.4, y = -0.2)))
And the result is:
How can I change the tooltip? Can I add words? I tried with paste("Dates","x") but doesn't work.
Thanks for your help.
You can use text in style to change the hover text.
The plotly object will have values accessible through a list as below. The date values will need to be converted with as.Date.
Edit: The code includes a full shiny app as a demo.
library(xts)
library(shiny)
data<-rnorm(10)
dates <- seq(as.Date("2016-01-01"), length =10, by = "days")
xtsMyData <- xts(x = data, order.by = dates)
ui <- fluidPage(
plotlyOutput("myplot")
)
server <- function(input, output, session) {
output$myplot <- renderPlotly({
r <- ggplot(tidy(xtsMyData), aes(x=index,y=value, color=series, type = 'scatter', mode = 'lines')) +
geom_line(size=2)
r <- ggplotly(r) %>%
plotly::config(displayModeBar = T) %>%
layout(legend = list(orientation = "h", x = 0.4, y = -0.2))
r %>%
style(text = paste0("Date:", as.Date(r$x$data[[1]]$x),
"</br></br>",
"Cantidad:", r$x$data[[1]]$y))
})
}
shinyApp(ui, server)
Plot
The first answer gave me the idea to change manually all, because I had 2 different geom_lines and that didn't work for me , this labels are stored in r$x$data[[1]]$text (the following line plots are in r$x$data[[2]]$text,r$x$data[[3]]$text... ), so, if you use an gsub, you could change everything you want, it's very dumb but it works. (You can use the same philosophy to delete the last label, manipulating strings)
I put an example for your problem, despite you already solve it, other person could have more than one line plot.
r$x$data[[1]]$text<-gsub(r$x$data[[1]]$text,pattern='index', replacement='Fecha')
r$x$data[[1]]$text<-gsub(r$x$data[[1]]$text,pattern='value', replacement='Valor')
r$x$data[[1]]$text<-gsub(r$x$data[[1]]$text,pattern='series', replacement='Serie')
I am developing a shiny app which steps through time by each hour and shows the precipitation on a mapdeck map. I read in the weather data for the entire day and using reactivity filtering the data for the hour and plotting them as scatterplot using mapdeck_update to update the data. The color scale changes whenever the map updates based on the range of data in that hour. What I want is a static color scale based on the data range for the day. Is it possible?
I have tried using manual colors but for some reason they are not working
library(mapdeck)
ui <- fluidPage(
fluidRow(sliderInput(inputId = "hr",label = "Hour",min = 1,max = 3,value = 1)),
fluidRow(mapdeckOutput(outputId = "wx"))
)
sr <- function(input, output, session) {
mydata <- read.table(header=TRUE, sep=",",text="
ROW,COL,Center Latitude,Center Longitude,vil_int_36,hr
28,439,23.669885449218786,-97.2498101160108,20,1
41,433,24.37845221074034,-97.59803936272704,21,1
59,441,25.35333762373948,-97.11966878019186,22,1
61,441,25.461905262766468,-97.11878391116397,23,1
62,443,25.515163854569053,-96.99946877404128,24,1
29,439,23.724265738052193,-97.24945283742396,25,2
43,433,24.48713046908765,-97.59764743717052,26,2
59,442,25.35284441116698,-97.06032252207848,27,2
61,442,25.46141127997772,-97.05937801465758,28,2
62,444,25.514605007836384,-96.94003374232112,29,2
29,440,23.723846594719276,-97.19096992696834,30,3
43,434,24.486897474919978,-97.53876699838483,31,3
60,443,25.406603480942334,-97.00047511628769,32,3
62,441,25.516184831702166,-97.11834002241596,33,3
62,449,25.511327212479294,-96.64286546489153,34,3
")
wx_map <- mapdeck(data=NULL,token = Sys.getenv("MAPBOX_API_TOKEN"),style = 'mapbox://styles/mapbox/dark-v9',zoom = 6, location = c(-97,24.5))
observe({
wx_dt <- mydata %>% dplyr::filter(hr == input$hr)
mapdeck_update(map_id = "wx") %>%
add_scatterplot(data=wx_dt,lon = "Center.Longitude",lat = "Center.Latitude",radius = 15000,fill_colour = "vil_int_36",legend = TRUE,layer_id = "wxlyr",update_view = FALSE,focus_layer=FALSE)
})
output$wx <- renderMapdeck(wx_map)
}
shinyApp(ui, sr)
Notice how the range of color scale in the legend changes but the color of the dots stay almost the same. I want the color to represent the min-max of the entire data set (not just the hour) so that I can see change in intensity while stepping through each hour. Thank you.
Good question; you're right you need to create a manual legend so it remains static, otherwise it will update each time the values in the plot update.
The manual legend needs to use the same colours as the map. The map gets coloured by library(colourvalues). So you can use this to make the colours outside of the map, then use the results as the manual legend
l <- colourvalues::colour_values(
x = mydata$vil_int_36
, n_summaries = 5
)
legend <- mapdeck::legend_element(
variables = l$summary_values
, colours = l$summary_colours
, colour_type = "fill"
, variable_type = "category"
)
js_legend <- mapdeck::mapdeck_legend(legend)
Now this js_legend object is in the correct JSON format for the map to render it as a legend
js_legend
# {"fill_colour":{"colour":["#440154FF","#3B528BFF","#21908CFF","#5DC963FF","#FDE725FF"],"variable":["20.00","23.50","27.00","30.50","34.00"],"colourType":["fill_colour"],"type":["category"],"title":[""],"css":[""]}}
Here it is in your shiny
library(mapdeck)
library(shiny)
ui <- fluidPage(
fluidRow(sliderInput(inputId = "hr",label = "Hour",min = 1,max = 3,value = 1)),
fluidRow(mapdeckOutput(outputId = "wx"))
)
sr <- function(input, output, session) {
mydata <- read.table(header=TRUE, sep=",",text="
ROW,COL,Center Latitude,Center Longitude,vil_int_36,hr
28,439,23.669885449218786,-97.2498101160108,20,1
41,433,24.37845221074034,-97.59803936272704,21,1
59,441,25.35333762373948,-97.11966878019186,22,1
61,441,25.461905262766468,-97.11878391116397,23,1
62,443,25.515163854569053,-96.99946877404128,24,1
29,439,23.724265738052193,-97.24945283742396,25,2
43,433,24.48713046908765,-97.59764743717052,26,2
59,442,25.35284441116698,-97.06032252207848,27,2
61,442,25.46141127997772,-97.05937801465758,28,2
62,444,25.514605007836384,-96.94003374232112,29,2
29,440,23.723846594719276,-97.19096992696834,30,3
43,434,24.486897474919978,-97.53876699838483,31,3
60,443,25.406603480942334,-97.00047511628769,32,3
62,441,25.516184831702166,-97.11834002241596,33,3
62,449,25.511327212479294,-96.64286546489153,34,3
")
## create a manual legend
l <- colourvalues::colour_values(
x = mydata$vil_int_36
, n_summaries = 5
)
legend <- mapdeck::legend_element(
variables = l$summary_values
, colours = l$summary_colours
, colour_type = "fill"
, variable_type = "category"
)
js_legend <- mapdeck::mapdeck_legend(legend)
### --------------------------------
wx_map <- mapdeck(
style = 'mapbox://styles/mapbox/dark-v9'
, zoom = 6
, location = c(-97,24.5)
)
observe({
wx_dt <- mydata %>% dplyr::filter(hr == input$hr)
mapdeck_update(map_id = "wx") %>%
add_scatterplot(
data = wx_dt
, lon = "Center.Longitude"
, lat = "Center.Latitude"
, radius = 15000
, fill_colour = "vil_int_36"
, legend = js_legend
, layer_id = "wxlyr"
, update_view = FALSE
, focus_layer = FALSE
)
})
output$wx <- renderMapdeck(wx_map)
}
shinyApp(ui, sr)
In the following shiny app, the plotly package is used to create an interactive correlation heat map. When individual tiles are clicked, the corresponding scatter plot appears. One can then download the individual scatters by clicking download plot as png. But is there a way to download all the possible scatter plots at once without having to click each individual tile and save each individual one? Thank you
library(plotly)
library(shiny)
# compute a correlation matrix
correlation <- round(cor(mtcars), 3)
nms <- names(mtcars)
ui <- fluidPage(
mainPanel(
plotlyOutput("heat"),
plotlyOutput("scatterplot")
),
verbatimTextOutput("selection")
)
server <- function(input, output, session) {
output$heat <- renderPlotly({
plot_ly(x = nms, y = nms, z = correlation,
key = correlation, type = "heatmap", source = "heatplot") %>%
layout(xaxis = list(title = ""),
yaxis = list(title = ""))
})
output$selection <- renderPrint({
s <- event_data("plotly_click")
if (length(s) == 0) {
"Click on a cell in the heatmap to display a scatterplot"
} else {
cat("You selected: \n\n")
as.list(s)
}
})
output$scatterplot <- renderPlotly({
s <- event_data("plotly_click", source = "heatplot")
if (length(s)) {
vars <- c(s[["x"]], s[["y"]])
d <- setNames(mtcars[vars], c("x", "y"))
yhat <- fitted(lm(y ~ x, data = d))
plot_ly(d, x = ~x) %>%
add_markers(y = ~y) %>%
add_lines(y = ~yhat) %>%
layout(xaxis = list(title = s[["x"]]),
yaxis = list(title = s[["y"]]),
showlegend = FALSE)
} else {
plotly_empty()
}
})
}
shinyApp(ui, server)
You can use webshot to capture a static image of Plotly's HTML output using the instructions here: https://plot.ly/r/static-image-export/
An example for loop below generates random scatter plots from mtcars.
library(plotly)
library(webshot)
## You'll need to run the function the first time if you dont't have phantomjs installed
#webshot::install_phantomjs()
ColumnOptions <- colnames(mtcars)
for (i in seq_len(5)){
xCol <- sample(ColumnOptions,1)
yCol <- sample(ColumnOptions,1)
ThisFileName <- paste0("Scatter_",xCol,"_vs_",yCol,".png")
plot_ly(x = mtcars[[xCol]], y = mtcars[[yCol]], type = "scatter", mode = "markers") %>%
export(., file = ThisFileName)
}
However, if you're going to be potentially doing this dozens of times, the amount of computation required to go through the following steps really adds up.
Generate a JSON plotly object from R
Use htmlwidgets/htmltoolsto generate a self-contained HTML web page
Render that HTML as a browser would see it with an external program --webshot
Use webshot to render an image of that HTML and save it as a PNG
This isn't really a reflection of plotly being slow, but to make an analogy it's kind've like using an airplane to travel half a mile -- the plane gets you there, but if you need to make that trip more than a few times you should probably consider a car.
The plotly loop above takes 27 seconds to render 5 PNG images, but the alternative method below using ggplot2 takes 1.2 seconds.
library(ggplot2)
ColumnOptions <- colnames(mtcars)
for (i in seq_len(5)){
xCol <- sample(ColumnOptions,1)
yCol <- sample(ColumnOptions,1)
ThisFileName <- paste0("ggplot2_Scatter_",xCol,"_vs_",yCol,".png")
ggplot() +
geom_point(aes(x = mtcars[[xCol]], y = mtcars[[yCol]])) +
labs(x = xCol, y = yCol) -> ThisPlot
ggsave(plot = ThisPlot, filename = ThisFileName)
}