How to use a highcharter event function in shiny module - r

My question is related to this post. By clicking on a bar in a bar plot I want to display the selected category. When rewriting the code into modules I do not get the expected result (i.e. display the category in text field), instead nothing happens not even an error message pops up. What am I doing wrong?
library(shiny)
library(highcharter)
myModuleUI <- function(id){
ns <- NS(id)
fluidPage(
column(width = 8, highchartOutput(ns("hcontainer"), height = "500px")),
column(width = 4, textOutput(ns("text")))
)
}
myModule <- function(input, output, session){
a <- data.frame(b = LETTERS[1:10], c = 11:20, d = 21:30, e = 31:40)
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_xAxis(categories = a$b) %>%
hc_add_series(name = "c", data = a$c) %>%
hc_add_series(name = "d", data = a$d) %>%
hc_add_series(name = "e", data = a$e) %>%
hc_plotOptions(series = list(stacking = FALSE, events = list(click = canvasClickFunction, legendItemClick = legendClickFunction))) %>%
hc_chart(type = "column")
})
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
})
}
ui <- shinyUI(fluidPage(
myModuleUI("myMod")
))
server <- function(input, output){
callModule(myModule, "myMod")
}

The thing with modules is that you need to pass the namespace. If you get the namespace in the beginning of your module ns <- session$ns and then adjust the JavaScript function like this
canvasClickFunction <- JS(paste0("function(event) {Shiny.onInputChange('", ns('canvasClicked'), "', [this.name, event.point.category]);}"))
legendClickFunction <- JS(paste0("function(event) {Shiny.onInputChange('", ns('legendClicked'), "', this.name);}"))
your code should work.

Related

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

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

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

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

R Highcharter: Select category from a single point

Using a highchart in R (using the highcharter package) I'm trying to select all the points for a single category when selecting any single point. The code below allows selecting a single slice of a stack in a stacked bar chart. I want the entire stacked bar to be selected/deselected by clicking on any of the stacked bar slices.
library("shiny")
library("highcharter")
ui <- shinyUI(
fluidPage(
column(width = 8, highchartOutput("hcontainer", height = "500px")),
column(width = 4, textOutput("text"))
)
)
server <- function(input, output) {
a <- data.frame(b = LETTERS[1:10], b_alt = LETTERS[11:20], c = 11:20, d = 21:30, e = 31:40)
output$hcontainer <- renderHighchart({
canvasClickFunction <- JS("function(event) {Shiny.onInputChange('canvasClicked', [this.name, event.point.series.chart.series[0].options.additionalInfo[event.point.index]]);}")
legendClickFunction <- JS("function(event) {Shiny.onInputChange('legendClicked', this.name);}")
highchart() %>%
hc_xAxis(categories = a$b) %>%
hc_add_series(name = "c", additionalInfo = a$b_alt, data = a$c, color = "red") %>%
hc_add_series(name = "d", data = a$d) %>%
hc_add_series(name = "e", data = a$e) %>%
hc_plotOptions(series = list(stacking = TRUE, allowPointSelect = TRUE, events = list(click = canvasClickFunction, legendItemClick = legendClickFunction))) %>%
hc_chart(type = "column")
})
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)
You can fire the event on point click (let's call that clicked point clickedPoint) loop through all series and then through all points, check if the point has the same category as our clickedPoint and if yes, select it using point.select() method.
Here is the main code:
hc_plotOptions(series = list(stacking = TRUE, events = list(click = canvasClickFunction, legendItemClick = legendClickFunction), point = list(events = list(click = JS(
"function() {
var clickedPoint = this;
clickedPoint.series.chart.series.forEach(function(series) {
series.points.forEach(function(point) {
if (point.category === clickedPoint.category) {
if (point.selected) {
point.select(false, true)
} else {
point.select(true, true)
}
}
})
})
}"
))))) %>%
And here is the whole code:
library("shiny")
library("highcharter")
ui <- shinyUI(
fluidPage(
column(width = 8, highchartOutput("hcontainer", height = "500px")),
column(width = 4, textOutput("text"))
)
)
server <- function(input, output) {
a <- data.frame(b = LETTERS[1:10], b_alt = LETTERS[11:20], c = 11:20, d = 21:30, e = 31:40)
output$hcontainer <- renderHighchart({
canvasClickFunction <- JS("function(event) {Shiny.onInputChange('canvasClicked', [this.name, event.point.series.chart.series[0].options.additionalInfo[event.point.index]]);}")
legendClickFunction <- JS("function(event) {Shiny.onInputChange('legendClicked', this.name);}")
highchart() %>%
hc_xAxis(categories = a$b) %>%
hc_add_series(name = "c", additionalInfo = a$b_alt, data = a$c, color = "red") %>%
hc_add_series(name = "d", data = a$d) %>%
hc_add_series(name = "e", data = a$e) %>%
hc_plotOptions(series = list(stacking = TRUE, events = list(click = canvasClickFunction, legendItemClick = legendClickFunction), point = list(events = list(click = JS(
"function() {
var clickedPoint = this;
clickedPoint.series.chart.series.forEach(function(series) {
series.points.forEach(function(point) {
if (point.category === clickedPoint.category) {
if (point.selected) {
point.select(false, true)
} else {
point.select(true, true)
}
}
})
})
}"
))))) %>%
hc_chart(type = "column")
})
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)
API: https://api.highcharts.com/class-reference/Highcharts.Point#select
https://api.highcharts.com/highcharts/plotOptions.column.point.events.click
jsFiddle with a pure JS implementation: https://jsfiddle.net/BlackLabel/p135s4vm/

