Commit 756607e6 authored by Kunst, Jonathan's avatar Kunst, Jonathan
Browse files

Now possible to build a fwd-bwd remim model from qtlpoly using mappoly geno...

Now possible to build a fwd-bwd remim model from qtlpoly using mappoly geno and phenotype data. Not yet in module as new modules are acting up...
parent 43e3e18c
......@@ -20,6 +20,7 @@ importFrom(golem,bundle_resources)
importFrom(golem,favicon)
importFrom(golem,with_golem_options)
importFrom(magrittr,"%>%")
importFrom(mappoly,calc_genoprob)
importFrom(parallel,detectCores)
importFrom(plotly,event_data)
importFrom(plotly,ggplotly)
......@@ -31,6 +32,8 @@ importFrom(polyqtlR,BLUE)
importFrom(polyqtlR,QTLscan)
importFrom(polyqtlR,estimate_IBD)
importFrom(polyqtlR,visualiseHaplo)
importFrom(qtlpoly,read_data)
importFrom(qtlpoly,remim)
importFrom(readr,read_csv)
importFrom(readr,read_rds)
importFrom(rhandsontable,hot_context_menu)
......
......@@ -9,6 +9,8 @@
#' @importFrom shiny NS tagList
#' @importFrom polyqtlR estimate_IBD visualiseHaplo
#' @importFrom waiter Waiter useWaiter spin_6 transparent
#' @importFrom mappoly calc_genoprob
#' @importFrom qtlpoly read_data
mod_IBD_panel_ui <- function(id){
ns <- NS(id)
tagList(
......@@ -16,46 +18,88 @@ mod_IBD_panel_ui <- function(id){
sidebarPanel(
h3('Estimation'),
# method of estimation
selectInput(inputId = ns('ibd_method'),
label = 'Estimation Method',
choices = c('Heuristic'= 'heur',
'HMM' = 'hmm')),
# mapping function
selectInput(inputId = ns('ibd_mf'),
label = 'Mapping Function',
choices = c('Haldane' = 'haldane',
'Kosambi' = 'kosambi')),
# ploidy level
numericInput(inputId = ns('ibd_ploidy'),
label = 'Ploidy level',
min = 2,
value = 4,
step = 2),
# cores
numericInput(inputId = ns('ibd_core'),
label = 'Numbers of processing cores',
min = 1,
value = detectCores() / 2,
max = detectCores() - 2),
tabsetPanel(
# polyqtlR IBD estimation ----
tabPanel('polyqtlR',
# method of estimation
selectInput(inputId = ns('ibd_method'),
label = 'Estimation Method',
choices = c('Heuristic'= 'heur',
'HMM' = 'hmm')),
# mapping function
selectInput(inputId = ns('ibd_mf'),
label = 'Mapping Function',
choices = c('Haldane' = 'haldane',
'Kosambi' = 'kosambi')),
# ploidy level
numericInput(inputId = ns('ibd_ploidy'),
label = 'Ploidy level',
min = 2,
value = 4,
step = 2),
# cores
numericInput(inputId = ns('ibd_core'),
label = 'Numbers of processing cores',
min = 1,
value = detectCores() / 2,
max = detectCores() - 2),
# Estimate
actionButton(inputId = ns('go'),
label = 'Estimate')
),
# QTLpoly IBD estimation ----
tabPanel('QTLpoly',
# ploidy level
numericInput(inputId = ns('qtlpoly_ploidy'),
label = 'Ploidy level',
min = 2,
value = 4,
max = 6,
step = 2),
# stepsize (cM)
numericInput(inputId = ns('qtlpoly_step'),
label = 'Stepsize (cM)',
min = 0,
value = 1,
step = 1),
# create genoprob file and generate qtlpoly data object
actionButton(inputId = ns('qtlpoly_go'),
label = 'Estimate')
)
)
),
# Estimate
actionButton(inputId = ns('go'),
label = 'Estimate')
),
mainPanel(
selectInput(inputId = ns('choice_lg'),
label = 'Select linkage group',
choices = 'Estimate or import first'),
selectInput(inputId = ns('choice_offspring'),
label = 'Select offspring',
choices = 'Estimate or import first'),
plotOutput(ns('plot_haplo'))
tabsetPanel(
# output polyqtlR ----
tabPanel('polyqtlR',
selectInput(inputId = ns('choice_lg'),
label = 'Select linkage group',
choices = 'Estimate or import first'),
selectInput(inputId = ns('choice_offspring'),
label = 'Select offspring',
choices = 'Estimate or import first'),
plotOutput(ns('plot_haplo'))
),
# output QTLpoly ----
tabPanel('QTLpoly',
verbatimTextOutput(ns('qtlpoly_ibd_print')),
verbatimTextOutput(ns('qtlpoldy_data_print'))
)
)
)
)
)
......@@ -69,6 +113,7 @@ mod_IBD_panel_server <- function(id, rv){
ns <- session$ns
# Side panel ----
# polyqtlr
observeEvent(input$go, {
progress <- Waiter$new(id = ns('go'),
html = spin_6(),
......@@ -84,8 +129,29 @@ mod_IBD_panel_server <- function(id, rv){
progress$hide()
})
# QTLpoly
observeEvent(input$qtlpoly_go, {
progress <- Waiter$new(id = ns('qtlpoly_go'),
html = spin_6(),
color = 'grey')
progress$show()
rv$qtlpoly_ibd <- lapply(rv$qtlpoly_linkmap, calc_genoprob)
progress$hide()
})
observeEvent(rv$qtlpoly_ibd, {
req(rv$qtlpoly_ibd, rv$qtlpoly_pheno)
rv$qtlpoly_data <- read_data(ploidy = input$qtlpoly_ploidy,
geno.prob = rv$qtlpoly_ibd,
pheno = rv$qtlpoly_pheno,
step = input$qtlpoly_step
)
})
# Main panel ----
# polyqtlr
# Linkage group selection modifier
observeEvent(rv$ibd_estimate, {
req(rv$ibd_estimate)
......@@ -112,6 +178,12 @@ mod_IBD_panel_server <- function(id, rv){
multiplot = c(1, 1))
)
})
# qtlpoly
# proof of succesful qtlpoly_ibd estimation
output$qtlpoly_ibd_print <- renderPrint({req(rv$qtlpoly_ibd)
try(print(rv$qtlpoly_ibd))
})
})
}
......
......@@ -12,6 +12,8 @@
#' @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 qtlpoly remim
mod_model_panel_ui <- function(id, rv){
ns <- NS(id)
tagList(
......@@ -27,7 +29,51 @@ mod_model_panel_ui <- function(id, rv){
),
# sidebarpanel for QTLpoly model options
tabPanel('QTLpoly')
tabPanel('QTLpoly',
# window size
numericInput(inputId = ns('qtlpoly_wsize'),
label = 'Window size (cM)',
min = 1,
step = 1,
value = 15),
# significance forward
numericInput(inputId = ns('qtlpoly_sigfw'),
label = 'Significance forward selection',
min = 0.00000001,
value = 0.01,
max = 0.1),
# significance backward
numericInput(inputId = ns('qtlpoly_sigbw'),
label = 'Significance backward selection',
min = 0.00000001,
value = 0.01,
max = 0.1),
# support interval
numericInput(inputId = ns('qtlpoly_dsint'),
label = 'Support interval (LOP-D)',
value = 1.5,
min = 0.00000001),
numericInput(inputId = ns('qtlpoly_cores'),
label = 'Numbers of processing cores',
min = 1,
value = detectCores() / 2,
max = detectCores() - 2),
# model name
textInput(inputId = ns('qtlpoly_model_name'),
label = 'Model name'),
hr(),
# scan
actionButton(inputId = ns('qtlpoly_go'),
label = 'Create'),
useWaiter())
)
),
......@@ -50,6 +96,27 @@ mod_model_panel_server <- function(id, rv){
# polyqtlR qtlscan options ----
mod_pqtlr_server("pqtlr_ui_1", rv = rv)
# QTLpoly options ----
observeEvent(input$qtlpoly_go, {
progress <- Waiter$new(id = ns('qtlpoly_go'),
html = spin_6(),
color = 'grey')
progress$show()
req(rv$qtlpoly_data, input$qtlpoly_model_name)
try(rv[[input$qtlpoly_model_name]] <- remim(data = rv$qtlpoly_data,
w.size = input$qtlpoly_wsize,
sig.fwd = input$qtlpoly_sigfw,
sig.bwd = input$qtlpoly_sigbw,
d.sint = input$qtlpoly_dsint,
n.clusters = input$qtlpoly_cores)
)
progress$hide()
showNotification('Model created', type = 'message')
})
# plotly generator ----
mod_qtl_plotly_panel_server("qtl_plotly_panel_ui_1", rv = rv)
})
......
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