Basic point selection made possible plotly object, but not persistent yet

polyqtlvis/NAMESPACE

@@ -3,8 +3,16 @@
 export(run_app)
 import(shiny)
 importFrom(dplyr,bind_rows)
+importFrom(dplyr,filter)
 importFrom(dplyr,left_join)
 importFrom(dplyr,select)
+importFrom(ggplot2,aes)
+importFrom(ggplot2,element_blank)
+importFrom(ggplot2,facet_wrap)
+importFrom(ggplot2,geom_line)
+importFrom(ggplot2,geom_point)
+importFrom(ggplot2,ggplot)
+importFrom(ggplot2,theme)
 importFrom(golem,activate_js)
 importFrom(golem,add_resource_path)
 importFrom(golem,bundle_resources)
@@ -12,6 +20,12 @@ importFrom(golem,favicon)
 importFrom(golem,with_golem_options)
 importFrom(magrittr,"%>%")
 importFrom(parallel,detectCores)
+importFrom(plotly,event_data)
+importFrom(plotly,ggplotly)
+importFrom(plotly,highlight)
+importFrom(plotly,layout)
+importFrom(plotly,plotlyOutput)
+importFrom(plotly,renderPlotly)
 importFrom(polyqtlR,QTLscan)
 importFrom(polyqtlR,estimate_IBD)
 importFrom(polyqtlR,visualiseHaplo)

polyqtlvis/R/mod_model_panel.R

@@ -8,8 +8,10 @@
 #'
 #' @importFrom shiny NS tagList 
 #' @importFrom polyqtlR QTLscan
-#' @importFrom dplyr left_join select bind_rows
+#' @importFrom dplyr left_join select bind_rows filter
 #' @importFrom magrittr %>%
+#' @importFrom ggplot2 ggplot aes geom_point geom_line facet_wrap theme element_blank
+#' @importFrom plotly ggplotly renderPlotly plotlyOutput highlight layout event_data
 mod_model_panel_ui <- function(id, rv){
   ns <- NS(id)
   tagList(
@@ -83,7 +85,12 @@ mod_model_panel_ui <- function(id, rv){
       ),
       
       mainPanel(
-        verbatimTextOutput(ns('value'))
+        actionButton(inputId = ns('update_plot'),
+                     label = 'Update plot'),
+        
+        plotlyOutput(outputId = ns('plotly')),
+        
+        verbatimTextOutput(ns('click'))
       )
     )
   )
@@ -139,8 +146,48 @@ mod_model_panel_server <- function(id, rv){
         left_join(select(bind_rows(rv$linkmap), c(position, marker)), by = 'position')
     })
     
-    # testoutput
-    output$value <- renderPrint({rv$model_list})
+    # generate ggplot object
+    observeEvent(input$update_plot, {
+      req(rv$polyqtl_scan)
+      
+      try(
+      rv$lod_ggplot <- ggplot(bind_rows(rv$model_list, .id = 'model'), aes(x = position, 
+                                                      y = LOD, 
+                                                      color = model, 
+                                                      linetype = model)) +
+        geom_point(aes(
+          text = paste(paste('LOD:', round(LOD, 2)), 
+                       paste('Marker:', marker),
+                       sep = '\n'
+          ))) +
+        geom_line() +
+        facet_wrap(~chromosome) +
+        theme(
+          panel.grid = element_blank(),
+          panel.background = element_blank(),
+          panel.border = element_blank(),
+          strip.background = element_blank(),
+          strip.placement = 'outside'
+        )
+      )
+    })
+    
+    # render of ggplot object as plotly object
+    output$plotly <- renderPlotly({
+      ggplotly(rv$lod_ggplot, tooltip = 'text') %>% 
+        highlight('plotly_selected') %>% 
+        layout(title = list(text = 'Chromosome', xanchor = 'center'))
+    })
+    
+    # render print of dataframe from selected points
+    output$click <- renderPrint({
+      d <- event_data('plotly_selected')
+      if (is.null(d)) return('select points')
+      bind_rows(rv$model_list, .id = 'model') %>% 
+        filter(position %in% d$x)
+        
+      
+    })
   })
 }