Commit 1cf27994 authored by Kunst, Jonathan's avatar Kunst, Jonathan
Browse files

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

parent 34429dd2
......@@ -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)
......
......@@ -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)
})
})
}
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment