Parallelisation

.gitignore

@@ -13,6 +13,8 @@
 
 # Output files from R CMD build
 /*.tar.gz
+src/*.o
+src/*.so
 
 # Output files from R CMD check
 /*.Rcheck/

DESCRIPTION

@@ -26,7 +26,7 @@ URL: https://github.com/HighlanderLab/SIMplyBee
 License: MIT + file LICENSE
 Encoding: UTF-8
 LazyData: true
-Imports: methods, R6, stats, utils, extraDistr (>= 1.9.1), RANN, Rcpp (>= 0.12.7)
+Imports: methods, R6, stats, utils, extraDistr (>= 1.9.1), RANN, Rcpp (>= 0.12.7), foreach, doParallel
 Depends: R (>= 3.3.0), AlphaSimR (>= 1.5.3)
 LinkingTo: Rcpp, RcppArmadillo (>= 0.7.500.0.0), BH
 RoxygenNote: 7.3.2

NAMESPACE

@@ -2,6 +2,7 @@
 
 export(SimParamBee)
 export(addCastePop)
+export(addCastePop_internal)
 export(addDrones)
 export(addVirginQueens)
 export(addWorkers)
@@ -75,7 +76,6 @@ export(getPooledGeno)
 export(getQtlGeno)
 export(getQtlHaplo)
 export(getQueen)
-export(getQueenAge)
 export(getQueenCsdAlleles)
 export(getQueenCsdGeno)
 export(getQueenGv)
@@ -206,7 +206,10 @@ exportClasses(MultiColony)
 import(AlphaSimR)
 import(Rcpp)
 importFrom(R6,R6Class)
+importFrom(doParallel,registerDoParallel)
 importFrom(extraDistr,rtpois)
+importFrom(foreach,"%dopar%")
+importFrom(foreach,foreach)
 importFrom(methods,"slot<-")
 importFrom(methods,classLabel)
 importFrom(methods,is)

NEWS.md

@@ -52,6 +52,20 @@ which caused an error. We now read in the locations from a csv file.
 
 -  Added new C++ function isHeterozygous() to speed up the SIMplyBee function isCsdHeterozygous() 
 
+- parallelised all the major functions (so they run on simParamBee$nThreads cores)
+
+- swarm/split/supersede do no longer store the year of the queen 
+
+- colonies with high inbreeding that do not produce a viable virgin queens in 
+max(10, SP$nVirginQueens) attempts are
+removed in swarm/supersede
+
+- split no longer creates virgin queens in the split colonies but returns colonies with workers 
+and meta data, but no virgin
+queens
+
+- createMultiColony() no longer creates an empty apiary, but it adds empty colonies with IDs
+
 ## Bug fixes
 
 -   Bug fix - get\*Haplo() functions were returning diploid drones when

R/Class-SimParamBee.R

@@ -425,13 +425,112 @@ SimParamBee <- R6Class(
       invisible(self)
     },
 
+    #' @description For internal use only.
+    #'
+    #' @param nNewInd Number of newly created individuals
+    #' @param id the name of each individual
+    #' @param mother vector of mother iids
+    #' @param father vector of father iids
+    #' @param isDH indicator for DH lines
+    addToBeePed = function(nNewInd,id,mother,father,isDH) {
+      stopifnot(nNewInd>0)
+      if(length(isDH)==1) isDH = rep(isDH,nNewInd)
+      mother = as.integer(mother)
+      father = as.integer(father)
+      isDH = as.integer(isDH)
+      stopifnot(length(mother)==nNewInd,
+                length(father)==nNewInd,
+                length(isDH)==nNewInd)
+      tmp = cbind(mother,father,isDH)
+      rownames(tmp) = id
+      private$.pedigree = rbind(private$.pedigree,tmp)
+      private$.lastId = private$.lastId + as.integer(nNewInd)
+      invisible(self)
+    },
+
+
+    #' @description For internal use only.
+    #'
+    #' @param nNewInd Number of newly created individuals
+    #' @param id the name of each individual
+    #' @param mother vector of mother iids
+    #' @param father vector of father iids
+    #' @param isDH indicator for DH lines
+    #' @param hist new recombination history
+    #' @param ploidy ploidy level
+    addToBeeRec = function(nNewInd,id,mother,father,isDH,
+                           hist,ploidy){
+      stopifnot(nNewInd>0)
+      if(length(isDH)==1) isDH = rep(isDH,nNewInd)
+      mother = as.integer(mother)
+      father = as.integer(father)
+      isDH = as.integer(isDH)
+      stopifnot(length(mother)==nNewInd,
+                length(father)==nNewInd,
+                length(isDH)==nNewInd)
+      tmp = cbind(mother,father,isDH)
+      rownames(tmp) = id
+      if(is.null(hist)){
+        newRecHist = vector("list",nNewInd)
+        tmpLastHaplo = private$.lastHaplo
+        if(all(isDH==1L)){
+          for(i in seq_len(nNewInd)){
+            tmpLastHaplo = tmpLastHaplo + 1L
+            newRecHist[[i]] = rep(tmpLastHaplo, ploidy)
+          }
+        }else{
+          for(i in seq_len(nNewInd)){
+            newRecHist[[i]] = (tmpLastHaplo+1L):(tmpLastHaplo+ploidy)
+            tmpLastHaplo = tmpLastHaplo + ploidy
+          }
+        }
+        private$.hasHap = c(private$.hasHap, rep(FALSE, nNewInd))
+        private$.isFounder = c(private$.isFounder, rep(TRUE, nNewInd))
+        #names(newRecHist) = id
+        private$.recHist = c(private$.recHist, newRecHist)
+        private$.lastHaplo = tmpLastHaplo
+      }else{
+        # Add hist to recombination history
+        private$.hasHap = c(private$.hasHap, rep(FALSE, nNewInd))
+        private$.isFounder = c(private$.isFounder, rep(FALSE, nNewInd))
+        #names(hist) = id
+        private$.recHist = c(private$.recHist, hist)
+      }
+      private$.pedigree = rbind(private$.pedigree, tmp)
+      private$.lastId = private$.lastId + as.integer(nNewInd)
+
+      invisible(self)
+    },
+
+    #' @description A function to update the caste
+    #'   For internal use only.
+    #'
+    #' @param caste vector, named vector of castes to be added
+    updateCaste = function(caste) {
+      private$.caste =  c(private$.caste, caste)
+      invisible(self)
+    },
+
+    #' @description A function to update the last
+    #'   ID everytime we create an individual
+    #'   For internal use in SIMplyBee only.
+    #'
+    #' @param lastId integer, last colony ID assigned
+    #' @param n integer, how many individuals to add
+    updateLastBeeId = function(n = 1L) {
+      private$.lastId = private$.lastId + as.integer(n)
+      invisible(self)
+    },
+
     #' @description A function to update the colony last
     #'   ID everytime we create a Colony-class with createColony.
     #'   For internal use only.
     #'
     #' @param lastColonyId integer, last colony ID assigned
-    updateLastColonyId = function() {
-      private$.lastColonyId = private$.lastColonyId + 1L
+    #' @param n integer, how many colonies to add
+    updateLastColonyId = function(n = 1) {
+      n = as.integer(n)
+      private$.lastColonyId = private$.lastColonyId + n
       invisible(self)
     }
   ),
@@ -459,7 +558,7 @@ SimParamBee <- R6Class(
     #'   created
     caste = function(value) {
       if (missing(value)) {
-          x = private$.caste
+        x = private$.caste
       } else {
         stop("`$caste` is read only", call. = FALSE)
       }
@@ -469,7 +568,7 @@ SimParamBee <- R6Class(
     #'   created with \code{\link[SIMplyBee]{createColony}}
     lastColonyId = function(value) {
       if (missing(value)) {
-          private$.lastColonyId
+        private$.lastColonyId
       } else {
         stop("`$lastColonyId` is read only", call. = FALSE)
       }