Related
I am giving a tutorial on MLE and am trying to figure out how to add a static grouping of points to a plotly graph. Obviously the idea is that as I slide the normal distributions over you can see that the points correspond to a lower or higher likeihood. However, I can only get the points to appear on the first frame.
x <- seq(0, 10, length.out = 1000)
aval <- list()
for (step in 1:6) {
aval[[step]] <- list(
visible = FALSE,
name = paste0('v = ', step),
x = x,
y = dnorm(x, step+1)
)
}
aval[3][[1]]$visible = TRUE
steps <- list()
fig <- plot_ly()
for (i in 1:6) {
fig <-
add_lines(
fig,
x = aval[i][[1]]$x,
y = aval[i][[1]]$y,
visible = aval[i][[1]]$visible,
name = aval[i][[1]]$name,
type = 'scatter',
mode = 'lines',
hoverinfo = 'name',
line = list(color = '00CED1'),
showlegend = FALSE
)
step <- list(args = list('visible', rep(FALSE, length(aval))),method = 'restyle')
step$args[[2]][i] = TRUE
steps[[i]] = step
}
fig <- fig %>% add_markers(x = c(4.5,5,5.5), y = c(0,0,0))
# add slider control to plot
fig <- fig %>%
layout(sliders = list(list(
active = 0,
currentvalue = list(prefix = "Frequency: "),
steps = steps
)))
fig
Why don't you use plotly's animation capabilities?
But regardless of whether you define custom steps or you use the frame parameter, you'll have to provide the "static" points for each step:
library(plotly)
library(data.table)
f <- 1:6
x <- seq(0, 10, length.out = 1000)
y <- unlist(lapply(f+1, dnorm, x = x))
DT <- CJ(f, x) # like expand.grid()
DT[, y := y]
DT[, step := paste0("step-", f)]
staticDT <- CJ(f, x = c(4.5,5,5.5), y = 0)
staticDT[, step := paste0("step-", f)]
fig <- plot_ly(
data = DT,
x = ~x,
y = ~y,
frame = ~step,
type = 'scatter',
mode = 'lines',
showlegend = FALSE,
color = I('#00CED1')
)
fig <- add_trace(
fig,
data = staticDT,
x = ~x,
y = ~y,
frame = ~step,
type = 'scatter',
mode = 'markers',
showlegend = FALSE,
color = I('red'),
inherit = FALSE
)
fig <- animation_opts(
fig, transition = 0, redraw = FALSE
)
fig <- animation_slider(
fig, currentvalue = list(prefix = "Frequency: ")
)
fig
Using the code snippet from the help page here, I'm trying to create a unique main label for each subplot but am not entirely successful. Any suggestions on how to do this?
library(plotly)
vars <- setdiff(names(economics), "date")
plots <- lapply(vars, function(var) {
plot_ly(economics, x = ~date, y = as.formula(paste0("~", var))) %>%
add_lines(name = var) %>% layout(title = paste("Title for", var, sep=' ') )
})
subplot(plots, nrows = length(plots), shareX = TRUE, titleX = FALSE)
I wish I had noticed this question sooner! Here is one way that you can make this happen.
I took the titles out of the plot build. Otherwise, you'll get an error.
library(plotly)
vars <- setdiff(names(economics), "date")
plots <- lapply(vars, function(var) {
plot_ly(economics, x = ~date, y = as.formula(paste0("~", var))) %>%
add_lines(name = var) #%>% layout(title = paste("Title for", var, sep=' '))
})
Then I created a vector of the titles.
nms <- invisible(lapply(vars, function(v){paste0("Title for ", v)}) %>% unlist())
Here I used annotations to create title objects to add to the subplot.
annots = lapply(
1:length(plots),
function(j){
list(x = .5,
y = 1 - (j - 1) * .205,
xanchor = "center",
yanchor = "center",
xref = "paper",
yref = "paper",
showarrow = F,
text = nms[j])
}
)
subplot(plots, nrows = length(plots), shareX = TRUE, titleX = FALSE) %>%
layout(annotations = annots)
In the following app the user can select points in the plot by dragging, which should swap their Selected state between 0 and 1
points will get a shape and color depending on their 0 / 1 state, as a visual support for a user to select/deselect model parameters for the next model run.
in the version of the plots I had in my real app, the plotted data is a reactive variable values$RFImp_FP1 but I found out that the plot does not re-render when the content of column Selected of that data.table (or data.frame) changes.
Therefore I am trying to change it to a reactive object, but I'm failing to figure out how to change the Selected column of reactive data.table `RFImp
my attempts (comments in the code) so far produce either an assign error, or an infinite loop.
P.S.: Since i'm coding the stuff with lapply as I am using the code block several times in my app (identical "modules" with different serial number and using different data as the app takes the user through sequential stages of processing data), the second approach with values (app 2) has my preference as this allows me to do things like this:
lapply(c('FP1', 'FP2'), function(FP){
values[[paste('RFAcc', FP, sep = '_')]] <- ".... code to select a dataframe from model result list object values[[paste('RFResults', FP, sep = '_']]$Accuracy...."
which as far as I know can't be done with objectname <- reactive({....}) as you can't paste on the left side of the <- here
REACTIVE OBJECT APPROACH:
library(shiny)
library(plotly)
library(dplyr)
library(data.table)
ui <- fluidPage(
plotlyOutput('RFAcc_FP1', width = 450)
)
server <- function(input, output, session) {
values <- reactiveValues()
observe({
if(!is.null(RFImp_FP1()$Selected)) {
parsToChange <- event_data("plotly_selected", source = 'RFAcc_FP1')$y
if(!is.null(event_data("plotly_selected", source = 'RFAcc_FP1'))){
data_df <- RFImp_FP1()
data_df <- data_df %>% .[, Selected := if_else(Variables %in% parsToChange, 1-Selected, Selected)]
# how to get the reactive Data frame to update the selected
# values$Selected <- data_df$Selected #creates infinite loop.....
# RFImp_FP1$Selected <- data_df$Selected # throws an error
}
}
})
RFImp_FP1 <- reactive({
# in real app the dataframe RFImp_FP1 is a part of a list with randomForest results,
RFImp_FP1 <- data.table( MeanDecreaseAccuracy = runif(10, min = 0, max = 1), Variables = letters[1:10])
RFImp_FP1$Selected <- 1
# RFImp_FP1$Selected <- if(!is.null(values$Selected)){
# values$Selected } else {1 }
RFImp_FP1
})
output$RFAcc_FP1 <- renderPlotly({
RFImp_FP1()[order(MeanDecreaseAccuracy)]
RFImp_score <- RFImp_FP1()
plotheight <- length(RFImp_score$Variables) * 80
p <- plot_ly(data = RFImp_score,
source = 'RFAcc_FP1',
height = plotheight,
width = 450) %>%
add_trace(x = RFImp_score$MeanDecreaseAccuracy,
y = RFImp_score$Variables,
type = 'scatter',
mode = 'markers',
color = factor(RFImp_score$Selected),
colors = c('#1b73c1', '#797979'),
symbol = factor(RFImp_score$Selected),
symbols = c('circle','x'),
marker = list(size = 6),
hoverinfo = "text",
text = ~paste ('<br>', 'Parameter: ', RFImp_score$Variables,
'<br>', 'Mean decrease accuracy: ', format(round(RFImp_score$MeanDecreaseAccuracy*100, digits = 2), nsmall = 2),'%',
sep = '')) %>%
layout(
margin = list(l = 160, r= 20, b = 70, t = 50),
hoverlabel = list(font=list( color = '#1b73c1'), bgcolor='#f7fbff'),
xaxis = list(title = 'Mean decrease accuracy index (%)',
tickformat = "%",
showgrid = F,
showline = T,
zeroline = F,
nticks = 5,
font = list(size = 8),
ticks = "outside",
ticklen = 5,
tickwidth = 2,
tickcolor = toRGB("black")
),
yaxis = list(categoryarray = RFImp_score$Variables,
autorange = T,
showgrid = F,
showline = T,
autotick = T,
font = list(size = 8),
ticks = "outside",
ticklen = 5,
tickwidth = 2,
tickcolor = toRGB("black")
),
dragmode = "select"
) %>% add_annotations(x = 0.5,
y = 1.05,
textangle = 0,
font = list(size = 14,
color = 'black'),
text = "Contribution to accuracy",
showarrow = F,
xref='paper',
yref='paper')
p <- p %>% config(displayModeBar = F)
p
})
}
shinyApp(ui, server)
PREVIOUS reactiveValues() approach:
as you can see, with this app, the plot does not update when selecting a region in the plot even though the code changes the content of column Selected
ui <- fluidPage(
actionButton(inputId = 'Go', label = 'Go'),
plotlyOutput('RFAcc_FP1', width = 450)
)
server <- function(input, output, session) {
values <- reactiveValues()
observe({
if(!is.null(values$RFImp_FP1)) {
parsToChange <- event_data("plotly_selected", source = 'RFAcc_FP1')$y
if(!is.null(event_data("plotly_selected", source = 'RFAcc_FP1'))){
data_df <- values$RFImp_FP1
data_df <- data_df %>% .[, Selected := if_else(Variables %in% parsToChange, 1-Selected, Selected)]
values$RFImp_FP1 <- data_df
}
}
})
observeEvent(input$Go, {
values$RFImp_FP1 <- data.table(MeanDecreaseAccuracy = runif(10, min = 0, max = 1), Variables = letters[1:10])
values$RFImp_FP1$Selected <- 1
})
output$RFAcc_FP1 <- renderPlotly({
if(!is.null(values$RFImp_FP1)) {
RFImp_score <- values$RFImp_FP1[order(MeanDecreaseAccuracy)]
plotheight <- length(RFImp_score$Variables) * input$testme
p <- plot_ly(data = RFImp_score,
source = 'RFAcc_FP1',
height = plotheight,
width = 450) %>%
add_trace(x = RFImp_score$MeanDecreaseAccuracy,
y = RFImp_score$Variables,
type = 'scatter',
mode = 'markers',
color = factor(RFImp_score$Selected),
colors = c('#1b73c1', '#797979'),
symbol = factor(RFImp_score$Selected),
symbols = c('circle','x'),
marker = list(size = 6),
hoverinfo = "text",
text = ~paste ('<br>', 'Parameter: ', RFImp_score$Variables,
'<br>', 'Mean decrease accuracy: ', format(round(RFImp_score$MeanDecreaseAccuracy*100, digits = 2), nsmall = 2),'%',
sep = '')) %>%
layout(
margin = list(l = 160, r= 20, b = 70, t = 50),
hoverlabel = list(font=list( color = '#1b73c1'), bgcolor='#f7fbff'),
xaxis = list(title = 'Mean decrease accuracy index (%)',
tickformat = "%",
showgrid = F,
showline = T,
zeroline = F,
nticks = 5,
font = list(size = 8),
ticks = "outside",
ticklen = 5,
tickwidth = 2,
tickcolor = toRGB("black")
),
yaxis = list(categoryarray = RFImp_score$Variables,
autorange = T,
showgrid = F,
showline = T,
autotick = T,
font = list(size = 8),
ticks = "outside",
ticklen = 5,
tickwidth = 2,
tickcolor = toRGB("black")
),
dragmode = "select"
) %>% add_annotations(x = 0.5,
y = 1.05,
textangle = 0,
font = list(size = 14,
color = 'black'),
text = "Contribution to accuracy",
showarrow = F,
xref='paper',
yref='paper')
p$elementId <- NULL ## to surpress warning of widgetid
p <- p %>% config(displayModeBar = F)
p
} else {
p <- plot_ly( type = 'scatter', mode = 'markers', height = '400px', width = 450) %>% layout(
margin = list(l = 160, r= 20, b = 70, t = 50),
xaxis = list(title = 'Mean decrease accuracy index', range= c(0,1), nticks = 2, showline = TRUE),
yaxis = list(title = 'Model input variables', range = c(0,1), nticks = 2, showline = TRUE)) %>%
add_annotations(x = 0.5, y = 1.1, textangle = 0, font = list(size = 14, color = 'black'),
text = 'Contribution to accuracy',
showarrow = F, xref='paper', yref='paper')
p$elementId <- NULL
p <- p %>% config(displayModeBar = F)
p}
})
}
shinyApp(ui, server)
Not sure if this is what you want (it´s a bit weird that the plot updates with random numbers after selecting points ;-) ), but I hope it helps.
Instead of using a normal observer I use observeEvent that fires when selecting something in the plot. I generally prefer observeEvent to catch an event. This triggers an update ob a reactiveValues value, which will initially be NULL
library(shiny)
library(plotly)
library(dplyr)
library(data.table)
testDF <- data.table( MeanDecreaseAccuracy = runif(10, min = 0, max = 1), Variables = letters[1:10])
testDF$Selected <- T
ui <- fluidPage(
plotlyOutput('RFAcc_FP1', width = 450)
)
server <- function(input, output, session) {
values <- reactiveValues(val = NULL)
observeEvent(event_data("plotly_selected", source = 'RFAcc_FP1')$y, {
values$val <- runif(1, min = 0, max = 1)
})
RFImp_FP1 <- reactive({
RFImp_FP1 <- testDF
if(!is.null(values$val)) {
parsToChange <- event_data("plotly_selected", source = 'RFAcc_FP1')$y
RFImp_FP1 <- RFImp_FP1 %>% .[, Selected := if_else(Variables %in% parsToChange, 1-Selected, Selected)]
} else { }
# in real app the dataframe RFImp_FP1 is a part of a list with randomForest results,
RFImp_FP1
# RFImp_FP1$Selected <- if(!is.null(values$Selected)){
# values$Selected } else {1 }
})
output$RFAcc_FP1 <- renderPlotly({
RFImp_score <- RFImp_FP1()[order(MeanDecreaseAccuracy)]
plotheight <- length(RFImp_score$Variables) * 80
p <- plot_ly(data = RFImp_score,
source = 'RFAcc_FP1',
height = plotheight,
width = 450) %>%
add_trace(x = RFImp_score$MeanDecreaseAccuracy,
y = RFImp_score$Variables,
type = 'scatter',
mode = 'markers',
color = factor(RFImp_score$Selected),
colors = c('#1b73c1', '#797979'),
symbol = factor(RFImp_score$Selected),
symbols = c('circle','x'),
marker = list(size = 6),
hoverinfo = "text",
text = ~paste ('<br>', 'Parameter: ', RFImp_score$Variables,
'<br>', 'Mean decrease accuracy: ', format(round(RFImp_score$MeanDecreaseAccuracy*100, digits = 2), nsmall = 2),'%',
sep = '')) %>%
layout(
margin = list(l = 160, r= 20, b = 70, t = 50),
hoverlabel = list(font=list( color = '#1b73c1'), bgcolor='#f7fbff'),
xaxis = list(title = 'Mean decrease accuracy index (%)',
tickformat = "%",
showgrid = F,
showline = T,
zeroline = F,
nticks = 5,
font = list(size = 8),
ticks = "outside",
ticklen = 5,
tickwidth = 2,
tickcolor = toRGB("black")
),
yaxis = list(categoryarray = RFImp_score$Variables,
autorange = T,
showgrid = F,
showline = T,
autotick = T,
font = list(size = 8),
ticks = "outside",
ticklen = 5,
tickwidth = 2,
tickcolor = toRGB("black")
),
dragmode = "select"
) %>% add_annotations(x = 0.5,
y = 1.05,
textangle = 0,
font = list(size = 14,
color = 'black'),
text = "Contribution to accuracy",
showarrow = F,
xref='paper',
yref='paper')
p <- p %>% config(displayModeBar = F)
p
})
}
shinyApp(ui, server)
I am trying to generate multiple graphs in Plotly for 30 different sales offices. Each graph would have 3 lines: sales, COGS, and inventory. I would like to keep this on one graph with 30 buttons for the different offices. This is the closest solution I could find on SO:
## Create random data. cols holds the parameter that should be switched
l <- lapply(1:100, function(i) rnorm(100))
df <- as.data.frame(l)
cols <- paste0(letters, 1:100)
colnames(df) <- cols
df[["c"]] <- 1:100
## Add trace directly here, since plotly adds a blank trace otherwise
p <- plot_ly(df,
type = "scatter",
mode = "lines",
x = ~c,
y= ~df[[cols[[1]]]],
name = cols[[1]])
## Add arbitrary number of traces
## Ignore first col as it has already been added
for (col in cols[-1]) {
p <- p %>% add_lines(x = ~c, y = df[[col]], name = col, visible = FALSE)
}
p <- p %>%
layout(
title = "Dropdown line plot",
xaxis = list(title = "x"),
yaxis = list(title = "y"),
updatemenus = list(
list(
y = 0.7,
## Add all buttons at once
buttons = lapply(cols, function(col) {
list(method="restyle",
args = list("visible", cols == col),
label = col)
})
)
)
)
print(p)
It works but only on graphs with single lines/traces. How can I modify this code to do the same thing but with graphs with 2 or more traces? or is there a better solution? Any help would be appreciated!
### EXAMPLE 2
#create fake time series data
library(plotly)
set.seed(1)
df <- data.frame(replicate(31,sample(200:500,24,rep=TRUE)))
cols <- paste0(letters, 1:31)
colnames(df) <- cols
#create time series
timeseries <- ts(df[[1]], start = c(2018,1), end = c(2019,12), frequency = 12)
fit <- auto.arima(timeseries, d=1, D=1, stepwise =FALSE, approximation = FALSE)
fore <- forecast(fit, h = 12, level = c(80, 95))
## Add trace directly here, since plotly adds a blank trace otherwise
p <- plot_ly() %>%
add_lines(x = time(timeseries), y = timeseries,
color = I("black"), name = "observed") %>%
add_ribbons(x = time(fore$mean), ymin = fore$lower[, 2], ymax = fore$upper[, 2],
color = I("gray95"), name = "95% confidence") %>%
add_ribbons(x = time(fore$mean), ymin = fore$lower[, 1], ymax = fore$upper[, 1],
color = I("gray80"), name = "80% confidence") %>%
add_lines(x = time(fore$mean), y = fore$mean, color = I("blue"), name = "prediction")
## Add arbitrary number of traces
## Ignore first col as it has already been added
for (col in cols[2:31]) {
timeseries <- ts(df[[col]], start = c(2018,1), end = c(2019,12), frequency = 12)
fit <- auto.arima(timeseries, d=1, D=1, stepwise =FALSE, approximation = FALSE)
fore <- forecast(fit, h = 12, level = c(80, 95))
p <- p %>%
add_lines(x = time(timeseries), y = timeseries,
color = I("black"), name = "observed", visible = FALSE) %>%
add_ribbons(x = time(fore$mean), ymin = fore$lower[, 2], ymax = fore$upper[, 2],
color = I("gray95"), name = "95% confidence", visible = FALSE) %>%
add_ribbons(x = time(fore$mean), ymin = fore$lower[, 1], ymax = fore$upper[, 1],
color = I("gray80"), name = "80% confidence", visible = FALSE) %>%
add_lines(x = time(fore$mean), y = fore$mean, color = I("blue"), name = "prediction", visible = FALSE)
}
p <- p %>%
layout(
title = "Dropdown line plot",
xaxis = list(title = "x"),
yaxis = list(title = "y"),
updatemenus = list(
list(
y = 0.7,
## Add all buttons at once
buttons = lapply(cols, function(col) {
list(method="restyle",
args = list("visible", cols == col),
label = col)
})
)
)
)
p
You were very close!
If for example you want graphs with 3 traces,
You only need to tweak two things:
Set visible the three first traces,
Modify buttons to show traces in groups of three.
My code:
## Create random data. cols holds the parameter that should be switched
library(plotly)
l <- lapply(1:99, function(i) rnorm(100))
df <- as.data.frame(l)
cols <- paste0(letters, 1:99)
colnames(df) <- cols
df[["c"]] <- 1:100
## Add trace directly here, since plotly adds a blank trace otherwise
p <- plot_ly(df,
type = "scatter",
mode = "lines",
x = ~c,
y= ~df[[cols[[1]]]],
name = cols[[1]])
p <- p %>% add_lines(x = ~c, y = df[[2]], name = cols[[2]], visible = T)
p <- p %>% add_lines(x = ~c, y = df[[3]], name = cols[[3]], visible = T)
## Add arbitrary number of traces
## Ignore first col as it has already been added
for (col in cols[4:99]) {
print(col)
p <- p %>% add_lines(x = ~c, y = df[[col]], name = col, visible = F)
}
p <- p %>%
layout(
title = "Dropdown line plot",
xaxis = list(title = "x"),
yaxis = list(title = "y"),
updatemenus = list(
list(
y = 0.7,
## Add all buttons at once
buttons = lapply(0:32, function(col) {
list(method="restyle",
args = list("visible", cols == c(cols[col*3+1],cols[col*3+2],cols[col*3+3])),
label = paste0(cols[col*3+1], " ",cols[col*3+2], " ",cols[col*3+3] ))
})
)
)
)
print(p)
PD: I only use 99 cols because I want 33 groups of 3 graphs
I would like to create a plotly plot where the fill under each line is toggled upon mouseover/hover. The closest that I've come is using a combination of plotly and Shiny in the code below. Basically, I use the function event_data("plotly_hover") with a call to add_trace, which generates the fill for the line. However, when the mouse is moved away from the line, or unhovered, I get an error message: Error: incorrect length (0), expecting: 2366. In addition, the hoverinfo text no longer appears, or only briefly before the fill appears.
I'm not sure what the program is looking for when unhovering, so am not sure why I'm getting this error. Or perhaps there is different and simpler way to toggle the fill for plotly graphs?
ui.R
shinyUI(fluidPage(
titlePanel("Snow Weather Stations"),
mainPanel(
plotlyOutput("testplot", height = "500px")
)
)
)
server.R
library(shiny)
library(plotly)
library(dplyr)
library(tidyr)
csvf <- read.csv(file = "http://bcrfc.env.gov.bc.ca/data/asp/realtime/data/SW.csv",
check.names = FALSE, stringsAsFactors = FALSE)
swe <- csvf %>%
gather(STATION, SWE, -1) %>%
separate(`DATE (UTC)`, c('DATE', 'TIME'), sep = " ") %>%
filter(TIME == "15:00:00") %>%
select(-TIME) %>%
filter(substr(STATION,1,2) == "1A")
swe$DATE <- as.Date(swe$DATE)
swe$HOVERTEXT <- paste(swe$STATION, paste0(swe$SWE, " mm"), sep = "<br>")
xmin <- as.numeric(as.Date("2015-10-01")) * 24 * 60 * 60 * 1000
xmax <- as.numeric(as.Date("2016-09-30")) * 24 * 60 * 60 * 1000
shinyServer(function(input, output) {
output$testplot <- renderPlotly({
plot_ly(swe, x = DATE, y = SWE, group = STATION,
line = list(color = '#CCCCCC'),
text = HOVERTEXT, hoverinfo = "text+x",
hoveron = "points",
key = STATION) %>%
layout(showlegend = FALSE,
hovermode = 'closest',
xaxis = list(title = "",
showgrid = FALSE, showline = TRUE,
mirror = "ticks", ticks = "inside", tickformat = "%b",
hoverformat = "%b %-d",
range = c(xmin, xmax)),
yaxis = list(title = "Snow Water Equivalent (mm)",
showgrid = FALSE, showline = TRUE,
mirror = "ticks", ticks = "inside",
rangemode = "tozero")) %>%
config(displayModeBar = FALSE)
d <- event_data("plotly_hover")
if (is.null(d)) {
stn <- "1A01P Yellowhead Lake"
} else {
stn <- d$key[1]
}
add_trace(filter(swe, STATION == stn), x = DATE, y = SWE,
line = list(color = "404040"), fill = "tozeroy")
})
})