Draggable only part of a series : highcharts

I would like drag points when x is greater than 5.
Can anyone help me on that?
Example:
library("shiny")
library("highcharter")
ui <- shinyUI(
fluidPage(
column(width = 8, highchartOutput("hcontainer", height = "500px")),
column(width = 4, textOutput("text"))
)
)
server <- function(input, output) {
a <- data.frame(b = LETTERS[1:10], c = 11:20, d = 21:30, e = 31:40)
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_xAxis(categories = a$b) %>%
hc_add_serie(name = "c", data = a$c) %>%
hc_add_serie(name = "d", data = a$d) %>%
hc_add_serie(name = "e", data = a$e) %>%
hc_plotOptions(series = list(stacking = FALSE, events = list(click = canvasClickFunction, legendItemClick = legendClickFunction))) %>%
hc_chart(type = "column")
})
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)

Shiny Gvis Output is opening in browser and not within the app

I am trying to get my shinydashboard to plot a sankey chart within a box but when I run it it opens in another tab on my browser. Can I htmlOutput to have the sankey plot open in the box in the app? I tried changing it to DataTable and it works perfect, but with a sankey renderGvis and htmlOutput it doesn't seem to work.
Here's snipits on my code...
UI
tabItem("PatronTransactionFlow",
box(title = "Controls",
width = 12,
status = "success",
solidHeader = TRUE,
uiOutput("PurchaseColumnSankeyChoice"),
uiOutput("SankeyPurchaseFilterNum")),
box(title = paste0(eventname, " Patron Transaction Flow"),
width = 12,
status = "success",
solidHeader = TRUE,
htmlOutput("SankeyPurchasePlot")
)
)
Server
SankeyPurchaseData <- reactive({
sankey <- OverviewPurchaseData %>%
select(Time.y, Tag, Point) %>%
group_by(Time.y, Tag) %>%
arrange(Time.y) %>%
unique() %>%
group_by(Tag) %>%
mutate(n.order = paste('Transaction', c(1:n()), sep='')) %>%
dcast(Tag ~ n.order, value.var='Point', fun.aggregate = NULL)
sankey
})
output$PurchaseColumnSankeyChoice <- renderUI({
sankey <- SankeyPurchaseData()
colchoice <- mixedsort(colnames(sankey)[2:ncol(sankey)])
selectInput("PurchaseColumnSankeyChoice", "Choose Transactions to View",
choices = mixedsort(colnames(sankey)[2:ncol(sankey)]),
selected = mixedsort(colnames(sankey)[2:ncol(sankey)])[1:3],
selectize = TRUE,
multiple = TRUE)
})
SankeyPurchasePlotData <- reactive({
sankey <- SankeyPurchaseData()
sankeyplot <- sankey %>%
select_(.dots = input$PurchaseColumnSankeyChoice)
orders.plot <- data.frame()
for (i in 2:ncol(sankeyplot)) {
ord.cache <- sankeyplot %>%
group_by(sankeyplot[ , i-1], sankeyplot[ , i]) %>%
na.omit()%>%
summarise(n=n())
colnames(ord.cache)[1:2] <- c('from', 'to')
# adding tags to carts
ord.cache$from <- paste(ord.cache$from, '(', i-1, ')', sep='')
ord.cache$to <- paste(ord.cache$to, '(', i, ')', sep='')
orders.plot <- rbind(orders.plot, ord.cache)
}
orders.plot
})
output$SankeyPurchaseFilterNum <- renderUI({
data <- SankeyPurchasePlotData()
max1 <- max(data$n)
sliderInput("SankeyPurchaseFilterNum", "Choose Sequence Number to filter by:",
min = 1, max = max1, value = round(max1*0.7, digits = 0))
})
output$SankeyPurchasePlot <- renderGvis({
orders.plot <- SankeyPurchasePlotData()
orders.plot2 <- orders.plot[which(orders.plot$n >= as.numeric(input$SankeyPurchaseFilterNum)),]
plot <- plot(gvisSankey(orders.plot2, from='from', to='to', weight='n'))
plot
})

Resources