diff --git a/polyqtlvis/NAMESPACE b/polyqtlvis/NAMESPACE index c3607d4ad599aa64dd0917411ed2f6814c8135a2..e92037ffa96a224f7b62d5f5fb51d45a66d8c695 100644 --- a/polyqtlvis/NAMESPACE +++ b/polyqtlvis/NAMESPACE @@ -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) diff --git a/polyqtlvis/R/app_server.R b/polyqtlvis/R/app_server.R index a1a6cc24c4c87e9a0c6cd071c7303d6c745f110b..e0ad2d06d57415701ba593835746ff7b66546261 100644 --- a/polyqtlvis/R/app_server.R +++ b/polyqtlvis/R/app_server.R @@ -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) diff --git a/polyqtlvis/R/app_ui.R b/polyqtlvis/R/app_ui.R index 9587fe7ce1d346d27de52e71f9c8ab3c834bd595..968b3cb567b110b66d36f97a55f594b88d1f2cac 100644 --- a/polyqtlvis/R/app_ui.R +++ b/polyqtlvis/R/app_ui.R @@ -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")) diff --git a/polyqtlvis/R/mod_IBD_panel.R b/polyqtlvis/R/mod_IBD_panel.R index cdb6c5bf53ed4a9fbe4c56bf7b0cff887ced2488..8ecbf3012b14d547e9e2dafbde68aaec9e7ecb62 100644 --- a/polyqtlvis/R/mod_IBD_panel.R +++ b/polyqtlvis/R/mod_IBD_panel.R @@ -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), diff --git a/polyqtlvis/R/mod_model_panel.R b/polyqtlvis/R/mod_model_panel.R index 6f2949d1456ff95b7ed64aa0648202b940df5b17..a376dd9b744c43a9fb196c4d1644ee7e5686aec0 100644 --- a/polyqtlvis/R/mod_model_panel.R +++ b/polyqtlvis/R/mod_model_panel.R @@ -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") diff --git a/polyqtlvis/dev/02_dev.R b/polyqtlvis/dev/02_dev.R index 0b84a7922ba7cd9041b94673fad897e7f5388762..49fe993df98d2c46a5ca7d2a1177793d6f7732e5 100644 --- a/polyqtlvis/dev/02_dev.R +++ b/polyqtlvis/dev/02_dev.R @@ -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') diff --git a/test_script.R b/test_script.R index d028339f6510dac6517ecf667fbe5ce43007c095..abd64a2ebd9a9b0b2cac4deb4821c5ad7303dae4 100644 --- a/test_script.R +++ b/test_script.R @@ -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')