R Shiny: relayout plotly annotations - r

I want a plotly plot to change an annotation if the user clicks a button in a shiny app.
I have no idea why this does not work:
library(shiny)
library(plotly)
d <- data.frame(x = c(1,2,3), y = c(9,99,999))
ui <- fluidPage(
plotlyOutput("plot"),
actionButton("button", "toggle visibility"))
server <- function(input, output) {
output$plot <- renderPlotly({
plot_ly(d)%>%
add_lines(y=d$y, x= d$x)%>%
layout(annotations = list(x = 2, y= 99 , text = "hi"))})
observeEvent(input$button, {
plotlyProxy("plot", session= shiny::getDefaultReactiveDomain()) %>%
plotlyProxyInvoke("relayout", list(annotations= list(x = 2, y= 99 ,
text = "ho")))})}
shinyApp(ui, server)

That is not the way to use relayout in plotly. See below for your example using relayout.
I prefer using native shiny buttons for this purpose because of the greater flexibility it offers. Here is how one might go about achieving the hi-ho toggle.
shiny way
library(shiny)
library(plotly)
d <- data.frame(x = c(1,2,3), y = c(9,99,999))
ui <- fluidPage(
plotlyOutput("plot"),
actionButton("button", "toggle visibility"))
server <- function(input, output) {
output$plot <- renderPlotly({
p <- plot_ly(d)%>%
add_lines(y=d$y, x= d$x)
if (is.null(input$button) | (input$button%%2 == 0)) {
p <- p %>% layout(annotations = list(x = 2, y= 99 , text = "hi"))
} else {
p <- p %>% layout(annotations = list(x = 2, y= 99 , text = "ho"))
}
p
})
}
shinyApp(ui, server)
In this case though, it is simple enough to make the relayout feature work, although it does require an extra button.
plotly relayout way
library(shiny)
library(plotly)
d <- data.frame(x = c(1,2,3), y = c(9,99,999))
ui <- fluidPage(
plotlyOutput("plot")
)
server <- function(input, output) {
output$plot <- renderPlotly({
updatemenus <- list(
list(
active = -1,
type = 'buttons',
buttons = list(
list(
label = "hi",
method = "relayout",
args = list(list(annotations = list(list(x = 2, y= 99 , text = "hi"))))),
list(
label = "ho",
method = "relayout",
args = list(list(annotations = list(list(x = 2, y= 99 , text = "ho")))))
)
)
)
p <- plot_ly(d) %>%
add_lines(y=d$y, x= d$x) %>%
layout(updatemenus = updatemenus)
p
})
}
shinyApp(ui, server)

I believe all that needs to change in your code in order to get this to work is wrapping another list around the defined annotation list in your plotly proxy relayout code. I recently discovered that this recursive list structure is all that's needed in order to manipulate annotations using relayout - you can check out my answer to another SO question related to the same issue, but with slightly different context: https://stackoverflow.com/a/70610374/17852464
library(shiny)
library(plotly)
d <- data.frame(x = c(1,2,3), y = c(9,99,999))
ui <- fluidPage(
plotlyOutput("plot"),
actionButton("button", "toggle visibility"))
server <- function(input, output) {
output$plot <- renderPlotly({
plot_ly(d)%>%
add_lines(y=d$y, x= d$x)%>%
layout(annotations = list(x = 2, y= 99 , text = "hi"))
})
observeEvent(input$button, {
plotlyProxy("plot", session= shiny::getDefaultReactiveDomain()) %>%
plotlyProxyInvoke("relayout", list(annotations= list(list(x = 2, y= 99 ,
text = "ho"))))})}
}
shinyApp(ui, server)

Related

How to send a message to highcharter in Shiny to select a point

