Added function options and QTLscan implementation

Added model_list value in rv to collect models accross packages

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)

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)
   

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"))

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),

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")
 
 

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')

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')