Commit 34429dd2 authored by Kunst, Jonathan's avatar Kunst, Jonathan
Browse files

Added function options and QTLscan implementation

Added model_list value in rv to collect models accross packages
parent 2f1d670f
......@@ -2,12 +2,17 @@
export(run_app)
import(shiny)
importFrom(dplyr,bind_rows)
importFrom(dplyr,left_join)
importFrom(dplyr,select)
importFrom(golem,activate_js)
importFrom(golem,add_resource_path)
importFrom(golem,bundle_resources)
importFrom(golem,favicon)
importFrom(golem,with_golem_options)
importFrom(magrittr,"%>%")
importFrom(parallel,detectCores)
importFrom(polyqtlR,QTLscan)
importFrom(polyqtlR,estimate_IBD)
importFrom(polyqtlR,visualiseHaplo)
importFrom(readr,read_csv)
......
......@@ -8,6 +8,9 @@ app_server <- function( input, output, session ) {
# initialise reactive values object
rv <- reactiveValues()
# construct list in rv to carry different models made
rv$model_list <- list()
# Input data ----
mod_import_panel_server("import_panel_ui_1", rv = rv)
......
......@@ -14,10 +14,12 @@ app_ui <- function(request) {
tabPanel('Data import',
mod_import_panel_ui('import_panel_ui_1')
),
# IBD panel ----
tabPanel('IBD',
mod_IBD_panel_ui("IBD_panel_ui_1")
),
# Model panel
tabPanel('Model',
mod_model_panel_ui("model_panel_ui_1"))
......
......@@ -15,26 +15,26 @@ mod_IBD_panel_ui <- function(id){
sidebarPanel(
h3('Estimation'),
# Method of estimation
# method of estimation
selectInput(inputId = ns('ibd_method'),
label = 'Estimation Method',
choices = c('Heuristic'= 'heur',
'HMM' = 'hmm')),
# Mapping function
# mapping function
selectInput(inputId = ns('ibd_mf'),
label = 'Mapping Function',
choices = c('Haldane' = 'haldane',
'Kosambi' = 'kosambi')),
# Ploidy level
# ploidy level
numericInput(inputId = ns('ibd_ploidy'),
label = 'Ploidy level',
min = 2,
value = 4,
step = 2),
# Cores
# cores
numericInput(inputId = ns('ibd_core'),
label = 'Numbers of processing cores',
min = 1,
......@@ -81,6 +81,7 @@ mod_IBD_panel_server <- function(id, rv){
# Main panel ----
# Linkage group selection modifier
observeEvent(rv$ibd_estimate, {
req(rv$ibd_estimate)
updateSelectInput(session, 'choice_lg',
choices = 1:length(names(rv$ibd_estimate)))
})
......@@ -92,8 +93,9 @@ mod_IBD_panel_server <- function(id, rv){
choices = rv$ibd_estimate[[as.numeric(input$choice_lg)]]$offspring)
})
# haplotype visualisation as proof of succesful estimation
output$plot_haplo <- renderPlot({
req(rv$ibd_estimate)
req(rv$ibd_estimate, input$choice_lg, input$choice_offspring) # BUG: SHORT UBSCRIPT OUT OF BOUNDS ERROR
visualiseHaplo(IBD_list = rv$ibd_estimate,
display_by = "name",
linkage_group = as.numeric(input$choice_lg),
......
......@@ -7,17 +7,84 @@
#' @noRd
#'
#' @importFrom shiny NS tagList
mod_model_panel_ui <- function(id){
#' @importFrom polyqtlR QTLscan
#' @importFrom dplyr left_join select bind_rows
#' @importFrom magrittr %>%
mod_model_panel_ui <- function(id, rv){
ns <- NS(id)
tagList(
sidebarLayout(
sidebarPanel(
tabsetPanel(
tabPanel('PolyqtlR'),
# siebarpanel 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 block need to be taken into account?
checkboxInput(inputId = ns('check_block'), #outside ns for conditionalpanel
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')
),
# sidebarpanel for qtlpoly model options
tabPanel('qtlpoly')
)
),
mainPanel()
mainPanel(
verbatimTextOutput(ns('value'))
)
)
)
}
......@@ -28,7 +95,52 @@ mod_model_panel_ui <- function(id){
mod_model_panel_server <- function(id, rv){
moduleServer( id, function(input, output, session){
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]]))
})
# create polyqtlR model
observeEvent(input$go, {
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,
block = input$choice_block,
perm_test = input$check_permutation,
N_parm.max = 1000,
ncores = input$choice_core,
verbose = TRUE)
)
})
# 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')
})
# testoutput
output$value <- renderPrint({rv$model_list})
})
}
......@@ -37,5 +149,11 @@ mod_model_panel_server <- function(id, rv){
## To be copied in the server
# mod_model_panel_server("model_panel_ui_1")
#
# qtl_LODs.4x <- QTLscan(IBD_list = IBD_4x,
# Phenotype.df = Phenotypes_4x,
# genotype.ID = "geno",
# trait.ID = "pheno",
# block = "year")
......@@ -16,6 +16,7 @@
## Dependencies ----
## Add one line by package you want to add as dependency
usethis::use_package('polyqtlR')
usethis::use_package('tidyverse')
usethis::use_package('plotly')
usethis::use_package('readr')
usethis::use_package('parallel')
......
......@@ -36,7 +36,8 @@ qtl_LODs.4x <- QTLscan(IBD_list = IBD_4x,
Phenotype.df = Phenotypes_4x,
genotype.ID = "geno",
trait.ID = "pheno",
block = "year")
block = "year",
N_perm.max = 1000)
# visualise QTLs
plotQTL(LOD_data = qtl_LODs.4x,
......@@ -141,7 +142,7 @@ visualiseQTLeffects(IBD_list = IBD_4x,
modellist <- list()
modellist[['nonfactor']] <- qtl_LODs.4x$QTL.res %>%
left_join(bind_rows(phased_maplist.4x), by = 'position')
left_join(select(bind_rows(phased_maplist.4x), c(position, marker)), by = 'position')
modellist[['co-factor']] <- qtl_LODs.4x_cofactor$QTL.res %>%
left_join(select(bind_rows(phased_maplist.4x), !marker), by = 'position')
......
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