In the relatively simple shiny application below I select a point on load. Once the user chooses a new number in the selector I'd like highcharter to select that point instead. In other words, if the user selects 1 then then it should select the 1st point.
Suggestions for how to do this?
library(shiny)
library(highcharter)
ui <- function(){
div(
selectInput('id', label = 'select', choices = 1:3, selected = 2),
highchartOutput("plot")
)
}
server <- function(session, input, output){
output$plot <- renderHighchart({
hc <- highchart() %>%
hc_chart(events = list(load = JS("function(){this.series[0].points[2].select()}"))) %>%
hc_add_series(data.frame(x = 1:3, y = 1:3), "scatter", hcaes(x, y)) %>%
hc_plotOptions(
allowPointSelect = TRUE
)
hc
})
observeEvent(input$id, {
# Here I'd like to send a message to the highchart
# to select the chosen point
})
}
shinyApp(ui, server)
This can be done using hcpxy_update_point function in the development version of {highcharter} (remotes::install_github("jbkunst/highcharter")).
Be sure to use the correct id for the chart which in this case is plot.
More examples in https://jbkunst.shinyapps.io/02-proxy-functions/.
library(shiny)
library(highcharter)
ui <- function(){
div(
selectInput('id', label = 'select', choices = 1:3, selected = 2),
highchartOutput("plot")
)
}
server <- function(session, input, output){
output$plot <- renderHighchart({
hc <- highchart() %>%
hc_chart(events = list(load = JS("function(){this.series[0].points[2].select()}"))) %>%
hc_add_series(
data.frame(x = 1:3, y = 1:3),
"scatter",
hcaes(x, y),
id = "someid",
) %>%
hc_plotOptions(
allowPointSelect = TRUE
)
hc
})
observeEvent(input$id, {
id_0_based <- as.numeric(input$id) - 1
highchartProxy("plot") %>%
# set all points unselected `selected = FALSE`
hcpxy_update_point(id = "someid", 0:2, selected = FALSE) %>%
# then set to selected the _selected_ point
hcpxy_update_point(
id = "someid",
id_point = id_0_based,
selected = TRUE
)
})
}
shinyApp(ui, server)

Restyling traces using plotlyProxy in a scatterplot is unstable when points are colored according to category

