Skip to content
Snippets Groups Projects
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
No related branches found
No related tags found
No related merge requests found
......@@ -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)
})
})
}
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Please register or to comment