Related
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
))
)
}
})
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.
I am writing a shiny app to manipulate daily percentage distributions of call arrivals per interval via drag and drop.
I am trying to display one day only via selectInput.
However, the DataTable Output and Plot Output do not change when I select another day than Monday (first option in selectInput), i.e., the outputs (datatable and plotly) only display Monday regardless of what I am selecting via selectInput.
Appreciate your help! Thank you in advance!
Dummy data:
save_name2 <- paste("Percentage_Forecasts.csv")
df_MON<-data.frame(b=c("MON 07:00","MON 07:30","MON 08:00","MON 08:30","MON 09:00","MON 09:30","MON 10:00"),a=c(15,20,14,6,10,15,20))
df_TUE<-data.frame(b=c("TUE 07:00","TUE 07:30","TUE 08:00","TUE 08:30","TUE 09:00","TUE 09:30","TUE 10:00"),a=c(15,20,14,6,10,15,20))
df_WED<-data.frame(b=c("WED 07:00","WED 07:30","WED 08:00","WED 08:30","WED 09:00","WED 09:30","WED 10:00"),a=c(15,20,14,6,10,15,20))
df_THU<-data.frame(b=c("THU 07:00","THU 07:30","THU 08:00","THU 08:30","THU 09:00","THU 09:30","THU 10:00"),a=c(15,20,14,6,10,15,20))
df_FRI<-data.frame(b=c("FRI 07:00","FRI 07:30","FRI 08:00","FRI 08:30","FRI 09:00","FRI 09:30","FRI 10:00"),a=c(15,20,14,6,10,15,20))
df_SAT<-data.frame(b=c("SAT 07:00","SAT 07:30","SAT 08:00","SAT 08:30","SAT 09:00","SAT 09:30","SAT 10:00"),a=c(15,20,14,6,10,15,20))
Here is my ui.R:
ui <- fluidPage( titlePanel("Prozentuale Verteilung Prognosewoche"),
fluidRow(
column(selectInput(inputId = "dataset",
label = "Choose a weekday",
choices = c("MON", "TUE","WED","THU","FRI","SAT")),
DTOutput("table"),width = 5,downloadButton("downloadData", "Save")),
column(12, plotlyOutput("p"))))
Here is my server.R:
server <- function(input, output, session) {
#i think here is where the problem starts!
datasetInput <- reactive({
switch(input$dataset,
"MON" = df_MON,
"TUE" = df_TUE,
"WED" = df_WED,
"THU" = df_THU,
"FRI" = df_FRI,
"SAT" = df_SAT)
})
rv <- reactiveValues(
x = isolate(datasetInput())$b,
y = isolate(datasetInput())$a)
grid <- reactive({
data.frame(y = rv$y, length=180)})
output$p <- renderPlotly({
circles <- map2(rv$x,
rv$y,
~list(
type = "circle",
xanchor = .x,
yanchor = .y,
x0 = -4, x1 = 4,
y0 = -4, y1 = 4,
xsizemode = "pixel",
ysizemode = "pixel",
# other visual properties
fillcolor = "orange",
line = list(color = "transparent") ) )
plot_ly(grid(), type="scatter", mode='lines+markers', width = 1200, height = 300) %>%
add_trace(y = grid()$y, x = isolate(datasetInput())$b,mode='lines+markers') %>%
layout(shapes = circles) %>%
config(edits = list(shapePosition = TRUE))
})
output$table <-renderDT(rbind({data.frame(rv$x,rv$y)}, c(NULL,sum(rv$y))),colnames=c("Weekday/Time", "Percentage"),width = 800,options = list(
lengthMenu = list(c(15,31), list('15','31')),
pageLength = 15, initComplete = JS(
"function(settings, json) {",
"$(this.api().table().body()).css({'font-size': '70%'});",
"}")
))
observe({
ed <- event_data("plotly_relayout")
shape_anchors <- ed[grepl("^shapes.*anchor$", names(ed))]
if (length(shape_anchors) != 2) return()
row_index <- unique(readr::parse_number(names(shape_anchors)) + 1)
pts <- as.numeric(shape_anchors)
rv$y[row_index] <- pts[2]
})
output$downloadData <- downloadHandler(
filename = function(){save_name2},
content = function(fname){
write.table(data.frame(rv$x,rv$y), row.names=FALSE, sep=";", fname,col.names=c("Weekday/Calendar Week","Percentage"))
})
}
shinyApp(ui, server)
I edited these parts and removed the isolate's:
rv <- reactiveValues()
observe({
rv$x = datasetInput()$b
rv$y = datasetInput()$a
})
and
add_trace(y = grid()$y, x = rv$x,mode='lines+markers')
Full server code:
server <- function(input, output, session) {
#i think here is where the problem starts!
datasetInput <- reactive({
switch(input$dataset,
"MON" = df_MON,
"TUE" = df_TUE,
"WED" = df_WED,
"THU" = df_THU,
"FRI" = df_FRI,
"SAT" = df_SAT)
})
rv <- reactiveValues()
observe({
rv$x = datasetInput()$b
rv$y = datasetInput()$a
})
grid <- reactive({
data.frame(y = rv$y, length=180)})
output$p <- renderPlotly({
circles <- map2(rv$x,
rv$y,
~list(
type = "circle",
xanchor = .x,
yanchor = .y,
x0 = -4, x1 = 4,
y0 = -4, y1 = 4,
xsizemode = "pixel",
ysizemode = "pixel",
# other visual properties
fillcolor = "orange",
line = list(color = "transparent") ) )
plot_ly(grid(), type="scatter", mode='lines+markers', width = 1200, height = 300) %>%
add_trace(y = grid()$y, x = rv$x,mode='lines+markers') %>%
layout(shapes = circles) %>%
config(edits = list(shapePosition = TRUE))
})
output$table <-renderDT(rbind({data.frame(rv$x,rv$y)}, c(NULL,sum(rv$y))),colnames=c("Weekday/Time", "Percentage"),width = 800,options = list(
lengthMenu = list(c(15,31), list('15','31')),
pageLength = 15, initComplete = JS(
"function(settings, json) {",
"$(this.api().table().body()).css({'font-size': '70%'});",
"}")
))
observe({
ed <- event_data("plotly_relayout")
shape_anchors <- ed[grepl("^shapes.*anchor$", names(ed))]
if (length(shape_anchors) != 2) return()
row_index <- unique(readr::parse_number(names(shape_anchors)) + 1)
pts <- as.numeric(shape_anchors)
rv$y[row_index] <- pts[2]
})
output$downloadData <- downloadHandler(
filename = function(){save_name2},
content = function(fname){
write.table(data.frame(rv$x,rv$y), row.names=FALSE, sep=";", fname,col.names=c("Weekday/Calendar Week","Percentage"))
})
}
shinyApp(ui, server)
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/
Please run the script below, there are two charts created using the patients dataset from the bupaR library, the chart on the left displays a sankey chart showing relationship between the resource("employee") and activities("handling") and the chart on the right displays the details of link between the resource and activities when we perform "on-click". Basically, we see a subset of data with corresponding values say "r1" and "Registration" values when we click the link connecting "r1" to "Registration" and so on. However, when I run code with any other resource and activity column, the sankey chart does not get created and I get the following error "non-numeric argument to binary operator". Please try the script with a simple dataset and help:
a1 = c("A","B","C","A","B","B")
a2 = c("D","E","D","E","D","F")
a12 = data.frame(a1,a2)
library(shiny)
library(shinydashboard)
library(devtools)
library(ggplot2)
library(plotly)
library(proto)
library(RColorBrewer)
library(gapminder)
library(stringr)
library(broom)
library(mnormt)
library(DT)
library(bupaR)
library(dplyr)
ui <- dashboardPage(
dashboardHeader(title = "Sankey Chart"),
dashboardSidebar(
width = 0
),
dashboardBody(
box(title = "Sankey Chart", status = "primary",height = "455" ,solidHeader =
T,
plotlyOutput("sankey_plot")),
box( title = "Case Summary", status = "primary", height = "455",solidHeader
= T,
dataTableOutput("sankey_table"))
)
)
server <- function(input, output)
{
sankeyData <- reactive({
sankeyData <- patients %>%
group_by(employee,handling) %>%
count()
sankeyNodes <- list(label = c(sankeyData$employee,sankeyData$handling))
trace2 <- list(
domain = list(
x = c(0, 1),
y = c(0, 1)
),
link = list(
label = paste0("Case",1:nrow(sankeyData)),
source = sapply(sankeyData$employee,function(e) {which(e ==
sankeyNodes$label) }, USE.NAMES = FALSE) - 1,
target = sapply(sankeyData$handling,function(e) {which(e ==
sankeyNodes$label) }, USE.NAMES = FALSE) - 1,
value = sankeyData$n
),
node = list(label = sankeyNodes$label),
type = "sankey"
)
trace2
})
output$sankey_plot <- renderPlotly({
trace2 <- sankeyData()
p <- plot_ly()
p <- add_trace(p, domain=trace2$domain, link=trace2$link,
node=trace2$node, type=trace2$type)
p
})
output$sankey_table <- renderDataTable({
d <- event_data("plotly_click")
req(d)
trace2 <- sankeyData()
sIdx <- trace2$link$source[d$pointNumber+1]
Source <- trace2$node$label[sIdx + 1 ]
tIdx <- trace2$link$target[d$pointNumber+1]
Target <- trace2$node$label[tIdx+1]
patients %>% filter(employee == Source & handling == Target)
})
}
shinyApp(ui, server)
In order to make this "ready solution" with any dataset I think you need one character (cut and color were turned into character using as.character()) of column b for each character of column a. For example, in the patient dataset, there is only one possibility (registration) for r1; same for r2 to r7. Your app did not work with the full diamonds dataset. But using the same logic, the app works.
diamonds_b <- diamonds %>% filter(cut == "Ideal" & color == "D")
diamonds_c <- diamonds %>% filter(cut == "Fair" & color == "E")
diamonds_d <- rbind(diamonds_b, diamonds_c)
diamonds_d$cut <- as.character(diamonds_d$cut)
diamonds_d$color <- as.character(diamonds_d$color)
and now running the shiny app with the diamonds_d dataset works:
ui <- dashboardPage(
dashboardHeader(title = "Sankey Chart"),
dashboardSidebar(
width = 0
),
dashboardBody(
box(title = "Sankey Chart", status = "primary",height = "455" ,solidHeader =
T,
plotlyOutput("sankey_plot")),
box( title = "Case Summary", status = "primary", height = "455",solidHeader
= T,
dataTableOutput("sankey_table"))
)
)
server <- function(input, output)
{
sankeyData <- reactive({
sankeyData <- diamonds_d %>%
group_by(cut,color) %>%
count()
sankeyNodes <- list(label = c(sankeyData$cut,sankeyData$color))
trace2 <- list(
domain = list(
x = c(0, 1),
y = c(0, 1)
),
link = list(
label = paste0("Case",1:nrow(sankeyData)),
source = sapply(sankeyData$cut,function(e) {which(e == sankeyNodes$label) }, USE.NAMES = FALSE) - 1,
target = sapply(sankeyData$color,function(e) {which(e == sankeyNodes$label) }, USE.NAMES = FALSE) - 1,
value = sankeyData$n
),
node = list(label = sankeyNodes$label),
type = "sankey"
)
trace2
})
output$sankey_plot <- renderPlotly({
trace2 <- sankeyData()
p <- plot_ly()
p <- add_trace(p, domain=trace2$domain, link=trace2$link,
node=trace2$node, type=trace2$type)
p
})
output$sankey_table <- renderDataTable({
d <- event_data("plotly_click")
req(d)
trace2 <- sankeyData()
sIdx <- trace2$link$source[d$pointNumber+1]
Source <- trace2$node$label[sIdx + 1 ]
tIdx <- trace2$link$target[d$pointNumber+1]
Target <- trace2$node$label[tIdx+1]
diamonds %>% filter(cut == Source & color == Target)
})
}
shinyApp(ui, server)