I have a Shiny app that builds a scatterplot and highlights the clicked points by restyling the marker outline via plotlyProxy.
The app also subsets the data and moves the entries corresponding to the clicked points from the original "Data table" to an "Outlier table".
This seems to work fine when the markers are all the same color, or when they are colored by a continuous variable. But when I color the points by a categorical variable (like "Species"), it has a weird behavior, restyling a marker from each category instead of the clicked one. The data subsets correctly.
I think the restyle function should update all traces unless specified otherwise, so I am not sure where exactly lies the problem.
Here is my code:
library(plotly)
library(DT)
ui <- fluidPage(
mainPanel(
fluidRow(
div(
column(
width = 2,
uiOutput('chartOptions')),
column(width = 5,
h3("Scatter plot"),
plotlyOutput("scatterplot"),
verbatimTextOutput("click")
)
)
),
hr(),
div(
column(width = 6,
h2("Data Table"),
div(
DT::dataTableOutput(outputId = "table_keep"),
style = "height:auto; overflow-y: scroll;overflow-x: scroll;")),
column(width = 6,
h2("Outlier Data"),
div(
DT::dataTableOutput(outputId = "table_outliers"),
style = "height:auto; overflow-y: scroll;overflow-x: scroll;"))
)
))
server <- function(input, output, session){
datasetInput <- reactive({
df <- iris
return(df)
})
output$chartOptions <- renderUI({#choose variables to plot
if(is.null(datasetInput())){}
else {
list(
selectizeInput("xAxisSelector", "X Axis Variable",
colnames(datasetInput())),
selectizeInput("yAxisSelector", "Y Axis Variable",
colnames(datasetInput())),
selectizeInput("colorBySelector", "Color By:",
c(c("Do not color",colnames(datasetInput()))))
)
}
})
vals <- reactiveValues(#define reactive values for:
data = NULL,
data_keep = NULL,
data_exclude = NULL)
observe({
vals$data <- datasetInput()
vals$data_keep <- datasetInput()
})
## Datatable
output$table_keep <- renderDT({
vals$data_keep
},options = list(pageLength = 5))
output$table_outliers <- renderDT({
vals$data_exclude
},options = list(pageLength = 5))
# mechanism for managing selected points
keys <- reactiveVal()
observeEvent(event_data("plotly_click", source = "outliers", priority = "event"), {
req(vals$data)
is_outlier <- NULL
key_new <- event_data("plotly_click", source = "outliers")$key
key_old <- keys()
if (key_new %in% key_old){
keys(setdiff(key_old, key_new))
} else {
keys(c(key_new, key_old))
}
is_outlier <- rownames(vals$data) %in% keys()
vals$data_keep <- vals$data[!is_outlier, ]
vals$data_exclude <- vals$data[is_outlier, ]
plotlyProxy("scatterplot", session) %>%
plotlyProxyInvoke(
"restyle",
list(marker.line = list(
color = as.vector(ifelse(is_outlier,'black','grey')),
width = 2
))
)
})
observeEvent(event_data("plotly_doubleclick", source = "outliers"), {
req(vals$data)
keys(NULL)
vals$data_keep <- vals$data
vals$data_exclude <- NULL
plotlyProxy("scatterplot", session) %>%
plotlyProxyInvoke(
"restyle",
list(marker.line = list(
color = 'grey',
width = 2
)
))
})
output$scatterplot <- renderPlotly({
req(vals$data,input$xAxisSelector,input$yAxisSelector)
dat <- vals$data
key <- rownames(vals$data)
x <- input$xAxisSelector
y <- input$yAxisSelector
if(input$colorBySelector != "Do not color"){
color <- dat[, input$colorBySelector]
}else{
color <- "orange"
}
scatterplot <- dat %>%
plot_ly(x = dat[,x], y = dat[,y], source = "outliers") %>%
add_markers(key = key,color = color,
marker = list(size = 10, line = list(
color = 'grey',
width = 2
))) %>%
layout(showlegend = FALSE)
return(scatterplot)
})
output$click <- renderPrint({#click event data
d <- event_data("plotly_click", source = "outliers")
if (is.null(d)) "click events appear here (double-click to clear)" else d
})
}
shinyApp(ui, server)
The problem with your above code is that no traceIndices argument is provided for restyle. Please see this.
In your example, once you switch coloring to the factor Species plotly no longer creates one trace, but three. This happens in JS so counting is done from 0 to 2.
To restyle those traces you can address them via curveNumber (in this case 0:2) and pointNumber (50 data points in each trace 0:49)
With a single trace your example works as your key and your trace have the same length (150).
As your provided code is pretty long I just focused on the "Species" problem. It won't work in all other cases, but you should be able to deduce a more general approach from it:
library(shiny)
library(plotly)
library(DT)
ui <- fluidPage(
mainPanel(
fluidRow(
div(
column(
width = 2,
uiOutput('chartOptions')),
column(width = 5,
h3("Scatter plot"),
plotlyOutput("scatterplot"),
verbatimTextOutput("click")
)
)
),
hr(),
div(
column(width = 6,
h2("Data Table"),
div(
DT::dataTableOutput(outputId = "table_keep"),
style = "height:auto; overflow-y: scroll;overflow-x: scroll;")),
column(width = 6,
h2("Outlier Data"),
div(
DT::dataTableOutput(outputId = "table_outliers"),
style = "height:auto; overflow-y: scroll;overflow-x: scroll;"))
)
))
server <- function(input, output, session){
datasetInput <- reactive({
df <- iris
df$is_outlier <- FALSE
return(df)
})
output$chartOptions <- renderUI({#choose variables to plot
if(is.null(datasetInput())){}
else {
list(
selectizeInput("xAxisSelector", "X Axis Variable",
colnames(datasetInput())),
selectizeInput("yAxisSelector", "Y Axis Variable",
colnames(datasetInput())),
selectizeInput("colorBySelector", "Color By:",
c(c("Do not color",colnames(datasetInput()))))
)
}
})
vals <- reactiveValues(#define reactive values for:
data = NULL,
data_keep = NULL,
data_exclude = NULL)
observe({
vals$data <- datasetInput()
vals$data_keep <- datasetInput()
})
## Datatable
output$table_keep <- renderDT({
vals$data_keep
},options = list(pageLength = 5))
output$table_outliers <- renderDT({
vals$data_exclude
},options = list(pageLength = 5))
# mechanism for managing selected points
keys <- reactiveVal()
myPlotlyProxy <- plotlyProxy("scatterplot", session)
observeEvent(event_data("plotly_click", source = "outliers", priority = "event"), {
req(vals$data)
is_outlier <- NULL
plotlyEventData <- event_data("plotly_click", source = "outliers")
key_new <- plotlyEventData$key
key_old <- keys()
if (key_new %in% key_old){
keys(setdiff(key_old, key_new))
} else {
keys(c(key_new, key_old))
}
vals$data[keys(),]$is_outlier <- TRUE
is_outlier <- vals$data$is_outlier
vals$data_keep <- vals$data[!is_outlier, ]
vals$data_exclude <- vals$data[is_outlier, ]
print(paste("pointNumber:", plotlyEventData$pointNumber))
print(paste("curveNumber:", plotlyEventData$curveNumber))
plotlyProxyInvoke(
myPlotlyProxy,
"restyle",
list(marker.line = list(
color = as.vector(ifelse(vals$data[vals$data$Species %in% vals$data[plotlyEventData$key, ]$Species, ]$is_outlier,'black','grey')),
width = 2
)), plotlyEventData$curveNumber
)
})
observeEvent(event_data("plotly_doubleclick", source = "outliers"), {
req(vals$data)
keys(NULL)
vals$data_keep <- vals$data
vals$data_exclude <- NULL
plotlyProxyInvoke(
myPlotlyProxy,
"restyle",
list(marker.line = list(
color = 'grey',
width = 2
)
))
})
output$scatterplot <- renderPlotly({
req(datasetInput(),input$xAxisSelector,input$yAxisSelector)
dat <- datasetInput()
key <- rownames(dat)
x <- input$xAxisSelector
y <- input$yAxisSelector
if(input$colorBySelector != "Do not color"){
color <- dat[, input$colorBySelector]
}else{
color <- "orange"
}
scatterplot <- dat %>%
plot_ly(x = dat[,x], y = dat[,y], source = "outliers") %>%
add_markers(key = key,color = color,
marker = list(size = 10, line = list(
color = 'grey',
width = 2
))) %>%
layout(showlegend = FALSE)
return(scatterplot)
})
output$click <- renderPrint({#click event data
d <- event_data("plotly_click", source = "outliers")
if (is.null(d)) "click events appear here (double-click to clear)" else d
})
}
shinyApp(ui, server)
As a quick workaround, to avoid creating 3 traces, I simply converted the categorical variable assigned to color to numeric, and I hid the colorbar, so the output looks like this:
output$scatterplot <- renderPlotly({
req(vals$data,input$xAxisSelector,input$yAxisSelector)
dat <- vals$data
key <- rownames(vals$data)
x <- input$xAxisSelector
y <- input$yAxisSelector
if(input$colorBySelector != "Do not color"){
color <- as.numeric(dat[, input$colorBySelector])
}else{
color <- "orange"
}
scatterplot <- dat %>%
plot_ly(x = dat[,x], y = dat[,y], source = "outliers") %>%
add_markers(key = key,color = color,
marker = list(size = 10, line = list(
color = 'grey',
width = 2
))) %>%
layout(showlegend = FALSE) %>%
hide_colorbar()%>%
event_register("plotly_click")
return(scatterplot)
})
Update:
Another solution that I found is to make a loop of plotly proxies for each trace / category in the click event.
So the click event looks like this:
observeEvent(event_data("plotly_click", source = "outliers", priority = "event"), {
req(vals$data)
is_outlier <- NULL
key_new <- event_data("plotly_click", source = "outliers")$key
key_old <- keys()
#keys(c(key_new, key_old))
if (key_new %in% key_old){
keys(setdiff(key_old, key_new))
} else {
keys(c(key_new, key_old))
}
is_outlier <- rownames(vals$data) %in% keys()
vals$data_keep <- vals$data[!is_outlier, ]
vals$data_exclude <- vals$data[is_outlier, ]
indices <- list()
p <- plotlyProxy("scatterplot", session)
if(input$colorBySelector != "Do not color"){
if(is.factor(vals$data[,input$colorBySelector])){
for (i in 1:length(levels(vals$data[,input$colorBySelector]))){
indices[[i]] <- rownames(vals$data[which(vals$data[,input$colorBySelector] == levels(vals$data[,input$colorBySelector])[i]), ]) #retrieve indices for each category
plotlyProxyInvoke(p,
"restyle",
list(marker.line = list(
color = as.vector(ifelse(is_outlier[as.numeric(indices[[i]])],'black','grey')),
width = 2
)), c(i-1) #specify the trace (traces are indexed from 0)
)
}
}else{
p %>%
plotlyProxyInvoke(
"restyle",
list(marker.line = list(
color = as.vector(ifelse(is_outlier,'black','grey')),
width = 2
))
)
}
}else{
p %>%
plotlyProxyInvoke(
"restyle",
list(marker.line = list(
color = as.vector(ifelse(is_outlier,'black','grey')),
width = 2
))
)
}
})

