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...

polyqtlvis/NAMESPACE

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

polyqtlvis/R/mod_IBD_panel.R

@@ -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))
+      })
   })
 }
     

polyqtlvis/R/mod_model_panel.R

@@ -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)
   })