I have this scatter plot where I want to zoom in an area and then subset a table to show only the data from the subsetted points. The first step is done by zoomType = "xy", but I'm having troubles on the second step. Could anyone give me a hint on how can I access the upper left and bottom right points coordinates of the zoomed area, so I can subset the table?
Thank you!
library("shiny")
library("highcharter")
ui <- shinyUI(
fluidPage(
column(width = 8, highchartOutput("hcontainer", height = "500px")),
column(width = 4, textOutput("text"))
)
)
server <- function(input, output) {
dscars <- round(mvrnorm(n = 20, mu = c(1, 1), Sigma = matrix(c(1,0,0,1),2)), 2)
dsplan <- round(mvrnorm(n = 10, mu = c(3, 4), Sigma = matrix(c(2,.5,2,2),2)), 2)
dstrck <- round(mvrnorm(n = 15, mu = c(5, 1), Sigma = matrix(c(1,.5,.5,1),2)), 2)
output$hcontainer <- renderHighchart({
canvasClickFunction <- JS("function(event) {Shiny.onInputChange('canvasClicked', [this.name, event.point.category]);}")
legendClickFunction <- JS("function(event) {Shiny.onInputChange('legendClicked', this.name);}")
highchart() %>%
hc_chart(type = "scatter", zoomType = "xy") %>%
hc_tooltip(
useHTML = T,
enabled = F,
pointFormat = paste0("<span style=\"color:{series.color};\">{series.options.icon}</span>",
"{series.name}: <b>[{point.x}, {point.y}]</b><br/>")
) %>%
hc_add_series(data = list.parse2(as.data.frame(dscars)),marker = list(symbol = fa_icon_mark("car")),icon = fa_icon("car"), name = "car") %>%
hc_add_series(data = list.parse2(as.data.frame(dsplan)),marker = list(symbol = fa_icon_mark("plane")),icon = fa_icon("plane"), name = "plane") %>%
hc_add_series(data = list.parse2(as.data.frame(dstrck)),marker = list(symbol = fa_icon_mark("truck")),icon = fa_icon("truck"), name = "truck") %>%
hc_plotOptions(series = list(stacking = FALSE, events = list(click = canvasClickFunction, legendItemClick = legendClickFunction)))
})
makeReactiveBinding("outputText")
observeEvent(input$canvasClicked, {
outputText <<- paste0("You clicked on series ", input$canvasClicked[1], " and the bar you clicked was from category ", input$canvasClicked[2], ".")
})
observeEvent(input$legendClicked, {
outputText <<- paste0("You clicked into the legend and selected series ", input$legendClicked, ".")
})
output$text <- renderText({
outputText
})
}
shinyApp(ui, server)
2nd Try
I tried something like:
selectionfunction<- JS("function(event) {Shiny.onInputChange('range', [event.xAxis, event.yAxis]);}")
with:
hc_plotOptions(series = list(stacking = FALSE, events = list( selection=selectionfunction )))
makeReactiveBinding("outputText")
observeEvent(input$range, {
outputText <<- paste0("x= ", input$range[1],"y= " ,input$range[2])
})
output$text <- renderText({
outputText
})
But it seems to me that the function selectionfunction is not called when I zoom the plot.
Almost a good solution
I found a almost functional solution:
library("shiny")
library("highcharter")
library("MASS")
ui <- shinyUI(
fluidPage(
column(width = 8, highchartOutput("hcontainer", height = "500px")),
column(width = 4, textOutput("text"))
)
)
server <- function(input, output) {
dscars <- round(mvrnorm(n = 20, mu = c(1, 1), Sigma = matrix(c(1,0,0,1),2)), 2)
dsplan <- round(mvrnorm(n = 10, mu = c(3, 4), Sigma = matrix(c(2,.5,2,2),2)), 2)
dstrck <- round(mvrnorm(n = 15, mu = c(5, 1), Sigma = matrix(c(1,.5,.5,1),2)), 2)
output$hcontainer <- renderHighchart({
selectionfunction <- JS("function(event) {
Shiny.onInputChange('canvasClicked2', [event.xAxis[0].min , event.xAxis[0].max , event.yAxis[0].min , event.yAxis[0].max ] );}")
highchart() %>%
hc_chart(type = "scatter", zoomType = "xy", events= list(selection=selectionfunction)) %>%
hc_tooltip(
useHTML = T,
enabled = F,
pointFormat = paste0("<span style=\"color:{series.color};\">{series.options.icon}</span>",
"{series.name}: <b>[{point.x}, {point.y}]</b><br/>")
) %>%
hc_add_series(data = list.parse2(as.data.frame(dscars)),marker = list(symbol = fa_icon_mark("car")),icon = fa_icon("car"), name = "car") %>%
hc_add_series(data = list.parse2(as.data.frame(dsplan)),marker = list(symbol = fa_icon_mark("plane")),icon = fa_icon("plane"), name = "plane") %>%
hc_add_series(data = list.parse2(as.data.frame(dstrck)),marker = list(symbol = fa_icon_mark("truck")),icon = fa_icon("truck"), name = "truck")
})
makeReactiveBinding("outputText")
observeEvent(input$canvasClicked, {
outputText <<- paste0("You clicked on series ", input$canvasClicked[1], " and the bar you clicked was from category ", input$canvasClicked[2],input$canvasClicked[3], ".")
})
observeEvent(input$canvasClicked2, {
outputText <<- paste0(input$canvasClicked2[1]," ",input$canvasClicked2[2]," ",input$canvasClicked2[3]," ",input$canvasClicked2[4])
})
output$text <- renderText({
outputText
})
}
shinyApp(ui, server)
The axis boundaries are correctly printed but with 1 step delay. Can someone help?
Final Solution
I found a solution by working on the JS function:
selectionfunction1 <- JS("function(event) {
var x_axis_min,x_axis_max,y_axis_min,y_axis_max;
if (event.xAxis) {
x_axis_min = Highcharts.numberFormat(event.xAxis[0].min, 2),
x_axis_max = Highcharts.numberFormat(event.xAxis[0].max, 2);
}else{
x_axis_min = 'reset',
x_axis_max = 'reset';
}
if (event.yAxis) {
y_axis_min = Highcharts.numberFormat(event.yAxis[0].min, 2),
y_axis_max = Highcharts.numberFormat(event.yAxis[0].max, 2);
}else{
y_axis_min = 'reset',
y_axis_max = 'reset';
}
Shiny.onInputChange('canvasClickedxmin', x_axis_min);
Shiny.onInputChange('canvasClickedxmax', x_axis_max);
Shiny.onInputChange('canvasClickedymin', y_axis_min);
Shiny.onInputChange('canvasClickedymax', y_axis_max);
}")
Related
I'm trying to freeze the left-most column of the matrix rendered as a container via JS/CSS, as shown in the image below. I believe the issue lies with the line runjs("$('#container').scrollLeft(1000)") towards the bottom of the code. I keep fiddling with this line with no luck, as my JS/CSS skills are lacking. Any recommendations for solving this?
Code:
library(dplyr)
library(shiny)
library(shinyMatrix)
library(shinyjs)
mat3Rows <- c('Term A','Term B','Term C','Term D')
mat3Default <- data.frame('Series 1' = c(1, 24, 0, 100), row.names = mat3Rows) %>% as.matrix()
mat3Input <- function(inputId, mat3Default) {
matrixInput(
inputId = inputId,
label = "Input terms:",
value = mat3Default,
rows = list(extend = FALSE, names = TRUE),
cols = list(extend = TRUE, names = TRUE, editableNames = FALSE, delete = TRUE),
class = "numeric"
)
}
ui <- fluidPage(
useShinyjs(),
div(style = "margin-top: 20px"),
actionButton('modMat3','Modify')
)
server <- function(input,output,session)({
rv3 <- reactiveValues(
mat3 = mat3Input("mat3",mat3Default),
input = mat3Default,
colHeader = colnames(input)
)
mat3Inputs <- reactive({
df <- mat3Default
colnames(df) <- paste("Series", 1:ncol(df))
df[3:4, ] <- sprintf('%.2f%%', df[3:4, ])
df
})
observeEvent(input$modMat3, {
showModal(modalDialog(
wellPanel(div(style = "overflow-x: auto;", id = "container",rv3$mat3)),
footer = tagList(modalButton("Close"))
)
)
})
# Prevents input matrix 3 from scrunching as it expands
observeEvent(c(input$modMat3, input$mat3), {
print(paste0('$("#mat3").css("width","calc(100% + ', (dim(input$mat3)[2]-1 + dim(input$mat3)[2]%%2)*115, 'px")'))
runjs(paste0('$("#mat3").css("width","calc(100% + ', (dim(input$mat3)[2]-1 + dim(input$mat3)[2]%%2)*115, 'px")'))
runjs("$('#container').scrollLeft(1000)") # solution will be in this line
})
})
shinyApp(ui, server)
How can I add a mouse 'click' event to each polygon plotted on a leaflet map? I want to do this so I can then filter a separate widget based on data from the features (in this case WD21CD).
---
output: html_document
---
```{r setup, include=FALSE}
knitr::opts_chunk$set(echo = FALSE)
library(tidyverse)
library(htmltools)
library(leaflet)
```
```{r cars, echo=FALSE}
url <- 'https://opendata.arcgis.com/api/v3/datasets/bf9d32b1aa9941af84e6c2bf0c54b1bb_0/downloads/data?format=geojson&spatialRefId=4326'
wardShapes <- sf::st_read(url) %>%
filter(WD21CD >= "E05011175" & WD21CD <= "E05011181")
leaflet(wardShapes,elementId = "bhamMap",
height = 550,# width = 10,
options = leafletOptions(minZoom = 10, maxZoom = 14)) %>%
addTiles() %>%
setView(lng = -1.810, lat = 52.555, zoom = 12) %>%
addPolygons(
weight = 0.5, smoothFactor = 0.5,
opacity = 1.0, fillOpacity = 0.2,
highlightOptions = highlightOptions(color = "white", weight = 2, bringToFront = TRUE),
label = ~as.character(WD21NM),
labelOptions = (interactive = TRUE)
)
```
```{js, class.source = "jsvis1", echo=FALSE}
document.getElementById("bhamMap").addEventListener("click", function(e){
console.log("hello");
});
We can use htmlwidgets::onRender to pass custom JS code to the leaflet htmlwidget.
With the help of the eachLayer method we can add an on-click function to each polygon layer:
---
title: "leaflet polygons clicks"
output: html_document
---
```{r setup, include=FALSE}
knitr::opts_chunk$set(echo = FALSE)
library(tidyverse)
library(htmltools)
library(leaflet)
library(sf)
library(htmlwidgets)
```
```{r cars, echo=FALSE}
url <- 'https://opendata.arcgis.com/api/v3/datasets/bf9d32b1aa9941af84e6c2bf0c54b1bb_0/downloads/data?format=geojson&spatialRefId=4326'
wardShapes <- sf::st_read(url) %>%
filter(WD21CD >= "E05011175" & WD21CD <= "E05011181")
leaflet(wardShapes,elementId = "bhamMap",
height = 550,# width = 10,
options = leafletOptions(minZoom = 10, maxZoom = 14)) %>%
addTiles() %>%
setView(lng = -1.810, lat = 52.555, zoom = 12) %>%
addPolygons(
weight = 0.5, smoothFactor = 0.5,
opacity = 1.0, fillOpacity = 0.2,
highlightOptions = highlightOptions(color = "white", weight = 2, bringToFront = TRUE),
label = ~ as.character(WD21NM),
labelOptions = (interactive = TRUE),
options = pathOptions(title = ~ WD21CD, customdata = ~ WD21NM)
) %>% htmlwidgets::onRender("
function(el, x) {
var map = this;
map.eachLayer(function(layer) {
if(layer instanceof L.Polygon){
layer.on('click', function(e){
alert('You clicked on layer._leaflet_id: ' + layer._leaflet_id + '\\nWD21CD: ' + layer.options.title + '\\ncustomdata: ' + layer.options.customdata);
})
.addTo(map)
}
});
}
")
```
I'm experimenting with some code for hover messages on top of ggplot2 objects,
and so far it is working quite well, except now the following challenge goes beyond my skills I fear:
In an App where I will have about 6 to 72 similar ggplots spread over various pages in my app, I would like to be able to attach the hover javascript to all of them automatically: i.e. change from a single tags$script to a generic solution that works for all plots
I tried to build a new plotOutput2 function but I can't get it to work at all.
plotOutput2 <- function(outputId, width = "100%", height = "400px", click = NULL,
dblclick = NULL, hover = NULL, hoverDelay = NULL, hoverDelayType = NULL,
brush = NULL, clickId = NULL, hoverId = NULL, inline = FALSE,
onhover) {
input <- plotOutput(outputId, width, height, click, dblclick,
hover, hoverDelay, hoverDelayType, brush, clickId, hoverId, inline)
attribs <- c(input$children[[2]]$attribs, onhover = onhover)
input$children[[2]]$attribs <- attribs
input
}
but I get an error that says:
input$children[[2]] : subscript out of bounds
The idea is to then call this:
plotOutput2("ploty", hover = hoverOpts(id = "ploty_hover", delay = 0), onhover = "hoverJS(this.id)"),
and the javascript (unfinished) needs to look something like this but create unique output ids instead of #my_tooltip that contain the plotname + tooltip: i.e.: #distPlot_tooltip
hoverjs <- c(
"function hoverJS(id){",
"document.getElementById(id).mousemove(function(e) {",
"$('#my_tooltip').show();",
"$('#my_tooltip').css({",
"top: (e.pageY + 5) + 'px',",
"left: (e.pageX + 5) + 'px'",
"});",
"});",
"}"
)
with the following line in the UI
tags$script(HTML(hoverjs)), ## to add the javascript to the app
The app with only a single precoded javascript hover popup for one plot (top one of the two) looks like this:
library(shiny)
library(ggplot2)
# put function plotOutput2 here
# put hoverJS code here
ui <- fluidPage(
tags$head(tags$style('
#my_tooltip {
position: absolute;
width: 300px;
z-index: 100;
padding: 0;
}
')),
tags$script('
$(document).ready(function() {
// id of the plot
$("#ploty").mousemove(function(e) {
// ID of uiOutput
$("#my_tooltip").show();
$("#my_tooltip").css({
top: (e.pageY + 5) + "px",
left: (e.pageX + 5) + "px"
});
});
});
'),
#tags$script(HTML(hoverjs)),
selectInput("var_y", "Y-Axis", choices = names(iris)),
plotOutput("ploty", hover = hoverOpts(id = "ploty_hover", delay = 0)),
plotOutput("plotx", hover = hoverOpts(id = "plotx_hover", delay = 0)),
uiOutput("my_tooltip")
)
server <- function(input, output) {
output$ploty <- renderPlot({
req(input$var_y)
ggplot(iris, aes_string("Sepal.Width", input$var_y)) +
geom_point()
})
output$plotx <- renderPlot({
req(input$var_y)
ggplot(mtcars, aes_string("mpg", 'hp')) +
geom_point()
})
output$my_tooltip <- renderUI({
hover <- input$ploty_hover
y <- nearPoints(iris, input$ploty_hover)
req(nrow(y) != 0)
wellPanel(DT::dataTableOutput("vals"), style = 'background-color:#fff; padding:10px; width:400px;border-color:#339fff')
})
output$vals <- DT::renderDataTable({
hover <- input$ploty_hover
y <- nearPoints(iris, input$ploty_hover)
req(nrow(y) != 0)
DT::datatable(t(y), colnames = rep("", ncol(t(y))), options = list(dom = 't', searching = F, bSort = FALSE))
})
}
shinyApp(ui = ui, server = server)
EDIT based on initial answer:
I will have (currently) 7 groups of plots in my app,
each plot name will start with a name identifying the group (each group uses a different data frame): in the example 2 groups: 'FP1Plot' and 'CleanFP1'
The subplots within one group will get a serialnr
i.e.: 'FP1Plot_1', 'FP1Plot_2', 'CleanFP1_1', 'CleanFP1_2'
I have tried to rewrite the hovers <- .... to make it a easily generated list for the possible huge (>100) number of plots, and will look up the needed dataframe in an if statement construction,
but at this point the hover doesn't react
require('shiny')
require('ggplot2')
require('shinyjqui')
mtcars <- as.data.table(mtcars)
max_plots <- 12;
ui <- pageWithSidebar(
headerPanel("Dynamic number of plots"),
sidebarPanel(width = 2, sliderInput("n", "Number of plots", value=5, min=1, max=max_plots),
h4('click points to see info'),
h4('select area to zoom'),
h4('Double click to unzoom')
),
mainPanel(
tags$head(
tags$style('
#my_tooltip {
position: absolute;
pointer-events:none;
width: 300px;
z-index: 100;
padding: 0;
}'),
tags$script('
$(document).ready(function() {
$("[id^=plot]").mousemove(function(e) {
$("#my_tooltip").show();
$("#my_tooltip").css({
top: (e.pageY + 5) + "px",
left: (e.pageX + 5) + "px"
});
});
});')
),
tabsetPanel(
tabPanel('fp1',
uiOutput("FP1Plotmultiplots")
),
tabPanel('clean',
uiOutput("CleanFP1multiplots")
)
),
style = 'width:1250px'
)
)
server <- function(input, output, session) {
plotlist <- c('FP1Plot', 'CleanFP1')
ranges <- reactiveValues()
# make the individual plots
observe({
lapply(1:input$n, function(i){
plotname <- paste0('FP1Plot', i)
output[[plotname]] <- renderPlot({
ggplot(mtcars, aes(wt, mpg, color = as.factor(cyl))) + geom_point() +
coord_cartesian(xlim =ranges[[paste('FP1Plot', i, 'x', sep = '')]],
ylim = ranges[[paste('FP1Plot', i, 'y', sep = '')]]
) +
theme_classic() +
theme(legend.text=element_text(size=12),
legend.title=element_blank(),
legend.position = 'bottom')
})
})
})
observe({
lapply(1:input$n, function(i){
plotname <- paste0('CleanFP1', i)
output[[plotname]] <- renderPlot({
ggplot(iris, aes(iris[ ,ncol(iris)-1], iris[ ,i], color = as.factor(Species))) + geom_point() +
coord_cartesian(xlim =ranges[[paste('CleanFP1', i, 'x', sep = '')]],
ylim = ranges[[paste('CleanFP1', i, 'y', sep = '')]]
) +
theme_classic() +
theme(legend.text=element_text(size=12),
legend.title=element_blank(),
legend.position = 'bottom')
})
})
})
# make the divs with plots and buttons etc
lapply(plotlist, function(THEPLOT) {
output[[paste(THEPLOT, 'multiplots', sep = '')]] <- renderUI({
plot_output_list <- list()
n <- input$n
n_cols <- if(n == 1) {
1
} else if (n %in% c(2,4)) {
2
} else if (n %in% c(3,5,6,9)) {
3
} else {
4
}
Pwidth <- 900/n_cols
Pheigth <- 500/ceiling(n/n_cols) # calculate number of rows
Pwidth2 <- Pwidth+40
Pheigth2 <-Pheigth+40
plot_output_list <- list();
for(i in 1:input$n) {
plot_output_list <- append(plot_output_list,list(
div(id = paste0('div', THEPLOT, i),
wellPanel(
plotOutput(paste0(THEPLOT, i),
width = Pwidth,
height = Pheigth,
hover = hoverOpts(id = paste(THEPLOT, i, "hover", sep = '_'), delay = 0)
# click = paste0(THEPLOT, i, '_click'),
# dblclick = paste0(THEPLOT, i, '_dblclick'),
# brush = brushOpts(
# id = paste0(THEPLOT, i, '_brush'),
# resetOnNew = TRUE
# )
),
style = paste('border-color:#339fff; border-width:2px; background-color: #fff; width:', Pwidth2, 'px; height:', Pheigth2, 'px', sep = '')),
style = paste('display: inline-block; margin: 2px; width:', Pwidth2, 'px; height:', Pheigth2, 'px', sep = ''))
))
}
do.call(tagList, plot_output_list)
})
})
eg <- expand.grid(plotlist, 1:max_plots)
tooltipTable <- reactive({
## attempt to make this work for the large amount of plots in my app
hovers <- as.list(sapply(c(sprintf('%s_%s', eg[,1], eg[,2])), function(key) key = eval(parse(text = paste('input$', key, '_hover', sep = ''))) ))
notNull <- sapply(hovers, Negate(is.null))
if(any(notNull)){
plotid <- names(which(notNull))
plothoverid <- paste0(plotid, "_hover")
dataset <- if(grepl('FP1Plot', plotid)) { mtcars } else { iris }
## I will add some code here based on the plot nr to grab the needed columns for the x and y data of the specific plot, since the list of x and y columns will be stored in two vectors:
## 1 vector with x parameter 1:12, and 1 for y.
## every group of plots will use the same list of selected x and y parameters
# (or if I switch to plot group specific lists, the lists will contain the group names just like the plots, so I can link them by name here)
y <- nearPoints(dataset, input[[plothoverid]],
threshold = 15)
if(nrow(y)){
datatable(t(y), colnames = rep("", nrow(y)),
options = list(dom = 't'))
}
}
})
output$my_tooltip <- renderUI({
req(tooltipTable())
wellPanel(DTOutput("vals"),
style = 'background-color:#fff; padding:10px; width:400px;border-color:#339fff')
})
output$vals <- renderDT({
tooltipTable()
})
}
shinyApp(ui, server)
I don't understand the general context, but maybe this can help:
library(shiny)
library(ggplot2)
library(DT)
ui <- fluidPage(
tags$head(
tags$style('
#my_tooltip {
position: absolute;
pointer-events:none;
width: 300px;
z-index: 100;
padding: 0;
}'),
tags$script('
$(document).ready(function() {
$("[id^=plot]").mousemove(function(e) {
$("#my_tooltip").show();
$("#my_tooltip").css({
top: (e.pageY + 5) + "px",
left: (e.pageX + 5) + "px"
});
});
});')
),
selectInput("var_y", "Y-Axis", choices = names(iris)),
plotOutput("ploty", hover = hoverOpts(id = "ploty_hover", delay = 0)),
plotOutput("plotx", hover = hoverOpts(id = "plotx_hover", delay = 0)),
uiOutput("my_tooltip")
)
datasets <- list(plotx = mtcars, ploty = iris)
server <- function(input, output) {
output$ploty <- renderPlot({
req(input$var_y)
ggplot(iris, aes_string("Sepal.Width", input$var_y)) + geom_point()
})
output$plotx <- renderPlot({
ggplot(mtcars, aes_string("mpg", 'hp')) + geom_point()
})
tooltipTable <- reactive({
hovers <- list(plotx = input$plotx_hover, ploty = input$ploty_hover)
notNull <- sapply(hovers, Negate(is.null))
if(any(notNull)){
plotid <- names(which(notNull))
plothoverid <- paste0(plotid, "_hover")
y <- nearPoints(datasets[[plotid]], input[[plothoverid]],
threshold = 15)
if(nrow(y)){
datatable(t(y), colnames = rep("", nrow(y)),
options = list(dom = 't'))
}
}
})
output$my_tooltip <- renderUI({
req(tooltipTable())
wellPanel(DTOutput("vals"),
style = 'background-color:#fff; padding:10px; width:400px;border-color:#339fff')
})
output$vals <- renderDT({
tooltipTable()
})
}
shinyApp(ui = ui, server = server)
Update
require('shiny')
require('ggplot2')
library(DT)
#mtcars <- as.data.table(mtcars)
max_plots <- 12;
ui <- pageWithSidebar(
headerPanel("Dynamic number of plots"),
sidebarPanel(width = 2, sliderInput("n", "Number of plots", value=5, min=1, max=max_plots),
h4('click points to see info'),
h4('select area to zoom'),
h4('Double click to unzoom')
),
mainPanel(
tags$head(
tags$style('
#my_tooltip {
position: absolute;
pointer-events:none;
width: 300px;
z-index: 100;
padding: 0;
}'),
tags$script('
$(document).ready(function() {
setTimeout(function(){
$("[id^=FP1Plot],[id^=CleanFP1]").mousemove(function(e) {
$("#my_tooltip").show();
$("#my_tooltip").css({
top: (e.offsetY) + "px",
left: (e.pageX + 5) + "px"
});
});
},5000)});')
),
tabsetPanel(
tabPanel('fp1',
div(style = "position:relative",
uiOutput("FP1Plotmultiplots"))
),
tabPanel('clean',
uiOutput("CleanFP1multiplots")
)
),
uiOutput("my_tooltip"),
style = 'width:1250px'
)
)
server <- function(input, output, session) {
plotlist <- c('FP1Plot', 'CleanFP1')
ranges <- reactiveValues()
# make the individual plots
observe({
lapply(1:input$n, function(i){
plotname <- paste0('FP1Plot', i)
output[[plotname]] <- renderPlot({
ggplot(mtcars, aes(wt, mpg, color = as.factor(cyl))) + geom_point() +
coord_cartesian(xlim =ranges[[paste('FP1Plot', i, 'x', sep = '')]],
ylim = ranges[[paste('FP1Plot', i, 'y', sep = '')]]
) +
theme_classic() +
theme(legend.text=element_text(size=12),
legend.title=element_blank(),
legend.position = 'bottom')
})
})
})
observe({
lapply(1:input$n, function(i){
plotname <- paste0('CleanFP1', i)
output[[plotname]] <- renderPlot({
x <- names(iris)[ncol(iris)-1]
y <- names(iris)[i]
ggplot(iris, aes_string(x, y, color = "Species")) + geom_point() +
coord_cartesian(xlim =ranges[[paste('CleanFP1', i, 'x', sep = '')]],
ylim = ranges[[paste('CleanFP1', i, 'y', sep = '')]]
) +
theme_classic() +
theme(legend.text=element_text(size=12),
legend.title=element_blank(),
legend.position = 'bottom')
})
})
})
# make the divs with plots and buttons etc
lapply(plotlist, function(THEPLOT) {
output[[paste(THEPLOT, 'multiplots', sep = '')]] <- renderUI({
plot_output_list <- list()
n <- input$n
n_cols <- if(n == 1) {
1
} else if (n %in% c(2,4)) {
2
} else if (n %in% c(3,5,6,9)) {
3
} else {
4
}
Pwidth <- 900/n_cols
Pheigth <- 500/ceiling(n/n_cols) # calculate number of rows
Pwidth2 <- Pwidth+40
Pheigth2 <- Pheigth+40
plot_output_list <- list();
for(i in 1:input$n) {
plot_output_list <- append(plot_output_list,list(
div(id = paste0('div', THEPLOT, i),
wellPanel(
plotOutput(paste0(THEPLOT, i),
width = Pwidth,
height = Pheigth,
hover = hoverOpts(id = paste(THEPLOT, i, "hover", sep = '_'), delay = 0)
# click = paste0(THEPLOT, i, '_click'),
# dblclick = paste0(THEPLOT, i, '_dblclick'),
# brush = brushOpts(
# id = paste0(THEPLOT, i, '_brush'),
# resetOnNew = TRUE
# )
),
style = paste('border-color:#339fff; border-width:2px; background-color: #fff; width:', Pwidth2, 'px; height:', Pheigth2, 'px', sep = '')),
style = paste('display: inline-block; margin: 2px; width:', Pwidth2, 'px; height:', Pheigth2, 'px', sep = ''))
))
}
do.call(tagList, plot_output_list)
})
})
eg <- expand.grid(plotlist, 1:max_plots)
plotids <- sprintf('%s_%s', eg[,1], eg[,2])
names(plotids) <- plotids
tooltipTable <- reactive({
hovers <-
lapply(plotids, function(key) input[[paste0(key, '_hover')]])
notNull <- sapply(hovers, Negate(is.null))
if(any(notNull)){
plotid <- names(which(notNull))
plothoverid <- paste0(plotid, "_hover")
dataset <- if(grepl('FP1Plot', plotid)) { mtcars } else { iris }
## I will add some code here based on the plot nr to grab the needed columns for the x and y data of the specific plot, since the list of x and y columns will be stored in two vectors:
## 1 vector with x parameter 1:12, and 1 for y.
## every group of plots will use the same list of selected x and y parameters
# (or if I switch to plot group specific lists, the lists will contain the group names just like the plots, so I can link them by name here)
y <- nearPoints(dataset, input[[plothoverid]],
threshold = 15)
if(nrow(y)){
datatable(t(y), colnames = rep("", nrow(y)),
options = list(dom = 't'))
}
}
})
output$my_tooltip <- renderUI({
req(tooltipTable())
wellPanel(DTOutput("vals"),
style = 'background-color:#fff; padding:10px; width:400px;border-color:#339fff')
})
output$vals <- renderDT({
tooltipTable()
})
}
shinyApp(ui, server)
This is a follow up question based on THIS post.
The demo app here is a closer representation of my more complex situation of my real shiny app that I'm trying to improve by replacing code that causes re-rendering of plotly objects by javascript codes that alter the existing plots.
This app has:
- 4 plots with unique ID's
- sets of 2 plots listen to the same set of colourInputs, 1 for each trace in each plot
- the legend and marker size in all plots are linked to numericInputs
The modification of the javascript from the previous question for this solution would need to:
- follow the size inputs
- follow the trace - colourInput linking
- target trace n in 2 plots based on colourInput n belonging to those 2 plots.
EDIT: slightly simplified scenario
Lets drop the legend issue for now, since the solution part 2 by Stephane does what I want for the colors. I'll deal with the legend sizing later.
The modified version might be a little clearer.
The javascript should:
if plot id is "plot1" or "plot2" listen to color-set1-1 till -3
if plot id is 'plot3' or 'plot4', lister to color-set2-1 till -3
I suppose we need some to add some lines in the js like: "
"var setnr = parseInt(id.split('-')[1]) ;",
to see which set of buttons we are looking at, followed by an if statement that achieves:
if 'setnr' == set1 , then var plots = plot1, plot2
else if 'setnr == set2, then var plots = plot3, plot4
and then update the trace in 'plots'
In the new app, the color-set1-1, color-set1-2, color-set1-3 still target all 4 plots.
library(plotly)
library(shiny)
library(colourpicker)
library(htmlwidgets)
js <- c(
"function(el,x){",
" $('[id^=Color]').on('change', function(){",
" var color = this.value;",
" var id = this.id;",
" var index = parseInt(id.split('-')[1]) - 1;",
" var data = el.data;",
" var marker = data[index].marker;",
" marker.color = color;",
" Plotly.restyle(el, {marker: marker}, [index]);",
" });",
"}")
ui <- fluidPage(
fluidRow(
column(4,plotlyOutput("plot1")),
column(4,plotlyOutput("plot2")),
column(4,
colourInput("Color-1", "Color item 1", value = "blue"), # these buttons will become named Color-set1-1, Color-set1-2, Color-set1-3
colourInput("Color-2", "Color item 2", value = "red"), # but that requires an extra change to the js
colourInput("Color-3", "Color item 3", value = "green")
)
),
fluidRow(
column(4,plotlyOutput("plot3")),
column(4,plotlyOutput("plot4")),
column(4,
colourInput("Color-set2-1", "Color item 1", value = "blue"),
colourInput("Color-set2-2", "Color item 2", value = "red"),
colourInput("Color-set2-3", "Color item 3", value = "green")
)
)
)
server <- function(input, output, session) {
values <- reactiveValues(colors1 = c('red', 'blue', 'black'), colors2 = c('yellow', 'blue', 'green') )
myplotly <- function(THEPLOT, xvar, setnr) {
markersize <- input[[paste('markersize', THEPLOT, sep = '_')]]
markerlegendsize <- input[[paste('legendsize', THEPLOT, sep = '_')]]
colors <- isolate ({values[[paste('colors', setnr, sep = '')]] })
p <- plot_ly(source = paste('plotlyplot', THEPLOT, sep = '.'))
p <- add_trace(p, data = mtcars, x = mtcars[[xvar]], y = ~mpg, type = 'scatter', mode = 'markers', color = ~as.factor(cyl), colors = colors)
p <- layout(p, title = 'mtcars group by cyl with switching colors')
p <- plotly_build(p)
p %>% onRender(js)
}
output$plot1 <- renderPlotly({ myplotly('plot1', 'hp', 1) })
output$plot2 <- renderPlotly({ myplotly('plot2', 'disp', 1)})
output$plot3 <- renderPlotly({ myplotly('plot3','hp', 2)})
output$plot4 <- renderPlotly({ myplotly('plot4', 'disp', 2)})
}
shinyApp(ui, server)
The original APP:
library(plotly)
library(shiny)
library(htmlwidgets)
library(colourpicker)
library(shinyjs)
## javascript from previous question's answer:
jsCode <- "shinyjs.changelegend = function(){
var paths = d3.select('#plot1').
select('.legend').
select('.scrollbox').
selectAll('.traces').
select('.scatterpts')
.attr('d','M8,0A8,8 0 1,1 0,-8A8,8 0 0,1 8,0Z');}"
ui <- fluidPage(
tags$script(src = "https://d3js.org/d3.v4.min.js"),
useShinyjs(),
extendShinyjs(text = jsCode),
fluidRow(
column(2,numericInput(inputId = 'markersize_plot1', label = 'marker', min = 1, max = 40, value = 20)),
column(2,numericInput(inputId = 'legendsize_plot1', label = 'legend', min = 1, max = 40, value = 10)),
column(2,numericInput(inputId = 'markersize_plot2', label = 'marker', min = 1, max = 40, value = 4)),
column(2,numericInput(inputId = 'legendsize_plot2', label = 'legend', min = 1, max = 40, value = 20))
),
fluidRow(
column(4,plotlyOutput("plot1")),
column(4,plotlyOutput("plot2")),
column(2,uiOutput('buttons_color_1'))
),
fluidRow(
column(2,numericInput(inputId = 'markersize_plot3', label = 'marker', min = 1, max = 40, value = 10)),
column(2,numericInput(inputId = 'legendsize_plot3', label = 'legend', min = 1, max = 40, value = 30)),
column(2,numericInput(inputId = 'markersize_plot4', label = 'marker', min = 1, max = 40, value = 7)),
column(2,numericInput(inputId = 'legendsize_plot4', label = 'legend', min = 1, max = 40, value = 40))
),
fluidRow(
column(4,plotlyOutput("plot3")),
column(4,plotlyOutput("plot4")),
column(2,uiOutput('buttons_color_2'))
)
)
server <- function(input, output, session) {
values <- reactiveValues(colors1 = c('red', 'blue', 'black'), colors2 = c('yellow', 'blue', 'green') )
lapply(c(1:2), function(i) {
output[[paste('buttons_color_', i,sep = '')]] <- renderUI({
isolate({ lapply(1:3, function(x) { ## 3 in my app changes based on clustering output of my model
Idname <- if(i == 1) { COLElement_1(x) } else {COLElement_2(x) }
div(colourpicker::colourInput(inputId = Idname, label = NULL,
palette = "limited", allowedCols = TheColors,
value = values[[paste('colors', i, sep = '')]][x],
showColour = "background", returnName = TRUE),
style = " height: 30px; width: 30px; border-radius: 6px; border-width: 2px; text-align:center; padding: 0px; display:block; margin: 10px")
})
})})
outputOptions(output, paste('buttons_color_', i,sep = ''), suspendWhenHidden=FALSE)
})
COLElement_1 <- function(idx){sprintf("COL_button_1-%d",idx)}
lapply(1:3, function(ob) {
COLElement_1 <- COLElement_1(ob)
observeEvent(input[[COLElement_1]], {
values[[paste('colors', 1, sep = '')]][ob] <- input[[COLElement_1]]
plotlyProxy("plot1", session) %>%
plotlyProxyInvoke("restyle", list(marker = list(color = input[[COLElement_1]])), list(as.numeric(ob)-1))
plotlyProxy("plot2", session) %>%
plotlyProxyInvoke("restyle", list(marker = list(color = input[[COLElement_1]])), list(as.numeric(ob)-1))
})
})
COLElement_2 <- function(idx){sprintf("COL_button_2-%d",idx)}
lapply(1:3, function(ob) {
COLElement_2 <- COLElement_2(ob)
observeEvent(input[[COLElement_2]], {
values[[paste('colors', 2, sep = '')]][ob] <- input[[COLElement_2]]
plotlyProxy("plot3", session) %>%
plotlyProxyInvoke("restyle", list(marker = list(color = input[[COLElement_2]])), list(as.numeric(ob)-1))
plotlyProxy("plot4", session) %>%
plotlyProxyInvoke("restyle", list(marker = list(color = input[[COLElement_2]])), list(as.numeric(ob)-1))
})
})
myplotly <- function(THEPLOT, xvar, setnr) {
markersize <- input[[paste('markersize', THEPLOT, sep = '_')]]
markerlegendsize <- input[[paste('legendsize', THEPLOT, sep = '_')]]
colors <- isolate ({values[[paste('colors', setnr, sep = '')]] })
p <- plot_ly(source = paste('plotlyplot', THEPLOT, sep = '.'))
p <- add_trace(p, data = mtcars, x = mtcars[[xvar]], y = ~mpg, type = 'scatter', mode = 'markers', color = ~as.factor(cyl), colors = colors)
p <- layout(p, title = 'mtcars group by cyl with switching colors')
p <- plotly_build(p)
# this is a bit of a hack to change the size of the legend markers to not be equal to the plot marker size.
# it makes a list of 1 size value for each marker in de trace in the plot, and another half of with sizes that are a lot bigger.
# the legend marker size is effectively the average size of all markers of a trace
for(i in seq(1, length(sort(unique(mtcars$cyl) )))) {
length.group <- nrow(mtcars[which(mtcars$cyl == sort(unique(mtcars$cyl))[i]), ])
p$x$data[[i]]$marker$size <- c(rep(markersize,length.group), rep(c(-markersize+2*markerlegendsize), length.group))
}
p
}
output$plot1 <- renderPlotly({ myplotly('plot1', 'hp', 1) })
output$plot2 <- renderPlotly({ myplotly('plot2', 'disp', 1)})
output$plot3 <- renderPlotly({ myplotly('plot3','hp', 2)})
output$plot4 <- renderPlotly({ myplotly('plot4', 'disp', 2)})
}
shinyApp(ui, server)
I'm lost :)
Let's start. Here is an app allowing to change the marker size:
library(plotly)
library(shiny)
js <- paste(c(
"$(document).ready(function(){",
" $('#size').on('change', function(){",
" var size = Number(this.value);",
" var plot = document.getElementById('plot');",
" var data = plot.data;",
" $.each(data, function(index,value){",
" var marker = data[index].marker;",
" marker.size = size;",
" Plotly.restyle(plot, {marker: marker}, [index]);",
" });",
" });",
"})"), sep = "\n")
ui <- fluidPage(
tags$head(
tags$script(HTML(js))
),
plotlyOutput("plot"),
numericInput("size", "Size", value = 5, min = 1, max = 15)
)
server <- function(input, output, session) {
output$plot <- renderPlotly({
p <- plot_ly()
for(name in c("drat", "wt", "qsec"))
{
p <- add_markers(p, x = as.numeric(mtcars$cyl), y = as.numeric(mtcars[[name]]), name = name)
}
p
})
}
shinyApp(ui, server)
And here is an app allowing to change the marker color:
library(plotly)
library(shiny)
library(colourpicker)
library(htmlwidgets)
js <- c(
"function(el,x){",
" $('[id^=Color]').on('change', function(){",
" var color = this.value;",
" var id = this.id;",
" var index = parseInt(id.split('-')[1]) - 1;",
" var data = el.data;",
" var marker = data[index].marker;",
" marker.color = color;",
" Plotly.restyle(el, {marker: marker}, [index]);",
" });",
"}")
ui <- fluidPage(
plotlyOutput("plot"),
colourInput("Color-1", "Color item 1", value = "blue"),
colourInput("Color-2", "Color item 2", value = "red"),
colourInput("Color-3", "Color item 3", value = "green")
)
server <- function(input, output, session) {
output$plot <- renderPlotly({
p <- plot_ly()
for(name in c("drat", "wt", "qsec"))
{
p <- add_markers(p, x = as.numeric(mtcars$cyl), y = as.numeric(mtcars[[name]]), name = name)
}
p %>% onRender(js)
})
}
shinyApp(ui, server)
Does it help?
With shiny, you can use color=~get(input$XXX). Here's an example with my own code:
fig = plot_mapbox()
# POLYGONS
fig = fig %>% add_sf(
data=districts,
split=~DISTRICT,
color=~log10(get(input$multi_indicator_districts.selectors.colorBy)))
# POINTS
fig = fig %>% add_trace(
type='scatter',
data=facilities,
x=~longitude,
y=~latitude,
split=~tier)
fig = fig %>% layout(
mapbox=list(
zoom=4,
style='open-street-map'))
I am plotting a timeseries with Plotly and by clicking on a certain column/day, some special event occurs. Now I also want to use navigation buttons (next / previous day), which change the selected day.
The problem is that the highlighting remains on the column that was clicked in the plot and therefore will differ from the actual selected day when clicking the navigation buttons.
How can I change the highlighting of Plotly with actionButtons?
or
How can I simulate a click on a Plotly-column with actionButons?
Test-App:
## Libs##########
library(shiny)
library(ggplot2)
library(plotly)
library(data.table)
## Data ############
dfN <- data.table(
time_stamp = seq.Date(as.Date("2018-04-01"), as.Date("2018-07-30"), 1),
val = runif(121, 100,1000),
qual = 8,
col = "green", stringsAsFactors = F
)
setkey(dfN, time_stamp)
Rnd <- sample(1:nrow(dfN), size = 10, replace = F)
dfN[Rnd,"col"] <- "red"
dfN[Rnd, "qual"] <- 3
## Ui ##########
ui <- fluidPage(
plotlyOutput("plot"),
h4("Which Day is selected:"),
verbatimTextOutput("selected"),
actionButton("prev1", "Previous Element"),
actionButton("next1", "Next Element")
)
## Server ##########
server <- function(input, output, session) {
## Plot
output$plot <- renderPlotly({
key <- highlight_key(dfN)
p <- ggplot() +
geom_col(data = key, aes(x = plotly:::to_milliseconds(time_stamp), y = val, fill=I(col),
text=paste("Date: ", time_stamp, "<br>",
"Quality: ", qual))) +
labs(y = "", x="") +
theme(legend.position="none")
ggplotly(p, source = "Src", tooltip = "text") %>%
layout(xaxis = list(tickval = NULL, ticktext = NULL, type = "date")) %>%
highlight(selectize=F, off = "plotly_doubleclick", on = "plotly_click", color = "blue",
opacityDim = 0.5, selected = attrs_selected(opacity = 1))
})
## Selected Day reactive
SelectedDay <- reactiveVal(NULL)
## Plotly Event for clicks
observe({
s <- event_data("plotly_click", source = "Src")
req(s)
SelectedDay(as.Date(s$x))
})
## Action buttons for next / previous Day
observeEvent(input$next1, {
IND <- which(dfN$time_stamp == SelectedDay()) + 1
if (IND >= length(dfN$time_stamp)) {
IND = length(dfN$time_stamp)
print("last element reached")
}
SelectedDay(dfN[IND,time_stamp])
})
observeEvent(input$prev1, {
IND <- which(dfN$time_stamp == SelectedDay()) - 1
if (IND <= 1) {
print("first element reached")
IND = 1
}
SelectedDay(dfN[IND,time_stamp])
})
## Print the actual selection
output$selected <- renderPrint({
req(SelectedDay())
SelectedDay()
})
}
shinyApp(ui, server)
I needed to drop your ggplotly(), but nevertheless here is how I would approach this:
## Libs##########
library(shiny)
library(plotly)
library(data.table)
## Data ############
dfN <- data.table(
time_stamp = seq.Date(as.Date("2018-04-01"), as.Date("2018-07-30"), 1),
val = runif(121, 100,1000),
qual = 8,
col = "green", stringsAsFactors = F
)
setkey(dfN, time_stamp)
Rnd <- sample(1:nrow(dfN), size = 10, replace = F)
dfN[Rnd,"col"] <- "red"
dfN[Rnd, "qual"] <- 3
## Ui ##########
ui <- fluidPage(
plotlyOutput("plot"),
h4("Which Day is selected:"),
verbatimTextOutput("selected"),
actionButton("prev1", "Previous Element"),
actionButton("next1", "Next Element")
)
## Server ##########
server <- function(input, output, session) {
## Plot
output$plot <- renderPlotly({
plot_ly(dfN, source = "Src", x=~time_stamp, y=~val, selectedpoints=as.list(which(dfN$time_stamp==SelectedDay())-1), type = "bar")
})
## Selected Day reactive
SelectedDay <- reactiveVal(dfN$time_stamp[1])
## Plotly Event for clicks
observe({
s <- event_data("plotly_click", source = "Src")
req(s)
SelectedDay(as.Date(s$x))
})
## Action buttons for next / previous Day
observeEvent(input$next1, {
IND <- which(dfN$time_stamp == SelectedDay()) + 1
if (IND >= length(dfN$time_stamp)) {
IND = length(dfN$time_stamp)
print("last element reached")
}
SelectedDay(dfN[IND,time_stamp])
})
observeEvent(input$prev1, {
IND <- which(dfN$time_stamp == SelectedDay()) - 1
if (IND <= 1) {
print("first element reached")
IND = 1
}
SelectedDay(dfN[IND,time_stamp])
})
## Print the actual selection
output$selected <- renderPrint({
req(SelectedDay())
SelectedDay()
})
}
shinyApp(ui, server)
Maybe you can adapt it to your needs. Please also see: https://plot.ly/r/reference/#bar-selectedpoints
Multiple selectedpoints example:
library(plotly)
singleP <- plot_ly(data.frame(x=1:10, y=1:10), x=~x, y=~y, selectedpoints=list(1,8), type = "bar")
multiP <- plot_ly(data.frame(x=1:10, y=1:10)) %>%
add_trace(x=~x, y=~y, selectedpoints=list(1,8), type = "bar") %>%
add_trace(x=~x, y=~y, selectedpoints=list(0,2,6), type = "bar")
subplot(singleP, multiP)