Show modal onclick plotly bar plot

I want a pop-up when I click over the bar chart for plotly.
library(shiny)
library(shinymaterial)
df1 <- data.frame(x = 1:10, y = 1:10)
df2 <- data.frame(x = c(rep('a', 10), rep('b', 10)),
y = c(rnorm(10), rnorm(10, 3, 1)))
ui <- material_page(title = "Material Design",
tags$br(),
font_color = "cyan darken-5",
nav_bar_color = "cyan darken-5",
plotlyOutput('scatter')
)
server <- function(input, output) {
output$scatter <- renderPlotly({
plot_ly(df1, x = df1$x, y = df1$y, type = 'bar', source = 'scatter')
})
}
shinyApp(ui = ui, server = server)
I am struck at a point where I need a help; I want a pop-up when I click
over the bar chart the respective contents to be displayed.
Please help me on the same.
You can use an observer and the event_data from your scatterchart to accomplish that. Working example below, hope this helps!
library(shiny)
library(plotly)
df1 <- data.frame(x = 1:10, y = 1:10)
df2 <- data.frame(x = c(rep('a', 10), rep('b', 10)),
y = c(rnorm(10), rnorm(10, 3, 1)))
ui <- fluidPage(
plotlyOutput('scatter')
)
server <- function(input, output) {
output$scatter <- renderPlotly({
plot_ly(df1, x = df1$x, y = df1$y, type = 'bar', source = 'scatter')
})
observeEvent(event_data("plotly_click", source = "scatter"),
{
event_data = event_data("plotly_click", source = "scatter")
showModal(modalDialog(
title = "Important message",
paste0('x: ', event_data$x, ', y: ', event_data$y)
))
}
)
}
shinyApp(ui = ui, server = server)

