transfer from old repo

apps/shinyDAG-1.0.0/R/module/clickpad.R

@@ -0,0 +1,310 @@
+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()))
+}