Commit 7cbe3b06 authored by Kunst, Jonathan's avatar Kunst, Jonathan
Browse files

Split up the model panel into separate modules of each modelling and visualisation packages

parent 4902813f
......@@ -3,7 +3,6 @@
export(run_app)
import(shiny)
importFrom(dplyr,bind_rows)
importFrom(dplyr,distinct)
importFrom(dplyr,filter)
importFrom(dplyr,left_join)
importFrom(dplyr,select)
......
......@@ -8,92 +8,22 @@
#'
#' @importFrom shiny NS tagList
#' @importFrom polyqtlR QTLscan
#' @importFrom dplyr left_join select bind_rows filter distinct
#' @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
#' @importFrom waiter Waiter useWaiter spin_6 transparent
#' @importFrom shinycssloaders withSpinner
#' @importFrom rhandsontable rhandsontable rHandsontableOutput renderRHandsontable hot_context_menu
mod_model_panel_ui <- function(id, rv){
ns <- NS(id)
tagList(
sidebarLayout(
sidebarPanel(
h3('Model settings'),
tabsetPanel(
# siebarpanel for polyqtlR qtlscan model options
# sidebarpanel for polyqtlR qtlscan model options
tabPanel('polyqtlR',
# genotype column selection
selectInput(inputId = ns('choice_geno'),
label = 'Select genotype column',
choices = 'Import phenotype file first'),
# phenotype column selection
selectInput(inputId = ns('choice_pheno'),
label = 'Select phenotype column',
choices = 'Import phenotype file first'),
# does co-factor need to be taken into account?
checkboxInput(inputId = ns('check_cofactor'),
label = 'Co-factor',
value = FALSE),
conditionalPanel(
condition ='input.check_cofactor',
ns = ns,
rHandsontableOutput(ns('cofactor_table')),
actionButton(inputId = ns('cofactor_save'),
label = 'Save')
),
# does block need to be taken into account?
checkboxInput(inputId = ns('check_block'),
label = 'Blocks',
value = FALSE),
# block column selection
conditionalPanel(
condition = 'input.check_block',
ns = ns,
selectInput(inputId = ns('choice_block'),
label = 'Select block column',
choices = 'Import phenotype file first')
),
# permutation test
checkboxInput(inputId = ns('check_permutation'),
label = 'Permutation test',
value = FALSE),
# max number of permutations
conditionalPanel(
condition = 'input.check_permutation',
ns = ns,
numericInput(inputId = ns('choice_permutation'),
label = 'Max number of permuations',
min = 1,
value = 1000,
max = 2000)
),
# cores
numericInput(inputId = ns('choice_core'),
label = 'Numbers of processing cores',
min = 1,
value = detectCores() / 2,
max = detectCores() - 2),
# model name
textInput(inputId = ns('model_name'),
label = 'Model name'),
hr(),
# scan
actionButton(inputId = ns('go'),
label = 'Create'),
useWaiter()
mod_pqtlr_ui(ns("pqtlr_ui_1"))
),
# sidebarpanel for QTLpoly model options
......@@ -105,12 +35,9 @@ mod_model_panel_ui <- function(id, rv){
),
mainPanel(
actionButton(inputId = ns('update_plot'),
label = 'Update plot'),
withSpinner(plotlyOutput(outputId = ns('plotly'))),
verbatimTextOutput(ns('click'))
h3('Visualisation'),
# plotly generator UI ----
mod_qtl_plotly_panel_ui(ns("qtl_plotly_panel_ui_1"))
)
)
)
......@@ -124,118 +51,10 @@ mod_model_panel_server <- function(id, rv){
ns <- session$ns
# polyqtlR qtlscan options ----
# genotype column selection
observeEvent(rv$phenotype, {
updateSelectInput(session, 'choice_geno',
choices = names(rv$phenotype[[1]]))
})
# phenotype column selection
observeEvent(rv$phenotype, {
updateSelectInput(session, 'choice_pheno',
choices = names(rv$phenotype[[1]]))
})
# block column selection
observeEvent(rv$phenotype, {
updateSelectInput(session, 'choice_block',
choices = names(rv$phenotype[[1]]))
})
# adding co-factor
observeEvent(input$cofactor_save, {
# save changes in editable table
rv$cofactor_df <- hot_to_r(input$cofactor_table)
# return feedback to user that cofactor was added
showNotification('Cofactor added', type = 'message')
Sys.sleep(.5)
})
# editable cofactor table
output$cofactor_table <- renderRHandsontable(rhandsontable(rv$cofactor_df, useTypes = TRUE) %>%
hot_context_menu(
allowRowEdit = TRUE,
allowColEdit = FALSE
)
)
# create polyqtlR model
observeEvent(input$go, {
progress <- Waiter$new(id = ns('go'),
html = spin_6(),
color = 'grey')
progress$show()
req(input$model_name, rv$ibd_estimate, rv$phenotype, input$choice_geno,
input$choice_pheno)
try(
rv$polyqtl_scan<- QTLscan(IBD_list = rv$ibd_estimate,
Phenotype.df = as.data.frame(rv$phenotype[[1]]), #BUG: load_file still needing indexing
genotype.ID = input$choice_geno,
trait.ID = input$choice_pheno,
cofactor_df = if(input$check_cofactor){rv$cofactor_df},
block = if(input$check_block){input$choice_block},
perm_test = input$check_permutation,
N_parm.max = input$choice_permutation,
ncores = input$choice_core,
verbose = TRUE)
)
progress$hide()
showNotification('Model created', type = 'message')
})
# add to model result of polyqtl scane to model_list for later binding
observeEvent(rv$polyqtl_scan, {
rv$model_list[[input$model_name]] <- rv$polyqtl_scan$QTL.res %>%
left_join(select(bind_rows(rv$linkmap), c(position, marker)), by = 'position')
})
# 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({
req(rv$lod_ggplot)
ggplotly(rv$lod_ggplot, tooltip = 'text') %>%
highlight('plotly_selected') %>%
layout(title = list(text = 'Chromosome', xanchor = 'center'))
})
mod_pqtlr_server("pqtlr_ui_1", rv = rv)
# render print of dataframe from selected points
output$click <- renderPrint({
event_df <- event_data('plotly_selected')
if (is.null(event_df)) return('select points')
bind_rows(rv$model_list, .id = 'model') %>%
filter(position %in% event_df$x & round(LOD) %in% round(event_df$y))
})
# plotly generator ----
mod_qtl_plotly_panel_server("qtl_plotly_panel_ui_1", rv = rv)
})
}
......
......@@ -7,13 +7,85 @@
#' @noRd
#'
#' @importFrom shiny NS tagList
#' @importFrom rhandsontable rhandsontable rHandsontableOutput renderRHandsontable hot_context_menu
#' @importFrom waiter Waiter useWaiter spin_6 transparent
#' @importFrom dplyr left_join select bind_rows
#' @importFrom magrittr %>%
mod_pqtlr_ui <- function(id){
ns <- NS(id)
tagList(
if(id == 'plot_haplo'){
plotOutput('plot_haplo')
}
)
# genotype column selection
selectInput(inputId = ns('choice_geno'),
label = 'Select genotype column',
choices = 'Import phenotype file first'),
# phenotype column selection
selectInput(inputId = ns('choice_pheno'),
label = 'Select phenotype column',
choices = 'Import phenotype file first'),
# does co-factor need to be taken into account?
checkboxInput(inputId = ns('check_cofactor'),
label = 'Co-factor',
value = FALSE),
conditionalPanel(
condition ='input.check_cofactor',
ns = ns,
rHandsontableOutput(ns('cofactor_table')),
actionButton(inputId = ns('cofactor_save'),
label = 'Save')
),
# does block need to be taken into account?
checkboxInput(inputId = ns('check_block'),
label = 'Blocks',
value = FALSE),
# block column selection
conditionalPanel(
condition = 'input.check_block',
ns = ns,
selectInput(inputId = ns('choice_block'),
label = 'Select block column',
choices = 'Import phenotype file first')
),
# permutation test
checkboxInput(inputId = ns('check_permutation'),
label = 'Permutation test',
value = FALSE),
# max number of permutations
conditionalPanel(
condition = 'input.check_permutation',
ns = ns,
numericInput(inputId = ns('choice_permutation'),
label = 'Max number of permuations',
min = 1,
value = 1000,
max = 2000)
),
# cores
numericInput(inputId = ns('choice_core'),
label = 'Numbers of processing cores',
min = 1,
value = detectCores() / 2,
max = detectCores() - 2),
# model name
textInput(inputId = ns('model_name'),
label = 'Model name'),
hr(),
# scan
actionButton(inputId = ns('go'),
label = 'Create'),
useWaiter()
)
}
#' pqtlr Server Functions
......@@ -23,27 +95,77 @@ mod_pqtlr_server <- function(id, rv){
moduleServer( id, function(input, output, session){
ns <- session$ns
if(id == 'ibd_estimate'){
rv[[id]]<- eventReactive(rv$go_estimate, {
estimate_IBD(phased_maplist = link_map(),
genotypes = as.matrix(dosage()),
method = input$IBD_method,
map_function = input$IBD_map,
ploidy = input$ploidy,
ncores = input$IBD_core)
# genotype column selection
observeEvent(rv$phenotype, {
updateSelectInput(session, 'choice_geno',
choices = names(rv$phenotype[[1]]))
})
# phenotype column selection
observeEvent(rv$phenotype, {
updateSelectInput(session, 'choice_pheno',
choices = names(rv$phenotype[[1]]))
})
} else if(id == 'plot_haplo'){
output[[id]] <- renderPlot(visualiseHaplo(IBD_list = rv$ibd_estimate,
display_by = "name",
linkage_group = 1,
select_offspring = 1,
multiplot = c(1, 1))
)
}
# block column selection
observeEvent(rv$phenotype, {
updateSelectInput(session, 'choice_block',
choices = names(rv$phenotype[[1]]))
})
# adding co-factor
observeEvent(input$cofactor_save, {
# save changes in editable table
rv$cofactor_df <- hot_to_r(input$cofactor_table)
# return feedback to user that cofactor was added
showNotification('Cofactor added', type = 'message')
Sys.sleep(.5)
})
})
# editable cofactor table
output$cofactor_table <- renderRHandsontable(rhandsontable(rv$cofactor_df, useTypes = TRUE) %>%
hot_context_menu(
allowRowEdit = TRUE,
allowColEdit = FALSE
)
)
# create polyqtlR model
observeEvent(input$go, {
progress <- Waiter$new(id = ns('go'),
html = spin_6(),
color = 'grey')
progress$show()
req(input$model_name, rv$ibd_estimate, rv$phenotype, input$choice_geno,
input$choice_pheno)
try(
rv$polyqtl_scan<- QTLscan(IBD_list = rv$ibd_estimate,
Phenotype.df = as.data.frame(rv$phenotype[[1]]), #BUG: load_file still needing indexing
genotype.ID = input$choice_geno,
trait.ID = input$choice_pheno,
cofactor_df = if(input$check_cofactor){rv$cofactor_df},
block = if(input$check_block){input$choice_block},
perm_test = input$check_permutation,
N_parm.max = input$choice_permutation,
ncores = input$choice_core,
verbose = TRUE)
)
progress$hide()
showNotification('Model created', type = 'message')
})
# add results of polyqtlscan to model_list for later binding
observeEvent(rv$polyqtl_scan, {
rv$model_list[[input$model_name]] <- rv$polyqtl_scan$QTL.res %>%
left_join(select(bind_rows(rv$linkmap), c(position, marker)), by = 'position')
})
})
}
## To be copied in the UI
......
#' qtl_plotly_panel UI Function
#'
#' @description A shiny Module.
#'
#' @param id,input,output,session Internal parameters for {shiny}.
#'
#' @noRd
#'
#' @importFrom shiny NS tagList
#' @importFrom shinycssloaders withSpinner
#' @importFrom plotly ggplotly renderPlotly plotlyOutput highlight layout event_data
#' @importFrom ggplot2 ggplot aes geom_point geom_line facet_wrap theme element_blank
#' @importFrom dplyr bind_rows filter
#' @importFrom magrittr %>%
mod_qtl_plotly_panel_ui <- function(id){
ns <- NS(id)
tagList(
fluidRow(
# models to include
selectizeInput(inputId = ns('choice_models'),
label = 'Models to include',
choices = 'Create a model first',
multiple = TRUE),
# linkage groups to include
actionButton(inputId = ns('update_plot'),
label = 'Update plot')
),
withSpinner(plotlyOutput(outputId = ns('plotly'))),
verbatimTextOutput(ns('click'))
)
}
#' qtl_plotly_panel Server Functions
#'
#' @noRd
mod_qtl_plotly_panel_server <- function(id, rv){
moduleServer( id, function(input, output, session){
ns <- session$ns
# model selection for plotly object
observeEvent(rv$polyqtl_scan, {
updateSelectInput(session, 'choice_models',
choices = names(rv$model_list))
})
# generate plotly 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({
req(rv$lod_ggplot)
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({
event_df <- event_data('plotly_selected')
if (is.null(event_df)) return('select points')
bind_rows(rv$model_list, .id = 'model') %>%
filter(position %in% event_df$x & round(LOD) %in% round(event_df$y))
})
})
}
## To be copied in the UI
# mod_qtl_plotly_panel_ui("qtl_plotly_panel_ui_1")
## To be copied in the server
# mod_qtl_plotly_panel_server("qtl_plotly_panel_ui_1")
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