Is there a way to preselect points in ggiraph (R shiny)?

I would like to preselect some points in a ggiraph::renderggiraph() output.
I can make the following shiny app which allows me to select points and then use those selected points elsewhere like so:
dat <- data.table(x = 1:6, y = 1:6 %% 3, id = 1:6, status = rep(c('on','off'),3))
ui <- fluidPage( ggiraphOutput("plot"),
verbatimTextOutput("choices"))
server <- function(input, output, session){
output$plot <- renderggiraph({
p <- ggplot(dat ) +
geom_point_interactive(aes(x = x, y = y, data_id = id), size = 5) +
scale_color_manual(limits = c('on','off'),values = c('red','black'))
ggiraph(code = print(p),
hover_css = "fill:red;cursor:pointer;",
selection_type = "multiple",
selected_css = "fill:red;")
})
output$choices <- renderPrint({
input$plot_selected
})
}
shinyApp(ui = ui, server = server)
But sometimes I want to have certain points selected before I initialize the app.
For example, if the points 1, 3, and 5 are already "on" orginally, I would like the user to be able to turn them "off".
So my question is, is it possible to achieve something like this?
Yes, by using session$sendCustomMessage in session$onFlushed:
library(shiny)
library(ggiraph)
library(data.table)
library(magrittr)
dat <- data.table(x = 1:6, y = 1:6 %% 3, id = 1:6, status = rep(c('on','off'),3))
ui <- fluidPage( fluidRow(
column(width = 7,
ggiraphOutput("ggobj") ),
column(width = 5, verbatimTextOutput("choices"))
) )
server <- function(input, output, session){
output$ggobj <- renderggiraph({
p <- ggplot(dat ) +
geom_point_interactive(aes(x = x, y = y, data_id = id), size = 5) +
scale_color_manual(limits = c('on','off'),values = c('red','black'))
ggiraph(code = print(p),
hover_css = "fill:red;cursor:pointer;",
selection_type = "multiple",
selected_css = "fill:red;")
})
session$onFlushed(function(){
session$sendCustomMessage(type = 'ggobj_set', message = 1:3)
})
output$choices <- renderPrint({
input$ggobj_selected
})
}
shinyApp(ui = ui, server = server)

