310 lines
9.5 KiB
R
310 lines
9.5 KiB
R
|
clickpad_UI <- function(id, ...) {
|
||
|
|
library(plotly)
|
||
|
|
ns <- NS(id)
|
||
|
|
tagList(
|
||
|
|
plotlyOutput(ns("plot"), ...)
|
||
|
|
)
|
||
|
|
}
|
||
|
|
|
||
|
|
clickpad_debug <- function(id, relayout = TRUE, doubleclick = TRUE, selected = FALSE, clickannotation = TRUE) {
|
||
|
|
ns <- NS(id)
|
||
|
|
col_width <- 12 / sum(relayout, doubleclick, selected, clickannotation)
|
||
|
|
tagList(
|
||
|
|
fluidRow(
|
||
|
|
style = "overflow-y: scroll; max-height: 200px;",
|
||
|
|
if (relayout) column(
|
||
|
|
col_width,
|
||
|
|
tags$p(tags$code("plotly_relayout")),
|
||
|
|
verbatimTextOutput(ns("v_relayout"))
|
||
|
|
),
|
||
|
|
if (doubleclick) column(
|
||
|
|
col_width,
|
||
|
|
tags$p(tags$code("plotly_doubleclick")),
|
||
|
|
verbatimTextOutput(ns("v_doubleclick"))
|
||
|
|
),
|
||
|
|
if (selected) column(
|
||
|
|
col_width,
|
||
|
|
tags$p(tags$code("plotly_selected")),
|
||
|
|
verbatimTextOutput(ns("v_selected"))
|
||
|
|
),
|
||
|
|
if (clickannotation) column(
|
||
|
|
col_width,
|
||
|
|
tags$p(tags$code("plotly_clickannotation")),
|
||
|
|
verbatimTextOutput(ns("v_clickannotation"))
|
||
|
|
)
|
||
|
|
)
|
||
|
|
)
|
||
|
|
}
|
||
|
|
|
||
|
|
clickpad <- function(
|
||
|
|
input, output, session,
|
||
|
|
nodes, edges,
|
||
|
|
plotly_source = "clickpad"
|
||
|
|
) {
|
||
|
|
library(plotly)
|
||
|
|
ns <- session$ns
|
||
|
|
|
||
|
|
node_primary <- reactive({ node_parent(nodes()) })
|
||
|
|
node_secondary <- reactive({ node_child(nodes()) })
|
||
|
|
node_is_adjusted <- reactive({ node_adjusted(nodes()) })
|
||
|
|
node_exposure <- reactive({ names(node_with_attribute(nodes(), "exposure")) })
|
||
|
|
node_outcome <- reactive({ names(node_with_attribute(nodes(), "outcome")) })
|
||
|
|
|
||
|
|
output$v_relayout <- renderPrint({
|
||
|
|
str(event_data("plotly_relayout", priority = "event", source = plotly_source))
|
||
|
|
})
|
||
|
|
|
||
|
|
output$v_doubleclick <- renderPrint({
|
||
|
|
str(event_data("plotly_doubleclick", priority = "event", source = plotly_source))
|
||
|
|
})
|
||
|
|
|
||
|
|
output$v_selected <- renderPrint({
|
||
|
|
str(event_data("plotly_clickannotation", priority = "event", source = plotly_source))
|
||
|
|
})
|
||
|
|
|
||
|
|
output$v_clickannotation <- renderPrint({
|
||
|
|
str(event_data("plotly_clickannotation", priority = "event", source = plotly_source))
|
||
|
|
})
|
||
|
|
|
||
|
|
arrow_path <- function(from.x, from.y, to.x, to.y, dist = 0.2, ...) {
|
||
|
|
# angle of the line between `from` and `to`
|
||
|
|
theta <- atan2(to.y - from.y, to.x - from.x)
|
||
|
|
|
||
|
|
# push line starting/ending points away from node by a fixed distance
|
||
|
|
path_points = list(
|
||
|
|
x0 = from.x + dist * cos(theta),
|
||
|
|
y0 = from.y + dist * sin(theta),
|
||
|
|
x1 = to.x - dist * cos(theta),
|
||
|
|
y1 = to.y - dist * sin(theta)
|
||
|
|
)
|
||
|
|
|
||
|
|
# Find points for corners of arrow head (third point is `to`)
|
||
|
|
arrow_anchor_x = path_points$x1 - dist * cos(theta)
|
||
|
|
arrow_anchor_y = path_points$y1 - dist * sin(theta)
|
||
|
|
ad <- 0.1 * dist / tan(1/6 * pi)
|
||
|
|
|
||
|
|
path_points$a1_x = arrow_anchor_x + ad * cos(theta + 1/2 * pi)
|
||
|
|
path_points$a1_y = arrow_anchor_y + ad * sin(theta + 1/2 * pi)
|
||
|
|
path_points$a2_x = arrow_anchor_x - ad * cos(theta + 1/2 * pi)
|
||
|
|
path_points$a2_y = arrow_anchor_y - ad * sin(theta + 1/2 * pi)
|
||
|
|
|
||
|
|
# Draw arrow head in SVG path notation
|
||
|
|
as.character(glue::glue_data(
|
||
|
|
path_points,
|
||
|
|
"M{x0},{y0} L{x1},{y1} L{a1_x},{a1_y} L{a2_x},{a2_y} L{x1},{y1}"
|
||
|
|
))
|
||
|
|
}
|
||
|
|
|
||
|
|
arrows <- reactive({
|
||
|
|
if (is.null(edges()) || length(edges()) == 0) return(NULL)
|
||
|
|
if (is.null(nodes()) || length(nodes()) == 0) return(NULL)
|
||
|
|
|
||
|
|
ep <- edge_points(edges(), nodes())
|
||
|
|
if (!nrow(ep)) return(NULL)
|
||
|
|
|
||
|
|
ep %>%
|
||
|
|
purrr::pmap_chr(arrow_path, dist = 0.2) %>%
|
||
|
|
purrr::map(~ list(
|
||
|
|
type = "path",
|
||
|
|
line = list(color = "#000", width = 1),
|
||
|
|
fillcolor = "#000",
|
||
|
|
path = .x,
|
||
|
|
opacity = 0.75
|
||
|
|
))
|
||
|
|
})
|
||
|
|
|
||
|
|
create_node_annotations <- function(x, y, name, hash, ...) {
|
||
|
|
set_color <- function(
|
||
|
|
default, not_in_dag = NULL,
|
||
|
|
primary = NULL, secondary = NULL,
|
||
|
|
exposure = NULL, outcome = NULL, adjusted = NULL,
|
||
|
|
apply_order = c("primary", "not_in_dag", "adjusted", "exposure", "outcome", "secondary")
|
||
|
|
) {
|
||
|
|
applicable_states <- c(
|
||
|
|
"primary" = !is.null(node_primary()) && hash %in% node_primary(),
|
||
|
|
"secondary" = !is.null(node_secondary()) && hash %in% node_secondary(),
|
||
|
|
"adjusted" = !is.null(node_is_adjusted()) && hash %in% node_is_adjusted(),
|
||
|
|
"exposure" = !is.null(node_exposure()) && hash %in% node_exposure(),
|
||
|
|
"outcome" = !is.null(node_outcome()) && hash %in% node_outcome(),
|
||
|
|
"not_in_dag" = x < 0
|
||
|
|
)
|
||
|
|
|
||
|
|
applicable_states <- applicable_states[applicable_states]
|
||
|
|
if (!length(applicable_states)) return(default)
|
||
|
|
|
||
|
|
applicable_states <- applicable_states[apply_order]
|
||
|
|
applicable_states <- applicable_states[!is.na(applicable_states)]
|
||
|
|
if (!length(applicable_states)) return(default)
|
||
|
|
|
||
|
|
color <- switch(
|
||
|
|
names(applicable_states)[1],
|
||
|
|
primary = primary,
|
||
|
|
secondary = secondary,
|
||
|
|
adjusted = adjusted,
|
||
|
|
outcome = outcome,
|
||
|
|
exposure = exposure,
|
||
|
|
not_in_dag = not_in_dag,
|
||
|
|
default
|
||
|
|
)
|
||
|
|
|
||
|
|
color %||% default
|
||
|
|
}
|
||
|
|
|
||
|
|
background_color <- set_color(
|
||
|
|
default = "rgba(255, 255, 255, 0.5)",
|
||
|
|
not_in_dag = "#FDFDFD",
|
||
|
|
primary = "rgba(246, 227, 209, 0.75)"
|
||
|
|
)
|
||
|
|
font_color <- set_color(
|
||
|
|
default = "#000000",
|
||
|
|
not_in_dag = "#666666",
|
||
|
|
primary = "#D3751C",
|
||
|
|
exposure = "#418c7a",
|
||
|
|
outcome = "#ba2d0b",
|
||
|
|
apply_order = c("not_in_dag", "exposure", "outcome", "primary")
|
||
|
|
)
|
||
|
|
border_color <- set_color(
|
||
|
|
default = "#EDEDED",
|
||
|
|
not_in_dag = "#AAAAAA",
|
||
|
|
primary = list(NULL),
|
||
|
|
adjusted = "#1c2d3f",
|
||
|
|
apply_order = c("not_in_dag", "adjusted", "primary")
|
||
|
|
)
|
||
|
|
|
||
|
|
list(text = name,
|
||
|
|
node_hash = hash,
|
||
|
|
x = x,
|
||
|
|
y = y,
|
||
|
|
font = list(size = 24, color = font_color),
|
||
|
|
showarrow = FALSE,
|
||
|
|
align = "center",
|
||
|
|
captureevents = TRUE,
|
||
|
|
textposition = "middle center",
|
||
|
|
bordercolor = border_color,
|
||
|
|
bgcolor = background_color,
|
||
|
|
borderpad = 4)
|
||
|
|
}
|
||
|
|
|
||
|
|
annotations <- reactive({
|
||
|
|
if (is.null(nodes()) || length(nodes()) == 0) return(NULL)
|
||
|
|
node_frame(nodes(), full = TRUE) %>%
|
||
|
|
purrr::pmap(create_node_annotations)
|
||
|
|
})
|
||
|
|
|
||
|
|
left_margin <- list(
|
||
|
|
type = "rect",
|
||
|
|
line = list(color = "#AAAAAA", width = 1),
|
||
|
|
fillcolor = "#EEEEEE",
|
||
|
|
x0 = -100,
|
||
|
|
y0 = -100,
|
||
|
|
x1 = 0,
|
||
|
|
y1 = 100
|
||
|
|
)
|
||
|
|
|
||
|
|
output$plot <- renderPlotly({
|
||
|
|
debug_line("rendering clickpad")
|
||
|
|
redraw_plot()
|
||
|
|
|
||
|
|
ax <- list(
|
||
|
|
title = "",
|
||
|
|
zeroline = FALSE,
|
||
|
|
showline = FALSE,
|
||
|
|
showticklabels = FALSE,
|
||
|
|
showgrid = TRUE,
|
||
|
|
range = list(-1.5, 12.5)
|
||
|
|
)
|
||
|
|
ay <- ax
|
||
|
|
y_min <- purrr::map_dbl(nodes(), "y") %>% min()
|
||
|
|
y_max <- purrr::map_dbl(nodes(), "y") %>% max()
|
||
|
|
ay$range <- list(min(0.5, y_min), max(7.5, y_max))
|
||
|
|
|
||
|
|
p <- plot_ly(type = "scatter", source = plotly_source)
|
||
|
|
|
||
|
|
p %>%
|
||
|
|
layout(
|
||
|
|
annotations = annotations(),
|
||
|
|
shapes = c(list(left_margin), arrows()),
|
||
|
|
xaxis = ax,
|
||
|
|
yaxis = ay
|
||
|
|
) %>%
|
||
|
|
config(
|
||
|
|
edits = list(
|
||
|
|
annotationPosition = TRUE
|
||
|
|
),
|
||
|
|
showAxisDragHandles = FALSE
|
||
|
|
# displayModeBar = FALSE
|
||
|
|
) %>%
|
||
|
|
plotly::event_register("plotly_click") %>%
|
||
|
|
plotly::event_register("plotly_doubleclick") %>%
|
||
|
|
plotly::event_register("plotly_selected") %>%
|
||
|
|
plotly::event_register("plotly_clickannotation") %>%
|
||
|
|
htmlwidgets::onRender("
|
||
|
|
function(el) {
|
||
|
|
el.on('plotly_hover', function(d) { console.log('Hover: ', d) });
|
||
|
|
el.on('plotly_click', function(d) { console.log('Click: ', d) });
|
||
|
|
el.on('plotly_selected', function(d) { console.log('Select: ', d) });
|
||
|
|
}
|
||
|
|
")
|
||
|
|
})
|
||
|
|
|
||
|
|
redraw_plot <- reactiveVal(Sys.time())
|
||
|
|
|
||
|
|
new_coords_lag <- list(hash = NA_character_, x = NA_real_, y = NA_real_)
|
||
|
|
|
||
|
|
new_locations <- reactive({
|
||
|
|
req(annotations())
|
||
|
|
## https://stackoverflow.com/questions/54990350/extract-xyz-coordinates-from-draggable-shape-in-plotly-ternary-r-shiny
|
||
|
|
|
||
|
|
event <- event_data("plotly_relayout", source = plotly_source)
|
||
|
|
if (!length(event)) return()
|
||
|
|
|
||
|
|
annot_event <- event[grepl("^annotations\\[\\d+\\]\\.[xy]$", names(event))]
|
||
|
|
annot_index <- sub(".+\\[(\\d+)\\].+", "\\1", names(annot_event)[1]) %>% as.integer()
|
||
|
|
|
||
|
|
if (is.na(annot_index) || !is.integer(annot_index)) return()
|
||
|
|
|
||
|
|
if (length(annotations()) <= annot_index) {
|
||
|
|
stop("An error occurred, unable to match plotly update to correct node")
|
||
|
|
}
|
||
|
|
|
||
|
|
node_hash <- annotations()[[annot_index + 1]]$node_hash
|
||
|
|
# cli::cat_line("event_name: ", names(event)[1])
|
||
|
|
# cli::cat_line("annot_index: ", annot_index)
|
||
|
|
# cli::cat_line("node_hash: ", node_hash)
|
||
|
|
|
||
|
|
req(!is.null(node_hash))
|
||
|
|
|
||
|
|
new_x <- annot_event[grepl("\\.x", names(annot_event))] %>% unlist() %>% unname()
|
||
|
|
new_x <- if (new_x > 0) round(new_x, 0) else new_x
|
||
|
|
|
||
|
|
new_y <- annot_event[grepl("\\.y", names(annot_event))] %>% unlist() %>% unname()
|
||
|
|
new_y <- if (new_x > 0) round(new_y, 0) else new_y
|
||
|
|
|
||
|
|
i_nodes <- isolate(nodes())
|
||
|
|
current_pos <- i_nodes[[node_hash]][c("x", "y")] %>% unlist() %>% unname()
|
||
|
|
|
||
|
|
new_coords <- list(
|
||
|
|
hash = node_hash,
|
||
|
|
x = new_x,
|
||
|
|
y = new_y
|
||
|
|
)
|
||
|
|
|
||
|
|
if (identical(c(new_coords$x, new_coords$y), current_pos)) {
|
||
|
|
# No change in current node position
|
||
|
|
return()
|
||
|
|
}
|
||
|
|
|
||
|
|
if (identical(new_coords, new_coords_lag)) {
|
||
|
|
# The plotly_redraw may not have been a result of annotation position change
|
||
|
|
return()
|
||
|
|
}
|
||
|
|
|
||
|
|
new_coords_lag <<- new_coords
|
||
|
|
|
||
|
|
# cli::cat_line("new_x: ", new_x)
|
||
|
|
# cli::cat_line("new_y: ", new_y)
|
||
|
|
new_coords
|
||
|
|
})
|
||
|
|
|
||
|
|
return(reactive(new_locations()))
|
||
|
|
}
|