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)
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);
}")
I would like to implement a button on a plotly chart that will copy the plot to the user's clipboard similar to how the snapshot button downloads a png of the plot as a file.
I've referenced this documentation to create a custom modebar button, but I'm not familiar enough with Javascript to know how to write that snippet (or if its even possible).
Below is the R code I wrote to try it, but it doesn't work. A button does appear (although the image is not visible, but I can tell its there if I hover in the upper rightmost corner). But when I click it, the plot is not copied to the clipboard and the chrome console says:
Uncaught TypeError: Plotly.execCommand is not a function
at Object.eval [as click] (eval at tryEval ((index):258), :2:15)
at HTMLAnchorElement. (:7:2055670)
Figure:
My code:
library(plotly)
library(shiny)
d <- data.frame(xaxis = c(1,2,3,4,5),
ydata = c(10,40,60,30,25))
p <- plot_ly() %>%
add_trace(data = d,
x = ~xaxis,
y = ~ydata,
type = "scatter", mode = "lines")
plotClip <- list(
name = "plotClip",
icon = list(
path = "plotClip.svg",
transform = 'matrix(1 0 0 1 -2 -2) scale(0.7)'
),
click = htmlwidgets::JS(
'function(gd) {
Plotly.execCommand("copy");
alert("Copied the plot");
}'
)
)
p <- p %>%
config(modeBarButtonsToAdd = list(plotClip),
displaylogo = FALSE,
toImageButtonOptions= list(filename = "plot.png",
format = "png",
width = 800, height = 400))
ui <- fluidPage(
plotlyOutput(outputId = "myplot")
)
server <- function(input, output) {
output$myplot <- renderPlotly({
p
})
}
shinyApp(ui, server)
Thanks for any insight on this!
I don't know how to deal with the toolbar, but here is how to copy the image to the clipboard by clicking a button:
library(shiny)
library(plotly)
d <- data.frame(X1 = rnorm(50,mean=50,sd=10),
X2 = rnorm(50,mean=5,sd=1.5),
Y = rnorm(50,mean=200,sd=25))
ui <- fluidPage(
title = 'Copy Plotly to clipboard',
sidebarLayout(
sidebarPanel(
helpText(),
actionButton('copy', "Copy")
),
mainPanel(
plotlyOutput('regPlot'),
tags$script('
async function copyImage(url) {
try {
const data = await fetch(url);
const blob = await data.blob();
await navigator.clipboard.write([
new ClipboardItem({
[blob.type]: blob
})
]);
console.log("Image copied.");
} catch (err) {
console.error(err.name, err.message);
}
}
document.getElementById("copy").onclick = function() {
var gd = document.getElementById("regPlot");
Plotly.Snapshot.toImage(gd, {format: "png"}).once("success", function(url) {
copyImage(url);
});
}')
)
)
)
server <- function(input, output, session) {
regPlot <- reactive({
plot_ly(d, x = d$X1, y = d$X2, mode = "markers")
})
output$regPlot <- renderPlotly({
regPlot()
})
}
shinyApp(ui = ui, server = server)
EDIT
I found how to deal with the toolbar. This even doesn't require Shiny.
library(plotly)
asd <- data.frame(
week = c(1, 2, 3),
a = c(12, 41, 33),
b = c(43, 21, 23),
c = c(43, 65, 43),
d = c(33, 45, 83)
)
js <- c(
'function (gd) {',
' Plotly.Snapshot.toImage(gd, { format: "png" }).once(',
' "success",',
' async function (url) {',
' try {',
' const data = await fetch(url);',
' const blob = await data.blob();',
' await navigator.clipboard.write([',
' new ClipboardItem({',
' [blob.type]: blob',
' })',
' ]);',
' console.log("Image copied.");',
' } catch (err) {',
' console.error(err.name, err.message);',
' }',
' }',
' );',
'}'
)
Copy_SVGpath <- "M97.67,20.81L97.67,20.81l0.01,0.02c3.7,0.01,7.04,1.51,9.46,3.93c2.4,2.41,3.9,5.74,3.9,9.42h0.02v0.02v75.28 v0.01h-0.02c-0.01,3.68-1.51,7.03-3.93,9.46c-2.41,2.4-5.74,3.9-9.42,3.9v0.02h-0.02H38.48h-0.01v-0.02 c-3.69-0.01-7.04-1.5-9.46-3.93c-2.4-2.41-3.9-5.74-3.91-9.42H25.1c0-25.96,0-49.34,0-75.3v-0.01h0.02 c0.01-3.69,1.52-7.04,3.94-9.46c2.41-2.4,5.73-3.9,9.42-3.91v-0.02h0.02C58.22,20.81,77.95,20.81,97.67,20.81L97.67,20.81z M0.02,75.38L0,13.39v-0.01h0.02c0.01-3.69,1.52-7.04,3.93-9.46c2.41-2.4,5.74-3.9,9.42-3.91V0h0.02h59.19 c7.69,0,8.9,9.96,0.01,10.16H13.4h-0.02v-0.02c-0.88,0-1.68,0.37-2.27,0.97c-0.59,0.58-0.96,1.4-0.96,2.27h0.02v0.01v3.17 c0,19.61,0,39.21,0,58.81C10.17,83.63,0.02,84.09,0.02,75.38L0.02,75.38z M100.91,109.49V34.2v-0.02h0.02 c0-0.87-0.37-1.68-0.97-2.27c-0.59-0.58-1.4-0.96-2.28-0.96v0.02h-0.01H38.48h-0.02v-0.02c-0.88,0-1.68,0.38-2.27,0.97 c-0.59,0.58-0.96,1.4-0.96,2.27h0.02v0.01v75.28v0.02h-0.02c0,0.88,0.38,1.68,0.97,2.27c0.59,0.59,1.4,0.96,2.27,0.96v-0.02h0.01 h59.19h0.02v0.02c0.87,0,1.68-0.38,2.27-0.97c0.59-0.58,0.96-1.4,0.96-2.27L100.91,109.49L100.91,109.49L100.91,109.49 L100.91,109.49z"
CopyImage <- list(
name = "Copy",
icon = list(
path = Copy_SVGpath,
width = 111,
height = 123
),
click = htmlwidgets::JS(js)
)
plot_ly(
asd, x = ~week, y = ~`a`, name = "a", type = "scatter", mode = "lines"
) %>%
add_trace(y = ~`b`, name = "b", mode = "lines") %>%
layout(
xaxis = list(title = "Week", showgrid = FALSE, rangemode = "normal"),
yaxis = list(title = "", showgrid = FALSE, rangemode = "normal"),
hovermode = "x unified"
) %>%
config(modeBarButtonsToAdd = list(CopyImage))
For anyone looking for how to do this in the toolbar/modebar specifically, I modified Stephane Laurent's answer from below to get it to work.
However, the issues that remain are:
The initial click of the button copies the chart to clipboard but the size is different from what is shown on screen initially. If you change the chart at all, even by simply changing the browser window size, then click the button again, the copied chart looks exactly like it does in browser (ideal behavior).
Setting {format: "png", height: 400, width: 800} does not seem to explicitly define the size of the copied chart.
The icon does not appear on the button despite the file being in the same dir as the app.
full code:
library(plotly)
library(shiny)
d <- data.frame(xaxis = c(1,2,3,4,5),
ydata = c(10,40,60,30,25))
p <- plot_ly() %>%
add_trace(data = d,
x = ~xaxis,
y = ~ydata,
type = "scatter", mode = "lines")
plotClip <- list(
name = "plotClip",
icon = list(
path = "plotClip.svg",
transform = 'matrix(1 0 0 1 -2 -2) scale(0.7)'
),
click = htmlwidgets::JS(
'function(gd) {
Plotly.Snapshot.toImage(gd, {format: "png"}).once("success", function(url) {
copyImage(url);
});
alert("Copied the plot");
}'
)
)
p <- p %>%
config(modeBarButtonsToAdd = list(plotClip),
displaylogo = FALSE,
toImageButtonOptions= list(filename = "plot.png",
format = "png",
width = 800, height = 400))
copyImgTag <- tags$script(
'async function copyImage(url) {
try {
const data = await fetch(url);
const blob = await data.blob();
await navigator.clipboard.write([
new ClipboardItem({
[blob.type]: blob
})
]);
console.log("Image copied.");
} catch (err) {
console.error(err.name, err.message);
}
}'
)
ui <- tagList(
fluidPage(
plotlyOutput(outputId = "myplot")
),
copyImgTag
)
server <- function(input, output) {
output$myplot <- renderPlotly({
p
})
}
shinyApp(ui, server)
I built upon Joe's answer to resolve his solution's limitations
Used Plotly.toImage instead of Plotly.Snapshot.toImage to enable users to either choose copied plot's size via toImageButtonOptions or default to whatever size is shown in shiny app.
added svg copy icon
Limitations:
only works in localhost or shinyapps.io or shiny server pro, because all browers will block clipboard access unless website uses HTTPS or is localhost
library(tidyverse)
library(plotly)
# only works in shinyapps.io or localhost due to all browsers only allowing clipboard access over HTTPS or localhost
plotly_add_copy_button <- function(pl) {
# can also be htmlwidgets::JS("Plotly.Icons.disk")
# download svg from eg https://uxwing.com/files-icon/
icon_copy_svg <- list(
path = str_c(
"M102.17,29.66A3,3,0,0,0,100,26.79L73.62,1.1A3,3,0,0,0,71.31,0h-46a5.36,5.36,0,0,0-5.36,5.36V20.41H5.36A5.36,5.36,0,0,0,0,25.77v91.75a5.36,",
"5.36,0,0,0,5.36,5.36H76.9a5.36,5.36,0,0,0,5.33-5.36v-15H96.82a5.36,5.36,0,0,0,5.33-5.36q0-33.73,0-67.45ZM25.91,20.41V6h42.4V30.24a3,3,0,0,0,",
"3,3H96.18q0,31.62,0,63.24h-14l0-46.42a3,3,0,0,0-2.17-2.87L53.69,21.51a2.93,2.93,0,0,0-2.3-1.1ZM54.37,30.89,72.28,47.67H54.37V30.89ZM6,116.89V26.",
"37h42.4V50.65a3,3,0,0,0,3,3H76.26q0,31.64,0,63.24ZM17.33,69.68a2.12,2.12,0,0,1,1.59-.74H54.07a2.14,2.14,0,0,1,1.6.73,2.54,2.54,0,0,1,.63,1.7,2.",
"57,2.57,0,0,1-.64,1.7,2.16,2.16,0,0,1-1.59.74H18.92a2.15,2.15,0,0,1-1.6-.73,2.59,2.59,0,0,1,0-3.4Zm0,28.94a2.1,2.1,0,0,1,1.58-.74H63.87a2.12,2.12,",
"0,0,1,1.59.74,2.57,2.57,0,0,1,.64,1.7,2.54,2.54,0,0,1-.63,1.7,2.14,2.14,0,0,1-1.6.73H18.94a2.13,2.13,0,0,1-1.59-.73,2.56,2.56,0,0,1,0-3.4ZM63.87,83.",
"41a2.12,2.12,0,0,1,1.59.74,2.59,2.59,0,0,1,0,3.4,2.13,2.13,0,0,1-1.6.72H18.94a2.12,2.12,0,0,1-1.59-.72,2.55,2.55,0,0,1-.64-1.71,2.5,2.5,0,0,1,.65",
"-1.69,2.1,2.1,0,0,1,1.58-.74ZM17.33,55.2a2.15,2.15,0,0,1,1.59-.73H39.71a2.13,2.13,0,0,1,1.6.72,2.61,2.61,0,0,1,0,3.41,2.15,2.15,0,0,1-1.59.73H18.92a2.",
"14,2.14,0,0,1-1.6-.72,2.61,2.61,0,0,1,0-3.41Zm0-14.47A2.13,2.13,0,0,1,18.94,40H30.37a2.12,2.12,0,0,1,1.59.72,2.61,2.61,0,0,1,0,3.41,2.13,2.13,0,0,1-1.58.",
"73H18.94a2.16,2.16,0,0,1-1.59-.72,2.57,2.57,0,0,1-.64-1.71,2.54,2.54,0,0,1,.65-1.7ZM74.3,10.48,92.21,27.26H74.3V10.48Z"
),
transform = 'scale(0.12)'
)
plotly_copy_button <- list(
name = "Copy to Clipboard",
icon = icon_copy_svg,
click = htmlwidgets::JS('function(gd) {copyPlot(gd)}') # JS function defined by us and added in ui.R
)
pl <- pl %>%
config(
modeBarButtonsToAdd = list(plotly_copy_button),
displaylogo = FALSE,
toImageButtonOptions= list(format = "png", width = NULL, height = NULL)
)
pl
}
# based on https://stackoverflow.com/questions/64721568/how-can-i-create-a-custom-js-function-to-copy-plotly-image-to-clipboard-in-r-shi
# stackoverlow used Plotly.Snapshot.toImage, but need to use Plotly.toImage to control height width: https://github.com/plotly/plotly.js/issues/83
# see https://github.com/plotly/plotly.js/blob/master/src/plot_api/to_image.js for optional arguments
# this JS function needs to be added to ui.R
copy_plot_js <- 'function copyPlot(gd) {
var toImageButtonOptions = gd._context.toImageButtonOptions;
var opts = {
format: toImageButtonOptions.format || "png",
width: toImageButtonOptions.width || null,
height: toImageButtonOptions.height || null
};
Plotly.toImage(gd, opts).then(async function(url) {
try {
const data = await fetch(url);
const blob = await data.blob();
await navigator.clipboard.write([
new ClipboardItem({
[blob.type]: blob
})
]);
console.log("Image copied.");
} catch (err) {
console.error(err.name, err.message);
}
});
alert("Copied the plot");
}'
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.