Select or highlight data on map by click on legend

Is there any way to select or highlight data on a leaflet map in by clicking on the legend in Rshiny?
example code:
library(shiny)
library(leaflet)
library(RColorBrewer)
library(leafletGeocoderRshiny)
ui <- fluidPage(
leafletOutput("map"),
p(),
actionButton("recalc", "New points")
)
server <- function(input, output, session) {
df = data.frame(x = rnorm(100), y = rexp(100, 2), z = runif(100))
pal = colorBin('PuOr', df$z, bins = c(0, .1, .4, .9, 1))
output$map <- renderLeaflet({ leaflet(df) %>%
addCircleMarkers(~x, ~y, color = ~pal(z)) %>%
addLegend(pal = pal, values = ~z)
})
}
shinyApp(ui, server)
The recent updates (0.2) to the mapedit package may help: http://r-spatial.org/r/2017/06/09/mapedit_0-2-0.html
I got close, but ran out of time now. But i decided to share anyway, maybe someone else sees a solution to the last step.
So far it works for the first click on any of the rectangles in the legend. It doesnt work for any following clicks as the map is redrawn and with it the onclick listeners are deleted. I didnt find a way to add them again so far,...
Its a hacky aprroach: I add onclick listener to the boxes and decided to update the colors via R as i didnt see a good way in JS.
library(shiny)
library(leaflet)
library(RColorBrewer)
library(leafletGeocoderRshiny)
library(shinyjs)
colors <- c("#000000", "#222222", "#888888", "#FFFFFF")
ui <- fluidPage(
useShinyjs(),
leafletOutput("map"),
p(),
actionButton("recalc", "New points")
)
server <- function(input, output, session) {
global <- reactiveValues(colors = colors,
bins = c(0, .1, .4, .9, 1))
observe({
print(input$interval)
isolate({
if(!is.null(input$interval)){
lowerBound <- as.numeric(unlist(input$interval))
global$colors <- colors
global$colors[which(global$bins == lowerBound)] <- "#FF0000"
}
})
})
session$onFlushed(function() {
runjs("
var legendButton = document.getElementsByTagName('i')
var elem; var interval;
for (nr = 0; nr < legendButton.length; nr++) {
elem = legendButton[nr]
elem.onclick = function(e){
console.log(e.target)
interval = e.target.nextSibling.nodeValue.split(' ');
Shiny.onInputChange('interval', interval[1]);
}
}
")
})
df = data.frame(x = rnorm(100), y = rexp(100, 2), z = runif(100))
pal = reactive({
colorBin(global$colors, df$z, bins = global$bins)
})
output$map <- renderLeaflet({ leaflet(df) %>%
addCircleMarkers(~x, ~y, color = ~pal()(z)) %>%
addLegend(pal = pal(), values = ~z)
})
}
runApp(shinyApp(ui, server), launch.browser = T)

Resources