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)
I am interested in using leaflet-groupedlayercontrol within an Leaflet map created in R and have been following this gist. I can successfully add the JS plugin (as in this working example below), but my question is how do I refer to marker groups already created in R?
library(leaflet)
library(htmltools)
library(htmlwidgets)
library(dplyr)
#Download the JS and CSS
urlf <- 'https://raw.githubusercontent.com/ismyrnow/leaflet-groupedlayercontrol/gh-pages/dist/%s'
download.file(sprintf(urlf,'leaflet.groupedlayercontrol.min.js'), 'C:/Temp/L.Control.groupedlayer.js', mode="wb")
download.file(sprintf(urlf,'leaflet.groupedlayercontrol.min.css'), 'C:/Temp/L.Control.groupedlayer.css', mode="wb")
#Add the dependency
ctrlGrouped <- htmltools::htmlDependency(
name = 'ctrlGrouped',
version = "1.0.0",
src = c(file = normalizePath('C:/Temp')),
script = "L.Control.groupedlayer.js",
stylesheet = "L.Control.groupedlayer.css"
)
registerPlugin <- function(map, plugin) {
map$dependencies <- c(map$dependencies, list(plugin))
map
}
#create a basic map
map <- leaflet() %>%
setView(-122.38, 47.56, zoom = 12)
#add the plugin and then tell it to do stuff within onRender()
map <- map %>% registerPlugin(ctrlGrouped) %>%
#I can create some points within onRender() but I want to refer to existing R objects if possible.
onRender("function(el, x) {
var basemaps = {
Grayscale: L.tileLayer('http://{s}.tiles.wmflabs.org/bw-mapnik/{z}/{x}/{y}.png', {
maxZoom: 18,
attribution: '© <a href=http://www.openstreetmap.org/copyright>OpenStreetMap</a>'
})
};
basemaps.Grayscale.addTo(this); // default base layer
var groups = {
highschool: new L.LayerGroup(),
elementary: new L.LayerGroup()
};
L.marker([47.577541, -122.3843482]).bindPopup('West Seattle HS').addTo(groups.highschool);
L.marker([47.5661429, -122.3840636]).bindPopup('Seattle Lutheran HS').addTo(groups.highschool);
L.marker([47.581081, -122.3871535]).bindPopup('Lafayette ES').addTo(groups.elementary);
L.marker([47.566556, -122.3964651]).bindPopup('Genesee Hill ES').addTo(groups.elementary);
// Overlay layers are grouped
var groupedOverlays = {
'all schools': {
'High School locations': groups.highschool,
'Elementary locations': groups.elementary
}
};
var options = {
groupCheckboxes: true
};
L.control.groupedLayers(null, groupedOverlays, options).addTo(this);
}")
map
Instead of making the all the markers within onRender(), I was hoping to refer existing R objects, use addLegend(), control what is visible initially, etc. If didn't want the grouped layer control so badly, the code would looks something more like this:
map <- leaflet() %>%
addCircles(lng =highschool$Longitude,lat=highschool$Latitude,weight = 1, radius = highschool$units*2 , color = ~pal(a_palette), popup = popup_hs, group="highschool" )%>%
addCircles(lng =elementary$Longitude,lat=elementary$Latitude,weight = 1, radius = misc$units*2 , color = ~pal(a_palette), popup = popup_el, group="elementary" )%>%
addLegend("bottomleft", colors = palette_color_RSEI ,group = "highschool",labels = c("Lowest ","","","Highest"),
title = "Highschool size", opacity = 1) %>%
addLegend("bottomleft", colors = a_palette ,group = "elementary",labels = c("Lower % of population", "", "","","","Higher % of population"),
title = "Elementary size", opacity = .5) %>%
addLayersControl(overlayGroups = c("highschool", "elementary"))%>%
hideGroup(c( "highschool"))
Any guidance would be greatly appreciated.
It also looks like you can reference R objects within htmlwidgets::onRender() within javascript for loop. Key for me was realizing that R objects have dot notation within onRender(). So for example, an R vector df$longitude is a JSON object as data.longitude within onRender().
Here is a example from my question, where I add 4 markers from an R object to a leaflet map within onRender()and then use leaflet add-on leaflet-groupedlayercontrol. My real world map had many more groups, so this may not be the most tidy approach.
library(leaflet)
library(dplyr)
library(htmlwidgets)
df<-tibble::tibble(lat= c(47.577541, 47.5661429,47.581081,47.566556),
lng = c(-122.3843482,-122.3840636,-122.3871535,-122.3964651),
name= c("West Seattle HS","Seattle Lutheran HS","Lafayette ES","Genesee Hill ES"),
grouping=c("groups.highschool","groups.highschool","groups.elementary","groups.elementary"))
urlf <- 'https://raw.githubusercontent.com/ismyrnow/leaflet-groupedlayercontrol/gh-pages/dist/%s'
download.file(sprintf(urlf,'leaflet.groupedlayercontrol.min.js'), 'C:/Temp/L.Control.groupedlayer.js', mode="wb")
download.file(sprintf(urlf,'leaflet.groupedlayercontrol.min.css'), 'C:/Temp/L.Control.groupedlayer.css', mode="wb")
ctrlGrouped <- htmltools::htmlDependency(
name = 'ctrlGrouped',
version = "1.0.0",
# works in R and Shiny - download js/css files, then use this:
src = c(file = normalizePath('C:/Temp')),
script = "L.Control.groupedlayer.js",
stylesheet = "L.Control.groupedlayer.css"
)
registerPlugin <- function(map, plugin) {
map$dependencies <- c(map$dependencies, list(plugin))
map
}
leaflet() %>% addTiles() %>%
registerPlugin(ctrlGrouped) %>%
fitBounds(min(df$lng), min(df$lat), max(df$lng), max(df$lat)) %>%
onRender("
function(el, x, data) {
var groups = {
highschool: new L.LayerGroup(),
elementary: new L.LayerGroup()
};
for (var i = 0; i < data.lng.length; i++) {
var label = JSON.stringify(data.name[i])
var mygroup = data.grouping[i]
var marker = L.marker([data.lat[i], data.lng[i]]).bindPopup(label).addTo(eval(mygroup));
}
var groupedOverlays = {
'all schools': {
'High School locations': groups.highschool,
'Elementary locations': groups.elementary
}
};
var options = {
groupCheckboxes: true,
collapsed:false
};
L.control.groupedLayers(null, groupedOverlays, options).addTo(this);
}
", data = df)
It would look similar to this:
map <- leaflet() %>%
addCircles(...) %>%
addCircles(...) %>%
addLegend(...) %>%
addLegend(...) %>%
registerPlugin(ctrlGrouped) %>%
onRender("function(el, x) {
var groupedOverlays = {
'all schools': {
'High School locations': groups.highschool,
'Elementary locations': groups.elementary
}
};
var options = {
groupCheckboxes: true
};
L.control.groupedLayers(null, groupedOverlays, options).addTo(this);
}")
An example showing L.tileLayer(s), adapted from SEAnalyst answer.
library(leaflet)
library(dplyr)
library(htmlwidgets)
urlf <- 'https://raw.githubusercontent.com/ismyrnow/leaflet-
groupedlayercontrol/gh-pages/dist/%s'
download.file(sprintf(urlf,'leaflet.groupedlayercontrol.min.js'),
'C:/grouped_layer_controls/L.Control.groupedlayer.js', mode="wb")
download.file(sprintf(urlf,'leaflet.groupedlayercontrol.min.css'),
'C:/grouped_layer_controls/L.Control.groupedlayer.css', mode="wb")
ctrlGrouped <- htmltools::htmlDependency(
name = 'ctrlGrouped',
version = "1.0.0",
# works in R and Shiny - download js/css files, then use this:
src = c(file = normalizePath('C:/grouped_layer_controls')),
script = "L.Control.groupedlayer.js",
stylesheet = "L.Control.groupedlayer.css"
)
registerPlugin <- function(map, plugin) {
map$dependencies <- c(map$dependencies, list(plugin))
map
}
leaflet() %>%
addTiles() %>%
setView(lng = -122.3903184, lat = 47.5724059, zoom = 15) |>
leaflet::addCircles(lng = -122.3903184,
lat = 47.5724059,
radius = 20,
fillColor = 'red',
fillOpacity = 1,
group = "r") |>
leaflet::addCircles(lng = -122.390,
lat = 47.572,
radius = 20,
fillColor = 'blue',
fillOpacity = 1,
group = "b") |>
leaflet::addLayersControl(baseGroups = c("r", "b"),
options = leaflet::layersControlOptions(collapsed = FALSE)) |>
registerPlugin(ctrlGrouped) %>%
htmlwidgets::onRender(
"function(el, x, data) {
var basemaps = {
Stadia_AlidadeSmoothDark:
L.tileLayer( 'https://tiles.stadiamaps.com/tiles/alidade_smooth_dark/{z}/{x}/{y}{r}.png',
{
attribution: '© BLAM-O'
}),
Streets:
L.tileLayer('http://{s}.tile.openstreetmap.org/{z}/{x}/{y}.png', {}),
CartoDB_Positron:
L.tileLayer('https://{s}.basemaps.cartocdn.com/light_all/{z}/{x}/{y}{r}.png', {})
};
var groupedOverlays = {
\"Map Type\": {
\"Stadia\": basemaps.Stadia_AlidadeSmoothDark,
\"Streets\": basemaps.Streets,
\"Positron\": basemaps.CartoDB_Positron
}
};
var options = {
groupCheckboxes: false,
exclusiveGroups: [\"Map Type\"],
collapsed:false
};
L.control.groupedLayers(null, groupedOverlays, options).addTo(this);
basemaps.Streets.addTo(this);
}")
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'))
Is there a way to return all the selected points from a scatter plot in highchart via shiny? The idea is to dynamically exclude or include points to be used for regression. I would like to have the ability to select the desired points, write them to a dataframe and then perform a non-linear regression on them. So far, I'm able to select and deselect points from the chart by using the JavaScript code from here and here. I can't seem to be able to return the selected points to a dataframe.
Please see my attempt below.
#devtools::install_github("jbkunst/highcharter")
library(highcharter)
library(htmlwidgets)
library(shiny)
#http://jsfiddle.net/gh/get/jquery/3.1.1/highcharts/highcharts/tree/master/samples/highcharts/chart/events-selection-points/
# selectPointsByDrag
s1 <- JS("/**
* Custom selection handler that selects points and cancels the default zoom behaviour
*/
function selectPointsByDrag(e) {
// Select points
Highcharts.each(this.series, function (series) {
Highcharts.each(series.points, function (point) {
if (point.x >= e.xAxis[0].min && point.x <= e.xAxis[0].max &&
point.y >= e.yAxis[0].min && point.y <= e.yAxis[0].max) {
point.select(true, true);
}
});
});
// Fire a custom event
Highcharts.fireEvent(this, 'selectedpoints', { points: this.getSelectedPoints() });
return false; // Don't zoom
}")
# unselectByClick
s2 <- JS("/**
* On click, unselect all points
*/
function unselectByClick() {
var points = this.getSelectedPoints();
if (points.length > 0) {
Highcharts.each(points, function (point) {
point.select(false);
});
}
}")
shinyApp(
ui = fluidPage(
uiOutput("selection_ui"),
highchartOutput("plot_hc"),
tableOutput("view")
),
server = function(input, output) {
df <- data.frame(x = 1:50, y = 1:50, otherInfo = letters[11:15])
df_copy <- df
output$plot_hc <- renderHighchart({
highchart() %>%
hc_chart(zoomType = 'xy', events = list(selection = s1, click = s2)) %>%
hc_add_series(df, "scatter") %>%
hc_add_event_point(event = "select")
})
output$view <- renderTable({
data.table(x = input$plot_hc_select$x, y = input$plot_hc_select$y)
})
observeEvent(input$plot_hc, print(paste("plot_hc", input$plot_hc)))
output$selection_ui <- renderUI({
if(is.null(input$plot_hc_select)) return()
wellPanel("Coordinates of selected point: ",input$plot_hc_select$x, input$plot_hc_select$y)
})
}
)
Error: column or argument 1 is NULL
There is no straightforward way to achieve what you want, using only Highcharter or Highcharts (as far as I know). One simple way to do this though would be to store each selected point in an (javascript) array, and to pass it to R. Thanks to Shiny, this can be easily done using Shiny.onInputChange (see example here).
One could rewrite your shiny app like this to make it work:
1) In the s1 function, store the selected points in xArr.
2) Use Shiny.onInputChange to pass xArr to R. xArr will be accessible via input$R_xArr (I chose the name R_xArr, it is not an automatic assignment).
3) Use a reactiveValues to store the selected points on the R side.
4) Update these values with appropriate observers.
#devtools::install_github("jbkunst/highcharter")
library(highcharter)
library(htmlwidgets)
library(shiny)
library(data.table)
# selectPointsByDrag
s1 <- JS("/**
* Custom selection handler that selects points and cancels the default zoom behaviour
*/
function selectPointsByDrag(e) {
var xArr = []
// Select points
Highcharts.each(this.series, function (series) {
Highcharts.each(series.points, function (point) {
if (point.x >= e.xAxis[0].min && point.x <= e.xAxis[0].max &&
point.y >= e.yAxis[0].min && point.y <= e.yAxis[0].max) {
xArr.push(point.x);
point.select(true, true);
}
});
});
Shiny.onInputChange('R_xArr', xArr);
// Fire a custom event
Highcharts.fireEvent(this, 'selectedpoints', { points: this.getSelectedPoints() });
return false; // Don't zoom
}")
# unselectByClick
s2 <- JS("/**
* On click, unselect all points
*/
function unselectByClick() {
var points = this.getSelectedPoints();
if (points.length > 0) {
Highcharts.each(points, function (point) {
point.select(false);
});
}
}")
shinyApp(
ui = fluidPage(
highchartOutput("plot_hc"),
tableOutput("view")
),
server = function(input, output) {
df <- data.frame(x = 1:50, y = 1:50, otherInfo = letters[11:15])
output$plot_hc <- renderHighchart({
highchart() %>%
hc_chart(zoomType = 'xy', events = list(selection = s1, click = s2)) %>%
hc_add_series(df, "scatter") %>%
hc_add_event_point(event = "unselect")
})
selected.points <- reactiveValues(x = NULL, y = NULL)
output$view <- renderTable({
if (is.null(selected.points$x) || is.null(selected.points$y)) {
return(NULL)
} else {
data.table(x = selected.points$x, y = selected.points$y)
}
})
observeEvent(input$R_xArr, {
selected.points$x <- sort(unique(c(selected.points$x, input$R_xArr)))
selected.points$y <- df$y[df$x %in% selected.points$x]
})
observeEvent(input$plot_hc_unselect, {
selected.points$x <- NULL
selected.points$y <- NULL
})
}
)
Hope this helps.