From d1939bf5cb669d651006cacf234c75d44d1950cc Mon Sep 17 00:00:00 2001 From: janaobsteter Date: Tue, 8 Apr 2025 16:47:41 +0200 Subject: [PATCH 01/42] Parallelising functions, keeping both options --- DESCRIPTION | 2 +- NAMESPACE | 21 +- R/Class-SimParamBee.R | 36 +- R/Functions_L0_auxilary.R | 43 +- R/Functions_L1_Pop.R | 637 ++++++++++++++- R/Functions_L2_Colony.R | 1485 +++++++++++++++++++++++++++++++---- R/Functions_L3_Colonies.R | 40 + man/MultiColony-class.Rd | 8 +- man/SimParamBee.Rd | 65 +- man/addCastePop.Rd | 2 +- man/addCastePop_internal.Rd | 24 + man/createCastePop.Rd | 24 +- man/createColony.Rd | 2 +- man/downsize.Rd | 10 +- man/removeCastePop.Rd | 19 +- man/supersede.Rd | 9 +- man/swarm.Rd | 6 - 17 files changed, 2259 insertions(+), 174 deletions(-) create mode 100644 man/addCastePop_internal.Rd diff --git a/DESCRIPTION b/DESCRIPTION index 5ac2bc7d..4ef4a624 100644 --- a/DESCRIPTION +++ b/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 diff --git a/NAMESPACE b/NAMESPACE index 231169a0..be1bdc2e 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -2,6 +2,8 @@ export(SimParamBee) export(addCastePop) +export(addCastePop_internal) +export(addCastePop_parallel) export(addDrones) export(addVirginQueens) export(addWorkers) @@ -10,6 +12,8 @@ export(areFathersPresent) export(areVirginQueensPresent) export(areWorkersPresent) export(buildUp) +export(buildUp_parallel) +export(buildUp_parallel_simplified) export(calcBeeAlleleFreq) export(calcBeeGRMIbd) export(calcBeeGRMIbs) @@ -21,19 +25,24 @@ export(calcPerformanceCriterion) export(calcQueensPHomBrood) export(calcSelectionCriterion) export(collapse) +export(collapse_parallel) export(combine) +export(combine_parallel) export(createCastePop) +export(createCastePop_parallel) export(createColony) export(createCrossPlan) export(createDCA) export(createDrones) export(createMatingStationDCA) export(createMultiColony) +export(createMultiColony_parallel) export(createVirginQueens) export(createWorkers) export(cross) export(downsize) export(downsizePUnif) +export(downsize_parallel) export(getCaste) export(getCasteId) export(getCastePop) @@ -168,6 +177,7 @@ export(nWorkersPoisson) export(nWorkersTruncPoisson) export(pHomBrood) export(pullCastePop) +export(pullCastePop_parallel) export(pullColonies) export(pullDroneGroupsFromDCA) export(pullDrones) @@ -177,30 +187,39 @@ export(pullVirginQueens) export(pullWorkers) export(rcircle) export(reQueen) +export(reQueen_parallel) export(reduceDroneGeno) export(reduceDroneHaplo) export(removeCastePop) +export(removeCastePop_parallel) export(removeColonies) export(removeDrones) export(removeQueen) -export(removeVirginQueens) +export(removeVirginQueens_parallel) export(removeWorkers) export(replaceCastePop) +export(replaceCastePop_parallel) export(replaceDrones) export(replaceVirginQueens) export(replaceWorkers) export(resetEvents) +export(resetEvents_parallel) export(selectColonies) +export(setEvents_parallel) export(setLocation) +export(setLocation_parallel) export(setMisc) export(setQueensYearOfBirth) export(simulateHoneyBeeGenomes) export(split) export(splitPColonyStrength) export(splitPUnif) +export(split_parallel) export(supersede) +export(supersede_parallel) export(swarm) export(swarmPUnif) +export(swarm_parallel) exportClasses(Colony) exportClasses(MultiColony) import(AlphaSimR) diff --git a/R/Class-SimParamBee.R b/R/Class-SimParamBee.R index 5ca066c3..aa5c0d31 100644 --- a/R/Class-SimParamBee.R +++ b/R/Class-SimParamBee.R @@ -425,13 +425,45 @@ SimParamBee <- R6Class( invisible(self) }, + #' @description A function to update the pedigree. + #' For internal use only. + #' + #' @param pedigree matrix, pedigree matrix to be added + updatePedigree = function(pedigree) { + private$.pedigree = rbind(private$.pedigree, pedigree) + 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 only. + #' + #' @param lastId integer, last colony ID assigned + #' @param n integer, how many individuals to add + updateLastId = function(n = 1) { + n = as.integer(n) + private$.lastId = private$.lastId + 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) } ), diff --git a/R/Functions_L0_auxilary.R b/R/Functions_L0_auxilary.R index 28e56689..7c492e44 100644 --- a/R/Functions_L0_auxilary.R +++ b/R/Functions_L0_auxilary.R @@ -341,6 +341,37 @@ calcQueensPHomBrood <- function(x, simParamBee = NULL) { return(ret) } + +calcQueensPHomBrood_parallel <- function(x, simParamBee = NULL) { + if (is.null(simParamBee)) { + simParamBee <- get(x = "SP", envir = .GlobalEnv) + } + if (isPop(x)) { + ret <- rep(x = NA, times = nInd(x)) + for (ind in seq_len(nInd(x))) { + + queensCsd <- apply( + X = getCsdAlleles(x[ind], simParamBee = simParamBee), MARGIN = 1, + FUN = function(x) paste0(x, collapse = "") + ) + fathersCsd <- apply( + X = getCsdAlleles(x@misc$fathers[[ind]], simParamBee = simParamBee), MARGIN = 1, + FUN = function(x) paste0(x, collapse = "") + ) + nComb <- length(queensCsd) * length(fathersCsd) + ret[ind] <- sum(fathersCsd %in% queensCsd) / nComb + } + } else if (isColony(x)) { + ret <- calcQueensPHomBrood(x = x@queen) + } else if (isMultiColony(x)) { + ret <- sapply(X = x@colonies, FUN = calcQueensPHomBrood) + names(ret) <- getId(x) + } else { + stop("Argument x must be a Pop, Colony, or MultiColony class object!") + } + return(ret) +} + #' @describeIn calcQueensPHomBrood Expected percentage of csd homozygous brood #' of a queen / colony #' @export @@ -359,11 +390,11 @@ pHomBrood <- function(x, simParamBee = NULL) { } } } else if (isColony(x)) { - if (is.null(x@queen@misc$pHomBrood[[1]])) { - ret <- NA - } else { - ret <- x@queen@misc$pHomBrood[[1]] - } + if (is.null(x@queen@misc$pHomBrood[[1]])) { + ret <- NA + } else { + ret <- x@queen@misc$pHomBrood[[1]] + } } else if (isMultiColony(x)) { ret <- sapply(X = x@colonies, FUN = pHomBrood) names(ret) <- getId(x) @@ -2545,7 +2576,7 @@ getCsdGeno <- function(x, caste = NULL, nInd = NULL, dronesHaploid = TRUE, } else { ret <- getCsdGeno( x = getCastePop(x, caste, simParamBee = simParamBee), nInd = nInd, - dronesHaploid = dronesHaploid, simParamBee = simParamBee + dronesHaploid = dronesHaploid, simParamBee = simParamBee ) } } else if (isMultiColony(x)) { diff --git a/R/Functions_L1_Pop.R b/R/Functions_L1_Pop.R index 005fe4fd..24fad680 100644 --- a/R/Functions_L1_Pop.R +++ b/R/Functions_L1_Pop.R @@ -416,6 +416,10 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, } if (is.function(nInd)) { nInd <- nInd(x, ...) + } else { + if (!is.null(nInd) && any(nInd < 0)) { + stop("nInd must be non-negative or NULL!") + } } # doing "if (is.function(nInd))" below if (isMapPop(x)) { @@ -542,6 +546,7 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, editCsd = TRUE, csdAlleles = NULL, simParamBee = simParamBee, ... ) + } names(ret) <- getId(x) } else { @@ -551,19 +556,298 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, return(ret) } +#' @export +createCastePop_parallel <- function(x, caste = NULL, nInd = NULL, + year = NULL, + editCsd = TRUE, csdAlleles = NULL, + simParamBee = NULL, + returnSP = FALSE, + ids = NULL, + nThreads = NULL, + ...) { + if (is.null(simParamBee)) { + simParamBee <- get(x = "SP", envir = .GlobalEnv) + } + if (is.null(nThreads)) { + nThreads = simParamBee$nThreads + } + if (is.null(nInd)) { + if (caste == "virginQueens") { + nInd <- simParamBee$nVirginQueens + } else if (caste == "workers") { + nInd <- simParamBee$nWorkers + } else if (caste == "drones") { + nInd <- simParamBee$nDrones + } + } + if (is.function(nInd)) { + nInd <- nInd(x, ...) + } + # doing "if (is.function(nInd))" below + if (isMapPop(x)) { + if (caste != "virginQueens") { # Creating virgin queens if input is a MapPop + stop("MapPop-class can only be used to create virgin queens!") + } + ret <- newPop(x, simParam = simParamBee) + if (!is.null(simParamBee$csdChr)) { + if (editCsd) { + ret <- editCsdLocus(ret, alleles = csdAlleles, simParamBee = simParamBee) + } + } + ret@sex[] <- "F" + simParamBee$changeCaste(id = ret@id, caste = "virginQueens") + if (!is.null(year)) { + ret <- setQueensYearOfBirth(x = ret, year = year, simParamBee = simParamBee) + } + } else if (isPop(x)) { + if (caste != "drones") { # Creating drones if input is a Pop + stop("Pop-class can only be used to create drones!") + } + if (any(!(isVirginQueen(x, simParamBee = simParamBee) | isQueen(x, simParamBee = simParamBee)))) { + stop("Individuals in x must be virgin queens or queens!") + } + if (length(nInd) == 1) { + # Diploid version - a hack, but it works + ret <- makeDH(pop = x, nDH = nInd, keepParents = FALSE, simParam = simParamBee) + } else { + if (length(nInd) < nInd(x)) { + stop("Too few values in the nInd argument!") + } + if (length(nInd) > 1 && length(nInd) > nInd(x)) { + warning(paste0("Too many values in the nInd argument, taking only the first ", nInd(x), "values!")) + nInd <- nInd[1:nInd(x)] + } + ret <- list() + for (virginQueen in 1:nInd(x)) { + ret[[virginQueen]] <- makeDH(pop = x[virginQueen], nDH = nInd[virginQueen], keepParents = FALSE, simParam = simParamBee) + } + ret <- mergePops(ret) + } + ret@sex[] <- "M" + simParamBee$addToCaste(id = ret@id, caste = "drones") + } else if (isColony(x)) { + if (!isQueenPresent(x, simParamBee = simParamBee)) { + stop("Missing queen!") + } + if (length(nInd) > 1) { + warning("More than one value in the nInd argument, taking only the first value!") + nInd <- nInd[1] + } + if (nInd > 0) { + if (caste == "workers") { + if (!returnSP) { + ret <- vector(mode = "list", length = 2) + names(ret) <- c("workers", "nHomBrood") + } else { + ret <- vector(mode = "list", length = 4) + names(ret) <- c("workers", "nHomBrood", "pedigree", "caste") + } + ret$workers <- combineBeeGametes( + queen = getQueen(x, simParamBee = simParamBee), drones = getFathers(x, simParamBee = simParamBee), + nProgeny = nInd, simParamBee = simParamBee + ) + + simParamBee$addToCaste(id = ret$workers@id, caste = "workers") + ret$workers@sex[] <- "F" + + if (returnSP) { + ret$pedigree = simParamBee$pedigree[ret$workers@id, , drop = F] + ret$caste = simParamBee$caste[ret$workers@id, drop = F] + } + + if (!is.null(ids)) { + if (nInd(ret$workers) < length(ids)) { + stop("Not enough IDs provided") + } + if (nInd(ret$workers) > length(ids)) { + stop("Too many IDs provided!") + } + ret$workers@id = ids + if (returnSP) { + rownames(ret$pedigree) = ids + names(ret$caste) = ids + } + } + + # THIS DOES STILL NOT WORK!!! + # if (isCsdActive(simParamBee = simParamBee)) { + # ret$nHomBrood <- sum(!isCsdHeterozygous(ret$workers)) / nInd(ret$workers) + # } + + } else if (caste == "virginQueens") { # Creating virgin queens if input is a Colony + ret <- createCastePop_parallel(x = x, caste = "workers", + nInd = nInd, exact = TRUE, simParamBee = simParamBee, + returnSP = returnSP, ids = ids, nThreads = 1, ...) + simParamBee$changeCaste(id = ret$workers@id, caste = "virginQueens") + if (!returnSP) { + ret <- ret$workers + } + if (!is.null(year)) { + ret <- setQueensYearOfBirth(x = ret, year = year, simParamBee = simParamBee) + } + } else if (caste == "drones") { # Creating drones if input is a Colony + drones <- makeDH( + pop = getQueen(x, simParamBee = simParamBee), nDH = nInd, keepParents = FALSE, + simParam = simParamBee + ) + drones@sex[] <- "M" + simParamBee$addToCaste(id = drones@id, caste = "drones") + + if (returnSP) { + print("Adding") + ret <- vector(mode = "list", length = 3) + names(ret) <- c("drones", "pedigree", "caste") + ret$pedigree = simParamBee$pedigree[drones@id, , drop = F] + ret$caste = simParamBee$caste[drones@id, drop = F] + } + + if (!is.null(ids)) { + if (nInd(drones) != length(ids)) { + stop("Not enough IDs provided") + } + drones@id = ids + if (returnSP) { + rownames(ret$pedigree) = ids + names(ret$caste) = ids + } + } + + if (returnSP) { + ret$drones= drones + } else { + ret = drones + } + } + } else { + ret <- NULL + } + } else if (isMultiColony(x)) { + registerDoParallel(cores = nThreads) + if (is.null(nInd)) { + string = paste0("n", toupper(substr(caste, 1, 1)), substr(caste, 2, nchar(caste))) + nInd <- simParaBee[[string]] + } + + nCol <- nColonies(x) + nNInd <- length(nInd) + + if (nNInd > 1 && nNInd < nCol) { + stop("Too few values in the nInd argument!") + } + if (nNInd > 1 && nNInd > nCol) { + warning(paste0("Too many values in the nInd argument, taking only the first ", nCol, "values!")) + nInd <- nInd[1:nCol] + } + + nNInd <- length(nInd) + totalNInd = ifelse(nNInd == 1, nInd * nCol, sum(nInd)) + if (totalNInd == 0) { + stop("Nothing to create.") + } + + lastId = simParamBee$lastId + ids = (lastId+1):(lastId+totalNInd) + + combine_list <- function(a, b) { + if (!is.null(names(a))) { + c(list(a), list(b)) + } else { + if ((is.null(a) | is.null(b)) & !(is.null(a) & is.null(b))) { + c(a, list(b)) + } else if (is.null(a) & is.null(b)) { + c(list(a), list(b)) + } else { + c(a, list(b)) + } + } + } + + ret <- foreach(colony = seq_len(nCol), .combine=combine_list) %dopar% { + nIndColony <- ifelse(nNInd == 1, nInd, nInd[colony]) + if (nIndColony > 0) { + if (nNInd == 1) { + colonyIds = ids[((colony-1)*nIndColony+1):(colony*nIndColony)] + } else { + colonyIds = base::split(ids, rep(seq_along(nInd), nInd))[[as.character(colony)]] + } + createCastePop_parallel( + x = x[[colony]], caste = caste, + nInd = nIndColony, + exact = exact, + year = year, + editCsd = TRUE, csdAlleles = NULL, + simParamBee = simParamBee, + returnSP = TRUE, + ids = as.character(colonyIds), ... + ) + } else { + NULL + } + } + simParamBee$updateLastId(n = totalNInd) + names(ret) <- getId(x) + + # Add to simParamBee: pedigree, caste, trackRecHis? + notNull = sapply(ret, FUN = function(x) !is.null(x)) + + Pedigree = do.call("rbind", lapply(ret[notNull], '[[', "pedigree")) + simParamBee$updatePedigree(pedigree = Pedigree) + + # Update caste + Caste = do.call("c", lapply(ret[notNull], '[[', "caste")) + if (caste == "virginQueens") { + Caste = rep("virginQueens", length(Caste)) + } + Names = do.call("c", lapply(ret[notNull], function(x) names(x$caste))) + names(Caste) = Names + simParamBee$updateCaste(caste = Caste) + + if (!returnSP) { + if (caste %in% c("drones", "virginQueens")) { + ret = lapply(ret, FUN = function(x) { + if (is.null(x)) return(NULL) # Return NULL if the element is NULL + x[!names(x) %in% c("pedigree", "caste")][[1]] + }) + } else { + ret = lapply(ret, FUN = function(x) { + if (is.null(x)) return(NULL) # Return NULL if the element is NULL + x[!names(x) %in% c("pedigree", "caste")] + }) + } + } + } else { + stop("Argument x must be a Map-Pop (only for virgin queens), + Pop (only for drones), Colony, or MultiColony class object!") + } + + return(ret) +} + #' @describeIn createCastePop Create workers from a colony #' @export -createWorkers <- function(x, nInd = NULL, exact = FALSE, simParamBee = NULL, ...) { +createWorkers <- function(x, nInd = NULL, exact = FALSE, simParamBee = NULL, + returnSP = FALSE, + ids = NULL, + nThreads = NULL, ...) { ret <- createCastePop(x, caste = "workers", nInd = nInd, - exact = exact, simParamBee = simParamBee, ...) + exact = exact, simParamBee = simParamBee, + returnSP = FALSE, + ids = NULL, + nThreads = NULL, ...) return(ret) } #' @describeIn createCastePop Create drones from a colony #' @export -createDrones <- function(x, nInd = NULL, simParamBee = NULL, ...) { +createDrones <- function(x, nInd = NULL, simParamBee = NULL, + returnSP = FALSE, + ids = NULL, + nThreads = NULL, ...) { ret <- createCastePop(x, caste = "drones", nInd = nInd, - simParamBee = simParamBee, ...) + simParamBee = simParamBee, + returnSP = FALSE, + ids = NULL, + nThreads = NULL, ...) return(ret) } @@ -573,10 +857,16 @@ createVirginQueens <- function(x, nInd = NULL, year = NULL, editCsd = TRUE, csdAlleles = NULL, simParamBee = NULL, + returnSP = FALSE, + ids = NULL, + nThreads = NULL, ...) { ret <- createCastePop(x, caste = "virginQueens", nInd = nInd, year = year, editCsd = editCsd, - csdAlleles = csdAlleles, simParamBee = simParamBee, ...) + csdAlleles = csdAlleles, simParamBee = simParamBee, + returnSP = FALSE, + ids = NULL, + nThreads = NULL, ...) return(ret) } @@ -1119,6 +1409,90 @@ pullCastePop <- function(x, caste, nInd = NULL, use = "rand", return(ret) } +#' @export +pullCastePop_parallel <- function(x, caste, nInd = NULL, use = "rand", + removeFathers = TRUE, collapse = FALSE, simParamBee = NULL, + nThreads = NULL) { + if (is.null(simParamBee)) { + simParamBee <- get(x = "SP", envir = .GlobalEnv) + } + if (is.null(nThreads)) { + nThreads = simParamBee$nThreads + } + if (length(caste) > 1) { + stop("Argument caste can be only of length 1!") + } + if (any(nInd < 0)) { + stop("nInd must be non-negative or NULL!") + } + if (isColony(x)) { + if (length(nInd) > 1) { + warning("More than one value in the nInd argument, taking only the first value!") + nInd <- nInd[1] + } + if (is.null(slot(x, caste))) { + ret <- list(pulled = NULL, remnant = x) + } else { + if (is.null(nInd)) { + nInd <- nInd(slot(x, caste)) + } + tmp <- pullInd(pop = slot(x, caste), nInd = nInd, use = use, simParamBee = simParamBee) + if (caste == "queen") { + slot(x, caste) <- NULL + } else { + slot(x, caste) <- tmp$remnant + } + if (caste == "drones" && removeFathers) { + test <- isDrone(tmp$pulled, simParamBee = simParamBee) + if (any(!test)) { + tmp$pulled <- tmp$pulled[test] + } + } + ret <- list(pulled = tmp$pulled, remnant = x) + } + } else if (isMultiColony(x)) { + registerDoParallel(cores = nThreads) + nCol <- nColonies(x) + nNInd <- length(nInd) + if (nNInd > 1 && nNInd < nCol) { + stop("Too few values in the nInd argument!") + } + if (nNInd > 1 && nNInd > nCol) { + warning(paste0("Too many values in the nInd argument, taking only the first ", nCol, "values!")) + nInd <- nInd[1:nCol] + } + ret <- vector(mode = "list", length = 2) + names(ret) <- c("pulled", "remnant") + ret$pulled <- vector(mode = "list", length = nCol) + names(ret$pulled) <- getId(x) + ret$remnant <- x + + tmp = foreach(colony = seq_len(nCol)) %dopar% { + if (is.null(nInd)) { + nIndColony <- NULL + } else { + nIndColony <- ifelse(nNInd == 1, nInd, nInd[colony]) + } + pullCastePop(x = x[[colony]], + caste = caste, + nInd = nIndColony, + use = use, + removeFathers = removeFathers, + collapse = collapse, + simParamBee = simParamBee) + } + ret$pulled <- lapply(tmp, '[[', "pulled") + ret$remnant@colonies <- lapply(tmp, '[[', "remnant") + + if (collapse) { + ret$pulled <- mergePops(ret$pulled) + } + } else { + stop("Argument x must be a Colony or MultiColony class object!") + } + return(ret) +} + #' @describeIn pullCastePop Pull queen from a colony #' @export pullQueen <- function(x, collapse = FALSE, simParamBee = NULL) { @@ -1528,6 +1902,259 @@ cross <- function(x, return(ret) } +cross_parallel <- function(x, + crossPlan = NULL, + drones = NULL, + droneColonies = NULL, + nDrones = NULL, + spatial = FALSE, + radius = NULL, + checkCross = "error", + simParamBee = NULL, + nThreads = NULL, + ...) { + if (is.null(simParamBee)) { + simParamBee <- get(x = "SP", envir = .GlobalEnv) + } + if (is.null(nThreads)) { + nThreads = simParamBee$nThreads + } + registerDoParallel(cores = nThreads) + + if (isPop(x)) { + type = "Pop" + } else if (isColony(x)) { + type = "Colony" + } else if (isMultiColony(x)) { + type = "MultiColony" + } else { + stop("Input x must be a Pop-class, Colony-class, or MultiColony-class!") + } + + if (is.null(nDrones)) { + nDrones <- simParamBee$nFathers + } + + IDs <- as.character(getId(x)) + oneColony <- (isPop(drones)) && (length(IDs) == 1) && (is.null(crossPlan)) + dronePackages <- is.list(drones) + crossPlan_given <- !dronePackages && is.list(crossPlan) + crossPlan_create <- ifelse(!is.null(crossPlan) && !dronePackages, (crossPlan[1] == "create"), FALSE) + crossPlan_droneID <- (!is.null(crossPlan)) && !is.null(drones) + crossPlan_colonyID <- (!is.null(crossPlan)) && !is.null(droneColonies) + + + # Do all the tests here to simplify the function + if (crossPlan_droneID && !isPop(drones)) { + stop("When using a cross plan, drones must be supplied as a single Pop-class!") + } + if (crossPlan_colonyID && !isMultiColony(droneColonies)) { + stop("When using a cross plan, droneColonies must be supplied as a single MultiColony-class!") + } + if (!is.null(drones) && !is.null(droneColonies)) { + stop("You can provide either drones or droneColonies, but not both!") + } + if (is.null(drones) & is.null(droneColonies)) { + stop("You must provide either drones or droneColonies!") + } + if (!dronePackages & !isPop(drones) & is.null(droneColonies)) { + stop("The argument drones must be a Pop-class + or a list of drone Pop-class objects!") + } + if (crossPlan_given && !is.null(drones) && !all(unlist(crossPlan) %in% drones@id)) { + stop("Some drones from the crossPlan are missing in the drones population!") + } + if (dronePackages && length(IDs) != length(drones)) { #check for list of father pops + stop("Length of argument drones should match the number of virgin queens/colonies!") + } + if (!is.null(crossPlan) && all(is.null(drones), is.null(droneColonies))) { + stop("When providing a cross plan, you must also provide drones or droneColonies!") + } + if (crossPlan_given && !all(IDs %in% names(crossPlan))) { #Check for cross plan + stop("Cross plan must include all the virgin queens/colonies!") + } + if (isPop(x)) { + if (any(!isVirginQueen(x, simParamBee = simParamBee))) { + stop("Individuals in pop must be virgin queens!") + } + } + if (isColony(x) | isMultiColony(x)) { + if (any(isQueenPresent(x, simParamBee = simParamBee))) { + stop("Queen already present in the colony!") + } + if (any(!isVirginQueensPresent(x, simParamBee = simParamBee))) { + stop("No virgin queen(s) in the colony to cross!") + } + } + + # Convert everything to a Pop + if (isColony(x) | isMultiColony(x)) { + inputId <- getId(x) + if (isColony(x)) { + colony <- x + x <- pullCastePop_parallel(x, caste = "virginQueens", nInd = 1)$pulled + ID_by_input <- data.frame(inputId = inputId, + virginId = getId(x)) + } else if (isMultiColony(x)) { + multicolony <- x + x <- pullCastePop_parallel(x, caste = "virginQueens", nInd = 1)$pulled + ID_by_input <- data.frame(inputId = inputId, + virginId = unlist(sapply(x, FUN = function(y) getId(y)))) + x <- mergePops(x) + } + + } + IDs <- as.character(getId(x)) + #Now x is always a Pop + ret <- list() + nVirgin = nInd(x) + + if (is.function(nDrones)) { + nD = nDrones(n = nVirgin, ...) + } else { + nD = nDrones + } + + if (crossPlan_create | crossPlan_given) { + if (crossPlan_create) { + crossPlan <- createCrossPlan(x = x, + drones = drones, + droneColonies = droneColonies, + nDrones = nDrones, + spatial = spatial, + radius = radius, + simParamBee = simParamBee) + } + + if (crossPlan_given) { + names(crossPlan) <- ID_by_input$virginId[match(ID_by_input$inputId, names(crossPlan))] + } + + noMatches <- sapply(crossPlan, FUN = length) + if (0 %in% noMatches) { + msg <- "Crossing failed!" + if (checkCross == "warning") { + message(msg) + ret <- x + } else if (checkCross == "error") { + stop(msg) + } + } + } + + combine_list <- function(a, b) { + if (isPop(a)) { + c(list(a), list(b)) + } else { + c(a, list(b)) + } + } + + if (crossPlan_given | crossPlan_create) { + if (crossPlan_colonyID) { # WHAT IF ONE ELEMENT IS EMPTY + crossPlanDF <- data.frame(virginID = rep(names(crossPlan), unlist(sapply(crossPlan, length))), + DPC = unlist(crossPlan)) + + crossPlanDF_sample <- do.call("rbind", lapply(IDs, FUN = function(x) { + data.frame(virginID = x, DPC = sample(crossPlan[[x]], size = nD[which(x == IDs)], replace = TRUE))})) %>% + arrange(DPC) + crossPlanDF_DPCtable <- as.data.frame(table(crossPlanDF_sample$DPC)) %>% arrange(Var1) + colnames(crossPlanDF_DPCtable) <- c("DPC", "noDrones") + + selectedDPC = droneColonies[as.character(crossPlanDF_DPCtable$DPC)] + dronesByDPC <- createCastePop_parallel(selectedDPC, caste = "drones", + nInd = as.integer(crossPlanDF_DPCtable$noDrones), simParamBee = simParamBee) + dronesByDPC_DF <- data.frame(DPC = rep(names(dronesByDPC), as.vector(crossPlanDF_DPCtable$noDrones)), + droneID = unlist(sapply(dronesByDPC, FUN = function(x) getId(x)))) %>% + arrange(as.numeric(DPC)) + dronePop = mergePops(dronesByDPC) + + if (any(!crossPlanDF_sample$DPC == dronesByDPC_DF$DPC)) { + stop("Something went wrong with cross plan - drone matching!") + } + + dronesByVirgin_DF <- cbind(dronesByDPC_DF, crossPlanDF_sample[, c("virginID"), drop = F]) %>% + arrange(virginID) + dronesByVirgin_list <- lapply(IDs, FUN = function(x) dronesByVirgin_DF$droneID[dronesByVirgin_DF$virginID == x]) + names(dronesByVirgin_list) <- IDs + + dronesByVirgin <- foreach(virgin = IDs, .combine = combine_list) %dopar% { + dronePop[as.character(dronesByVirgin_list[[virgin]])] + } + } else if (crossPlan_droneID) { + dronesByVirgin <- foreach(virgin = IDs, .combine = combine_list) %dopar% { + drones[as.character(crossPlan[[virgin]])] + } + } + } + + # At this point, x is a Pop and dronesByVirgin are a list (so are they if they come if via drone packages) + if (oneColony) { + dronesByVirgin <- list(drones) + } + if (dronePackages) { + dronesByVirgin <- drones + } + + names(dronesByVirgin) <- IDs + nDronesByVirgin <- sapply(dronesByVirgin, FUN = function(x) nInd(x)) + + + #if (all(nDronesByVirgin > 0)) { #There was a mistake here - if the message is warning, this still needs to happen + if (!all(sapply(dronesByVirgin, + FUN = function(x) all(isDrone(x, simParamBee = simParamBee))))) { + stop("Individuals in drones must be drones!") + } + + if (nInd(x) != length(dronesByVirgin)) { + stop("Number of virgin queens does not match the length of the assigned drones!") + } + + for (id in IDs) { + simParamBee$changeCaste(id = id, caste = "queen") + } + + for (id in as.vector(Reduce("c", sapply(dronesByVirgin, FUN = function(x) getId(x))))) { + simParamBee$changeCaste(id = id, caste = "fathers") + } + + # All of the input has been transformed to a Pop + crossVirginQueen <- function(virginQueen, virginQueenDrones, simParamBee = NULL) { + virginQueen@misc$fathers[[1]] <- virginQueenDrones + virginQueen <- setMisc(x = virginQueen, node = "nWorkers", value = 0) + virginQueen <- setMisc(x = virginQueen, node = "nDrones", value = 0) + + virginQueen <- setMisc(x = virginQueen, node = "nHomBrood", value = 0) + # if (isCsdActive(simParamBee = simParamBee)) { #This does still not work it the CSD is turned on + # val <- calcQueensPHomBrood(x = virginQueen, simParamBee = simParamBee) + # } else { + # val <- NA + # } + # + # virginQueen <- setMisc(x = virginQueen, node = "pHomBrood", value = val) + return(virginQueen) + } + + # Add drones in the queens father slot + x <- foreach(ID = 1:length(IDs), .combine = combine_list) %dopar% { + crossVirginQueen(virginQueen = x[ID], virginQueenDrones = dronesByVirgin[[ID]], simParamBee = SP) + } + + + if (type == "Pop") { + ret <- mergePops(x) + } else if (type == "Colony") { + ret <- reQueen(x = colony, queen = x[1], simParamBee = simParamBee) + ret <- removeVirginQueens(ret, simParamBee = simParamBee) + } else if (type == "MultiColony") { + ret <- reQueen_parallel(x = multicolony, queen = mergePops(x), simParamBee = simParamBee) + ret <- removeCastePop_parallel(ret, caste = "virginQueens", simParamBee = simParamBee) + } + + validObject(ret) + return(ret) +} + #' @rdname setQueensYearOfBirth #' @title Set the queen's year of birth #' diff --git a/R/Functions_L2_Colony.R b/R/Functions_L2_Colony.R index 390e76f5..0cce1016 100644 --- a/R/Functions_L2_Colony.R +++ b/R/Functions_L2_Colony.R @@ -31,15 +31,19 @@ #' colony1 <- cross(colony1, drones = drones) #' colony1 #' @export -createColony <- function(x = NULL, simParamBee = NULL) { +createColony <- function(x = NULL, simParamBee = NULL, id = NULL) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } simParamBee$updateLastColonyId() + if (is.null(id)) { + id <- simParamBee$lastColonyId + } + if (is.null(x)) { colony <- new( Class = "Colony", - id = simParamBee$lastColonyId + id = id ) } else { if (!isPop(x)) { @@ -60,7 +64,7 @@ createColony <- function(x = NULL, simParamBee = NULL) { colony <- new( Class = "Colony", - id = simParamBee$lastColonyId, + id = id, queen = queen, location = c(0, 0), virginQueens = virginQueens @@ -71,6 +75,9 @@ createColony <- function(x = NULL, simParamBee = NULL) { return(colony) } + + + #' @rdname reQueen #' @title Re-queen #' @@ -180,6 +187,80 @@ reQueen <- function(x, queen, removeVirginQueens = TRUE, simParamBee = NULL) { return(x) } +#' @export +reQueen_parallel <- function(x, queen, removeVirginQueens = TRUE, simParamBee = NULL, nThreads = NULL) { + if (is.null(simParamBee)) { + simParamBee <- get(x = "SP", envir = .GlobalEnv) + } + if (is.null(nThreads)) { + nThreads = simParamBee$nThreads + } + if (!isPop(queen)) { + stop("Argument queen must be a Pop class object!") + } + if (!all(isVirginQueen(queen, simParamBee = simParamBee) | isQueen(queen, simParamBee = simParamBee))) { + stop("Individual in queen must be a virgin queen or a queen!") + } + if (isColony(x)) { + if (all(isQueen(queen, simParamBee = simParamBee))) { + if (nInd(queen) > 1) { + stop("You must provide just one queen for the colony!") + } + x@queen <- queen + if (removeVirginQueens) { + x <- removeVirginQueens(x, simParamBee = simParamBee) + } + } else { + x <- removeQueen(x, addVirginQueens = FALSE, simParamBee = simParamBee) + x@virginQueens <- queen + } + } else if (isMultiColony(x)) { + registerDoParallel(cores = nThreads) + nCol <- nColonies(x) + if (nInd(queen) < nCol) { + stop("Not enough queens provided!") + } + x@colonies = foreach(colony = seq_len(nCol)) %dopar% { + reQueen( + x = x[[colony]], + queen = queen[colony], + simParamBee = simParamBee + ) + } + } else { + stop("Argument x must be a Colony or MultiColony class object!") + } + validObject(x) + return(x) +} + +#' @rdname addCastePop_internal +#' @title An internal function to add a population in a caste slot of the colony +#' +#' @description Helper function that returns a colony to allow parallelisation, +#' only for internal use. +#' +#' @param colony \code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}} +#' @param pop \code{\link[AlphaSimR]{Pop-class}} with one or many individual +#' @param caste character +#' @param new logical +#' +#' @return \code{\link[SIMplyBee]{Colony-class}} +#' @export +addCastePop_internal <- function(pop, colony, caste, new = FALSE) { + if (!is.null(pop)) { + if (caste == "queen" & nInd(pop) > 1) { + stop("Cannot add more than one queen!") + } + } + if (is.null(slot(colony, caste)) | new) { + slot(colony, caste) <- pop + } else { + slot(colony, caste) <- c(slot(colony, caste), pop) + } + return(colony) +} + #' @rdname addCastePop #' @title Add caste individuals to the colony #' @@ -284,7 +365,7 @@ addCastePop <- function(x, caste = NULL, nInd = NULL, new = FALSE, } if (length(nInd) > 1) { warning("More than one value in the nInd argument, taking only the first value!") - p <- p[1] + nInd <- nInd[1] } if (is.function(nInd)) { nInd <- nInd(x, ...) @@ -345,23 +426,144 @@ addCastePop <- function(x, caste = NULL, nInd = NULL, new = FALSE, return(x) } +#' @export +addCastePop_parallel <- function(x, caste = NULL, nInd = NULL, new = FALSE, + year = NULL, simParamBee = NULL, + nThreads = NULL, ...) { + if (is.null(simParamBee)) { + simParamBee <- get(x = "SP", envir = .GlobalEnv) + } + if (is.null(nThreads)) { + nThreads = simParamBee$nThreads + } + if (length(caste) != 1) { + stop("Argument caste must be of length 1!") + } + if (is.null(nInd)) { + if (caste == "workers") { + nInd <- simParamBee$nWorkers + } else if (caste == "drones") { + nInd <- simParamBee$nDrones + } else if (caste == "virginQueens") { + nInd <- simParamBee$nVirginQueens + } + } + # doing "if (is.function(nInd))" below + if (isColony(x)) { + if (hasCollapsed(x)) { + stop(paste0("The colony ", getId(x), " collapsed, hence you can not add individuals (from the queen) to it!")) + } + if (length(nInd) > 1) { + warning("More than one value in the nInd argument, taking only the first value!") + nInd <- nInd[1] + } + if (0 < nInd) { + newInds <- createCastePop_parallel(x, nInd, + caste = caste, + year = year, simParamBee = simParamBee, + nThreads = nThreads + ) + if (caste == "workers") { + homInds <- newInds$nHomBrood + newInds <- newInds$workers + x@queen@misc$nWorkers[[1]] <- x@queen@misc$nWorkers[[1]] + nInd(newInds) + #x@queen@misc$nHomBrood[[1]] <- x@queen@misc$nHomBrood[[1]] + homInds + } + if (caste == "drones") { + x@queen@misc$nDrones[[1]] <- x@queen@misc$nDrones[[1]] + nInd(newInds) + } + if (is.null(slot(x, caste)) | new) { + slot(x, caste) <- newInds + } else { + slot(x, caste) <- c(slot(x, caste), newInds) + } + } else { + warning("The number of individuals to add is less than 0, hence adding nothing.") + } + } else if (isMultiColony(x)) { + nCol = nColonies(x) + + if (any(hasCollapsed(x))) { + stop(paste0("The colony ", getId(x), " collapsed, hence you can not add individuals (from the queen) to it!")) + } + + newInds <- createCastePop_parallel(x, nInd, + caste = caste, + year = year, simParamBee = simParamBee, + nThreads = nThreads, returnSP = FALSE, ...) + + + if (caste == "workers") { + homInds = lapply(newInds, function(x) { + if (is.null(x)) return(NULL) + x[['nHomBrood']] + }) + newInds = lapply(newInds, function(x) { + if (is.null(x)) return(NULL) + x[["workers"]] + }) + } + nInds = lapply(newInds, function(x) { + if (is.null(x)) return(NULL) + nInd(x) + }) + + x@colonies <- foreach(colony = seq_len(nCol)) %dopar% { + if (!is.null(nInds[[colony]])) { + if (caste == "workers") { + x[[colony]]@queen@misc$nWorkers[[1]] <- x[[colony]]@queen@misc$nWorkers[[1]] + nInds[[colony]] + x[[colony]]@queen@misc$nHomBrood[[1]] <- x[[colony]]@queen@misc$nHomBrood[[1]] + ifelse(is.null(homInds[[colony]]), 0, homInds[[colony]]) + } else if (caste == "drones") { + x[[colony]]@queen@misc$nDrones[[1]] <- x[[colony]]@queen@misc$nDrones[[1]] + nInds[[colony]] + } + addCastePop_internal(colony = x[[colony]], pop = newInds[[colony]], caste = caste, new = new) + } else { + x[[colony]] + } + } + } else { + stop("Argument x must be a Colony or MultiColony class object!") + } + validObject(x) + return(x) +} + #' @describeIn addCastePop Add workers to a colony #' @export -addWorkers <- function(x, nInd = NULL, new = FALSE, - exact = FALSE, simParamBee = NULL, ...) { +addWorkers<- function(x, nInd = NULL, new = FALSE, + simParamBee = NULL, ...) { ret <- addCastePop( x = x, caste = "workers", nInd = nInd, new = new, - exact = exact, simParamBee = simParamBee, ... + simParamBee = simParamBee, ... + ) + return(ret) +} +addWorkers_parallel <- function(x, nInd = NULL, new = FALSE, + simParamBee = NULL, nThreads = NULL, ...) { + ret <- addCastePop_parallel( + x = x, caste = "workers", nInd = nInd, new = new, + simParamBee = simParamBee, nThreads = nThreads, ... ) return(ret) } #' @describeIn addCastePop Add drones to a colony #' @export -addDrones <- function(x, nInd = NULL, new = FALSE, simParamBee = NULL, ...) { +addDrones <- function(x, nInd = NULL, new = FALSE, + simParamBee = NULL, ...) { ret <- addCastePop( x = x, caste = "drones", nInd = nInd, new = new, - simParamBee = simParamBee, ... + simParamBee = simParamBee, ... + ) + return(ret) +} + +addDrones_parallel <- function(x, nInd = NULL, new = FALSE, + simParamBee = NULL, nThreads = NULL, ...) { + ret <- addCastePop_parallel( + x = x, caste = "drones", nInd = nInd, new = new, + simParamBee = simParamBee, + nThreads = nThreads, ... ) return(ret) } @@ -372,7 +574,17 @@ addVirginQueens <- function(x, nInd = NULL, new = FALSE, year = NULL, simParamBee = NULL, ...) { ret <- addCastePop( x = x, caste = "virginQueens", nInd = nInd, new = new, - year = year, simParamBee = simParamBee, ... + year = year, simParamBee = simParamBee, nThreads = nThreads, ... + ) + return(ret) +} + + +addVirginQueens_parallel <- function(x, nInd = NULL, new = FALSE, + year = NULL, simParamBee = NULL, nThreads = NULL, ...) { + ret <- addCastePop_parallel( + x = x, caste = "virginQueens", nInd = nInd, new = new, + year = year, simParamBee = simParamBee, nThreads = nThreads, ... ) return(ret) } @@ -589,110 +801,341 @@ buildUp <- function(x, nWorkers = NULL, nDrones = NULL, return(x) } - -#' @rdname downsize -#' @title Reduce number of workers and remove all drones and virgin queens from -#' a Colony or MultiColony object -#' -#' @description Level 2 function that downsizes a Colony or MultiColony object -#' by removing a proportion of workers, all drones and all virgin queens. -#' Usually in the autumn, such an event occurs in preparation for the winter months. -#' -#' @param x \code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}} -#' @param p numeric, proportion of workers to be removed from the colony; if -#' \code{NULL} then \code{\link[SIMplyBee]{SimParamBee}$downsizeP} is used. -#' If input is \code{\link[SIMplyBee]{MultiColony-class}}, -#' the input could also be a vector of the same length as the number of colonies. If -#' a single value is provided, the same value will be applied to all the colonies -#' @param use character, all the options provided by \code{\link[AlphaSimR]{selectInd}}; -#' it guides the selection of workers that will be removed -#' @param new logical, should we remove all current workers and add a targeted -#' proportion anew (say, create winter workers) -#' @param simParamBee \code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters -#' @param ... additional arguments passed to \code{p} when this argument is a -#' function -#' -#' @return \code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}} with workers reduced and -#' drones/virgin queens removed -#' -#' @examples -#' founderGenomes <- quickHaplo(nInd = 4, nChr = 1, segSites = 50) -#' SP <- SimParamBee$new(founderGenomes) -#' \dontshow{SP$nThreads = 1L} -#' basePop <- createVirginQueens(founderGenomes) -#' drones <- createDrones(x = basePop[1], nInd = 100) -#' droneGroups <- pullDroneGroupsFromDCA(drones, n = 3, nDrones = 12) -#' -#' # Create and cross Colony and MultiColony class -#' colony <- createColony(x = basePop[2]) -#' colony <- cross(colony, drones = droneGroups[[1]]) -#' colony <- buildUp(colony) -#' apiary <- createMultiColony(basePop[3:4], n = 2) -#' apiary <- cross(apiary, drones = droneGroups[c(2, 3)]) -#' apiary <- buildUp(apiary) -#' -#' # Downsize -#' colony <- downsize(x = colony, new = TRUE, use = "rand") -#' colony -#' apiary <- downsize(x = apiary, new = TRUE, use = "rand") -#' apiary[[1]] -#' -#' # Downsize with different numbers -#' nWorkers(apiary); nDrones(apiary) -#' apiary <- downsize(x = apiary, p = c(0.5, 0.1), new = TRUE, use = "rand") -#' nWorkers(apiary); nDrones(apiary) #' @export -downsize <- function(x, p = NULL, use = "rand", new = FALSE, - simParamBee = NULL, ...) { +buildUp_parallel <- function(x, nWorkers = NULL, nDrones = NULL, + new = TRUE, resetEvents = FALSE, + simParamBee = NULL, nThreads = NULL, ...) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } - if (!is.logical(new)) { - stop("Argument new must be logical!") + if (is.null(nThreads)) { + nThreads = simParamBee$nThreads } - if (any(1 < p)) { - stop("p must not be higher than 1!") - } else if (any(p < 0)) { - stop("p must not be less than 0!") + # Workers + if (is.null(nWorkers)) { + nWorkers <- simParamBee$nWorkers + } + + if (is.null(nDrones)) { + nDrones <- simParamBee$nDrones + } + if (is.function(nDrones)) { + nDrones <- nDrones(x = x, ...) } + if (isColony(x)) { - if (hasCollapsed(x)) { - stop(paste0("The colony ", getId(x), " collapsed, hence you can not downsize it!")) - } - if (is.null(p)) { - p <- simParamBee$downsizeP + if (is.function(nWorkers)) { + nWorkers <- nWorkers(colony = x,...) } - if (is.function(p)) { - p <- p(x, ...) + if (hasCollapsed(x)) { + stop(paste0("The colony ", getId(x), " collapsed, hence you can not build it up!")) } - if (length(p) > 1) { - warning("More than one value in the p argument, taking only the first value!") - p <- p[1] + if (length(nWorkers) > 1) { + warning("More than one value in the nWorkers argument, taking only the first value!") + nWorkers <- nWorkers[1] } - if (new == TRUE) { - n <- round(nWorkers(x, simParamBee = simParamBee) * (1 - p)) - x <- addWorkers(x = x, nInd = n, new = TRUE, simParamBee = simParamBee) + if (new) { + n <- nWorkers } else { - x <- removeWorkers(x = x, p = p, use = use, simParamBee = simParamBee) + n <- nWorkers - nWorkers(x, simParamBee = simParamBee) } - x <- removeDrones(x = x, p = 1, simParamBee = simParamBee) - x <- removeVirginQueens(x = x, p = 1, simParamBee = simParamBee) - x@production <- FALSE - } else if (isMultiColony(x)) { - nCol <- nColonies(x) - nP <- length(p) - if (nP > 1 && nP < nCol) { - stop("Too few values in the p argument!") + + if (0 < n) { + x <- addWorkers_parallel( + x = x, nInd = n, new = new, + exact = exact, simParamBee = simParamBee, + nThreads = nThreads) + } else if (n < 0) { + x@workers <- getWorkers(x, nInd = nWorkers, simParamBee = simParamBee) } - if (nP > 1 && nP > nCol) { - warning(paste0("Too many values in the p argument, taking only the first ", nCol, "values!")) - p <- p[1:nCol] + + # Drones + if (length(nDrones) > 1) { + warning("More than one value in the nDrones argument, taking only the first value!") + nDrones <- nDrones[1] } - for (colony in seq_len(nCol)) { - if (is.null(p)) { - pColony <- NULL - } else { - pColony <- ifelse(nP == 1, p, p[colony]) + if (new) { + n <- nDrones + } else { + n <- nDrones - nDrones(x, simParamBee = simParamBee) + } + + if (0 < n) { + x <- addDrones_parallel( + x = x, nInd = n, new = new, + simParamBee = simParamBee, + nThreads = nThreads + ) + } else if (n < 0) { + x@drones <- getDrones(x, nInd = nDrones, simParamBee = simParamBee) + } + + # Events + if (resetEvents) { + x <- resetEvents(x) + } + x@production <- TRUE + } else if (isMultiColony(x)) { + registerDoParallel(cores = nThreads) + + if (any(hasCollapsed(x))) { + stop(paste0("Some colonies are collapsed, hence you can not build it up!")) + } + nCol <- nColonies(x) + nNWorkers <- length(nWorkers) + nNDrones <- length(nDrones) + if (nNWorkers > 1 && nNWorkers < nCol) { + stop("Too few values in the nWorkers argument!") + } + if (nNDrones > 1 && nNDrones < nCol) { + stop("Too few values in the nDrones argument!") + } + if (nNWorkers > 1 && nNWorkers > nCol) { + warning(paste0("Too many values in the nWorkers argument, taking only the first ", nCol, "values!")) + nWorkers <- nWorkers[1:nCol] + } + if (nNDrones > 1 && nNDrones > nCol) { + warning(paste0("Too many values in the nDrones argument, taking only the first ", nCol, "values!")) + nNDrones <- nNDrones[1:nCol] + } + + if (is.function(nWorkers)) { + nWorkers <- nWorkers(colony = x,...) + } + + if (new) { + n <- nWorkers + } else { + n <- nWorkers - nWorkers(x, simParamBee = simParamBee) + } + + if (sum(nWorkers) > 0) { + x = addWorkers_parallel( + x = x, nInd = n, new = new, + simParamBee = simParamBee, nThreads = nThreads) + # } else if (nWorkersColony < 0) { + # #THIS IS A PROBLEM _ THE FUNCTION NEEDSD TO RETURN COLONY getWorkers(x, nInd = nWorkers, simParamBee = simParamBee) + # } + # } THIS NEEDS TO GO INTO ADDCASTEPOP + } + if (sum(nDrones) > 0) { + x = addDrones_parallel( + x = x, nInd = n, new = new, + simParamBee = simParamBee, nThreads = nThreads) + # } else if (nDronesColony < 0) { + # #THIS IS A PROBLEM _ THE FUNCTION NEEDSD TO RETURN COLONY getWorkers(x, nInd = nWorkers, simParamBee = simParamBee) + # + } + x <- setEvents_parallel(x, slot = "production", value = TRUE) + if (resetEvents) { + x <- resetEvents_parallel(x) + } + + } else { + stop("Argument x must be a Colony or MultiColony class object!") + } + + validObject(x) + return(x) +} + +#' @export +buildUp_parallel_simplified <- function(x, nWorkers = NULL, nDrones = NULL, + new = TRUE, resetEvents = FALSE, + simParamBee = NULL, nThreads = NULL, ...) { + if (is.null(simParamBee)) { + simParamBee <- get(x = "SP", envir = .GlobalEnv) + } + if (is.null(nThreads)) { + nThreads = simParamBee$nThreads + } + # Workers + if (is.null(nWorkers)) { + nWorkers <- simParamBee$nWorkers + } + + if (is.null(nDrones)) { + nDrones <- simParamBee$nDrones + } + if (is.function(nDrones)) { + nDrones <- nDrones(x = x, ...) + } + + if (isColony(x) | isMultiColony(x)) { + registerDoParallel(cores = nThreads) + + if (isColony(x)) { + nCol = 1 + } else if (isMultiColony(x)) { + nCol = nColonies(x) + } + if (is.function(nWorkers)) { + nWorkers <- nWorkers(colony = x, n = nCol, ...) + } + nNWorkers = length(nWorkers) + if (nNWorkers > nCol) { + warning("More than one value in the nWorkers argument, taking only the first value!") + nWorkers <- nWorkers[1:nCol] + } + if (nNWorkers > 1 && nNWorkers < nCol) { + stop("Too few values in the nWorkers argument!") + } + if (new) { + nWorkers <- nWorkers + } else { + nWorkers <- nWorkers - nWorkers(x, simParamBee = simParamBee) + } + + # Drones + nNDrones = length(nDrones) + if (nNDrones > nCol) { + warning("More than one value in the nDrones argument, taking only the first value!") + nDrones <- nDrones[1:nCol] + } + if (nNDrones > 1 && nNDrones < nCol) { + stop("Too few values in the nDrones argument!") + } + if (new) { + nDrones <- nDrones + } else { + nDrones <- nDrones - nDrones(x, simParamBee = simParamBee) + } + + if (sum(nWorkers) > 0) { + x = addWorkers_parallel( + x = x, nInd = nWorkers, new = new, + simParamBee = simParamBee, nThreads = nThreads) + # } else if (nWorkersColony < 0) { + # #THIS IS A PROBLEM _ THE FUNCTION NEEDSD TO RETURN COLONY getWorkers(x, nInd = nWorkers, simParamBee = simParamBee) + # } + # } THIS NEEDS TO GO INTO ADDCASTEPOP + } + if (sum(nDrones) > 0) { + x = addDrones_parallel( + x = x, nInd = nDrones, new = new, + simParamBee = simParamBee, nThreads = nThreads) + # } else if (nDronesColony < 0) { + # #THIS IS A PROBLEM _ THE FUNCTION NEEDSD TO RETURN COLONY getWorkers(x, nInd = nWorkers, simParamBee = simParamBee) + # + } + + # Events + if (resetEvents) { + x <- resetEvents(x) + } + #x@production <- TRUE + } else { + stop("Argument x must be a Colony or MultiColony class object!") + } + validObject(x) + return(x) +} + + +#' @rdname downsize +#' @title Reduce number of workers and remove all drones and virgin queens from +#' a Colony or MultiColony object +#' +#' @description Level 2 function that downsizes a Colony or MultiColony object +#' by removing a proportion of workers, all drones and all virgin queens. +#' Usually in the autumn, such an event occurs in preparation for the winter months. +#' +#' @param x \code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}} +#' @param p numeric, proportion of workers to be removed from the colony; if +#' \code{NULL} then \code{\link[SIMplyBee]{SimParamBee}$downsizeP} is used. +#' If input is \code{\link[SIMplyBee]{MultiColony-class}}, +#' the input could also be a vector of the same length as the number of colonies. If +#' a single value is provided, the same value will be applied to all the colonies +#' @param use character, all the options provided by \code{\link[AlphaSimR]{selectInd}}; +#' it guides the selection of workers that will be removed +#' @param new logical, should we remove all current workers and add a targeted +#' proportion anew (say, create winter workers) +#' @param simParamBee \code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters +#' @param ... additional arguments passed to \code{p} when this argument is a +#' function +#' +#' @return \code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}} with workers reduced and +#' drones/virgin queens removed +#' +#' @examples +#' founderGenomes <- quickHaplo(nInd = 4, nChr = 1, segSites = 50) +#' SP <- SimParamBee$new(founderGenomes) +#' \dontshow{SP$nThreads = 1L} +#' basePop <- createVirginQueens(founderGenomes) +#' drones <- createDrones(x = basePop[1], nInd = 100) +#' droneGroups <- pullDroneGroupsFromDCA(drones, n = 3, nDrones = 12) +#' +#' # Create and cross Colony and MultiColony class +#' colony <- createColony(x = basePop[2]) +#' colony <- cross(colony, drones = droneGroups[[1]]) +#' colony <- buildUp(colony) +#' apiary <- createMultiColony(basePop[3:4], n = 2) +#' apiary <- cross(apiary, drones = droneGroups[c(2, 3)]) +#' apiary <- buildUp(apiary) +#' +#' # Downsize +#' colony <- downsize(x = colony, new = TRUE, use = "rand") +#' colony +#' apiary <- downsize(x = apiary, new = TRUE, use = "rand") +#' apiary[[1]] +#' +#' # Downsize with different numbers +#' nWorkers(apiary); nDrones(apiary) +#' apiary <- downsize(x = apiary, p = c(0.5, 0.1), new = TRUE, use = "rand") +#' nWorkers(apiary); nDrones(apiary) +#' @export +#' +downsize <- function(x, p = NULL, use = "rand", new = FALSE, + simParamBee = NULL, nThreads = NULL, ...) { + if (is.null(simParamBee)) { + simParamBee <- get(x = "SP", envir = .GlobalEnv) + } + if (!is.logical(new)) { + stop("Argument new must be logical!") + } + if (any(1 < p)) { + stop("p must not be higher than 1!") + } else if (any(p < 0)) { + stop("p must not be less than 0!") + } + if (isColony(x)) { + if (hasCollapsed(x)) { + stop(paste0("The colony ", getId(x), " collapsed, hence you can not downsize it!")) + } + if (is.null(p)) { + p <- simParamBee$downsizeP + } + if (is.function(p)) { + p <- p(x, ...) + } + if (length(p) > 1) { + warning("More than one value in the p argument, taking only the first value!") + p <- p[1] + } + if (new == TRUE) { + n <- round(nWorkers(x, simParamBee = simParamBee) * (1 - p)) + x <- addWorkers(x = x, nInd = n, new = TRUE, simParamBee = simParamBee) + } else { + x <- removeWorkers(x = x, p = p, use = use, simParamBee = simParamBee) + } + x <- removeDrones(x = x, p = 1, simParamBee = simParamBee) + x <- removeVirginQueens(x = x, p = 1, simParamBee = simParamBee) + x@production <- FALSE + } else if (isMultiColony(x)) { + nCol <- nColonies(x) + nP <- length(p) + if (nP > 1 && nP < nCol) { + stop("Too few values in the p argument!") + } + if (nP > 1 && nP > nCol) { + warning(paste0("Too many values in the p argument, taking only the first ", nCol, "values!")) + p <- p[1:nCol] + } + for (colony in seq_len(nCol)) { + if (is.null(p)) { + pColony <- NULL + } else { + pColony <- ifelse(nP == 1, p, p[colony]) } x[[colony]] <- downsize( x = x[[colony]], @@ -710,6 +1153,92 @@ downsize <- function(x, p = NULL, use = "rand", new = FALSE, return(x) } +#' @export +downsize_parallel <- function(x, p = NULL, use = "rand", new = FALSE, + simParamBee = NULL, nThreads = NULL, ...) { + if (is.null(simParamBee)) { + simParamBee <- get(x = "SP", envir = .GlobalEnv) + } + if (!is.logical(new)) { + stop("Argument new must be logical!") + } + if (is.null(nThreads)) { + nThreads = simParamBee$nThreads + } + if (any(1 < p)) { + stop("p must not be higher than 1!") + } else if (any(p < 0)) { + stop("p must not be less than 0!") + } + if (isColony(x)) { + if (hasCollapsed(x)) { + stop(paste0("The colony ", getId(x), " collapsed, hence you can not downsize it!")) + } + if (is.null(p)) { + p <- simParamBee$downsizeP + } + if (is.function(p)) { + p <- p(x, ...) + } + if (length(p) > 1) { + warning("More than one value in the p argument, taking only the first value!") + p <- p[1] + } + if (new == TRUE) { + n <- round(nWorkers(x, simParamBee = simParamBee) * (1 - p)) + x <- addWorkers(x = x, nInd = n, new = TRUE, simParamBee = simParamBee) + } else { + x <- removeWorkers(x = x, p = p, use = use, simParamBee = simParamBee) + } + x <- removeDrones(x = x, p = 1, simParamBee = simParamBee) + x <- removeVirginQueens(x = x, p = 1, simParamBee = simParamBee) + x@production <- FALSE + } else if (isMultiColony(x)) { + registerDoParallel(cores = nThreads) + nCol <- nColonies(x) + nP <- length(p) + + if (any(hasCollapsed(x))) { + stop("Some of hte colonies have collapsed, hence you can not downsize them!") + } + if (is.null(p)) { + p <- simParamBee$downsizeP + } + if (is.function(p)) { + p <- p(x, ...) + } + if (nP > 1 && nP < nCol) { + stop("Too few values in the p argument!") + } + if (nP > 1 && nP > nCol) { + warning(paste0("Too many values in the p argument, taking only the first ", nCol, "values!")) + p <- p[1:nCol] + } + if (new == TRUE) { + n <- round(nWorkers(x, simParamBee = simParamBee) * (1 - p)) + x <- addWorkers_parallel(x = x, nInd = n, new = TRUE, + simParamBee = simParamBee, + nThreads = nThreads) + } else { + x <- removeWorkers_parallel(x = x, p = p, use = use, + simParamBee = simParamBee, nThreads = nThreads) + } + x <- removeDrones_parallel(x = x, p = 1, simParamBee = simParamBee, nThreads = nThreads) + x <- removeVirginQueens_parallel(x = x, p = 1, simParamBee = simParamBee, nThreads = nThreads) + for (colony in 1:nCol) { + x[[colony]]@production <- FALSE + } + + } else { + stop("Argument x must be a Colony or MultiColony class object!") + } + + validObject(x) + return(x) +} + + + #' @rdname replaceCastePop #' @title Replace a proportion of caste individuals with new ones #' @@ -854,6 +1383,69 @@ replaceCastePop <- function(x, caste = NULL, p = 1, use = "rand", exact = TRUE, return(x) } + +#' @export +replaceCastePop_parallel <- function(x, caste = NULL, p = 1, use = "rand", exact = TRUE, + year = NULL, simParamBee = NULL) { + if (is.null(simParamBee)) { + simParamBee <- get(x = "SP", envir = .GlobalEnv) + } + if (length(caste) != 1) { + stop("Argument caste must be of length 1!") + } + if (any(1 < p)) { + stop("p must not be higher than 1!") + } else if (any(p < 0)) { + stop("p must not be less than 0!") + } + if (isColony(x) | isMultiColony(x)) { + nP = length(p) + if (isColony(x)) { + nCol = 1 + } else if (isMultiColony(x)) { + nCol = nColonies(x) + } + if (any(hasCollapsed(x))) { + stop(paste0("The colony or some of the colonies have collapsed, hence you can not replace individuals in it!")) + } + if (any(!isQueenPresent(x, simParamBee = simParamBee))) { + stop("Missing queen in at least one colony!") + } + if (nP > 1 && nP < nCol) { + stop("Too few values in the p argument!") + } + if (length(p) > nCol) { + warning(paste0("More than one value in the p argument, taking only the first ", nCol, " values!")) + p <- p[nCol] + } + nInd <- nCaste(x, caste, simParamBee = simParamBee) + if (any(nInd > 0)) { + nIndReplaced <- round(nInd * p) + if (any(nIndReplaced < nInd)) { + + x <- removeCastePop_parallel(x, + caste = caste, + p = p) + nIndAdd <- nInd - nCaste(x, caste, simParamBee = simParamBee) + x <- addCastePop_parallel(x, + caste = caste, + nInd = nIndAdd, + year = year, simParamBee = simParamBee + ) + } + } else { + x <- addCastePop_parallel( + x = x, caste = caste, nInd = nIndReplaced, new = TRUE, + year = year, simParamBee = simParamBee + ) + } + } else { + stop("Argument x must be a Colony or MultiColony class object!") + } + validObject(x) + return(x) +} + #' @describeIn replaceCastePop Replaces some workers in a colony #' @export replaceWorkers <- function(x, p = 1, use = "rand", exact = TRUE, simParamBee = NULL) { @@ -1017,32 +1609,121 @@ removeCastePop <- function(x, caste = NULL, p = 1, use = "rand", return(x) } +#' @export +removeCastePop_parallel <- function(x, caste = NULL, p = 1, use = "rand", + year = NULL, simParamBee = NULL, nThreads = NULL) { + if (is.null(simParamBee)) { + simParamBee <- get(x = "SP", envir = .GlobalEnv) + } + if (is.null(nThreads)) { + nThreads = simParamBee$nThreads + } + if (length(caste) != 1) { + stop("Argument caste must be of length 1!") + } + if (any(1 < p)) { + stop("p must not be higher than 1!") + } else if (any(p < 0)) { + stop("p must not be less than 0!") + } + if (isColony(x)) { + if (hasCollapsed(x)) { + stop(paste0("The colony ", getId(x), " collapsed, hence can not remove individuals from it!")) + } + if (length(p) > 1) { + warning("More than one value in the p argument, taking only the first value!") + p <- p[1] + } + if (p == 1) { + slot(x, caste) <- NULL + } else { + nIndStay <- round(nCaste(x, caste, simParamBee = simParamBee) * (1 - p)) + if (nIndStay > 0) { + slot(x, caste) <- selectInd( + pop = slot(x, caste), + nInd = nIndStay, + use = use, + simParam = simParamBee + ) + } else { + x <- removeCastePop(x, caste, simParamBee = simParamBee) + } + } + } else if (isMultiColony(x)) { + registerDoParallel(cores = nThreads) + nCol <- nColonies(x) + nP <- length(p) + if (nP > 1 && nP < nCol) { + stop("Too few values in the p argument!") + } + if (nP > 1 && nP > nCol) { + warning(paste0("Too many values in the p argument, taking only the first ", nCol, "values!")) + p <- p[1:nCol] + } + x@colonies <- foreach(colony = seq_len(nCol)) %dopar% { + if (is.null(p)) { + pColony <- NULL + } else { + pColony <- ifelse(nP == 1, p, p[colony]) + } + removeCastePop( + x = x[[colony]], caste = caste, + p = pColony, + use = use, + simParamBee = simParamBee + ) + } + } else { + stop("Argument x must be a Colony or MultiColony class object!") + } + validObject(x) + return(x) +} + #' @describeIn removeCastePop Remove queen from a colony #' @export -removeQueen <- function(x, addVirginQueens = FALSE, nVirginQueens = NULL, year = NULL, simParamBee = NULL) { +#' +removeQueen <- function(x, addVirginQueens = FALSE, nVirginQueens = NULL, year = NULL, simParamBee = NULL, nThreads = NULL) { ret <- removeCastePop(x = x, caste = "queen", p = 1, addVirginQueens = addVirginQueens, nVirginQueens = nVirginQueens, year = year, simParamBee = simParamBee) return(ret) } +removeQueen_parallel <- function(x, year = NULL, simParamBee = NULL, nThreads = NULL) { + ret <- removeCastePop_parallel(x = x, caste = "queen", p = 1, year = year, simParamBee = simParamBee, nThreads = nThreads) + return(ret) +} + #' @describeIn removeCastePop Remove workers from a colony #' @export -removeWorkers <- function(x, p = 1, use = "rand", simParamBee = NULL) { - ret <- removeCastePop(x = x, caste = "workers", p = p, use = use, simParamBee = simParamBee) +removeWorkers <- function(x, p = 1, use = "rand", simParamBee = NULL, nThreads = NULL) { + ret <- removeCastePop_parallel(x = x, caste = "workers", p = p, use = use, simParamBee = simParamBee, nThreads = nThreads) + return(ret) +} +removeWorkers_parallel <- function(x, p = 1, use = "rand", simParamBee = NULL, nThreads = NULL) { + ret <- removeCastePop_parallel(x = x, caste = "workers", p = p, use = use, simParamBee = simParamBee, nThreads = nThreads) return(ret) } #' @describeIn removeCastePop Remove workers from a colony #' @export -removeDrones <- function(x, p = 1, use = "rand", simParamBee = NULL) { - ret <- removeCastePop(x = x, caste = "drones", p = p, use = use, simParamBee = simParamBee) +removeDrones <- function(x, p = 1, use = "rand", simParamBee = NULL, nThreads = NULL) { + ret <- removeCastePop_parallel(x = x, caste = "drones", p = p, use = use, simParamBee = simParamBee, nThreads = nThreads) + return(ret) +} +removeDrones_parallel <- function(x, p = 1, use = "rand", simParamBee = NULL, nThreads = NULL) { + ret <- removeCastePop_parallel(x = x, caste = "drones", p = p, use = use, simParamBee = simParamBee, nThreads = nThreads) return(ret) } #' @describeIn removeCastePop Remove virgin queens from a colony #' @export -removeVirginQueens <- function(x, p = 1, use = "rand", simParamBee = NULL) { - ret <- removeCastePop(x = x, caste = "virginQueens", p = p, use = use, simParamBee = simParamBee) +removeVirginQueens_parallel <- function(x, p = 1, use = "rand", simParamBee = NULL, nThreads = NULL) { + ret <- removeCastePop_parallel(x = x, caste = "virginQueens", p = p, use = use, simParamBee = simParamBee, nThreads = nThreads) + return(ret) +} +removeVirginQueens <- function(x, p = 1, use = "rand", simParamBee = NULL, nThreads = NULL) { + ret <- removeCastePop_parallel(x = x, caste = "virginQueens", p = p, use = use, simParamBee = simParamBee, nThreads = nThreads) return(ret) } @@ -1155,6 +1836,46 @@ resetEvents <- function(x, collapse = NULL) { return(x) } +#' @export +resetEvents_parallel <- function(x, collapse = NULL, simParamBee = NULL, nThreads = NULL) { + if (is.null(simParamBee)) { + simParamBee <- get(x = "SP", envir = .GlobalEnv) + } + if (is.null(nThreads)) { + nThreads = simParamBee$nThreads + } + if (isColony(x)) { + x@swarm <- FALSE + x@split <- FALSE + x@supersedure <- FALSE + # Reset collapse only if asked (!is.null(collapse)) or if it was not yet + # turned on (is.null(x@collapse)) + if (is.null(collapse)) { + collapse <- is.null(x@collapse) + } + if (collapse) { + x@collapse <- FALSE + } + x@production <- FALSE + validObject(x) + } else if (isMultiColony(x)) { + registerDoParallel(cores = nThreads) + nCol <- nColonies(x) + x@colonies = foreach(colony = seq_len(nCol)) %dopar% { + resetEvents( + x = x[[colony]], + collapse = collapse, + simParamBee = simParamBee, + nThreads = 1 + ) + } + validObject(x) + } else { + stop("Argument x must be a Colony or MultiColony class object!") + } + return(x) +} + #' @rdname collapse #' @title Collapse #' @@ -1216,6 +1937,32 @@ collapse <- function(x) { return(x) } +#' @export +collapse_parallel <- function(x, simParamBee = NULL, nThreads = NULL) { + if (is.null(simParamBee)) { + simParamBee <- get(x = "SP", envir = .GlobalEnv) + } + if (is.null(nThreads)) { + nThreads = simParamBee$nThreads + } + if (isColony(x)) { + x@collapse <- TRUE + x@production <- FALSE + } else if (isMultiColony(x)) { + registerDoParallel(cores = nThreads) + nCol <- nColonies(x) + x@colonies = foreach(colony = seq_len(nCol)) %dopar% { + collapse(x = x[[colony]], + simParamBee = simParamBee, + nThreads = 1) + } + } else { + stop("Argument x must be a Colony or MultiColony class object!") + } + validObject(x) + return(x) +} + #' @rdname swarm #' @title Swarm #' @@ -1234,10 +1981,6 @@ collapse <- function(x) { #' the input could also be a vector of the same length as the number of colonies. If #' a single value is provided, the same value will be applied to all the colonies #' @param year numeric, year of birth for virgin queens -#' @param nVirginQueens integer, the number of virgin queens to be created in the -#' colony; of these one is randomly selected as the new virgin queen of the -#' remnant colony. If \code{NULL}, the value from \code{simParamBee$nVirginQueens} -#' is used #' @param sampleLocation logical, sample location of the swarm by taking #' the current colony location and adding deviates to each coordinate using #' \code{\link[SIMplyBee]{rcircle}} @@ -1288,7 +2031,7 @@ collapse <- function(x) { #' # Swarm only the pulled colonies #' (swarm(tmp$pulled, p = 0.6)) #' @export -swarm <- function(x, p = NULL, year = NULL, nVirginQueens = NULL, +swarm <- function(x, p = NULL, year = NULL, sampleLocation = TRUE, radius = NULL, simParamBee = NULL, ...) { if (is.null(simParamBee)) { @@ -1334,6 +2077,7 @@ swarm <- function(x, p = NULL, year = NULL, nVirginQueens = NULL, # https://github.com/HighlanderLab/SIMplyBee/issues/160 tmp <- pullWorkers(x = x, nInd = nWorkersSwarm, simParamBee = simParamBee) currentLocation <- getLocation(x) + if (sampleLocation) { newLocation <- c(currentLocation + rcircle(radius = radius)) # c() to convert row-matrix to a numeric vector @@ -1348,11 +2092,10 @@ swarm <- function(x, p = NULL, year = NULL, nVirginQueens = NULL, swarmColony <- setLocation(x = swarmColony, location = newLocation) tmpVirginQueen <- createVirginQueens( - x = x, nInd = nVirginQueens, + x = x, nInd = 1, year = year, simParamBee = simParamBee ) - tmpVirginQueen <- selectInd(tmpVirginQueen, nInd = 1, use = "rand", simParam = simParamBee) remnantColony <- createColony(x = tmpVirginQueen, simParamBee = simParamBee) remnantColony@workers <- getWorkers(tmp$remnant, simParamBee = simParamBee) @@ -1387,37 +2130,182 @@ swarm <- function(x, p = NULL, year = NULL, nVirginQueens = NULL, remnant = createMultiColony(simParamBee = simParamBee) ) } else { - ret <- list( - swarm = createMultiColony(n = nCol, simParamBee = simParamBee), - remnant = createMultiColony(n = nCol, simParamBee = simParamBee) - ) - for (colony in seq_len(nCol)) { - if (is.null(p)) { - pColony <- NULL - } else { - pColony <- ifelse(nP == 1, p, p[colony]) - } - tmp <- swarm(x[[colony]], - p = pColony, - year = year, - nVirginQueens = nVirginQueens, - sampleLocation = sampleLocation, - radius = radius, - simParamBee = simParamBee, ... + ret <- list( + swarm = createMultiColony(n = nCol, simParamBee = simParamBee), + remnant = createMultiColony(n = nCol, simParamBee = simParamBee) + ) + for (colony in seq_len(nCol)) { + if (is.null(p)) { + pColony <- NULL + } else { + pColony <- ifelse(nP == 1, p, p[colony]) + } + tmp <- swarm(x[[colony]], + p = pColony, + year = year, + sampleLocation = sampleLocation, + radius = radius, + simParamBee = simParamBee, ... + ) + ret$swarm[[colony]] <- tmp$swarm + ret$remnant[[colony]] <- tmp$remnant + } + } + } else { + stop("Argument x must be a Colony or MultiColony class object!") + } + + validObject(ret$swarmColony) + validObject(ret$remnantColony) + return(ret) +} + +#' @export +swarm_parallel <- function(x, p = NULL, year = NULL, + sampleLocation = TRUE, radius = NULL, + simParamBee = NULL, nThreads= NULL, ...) { + if (is.null(simParamBee)) { + simParamBee <- get(x = "SP", envir = .GlobalEnv) + } + if (isMultiColony(x)) { + parallel = TRUE + } + if (is.null(nThreads)) { + nThreads = simParamBee$nThreads + } + if (is.null(p)) { + p <- simParamBee$swarmP + } + if (is.null(radius)) { + radius <- simParamBee$swarmRadius + } + if (is.null(nVirginQueens)) { + nVirginQueens <- simParamBee$nVirginQueens + } + if (isColony(x) | isMultiColony(x)) { + if (isColony(x)) { + nCol = 1 + } else if (isMultiColony(x)) { + nCol = nColonies(x) + } + nP <- length(p) + + if (any(hasCollapsed(x))) { + stop(paste0("One of the collonies is collapsed, hence you can not split it!")) + } + if (any(!isQueenPresent(x, simParamBee = simParamBee))) { + stop("No queen present in one of the colonies!") + } + if (any(!isWorkersPresent(x, simParamBee = simParamBee))) { + stop("No workers present in one of the colonies!") + } + if (is.function(p)) { + p <- p(x, ...) + } else { + if (p < 0 | 1 < p) { + stop("p must be between 0 and 1 (inclusive)!") + } + if (length(p) > nCol) { + warning("More than one value in the p argument, taking only the first value!") + p <- p[nCol] + } + if (nP > 1 && nP < nCol) { + stop("Too few values in the p argument!") + } + } + if (is.function(nVirginQueens)) { + nVirginQueens <- nVirginQueens(x, ...) + } + nWorkers <- nWorkers(x, simParamBee = simParamBee) + nWorkersSwarm <- round(nWorkers * p) + + # TODO: Add use="something" to select pWorkers that swarm + # https://github.com/HighlanderLab/SIMplyBee/issues/160 + + tmpVirginQueen <- createCastePop_parallel( + x = x, nInd = 1, + year = year, + caste = "virginQueens", + simParamBee = simParamBee, + nThreads = nThreads + ) + + tmp <- pullCastePop_parallel(x = x, caste = "workers", + nInd = nWorkersSwarm, simParamBee = simParamBee, + nThreads = nThreads) + remnantColony <- tmp$remnant + remnantColony <- removeQueen_parallel(remnantColony, nThreads = nThreads) + if (isColony(x)) { + remnantColony <- reQueen_parallel(remnantColony, + queen = tmpVirginQueen, + simParamBee = simParamBee, + nThreads = nThreads) + } else { + remnantColony <- reQueen_parallel(remnantColony, + queen = mergePops(tmpVirginQueen), + simParamBee = simParamBee, + nThreads = nThreads) + } + currentLocation <- getLocation(x) + + if (sampleLocation) { + newLocation <- lapply(1:nCol, function(x) currentLocation[[x]] + rcircle(n = nCol, radius = radius)[x,]) + # c() to convert row-matrix to a numeric vector + } else { + newLocation <- currentLocation + } + + + if (isColony(x)) { + swarmColony <- createColony(x = x@queen, simParamBee = simParamBee) + # It's not re-queening, but the function also sets the colony id + + swarmColony@workers <- tmp$pulled + swarmColony <- setLocation(x = swarmColony, location = newLocation[[1]]) + + remnantColony <- setLocation(x = remnantColony, location = currentLocation) + + remnantColony@swarm <- TRUE + swarmColony@swarm <- TRUE + + remnantColony@production <- FALSE + swarmColony@production <- FALSE + + ret <- list(swarm = swarmColony, remnant = remnantColony) + } else if (isMultiColony(x)) { + if (nCol == 0) { + ret <- list( + swarm = createMultiColony_parallel(simParamBee = simParamBee), + remnant = createMultiColony_parallel(simParamBee = simParamBee) ) - ret$swarm[[colony]] <- tmp$swarm - ret$remnant[[colony]] <- tmp$remnant + } else { + ret <- list( + swarm = createMultiColony_parallel(x = getQueen(x, collapse = T), + simParamBee = simParamBee, nThreads = nThreads), + remnant = remnantColony + ) + + ret$swarm@colonies <- foreach(colony = seq_len(nCol)) %dopar% { + addCastePop_internal(colony = ret$swarm@colonies[[colony]], + pop = tmp$pulled[[colony]], caste = "workers") + } + + ret$remnant <- setEvents_parallel(ret$remnant, slot = "swarm", value = TRUE, nThreads = nThreads) + ret$swarm <- setEvents_parallel(ret$swarm, slot = "swarm", value = TRUE, nThreads = nThreads) + ret$swarm <- setEvents_parallel(ret$swarm, slot = "production", value = FALSE, nThreads = nThreads) + ret$remnant <- setEvents_parallel(ret$remnant, slot = "production", value = FALSE, nThreads = nThreads) } } } else { stop("Argument x must be a Colony or MultiColony class object!") } - validObject(ret$swarmColony) validObject(ret$remnantColony) return(ret) } + + #' @rdname supersede #' @title Supersede #' @@ -1474,10 +2362,13 @@ swarm <- function(x, p = NULL, year = NULL, nVirginQueens = NULL, #' # Swarm only the pulled colonies #' (supersede(tmp$pulled)) #' @export -supersede <- function(x, year = NULL, nVirginQueens = NULL, simParamBee = NULL, ...) { +supersede <- function(x, year = NULL, nVirginQueens = NULL, simParamBee = NULL, nThreads = NULL, ...) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } + if (is.null(nThreads)) { + nThreads = simParamBee$nThreads + } if (is.null(nVirginQueens)) { nVirginQueens <- simParamBee$nVirginQueens } @@ -1519,6 +2410,75 @@ supersede <- function(x, year = NULL, nVirginQueens = NULL, simParamBee = NULL, return(x) } +#' @export +supersede_parallel <- function(x, addVirginQueens = TRUE, year = NULL, simParamBee = NULL, nThreads = NULL, ...) { + if (is.null(simParamBee)) { + simParamBee <- get(x = "SP", envir = .GlobalEnv) + } + if (is.null(nThreads)) { + nThreads = simParamBee$nThreads + } + if (isColony(x)) { + parallel = FALSE + } else if (isMultiColony(x)) { + parallel = TRUE + } + if (is.null(nVirginQueens)) { + nVirginQueens <- simParamBee$nVirginQueens + } + if (isColony(x)) { + if (hasCollapsed(x)) { + stop(paste0("The colony ", getId(x), " collapsed, hence it can not supresede!")) + } + if (!isQueenPresent(x, simParamBee = simParamBee)) { + stop("No queen present in the colony!") + } + if (is.function(nVirginQueens)) { + nVirginQueens <- nVirginQueens(x, ...) + } + + if (!parallel) { + x <- addVirginQueens(x, nInd = 1) + } + x <- removeQueen_parallel(x, year = year, simParamBee = simParamBee, nThreads = nThreads) + # TODO: We could consider that a non-random virgin queen prevails (say the most + # aggressive one), by creating many virgin queens and then picking the + # one with highest pheno for competition or some other criteria + # https://github.com/HighlanderLab/SIMplyBee/issues/239 + x@supersedure <- TRUE + } else if (isMultiColony(x)) { + registerDoParallel(cores = nThreads) + nCol <- nColonies(x) + if (nCol == 0) { + x <- createMultiColony_parallel(simParamBee = simParamBee, nThreads = nThreads) + } else { + virginQueens = createCastePop_parallel(x, caste = "virginQueens", nInd = 1, nThreads = nThreads) + + combine_list <- function(a, b) { + if (length(a) == 1) { + c(list(a), list(b)) + } else { + c(a, list(b)) + } + } + x@colonies <- foreach(colony = seq_len(nCol), .combine = combine_list) %do% { + supersede_parallel(x[[colony]], + year = year, + simParamBee = simParamBee, + nThreads = nThreads, ... + ) + } + x@colonies <- foreach(colony = seq_len(nColonies(x))) %dopar% { + addCastePop_internal(colony = x[[colony]], pop = virginQueens[[colony]], caste = "virginQueens") + } + } + } else { + stop("Argument x must be a Colony or MultiColony class object!") + } + validObject(x) + return(x) +} + #' @rdname split #' @title Split colony in two MultiColony #' @@ -1683,6 +2643,147 @@ split <- function(x, p = NULL, year = NULL, simParamBee = NULL, ...) { return(ret) } +#' @export +split_parallel <- function(x, p = NULL, year = NULL, simParamBee = NULL, nThreads = NULL, ...) { + if (is.null(simParamBee)) { + simParamBee <- get(x = "SP", envir = .GlobalEnv) + } + if (is.null(nThreads)) { + nThreads = simParamBee$nThreads + } + if (is.null(p)) { + p <- simParamBee$splitP + } + if (isMultiColony(x)) { + parallel = TRUE + } + + if (isColony(x) | isMultiColony(x)) { + registerDoParallel(cores = nThreads) + if (isColony(x)) { + nCol = 1 + } else if (isMultiColony(x)) { + nCol = nColonies(x) + } + nP <- length(p) + + location = getLocation(x) + if (any(hasCollapsed(x))) { + stop(paste0("One of the collonies is collapsed, hence you can not split it!")) + } + if (any(!isQueenPresent(x, simParamBee = simParamBee))) { + stop("No queen present in one of the colonies!") + } + if (any(!isWorkersPresent(x, simParamBee = simParamBee))) { + stop("No workers present in one of the colonies!") + } + if (is.function(p)) { + p <- p(x, ...) + } else { + if (p < 0 | 1 < p) { + stop("p must be between 0 and 1 (inclusive)!") + } + if (length(p) > nCol) { + warning("More than one value in the p argument, taking only the first value!") + p <- p[nCol] + } + if (nP > 1 && nP < nCol) { + stop("Too few values in the p argument!") + } + } + nWorkers <- nWorkers(x, simParamBee = simParamBee) + nWorkersSplit <- round(nWorkers * p) + # TODO: Split colony at random by default, but we could make it as a + # function of some parameters + # https://github.com/HighlanderLab/SIMplyBee/issues/179 + tmp <- pullCastePop_parallel(x = x, caste = "workers", nInd = nWorkersSplit, simParamBee = simParamBee) #Tole je treba sparalelizirat + remnantColony <- tmp$remnant + + tmpVirginQueens <- createCastePop_parallel( + x = x, nInd = 1, + year = year, + caste = "virginQueens", + simParamBee = simParamBee, + nThreads = nThreads + ) + + if (isColony(x)) { + + # Workers raise virgin queens from eggs laid by the queen (assuming) that + # a frame of brood is also provided to the split and then one random virgin + # queen prevails, so we create just one + # TODO: Could consider that a non-random one prevails (say the most aggressive + # one), by creating many virgin queens and then picking the one with + # highest pheno for competition or some other criteria + # https://github.com/HighlanderLab/SIMplyBee/issues/239 + + splitColony <- createColony(x = tmpVirginQueens, simParamBee = simParamBee) + splitColony <- setLocation(x = splitColony, location = location) + + splitColony@workers <- tmp$pulled + + remnantColony@split <- TRUE + splitColony@split <- TRUE + + remnantColony@production <- TRUE + splitColony@production <- FALSE + + ret <- list(split = splitColony, remnant = remnantColony) + } else if (isMultiColony(x)) { + if (nCol == 0) { + ret <- list( + split = createMultiColony_parallel(simParamBee = simParamBee, nThreads = nThreads), + remnant = createMultiColony_parallel(simParamBee = simParamBee, nThreads = nThreads) + ) + } else { + ret <- list( + split = createMultiColony_parallel(x = mergePops(tmpVirginQueens), n = nCol, + simParamBee = simParamBee, nThreads = nThreads), + remnant = tmp$remnant + + ) + ret$split <- setLocation_parallel(x = ret$split, location = location, nThreads = nThreads) + + ret$split@colonies <- foreach(colony = seq_len(nCol)) %dopar% { + addCastePop_internal(colony = ret$split@colonies[[colony]], + pop = tmp$pulled[[colony]], caste = "workers") + } + ret$split <- setEvents_parallel(ret$split, slot = "split", value = TRUE, nThreads = nThreads) + ret$remnant <- setEvents_parallel(ret$remnant, slot = "split", value = TRUE, nThreads = nThreads) + ret$split <- setEvents_parallel(ret$split, slot = "production", value = FALSE, nThreads = nThreads) + ret$remnant <- setEvents_parallel(ret$remnant, slot = "production", value = TRUE, nThreads = nThreads) + } + } + } else { + stop("Argument x must be a Colony or MultiColony class object!") + } + validObject(ret$splitColony) + validObject(ret$remnantColony) + return(ret) +} + +#' @export +# Helpi function - put it in auxiliary +setEvents_parallel <- function(x, slot, value, nThreads = NULL, simParamBee = NULL) { + if (is.null(simParamBee)) { + simParamBee <- get(x = "SP", envir = .GlobalEnv) + } + if (is.null(nThreads)) { + nThreads = simParamBee$nThreads + } + if (isColony(x)) { + slot(x, slot) <- value + } + if (isMultiColony(x)) { + registerDoParallel(cores = nThreads) + x@colonies <- foreach(colony = seq_len(nColonies(x))) %dopar% { + setEvents_parallel(x[[colony]], slot, value) + } + } + return(x) +} + + #' @rdname combine #' @title Combine two colony objects #' @@ -1762,6 +2863,43 @@ combine <- function(strong, weak) { return(strong) } +#' @export +combine_parallel <- function(strong, weak, simParamBee = NULL, nThreads = NULL) { + if (isColony(strong) & isColony(weak)) { + if (is.null(simParamBee)) { + simParamBee <- get(x = "SP", envir = .GlobalEnv) + } + if (is.null(nThreads)) { + nThreads = simParamBee$nThreads + } + if (hasCollapsed(strong)) { + stop(paste0("The colony ", getId(strong), " (strong) has collapsed, hence you can not combine it!")) + } + if (hasCollapsed(weak)) { + stop(paste0("The colony ", getId(weak), " (weak) has collapsed, hence you can not combine it!")) + } + strong@workers <- c(strong@workers, weak@workers) + strong@drones <- c(strong@drones, weak@drones) + } else if (isMultiColony(strong) & isMultiColony(weak)) { + registerDoParallel(cores = nThreads) + if (nColonies(weak) == nColonies(strong)) { + nCol <- nColonies(weak) + strong@colonies <- foreach(colony = seq_len(nCol)) %dopar% { + combine(strong = strong[[colony]], + weak = weak[[colony]], + simParamBee = simParamBee, + nThreads = 1) + } + } else { + stop("Weak and strong MultiColony objects must be of the same length!") + } + } else { + stop("Argument strong and weak must both be either a Colony or MultiColony class objects!") + } + return(strong) +} + + #' @rdname setLocation #' @title Set colony location #' @@ -1870,3 +3008,80 @@ setLocation <- function(x, location = c(0, 0)) { validObject(x) return(x) } + +#' @export +setLocation_parallel <- function(x, location = c(0, 0), simParamBee = NULL, nThreads = NULL) { + if (is.null(simParamBee)) { + simParamBee <- get(x = "SP", envir = .GlobalEnv) + } + if (is.null(nThreads)) { + nThreads = simParamBee$nThreads + } + if (isColony(x)) { + if (is.list(location)) { # is.list() captures also is.data.frame() + stop("Argument location must be numeric, when x is a Colony class object!") + } + if (is.numeric(location) && length(location) != 2) { + stop("When argument location is a numeric, it must be of length 2!") + } + x@location <- location + } else if (isMultiColony(x)) { + registerDoParallel(cores = nThreads) + n <- nColonies(x) + if (!is.null(location)) { + if (is.numeric(location)) { + if (length(location) != 2) { + stop("When argument location is a numeric, it must be of length 2!") + } + } else if (is.data.frame(location)) { + if (nrow(location) != n) { + stop("When argument location is a data.frame, it must have as many rows as the number of colonies!") + } + if (ncol(location) != 2) { + stop("When argument location is a data.frame, it must have 2 columns!") + } + } else if (is.list(location)) { + if (length(location) != n) { + stop("When argument location is a list, it must be of length equal to the number of colonies!") + } + tmp <- sapply(X = location, FUN = length) + if (!all(tmp == 2)) { + stop("When argument location is a list, each list node must be of length 2!") + } + } else if (is.numeric(location)) { + if (length(location) != 2) { + stop("When argument location is a numeric, it must be of length 2!") + } + } else { + stop("Argument location must be numeric, list, or data.frame!") + } + } + combine_list <- function(a, b) { + if (length(a) == 1) { + c(list(a), list(b)) + } else { + c(a, list(b)) + } + } + x@colonies <- foreach(colony = seq_len(n), .combine = combine_list) %do% { + if (is.data.frame(location)) { + loc <- location[colony, ] + loc <- c(loc$x, loc$y) + } else if (is.list(location)) { + loc <- location[[colony]] + } else { + loc <- location + } + + if (!is.null(x[[colony]])) { + x[[colony]]@location <- loc + } + + x[[colony]] + } + } else { + stop("Argument x must be a Colony or MultiColony class object!") + } + validObject(x) + return(x) +} diff --git a/R/Functions_L3_Colonies.R b/R/Functions_L3_Colonies.R index b8dbc191..76002ac4 100644 --- a/R/Functions_L3_Colonies.R +++ b/R/Functions_L3_Colonies.R @@ -80,6 +80,46 @@ createMultiColony <- function(x = NULL, n = NULL, simParamBee = NULL) { return(ret) } +#' @export +createMultiColony_parallel <- function(x = NULL, n = NULL, simParamBee = NULL, nThreads = NULL) { + if (is.null(simParamBee)) { + simParamBee <- get(x = "SP", envir = .GlobalEnv) + } + if (is.null(nThreads)) { + nThreads = simParamBee$nThreads + } + registerDoParallel(cores = nThreads) + if (is.null(x)) { + if (is.null(n)) { + ret <- new(Class = "MultiColony") + } else { + ret <- new(Class = "MultiColony", colonies = vector(mode = "list", length = n)) + } + } else { + if (!isPop(x)) { + stop("Argument x must be a Pop class object!") + } + if (any(!(isVirginQueen(x, simParamBee = simParamBee) | isQueen(x, simParamBee = simParamBee)))) { + stop("Individuals in x must be virgin queens or queens!") + } + if (is.null(n)) { + n <- nInd(x) + } + if (nInd(x) < n) { + stop("Not enough individuals in the x to create n colonies!") + } + ret <- new(Class = "MultiColony", colonies = vector(mode = "list", length = n)) + ids = (simParamBee$lastColonyId+1):(simParamBee$lastColonyId + n) + ret@colonies <- foreach(colony = seq_len(n)) %dopar% { + createColony(x = x[colony], simParamBee = simParamBee, id = ids[colony]) + } + # WHY IS IT NOT UPDATING SP??? + simParamBee$updateLastColonyId(n = n) + } + validObject(ret) + return(ret) +} + #' @rdname selectColonies #' @title Select colonies from MultiColony object #' diff --git a/man/MultiColony-class.Rd b/man/MultiColony-class.Rd index d81e7d6f..c898062b 100644 --- a/man/MultiColony-class.Rd +++ b/man/MultiColony-class.Rd @@ -7,8 +7,8 @@ \alias{show,MultiColony-method} \alias{c,MultiColony-method} \alias{c,MultiColonyOrNULL-method} -\alias{[,MultiColony,integerOrNumericOrLogical-method} -\alias{[,MultiColony,character-method} +\alias{[,MultiColony,integerOrNumericOrLogical,ANY,ANY-method} +\alias{[,MultiColony,character,ANY,ANY-method} \alias{[[,MultiColony,integerOrNumericOrLogical-method} \alias{[[,MultiColony,character-method} \alias{[<-,MultiColony,integerOrNumericOrLogicalOrCharacter,ANY,MultiColony-method} @@ -23,9 +23,9 @@ isMultiColony(x) \S4method{c}{MultiColonyOrNULL}(x, ...) -\S4method{[}{MultiColony,integerOrNumericOrLogical}(x, i, j, drop) +\S4method{[}{MultiColony,integerOrNumericOrLogical,ANY,ANY}(x, i, j, drop) -\S4method{[}{MultiColony,character}(x, i, j, drop) +\S4method{[}{MultiColony,character,ANY,ANY}(x, i, j, drop) \S4method{[[}{MultiColony,integerOrNumericOrLogical}(x, i) diff --git a/man/SimParamBee.Rd b/man/SimParamBee.Rd index 664475f4..3507dbf8 100644 --- a/man/SimParamBee.Rd +++ b/man/SimParamBee.Rd @@ -317,6 +317,9 @@ generate this object} \item \href{#method-SimParamBee-new}{\code{SimParamBee$new()}} \item \href{#method-SimParamBee-addToCaste}{\code{SimParamBee$addToCaste()}} \item \href{#method-SimParamBee-changeCaste}{\code{SimParamBee$changeCaste()}} +\item \href{#method-SimParamBee-updatePedigree}{\code{SimParamBee$updatePedigree()}} +\item \href{#method-SimParamBee-updateCaste}{\code{SimParamBee$updateCaste()}} +\item \href{#method-SimParamBee-updateLastId}{\code{SimParamBee$updateLastId()}} \item \href{#method-SimParamBee-updateLastColonyId}{\code{SimParamBee$updateLastColonyId()}} \item \href{#method-SimParamBee-clone}{\code{SimParamBee$clone()}} } @@ -356,7 +359,6 @@ generate this object}
  • AlphaSimR::SimParam$switchGenMap()
  • AlphaSimR::SimParam$switchMaleMap()
  • AlphaSimR::SimParam$switchTrait()
    • -
  • AlphaSimR::SimParam$updateLastId()
    • }} @@ -532,6 +534,63 @@ SP$caste } +} +\if{html}{\out{
    }} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-SimParamBee-updatePedigree}{}}} +\subsection{Method \code{updatePedigree()}}{ +A function to update the pedigree. + For internal use only. +\subsection{Usage}{ +\if{html}{\out{
    }}\preformatted{SimParamBee$updatePedigree(pedigree)}\if{html}{\out{
    }} +} + +\subsection{Arguments}{ +\if{html}{\out{
    }} +\describe{ +\item{\code{pedigree}}{matrix, pedigree matrix to be added} +} +\if{html}{\out{
    }} +} +} +\if{html}{\out{
    }} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-SimParamBee-updateCaste}{}}} +\subsection{Method \code{updateCaste()}}{ +A function to update the caste + For internal use only. +\subsection{Usage}{ +\if{html}{\out{
    }}\preformatted{SimParamBee$updateCaste(caste)}\if{html}{\out{
    }} +} + +\subsection{Arguments}{ +\if{html}{\out{
    }} +\describe{ +\item{\code{caste}}{vector, named vector of castes to be added} +} +\if{html}{\out{
    }} +} +} +\if{html}{\out{
    }} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-SimParamBee-updateLastId}{}}} +\subsection{Method \code{updateLastId()}}{ +A function to update the last + ID everytime we create an individual + For internal use only. +\subsection{Usage}{ +\if{html}{\out{
    }}\preformatted{SimParamBee$updateLastId(n = 1)}\if{html}{\out{
    }} +} + +\subsection{Arguments}{ +\if{html}{\out{
    }} +\describe{ +\item{\code{n}}{integer, how many individuals to add} + +\item{\code{lastId}}{integer, last colony ID assigned} +} +\if{html}{\out{
    }} +} } \if{html}{\out{
    }} \if{html}{\out{}} @@ -541,12 +600,14 @@ A function to update the colony last ID everytime we create a Colony-class with createColony. For internal use only. \subsection{Usage}{ -\if{html}{\out{
    }}\preformatted{SimParamBee$updateLastColonyId()}\if{html}{\out{
    }} +\if{html}{\out{
    }}\preformatted{SimParamBee$updateLastColonyId(n = 1)}\if{html}{\out{
    }} } \subsection{Arguments}{ \if{html}{\out{
    }} \describe{ +\item{\code{n}}{integer, how many colonies to add} + \item{\code{lastColonyId}}{integer, last colony ID assigned} } \if{html}{\out{
    }} diff --git a/man/addCastePop.Rd b/man/addCastePop.Rd index 89e896e3..6d6e36f7 100644 --- a/man/addCastePop.Rd +++ b/man/addCastePop.Rd @@ -18,7 +18,7 @@ addCastePop( ... ) -addWorkers(x, nInd = NULL, new = FALSE, exact = FALSE, simParamBee = NULL, ...) +addWorkers(x, nInd = NULL, new = FALSE, simParamBee = NULL, ...) addDrones(x, nInd = NULL, new = FALSE, simParamBee = NULL, ...) diff --git a/man/addCastePop_internal.Rd b/man/addCastePop_internal.Rd new file mode 100644 index 00000000..bba89e34 --- /dev/null +++ b/man/addCastePop_internal.Rd @@ -0,0 +1,24 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/Functions_L2_Colony.R +\name{addCastePop_internal} +\alias{addCastePop_internal} +\title{An internal function to add a population in a caste slot of the colony} +\usage{ +addCastePop_internal(pop, colony, caste, new = FALSE) +} +\arguments{ +\item{pop}{\code{\link[AlphaSimR]{Pop-class}} with one or many individual} + +\item{colony}{\code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}}} + +\item{caste}{character} + +\item{new}{logical} +} +\value{ +\code{\link[SIMplyBee]{Colony-class}} +} +\description{ +Helper function that returns a colony to allow parallelisation, +only for internal use. +} diff --git a/man/createCastePop.Rd b/man/createCastePop.Rd index 4766cbd1..1576aff7 100644 --- a/man/createCastePop.Rd +++ b/man/createCastePop.Rd @@ -19,9 +19,26 @@ createCastePop( ... ) -createWorkers(x, nInd = NULL, exact = FALSE, simParamBee = NULL, ...) +createWorkers( + x, + nInd = NULL, + exact = FALSE, + simParamBee = NULL, + returnSP = FALSE, + ids = NULL, + nThreads = NULL, + ... +) -createDrones(x, nInd = NULL, simParamBee = NULL, ...) +createDrones( + x, + nInd = NULL, + simParamBee = NULL, + returnSP = FALSE, + ids = NULL, + nThreads = NULL, + ... +) createVirginQueens( x, @@ -30,6 +47,9 @@ createVirginQueens( editCsd = TRUE, csdAlleles = NULL, simParamBee = NULL, + returnSP = FALSE, + ids = NULL, + nThreads = NULL, ... ) } diff --git a/man/createColony.Rd b/man/createColony.Rd index a8a96649..c4a24899 100644 --- a/man/createColony.Rd +++ b/man/createColony.Rd @@ -4,7 +4,7 @@ \alias{createColony} \title{Create a new Colony} \usage{ -createColony(x = NULL, simParamBee = NULL) +createColony(x = NULL, simParamBee = NULL, id = NULL) } \arguments{ \item{x}{\code{\link[AlphaSimR]{Pop-class}}, one queen or virgin queen(s)} diff --git a/man/downsize.Rd b/man/downsize.Rd index e418ad0b..e581e2f3 100644 --- a/man/downsize.Rd +++ b/man/downsize.Rd @@ -5,7 +5,15 @@ \title{Reduce number of workers and remove all drones and virgin queens from a Colony or MultiColony object} \usage{ -downsize(x, p = NULL, use = "rand", new = FALSE, simParamBee = NULL, ...) +downsize( + x, + p = NULL, + use = "rand", + new = FALSE, + simParamBee = NULL, + nThreads = NULL, + ... +) } \arguments{ \item{x}{\code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}}} diff --git a/man/removeCastePop.Rd b/man/removeCastePop.Rd index 9acecac0..6e07ea9b 100644 --- a/man/removeCastePop.Rd +++ b/man/removeCastePop.Rd @@ -5,7 +5,7 @@ \alias{removeQueen} \alias{removeWorkers} \alias{removeDrones} -\alias{removeVirginQueens} +\alias{removeVirginQueens_parallel} \title{Remove a proportion of caste individuals from a colony} \usage{ removeCastePop( @@ -24,14 +24,21 @@ removeQueen( addVirginQueens = FALSE, nVirginQueens = NULL, year = NULL, - simParamBee = NULL + simParamBee = NULL, + nThreads = NULL ) -removeWorkers(x, p = 1, use = "rand", simParamBee = NULL) +removeWorkers(x, p = 1, use = "rand", simParamBee = NULL, nThreads = NULL) -removeDrones(x, p = 1, use = "rand", simParamBee = NULL) +removeDrones(x, p = 1, use = "rand", simParamBee = NULL, nThreads = NULL) -removeVirginQueens(x, p = 1, use = "rand", simParamBee = NULL) +removeVirginQueens_parallel( + x, + p = 1, + use = "rand", + simParamBee = NULL, + nThreads = NULL +) } \arguments{ \item{x}{\code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}}} @@ -72,7 +79,7 @@ Level 2 function that removes a proportion of virgin queens of \item \code{removeDrones()}: Remove workers from a colony -\item \code{removeVirginQueens()}: Remove virgin queens from a colony +\item \code{removeVirginQueens_parallel()}: Remove virgin queens from a colony }} \examples{ diff --git a/man/supersede.Rd b/man/supersede.Rd index 04291135..90da056a 100644 --- a/man/supersede.Rd +++ b/man/supersede.Rd @@ -4,7 +4,14 @@ \alias{supersede} \title{Supersede} \usage{ -supersede(x, year = NULL, nVirginQueens = NULL, simParamBee = NULL, ...) +supersede( + x, + year = NULL, + nVirginQueens = NULL, + simParamBee = NULL, + nThreads = NULL, + ... +) } \arguments{ \item{x}{\code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}}} diff --git a/man/swarm.Rd b/man/swarm.Rd index e178fe26..34d2c198 100644 --- a/man/swarm.Rd +++ b/man/swarm.Rd @@ -8,7 +8,6 @@ swarm( x, p = NULL, year = NULL, - nVirginQueens = NULL, sampleLocation = TRUE, radius = NULL, simParamBee = NULL, @@ -26,11 +25,6 @@ a single value is provided, the same value will be applied to all the colonies} \item{year}{numeric, year of birth for virgin queens} -\item{nVirginQueens}{integer, the number of virgin queens to be created in the -colony; of these one is randomly selected as the new virgin queen of the -remnant colony. If \code{NULL}, the value from \code{simParamBee$nVirginQueens} -is used} - \item{sampleLocation}{logical, sample location of the swarm by taking the current colony location and adding deviates to each coordinate using \code{\link[SIMplyBee]{rcircle}}} From 004065f6e7e3197ce01421a520d4d252e5a4c4b4 Mon Sep 17 00:00:00 2001 From: janaobsteter Date: Wed, 9 Apr 2025 09:09:10 +0200 Subject: [PATCH 02/42] Parallelisation --- DESCRIPTION | 4 +- NAMESPACE | 21 +- NEWS.md | 11 + R/Class-SimParamBee.R | 36 +- R/Functions_L0_auxilary.R | 43 +- R/Functions_L1_Pop.R | 637 +++++++++++++++- R/Functions_L2_Colony.R | 1485 +++++++++++++++++++++++++++++++++---- R/Functions_L3_Colonies.R | 40 + man/MultiColony-class.Rd | 8 +- man/SimParamBee.Rd | 65 +- man/createCastePop.Rd | 24 +- man/createColony.Rd | 2 +- man/downsize.Rd | 10 +- man/removeCastePop.Rd | 19 +- man/supersede.Rd | 9 +- man/swarm.Rd | 6 - 16 files changed, 2246 insertions(+), 174 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index bdb95b1c..4ef4a624 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: SIMplyBee Type: Package Title: 'AlphaSimR' Extension for Simulating Honeybee Populations and Breeding Programmes -Version: 0.4.0 +Version: 0.4.1 Authors@R: c( person("Jana", "Obšteter", email = "obsteter.jana@gmail.com", role = c("aut", "cre"), comment = c(ORCID = "0000-0003-1511-3916")), @@ -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 diff --git a/NAMESPACE b/NAMESPACE index 231169a0..be1bdc2e 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -2,6 +2,8 @@ export(SimParamBee) export(addCastePop) +export(addCastePop_internal) +export(addCastePop_parallel) export(addDrones) export(addVirginQueens) export(addWorkers) @@ -10,6 +12,8 @@ export(areFathersPresent) export(areVirginQueensPresent) export(areWorkersPresent) export(buildUp) +export(buildUp_parallel) +export(buildUp_parallel_simplified) export(calcBeeAlleleFreq) export(calcBeeGRMIbd) export(calcBeeGRMIbs) @@ -21,19 +25,24 @@ export(calcPerformanceCriterion) export(calcQueensPHomBrood) export(calcSelectionCriterion) export(collapse) +export(collapse_parallel) export(combine) +export(combine_parallel) export(createCastePop) +export(createCastePop_parallel) export(createColony) export(createCrossPlan) export(createDCA) export(createDrones) export(createMatingStationDCA) export(createMultiColony) +export(createMultiColony_parallel) export(createVirginQueens) export(createWorkers) export(cross) export(downsize) export(downsizePUnif) +export(downsize_parallel) export(getCaste) export(getCasteId) export(getCastePop) @@ -168,6 +177,7 @@ export(nWorkersPoisson) export(nWorkersTruncPoisson) export(pHomBrood) export(pullCastePop) +export(pullCastePop_parallel) export(pullColonies) export(pullDroneGroupsFromDCA) export(pullDrones) @@ -177,30 +187,39 @@ export(pullVirginQueens) export(pullWorkers) export(rcircle) export(reQueen) +export(reQueen_parallel) export(reduceDroneGeno) export(reduceDroneHaplo) export(removeCastePop) +export(removeCastePop_parallel) export(removeColonies) export(removeDrones) export(removeQueen) -export(removeVirginQueens) +export(removeVirginQueens_parallel) export(removeWorkers) export(replaceCastePop) +export(replaceCastePop_parallel) export(replaceDrones) export(replaceVirginQueens) export(replaceWorkers) export(resetEvents) +export(resetEvents_parallel) export(selectColonies) +export(setEvents_parallel) export(setLocation) +export(setLocation_parallel) export(setMisc) export(setQueensYearOfBirth) export(simulateHoneyBeeGenomes) export(split) export(splitPColonyStrength) export(splitPUnif) +export(split_parallel) export(supersede) +export(supersede_parallel) export(swarm) export(swarmPUnif) +export(swarm_parallel) exportClasses(Colony) exportClasses(MultiColony) import(AlphaSimR) diff --git a/NEWS.md b/NEWS.md index c304462e..d72a41ac 100644 --- a/NEWS.md +++ b/NEWS.md @@ -4,6 +4,17 @@ editor_options: wrap: 72 --- +# SIMplyBee version 0.4.1 + +- 2024-09-19 + +## Bug fixes + +- locations of the colonies in the D_Crossing vignettes were previously +sampled by random. This caused that on some runs some queens were left unmated, +which caused an error. We now read in the locations from a csv file. + + # SIMplyBee version 0.4.0 - 2024-08-23 diff --git a/R/Class-SimParamBee.R b/R/Class-SimParamBee.R index 5ca066c3..aa5c0d31 100644 --- a/R/Class-SimParamBee.R +++ b/R/Class-SimParamBee.R @@ -425,13 +425,45 @@ SimParamBee <- R6Class( invisible(self) }, + #' @description A function to update the pedigree. + #' For internal use only. + #' + #' @param pedigree matrix, pedigree matrix to be added + updatePedigree = function(pedigree) { + private$.pedigree = rbind(private$.pedigree, pedigree) + 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 only. + #' + #' @param lastId integer, last colony ID assigned + #' @param n integer, how many individuals to add + updateLastId = function(n = 1) { + n = as.integer(n) + private$.lastId = private$.lastId + 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) } ), diff --git a/R/Functions_L0_auxilary.R b/R/Functions_L0_auxilary.R index 28e56689..7c492e44 100644 --- a/R/Functions_L0_auxilary.R +++ b/R/Functions_L0_auxilary.R @@ -341,6 +341,37 @@ calcQueensPHomBrood <- function(x, simParamBee = NULL) { return(ret) } + +calcQueensPHomBrood_parallel <- function(x, simParamBee = NULL) { + if (is.null(simParamBee)) { + simParamBee <- get(x = "SP", envir = .GlobalEnv) + } + if (isPop(x)) { + ret <- rep(x = NA, times = nInd(x)) + for (ind in seq_len(nInd(x))) { + + queensCsd <- apply( + X = getCsdAlleles(x[ind], simParamBee = simParamBee), MARGIN = 1, + FUN = function(x) paste0(x, collapse = "") + ) + fathersCsd <- apply( + X = getCsdAlleles(x@misc$fathers[[ind]], simParamBee = simParamBee), MARGIN = 1, + FUN = function(x) paste0(x, collapse = "") + ) + nComb <- length(queensCsd) * length(fathersCsd) + ret[ind] <- sum(fathersCsd %in% queensCsd) / nComb + } + } else if (isColony(x)) { + ret <- calcQueensPHomBrood(x = x@queen) + } else if (isMultiColony(x)) { + ret <- sapply(X = x@colonies, FUN = calcQueensPHomBrood) + names(ret) <- getId(x) + } else { + stop("Argument x must be a Pop, Colony, or MultiColony class object!") + } + return(ret) +} + #' @describeIn calcQueensPHomBrood Expected percentage of csd homozygous brood #' of a queen / colony #' @export @@ -359,11 +390,11 @@ pHomBrood <- function(x, simParamBee = NULL) { } } } else if (isColony(x)) { - if (is.null(x@queen@misc$pHomBrood[[1]])) { - ret <- NA - } else { - ret <- x@queen@misc$pHomBrood[[1]] - } + if (is.null(x@queen@misc$pHomBrood[[1]])) { + ret <- NA + } else { + ret <- x@queen@misc$pHomBrood[[1]] + } } else if (isMultiColony(x)) { ret <- sapply(X = x@colonies, FUN = pHomBrood) names(ret) <- getId(x) @@ -2545,7 +2576,7 @@ getCsdGeno <- function(x, caste = NULL, nInd = NULL, dronesHaploid = TRUE, } else { ret <- getCsdGeno( x = getCastePop(x, caste, simParamBee = simParamBee), nInd = nInd, - dronesHaploid = dronesHaploid, simParamBee = simParamBee + dronesHaploid = dronesHaploid, simParamBee = simParamBee ) } } else if (isMultiColony(x)) { diff --git a/R/Functions_L1_Pop.R b/R/Functions_L1_Pop.R index 005fe4fd..24fad680 100644 --- a/R/Functions_L1_Pop.R +++ b/R/Functions_L1_Pop.R @@ -416,6 +416,10 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, } if (is.function(nInd)) { nInd <- nInd(x, ...) + } else { + if (!is.null(nInd) && any(nInd < 0)) { + stop("nInd must be non-negative or NULL!") + } } # doing "if (is.function(nInd))" below if (isMapPop(x)) { @@ -542,6 +546,7 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, editCsd = TRUE, csdAlleles = NULL, simParamBee = simParamBee, ... ) + } names(ret) <- getId(x) } else { @@ -551,19 +556,298 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, return(ret) } +#' @export +createCastePop_parallel <- function(x, caste = NULL, nInd = NULL, + year = NULL, + editCsd = TRUE, csdAlleles = NULL, + simParamBee = NULL, + returnSP = FALSE, + ids = NULL, + nThreads = NULL, + ...) { + if (is.null(simParamBee)) { + simParamBee <- get(x = "SP", envir = .GlobalEnv) + } + if (is.null(nThreads)) { + nThreads = simParamBee$nThreads + } + if (is.null(nInd)) { + if (caste == "virginQueens") { + nInd <- simParamBee$nVirginQueens + } else if (caste == "workers") { + nInd <- simParamBee$nWorkers + } else if (caste == "drones") { + nInd <- simParamBee$nDrones + } + } + if (is.function(nInd)) { + nInd <- nInd(x, ...) + } + # doing "if (is.function(nInd))" below + if (isMapPop(x)) { + if (caste != "virginQueens") { # Creating virgin queens if input is a MapPop + stop("MapPop-class can only be used to create virgin queens!") + } + ret <- newPop(x, simParam = simParamBee) + if (!is.null(simParamBee$csdChr)) { + if (editCsd) { + ret <- editCsdLocus(ret, alleles = csdAlleles, simParamBee = simParamBee) + } + } + ret@sex[] <- "F" + simParamBee$changeCaste(id = ret@id, caste = "virginQueens") + if (!is.null(year)) { + ret <- setQueensYearOfBirth(x = ret, year = year, simParamBee = simParamBee) + } + } else if (isPop(x)) { + if (caste != "drones") { # Creating drones if input is a Pop + stop("Pop-class can only be used to create drones!") + } + if (any(!(isVirginQueen(x, simParamBee = simParamBee) | isQueen(x, simParamBee = simParamBee)))) { + stop("Individuals in x must be virgin queens or queens!") + } + if (length(nInd) == 1) { + # Diploid version - a hack, but it works + ret <- makeDH(pop = x, nDH = nInd, keepParents = FALSE, simParam = simParamBee) + } else { + if (length(nInd) < nInd(x)) { + stop("Too few values in the nInd argument!") + } + if (length(nInd) > 1 && length(nInd) > nInd(x)) { + warning(paste0("Too many values in the nInd argument, taking only the first ", nInd(x), "values!")) + nInd <- nInd[1:nInd(x)] + } + ret <- list() + for (virginQueen in 1:nInd(x)) { + ret[[virginQueen]] <- makeDH(pop = x[virginQueen], nDH = nInd[virginQueen], keepParents = FALSE, simParam = simParamBee) + } + ret <- mergePops(ret) + } + ret@sex[] <- "M" + simParamBee$addToCaste(id = ret@id, caste = "drones") + } else if (isColony(x)) { + if (!isQueenPresent(x, simParamBee = simParamBee)) { + stop("Missing queen!") + } + if (length(nInd) > 1) { + warning("More than one value in the nInd argument, taking only the first value!") + nInd <- nInd[1] + } + if (nInd > 0) { + if (caste == "workers") { + if (!returnSP) { + ret <- vector(mode = "list", length = 2) + names(ret) <- c("workers", "nHomBrood") + } else { + ret <- vector(mode = "list", length = 4) + names(ret) <- c("workers", "nHomBrood", "pedigree", "caste") + } + ret$workers <- combineBeeGametes( + queen = getQueen(x, simParamBee = simParamBee), drones = getFathers(x, simParamBee = simParamBee), + nProgeny = nInd, simParamBee = simParamBee + ) + + simParamBee$addToCaste(id = ret$workers@id, caste = "workers") + ret$workers@sex[] <- "F" + + if (returnSP) { + ret$pedigree = simParamBee$pedigree[ret$workers@id, , drop = F] + ret$caste = simParamBee$caste[ret$workers@id, drop = F] + } + + if (!is.null(ids)) { + if (nInd(ret$workers) < length(ids)) { + stop("Not enough IDs provided") + } + if (nInd(ret$workers) > length(ids)) { + stop("Too many IDs provided!") + } + ret$workers@id = ids + if (returnSP) { + rownames(ret$pedigree) = ids + names(ret$caste) = ids + } + } + + # THIS DOES STILL NOT WORK!!! + # if (isCsdActive(simParamBee = simParamBee)) { + # ret$nHomBrood <- sum(!isCsdHeterozygous(ret$workers)) / nInd(ret$workers) + # } + + } else if (caste == "virginQueens") { # Creating virgin queens if input is a Colony + ret <- createCastePop_parallel(x = x, caste = "workers", + nInd = nInd, exact = TRUE, simParamBee = simParamBee, + returnSP = returnSP, ids = ids, nThreads = 1, ...) + simParamBee$changeCaste(id = ret$workers@id, caste = "virginQueens") + if (!returnSP) { + ret <- ret$workers + } + if (!is.null(year)) { + ret <- setQueensYearOfBirth(x = ret, year = year, simParamBee = simParamBee) + } + } else if (caste == "drones") { # Creating drones if input is a Colony + drones <- makeDH( + pop = getQueen(x, simParamBee = simParamBee), nDH = nInd, keepParents = FALSE, + simParam = simParamBee + ) + drones@sex[] <- "M" + simParamBee$addToCaste(id = drones@id, caste = "drones") + + if (returnSP) { + print("Adding") + ret <- vector(mode = "list", length = 3) + names(ret) <- c("drones", "pedigree", "caste") + ret$pedigree = simParamBee$pedigree[drones@id, , drop = F] + ret$caste = simParamBee$caste[drones@id, drop = F] + } + + if (!is.null(ids)) { + if (nInd(drones) != length(ids)) { + stop("Not enough IDs provided") + } + drones@id = ids + if (returnSP) { + rownames(ret$pedigree) = ids + names(ret$caste) = ids + } + } + + if (returnSP) { + ret$drones= drones + } else { + ret = drones + } + } + } else { + ret <- NULL + } + } else if (isMultiColony(x)) { + registerDoParallel(cores = nThreads) + if (is.null(nInd)) { + string = paste0("n", toupper(substr(caste, 1, 1)), substr(caste, 2, nchar(caste))) + nInd <- simParaBee[[string]] + } + + nCol <- nColonies(x) + nNInd <- length(nInd) + + if (nNInd > 1 && nNInd < nCol) { + stop("Too few values in the nInd argument!") + } + if (nNInd > 1 && nNInd > nCol) { + warning(paste0("Too many values in the nInd argument, taking only the first ", nCol, "values!")) + nInd <- nInd[1:nCol] + } + + nNInd <- length(nInd) + totalNInd = ifelse(nNInd == 1, nInd * nCol, sum(nInd)) + if (totalNInd == 0) { + stop("Nothing to create.") + } + + lastId = simParamBee$lastId + ids = (lastId+1):(lastId+totalNInd) + + combine_list <- function(a, b) { + if (!is.null(names(a))) { + c(list(a), list(b)) + } else { + if ((is.null(a) | is.null(b)) & !(is.null(a) & is.null(b))) { + c(a, list(b)) + } else if (is.null(a) & is.null(b)) { + c(list(a), list(b)) + } else { + c(a, list(b)) + } + } + } + + ret <- foreach(colony = seq_len(nCol), .combine=combine_list) %dopar% { + nIndColony <- ifelse(nNInd == 1, nInd, nInd[colony]) + if (nIndColony > 0) { + if (nNInd == 1) { + colonyIds = ids[((colony-1)*nIndColony+1):(colony*nIndColony)] + } else { + colonyIds = base::split(ids, rep(seq_along(nInd), nInd))[[as.character(colony)]] + } + createCastePop_parallel( + x = x[[colony]], caste = caste, + nInd = nIndColony, + exact = exact, + year = year, + editCsd = TRUE, csdAlleles = NULL, + simParamBee = simParamBee, + returnSP = TRUE, + ids = as.character(colonyIds), ... + ) + } else { + NULL + } + } + simParamBee$updateLastId(n = totalNInd) + names(ret) <- getId(x) + + # Add to simParamBee: pedigree, caste, trackRecHis? + notNull = sapply(ret, FUN = function(x) !is.null(x)) + + Pedigree = do.call("rbind", lapply(ret[notNull], '[[', "pedigree")) + simParamBee$updatePedigree(pedigree = Pedigree) + + # Update caste + Caste = do.call("c", lapply(ret[notNull], '[[', "caste")) + if (caste == "virginQueens") { + Caste = rep("virginQueens", length(Caste)) + } + Names = do.call("c", lapply(ret[notNull], function(x) names(x$caste))) + names(Caste) = Names + simParamBee$updateCaste(caste = Caste) + + if (!returnSP) { + if (caste %in% c("drones", "virginQueens")) { + ret = lapply(ret, FUN = function(x) { + if (is.null(x)) return(NULL) # Return NULL if the element is NULL + x[!names(x) %in% c("pedigree", "caste")][[1]] + }) + } else { + ret = lapply(ret, FUN = function(x) { + if (is.null(x)) return(NULL) # Return NULL if the element is NULL + x[!names(x) %in% c("pedigree", "caste")] + }) + } + } + } else { + stop("Argument x must be a Map-Pop (only for virgin queens), + Pop (only for drones), Colony, or MultiColony class object!") + } + + return(ret) +} + #' @describeIn createCastePop Create workers from a colony #' @export -createWorkers <- function(x, nInd = NULL, exact = FALSE, simParamBee = NULL, ...) { +createWorkers <- function(x, nInd = NULL, exact = FALSE, simParamBee = NULL, + returnSP = FALSE, + ids = NULL, + nThreads = NULL, ...) { ret <- createCastePop(x, caste = "workers", nInd = nInd, - exact = exact, simParamBee = simParamBee, ...) + exact = exact, simParamBee = simParamBee, + returnSP = FALSE, + ids = NULL, + nThreads = NULL, ...) return(ret) } #' @describeIn createCastePop Create drones from a colony #' @export -createDrones <- function(x, nInd = NULL, simParamBee = NULL, ...) { +createDrones <- function(x, nInd = NULL, simParamBee = NULL, + returnSP = FALSE, + ids = NULL, + nThreads = NULL, ...) { ret <- createCastePop(x, caste = "drones", nInd = nInd, - simParamBee = simParamBee, ...) + simParamBee = simParamBee, + returnSP = FALSE, + ids = NULL, + nThreads = NULL, ...) return(ret) } @@ -573,10 +857,16 @@ createVirginQueens <- function(x, nInd = NULL, year = NULL, editCsd = TRUE, csdAlleles = NULL, simParamBee = NULL, + returnSP = FALSE, + ids = NULL, + nThreads = NULL, ...) { ret <- createCastePop(x, caste = "virginQueens", nInd = nInd, year = year, editCsd = editCsd, - csdAlleles = csdAlleles, simParamBee = simParamBee, ...) + csdAlleles = csdAlleles, simParamBee = simParamBee, + returnSP = FALSE, + ids = NULL, + nThreads = NULL, ...) return(ret) } @@ -1119,6 +1409,90 @@ pullCastePop <- function(x, caste, nInd = NULL, use = "rand", return(ret) } +#' @export +pullCastePop_parallel <- function(x, caste, nInd = NULL, use = "rand", + removeFathers = TRUE, collapse = FALSE, simParamBee = NULL, + nThreads = NULL) { + if (is.null(simParamBee)) { + simParamBee <- get(x = "SP", envir = .GlobalEnv) + } + if (is.null(nThreads)) { + nThreads = simParamBee$nThreads + } + if (length(caste) > 1) { + stop("Argument caste can be only of length 1!") + } + if (any(nInd < 0)) { + stop("nInd must be non-negative or NULL!") + } + if (isColony(x)) { + if (length(nInd) > 1) { + warning("More than one value in the nInd argument, taking only the first value!") + nInd <- nInd[1] + } + if (is.null(slot(x, caste))) { + ret <- list(pulled = NULL, remnant = x) + } else { + if (is.null(nInd)) { + nInd <- nInd(slot(x, caste)) + } + tmp <- pullInd(pop = slot(x, caste), nInd = nInd, use = use, simParamBee = simParamBee) + if (caste == "queen") { + slot(x, caste) <- NULL + } else { + slot(x, caste) <- tmp$remnant + } + if (caste == "drones" && removeFathers) { + test <- isDrone(tmp$pulled, simParamBee = simParamBee) + if (any(!test)) { + tmp$pulled <- tmp$pulled[test] + } + } + ret <- list(pulled = tmp$pulled, remnant = x) + } + } else if (isMultiColony(x)) { + registerDoParallel(cores = nThreads) + nCol <- nColonies(x) + nNInd <- length(nInd) + if (nNInd > 1 && nNInd < nCol) { + stop("Too few values in the nInd argument!") + } + if (nNInd > 1 && nNInd > nCol) { + warning(paste0("Too many values in the nInd argument, taking only the first ", nCol, "values!")) + nInd <- nInd[1:nCol] + } + ret <- vector(mode = "list", length = 2) + names(ret) <- c("pulled", "remnant") + ret$pulled <- vector(mode = "list", length = nCol) + names(ret$pulled) <- getId(x) + ret$remnant <- x + + tmp = foreach(colony = seq_len(nCol)) %dopar% { + if (is.null(nInd)) { + nIndColony <- NULL + } else { + nIndColony <- ifelse(nNInd == 1, nInd, nInd[colony]) + } + pullCastePop(x = x[[colony]], + caste = caste, + nInd = nIndColony, + use = use, + removeFathers = removeFathers, + collapse = collapse, + simParamBee = simParamBee) + } + ret$pulled <- lapply(tmp, '[[', "pulled") + ret$remnant@colonies <- lapply(tmp, '[[', "remnant") + + if (collapse) { + ret$pulled <- mergePops(ret$pulled) + } + } else { + stop("Argument x must be a Colony or MultiColony class object!") + } + return(ret) +} + #' @describeIn pullCastePop Pull queen from a colony #' @export pullQueen <- function(x, collapse = FALSE, simParamBee = NULL) { @@ -1528,6 +1902,259 @@ cross <- function(x, return(ret) } +cross_parallel <- function(x, + crossPlan = NULL, + drones = NULL, + droneColonies = NULL, + nDrones = NULL, + spatial = FALSE, + radius = NULL, + checkCross = "error", + simParamBee = NULL, + nThreads = NULL, + ...) { + if (is.null(simParamBee)) { + simParamBee <- get(x = "SP", envir = .GlobalEnv) + } + if (is.null(nThreads)) { + nThreads = simParamBee$nThreads + } + registerDoParallel(cores = nThreads) + + if (isPop(x)) { + type = "Pop" + } else if (isColony(x)) { + type = "Colony" + } else if (isMultiColony(x)) { + type = "MultiColony" + } else { + stop("Input x must be a Pop-class, Colony-class, or MultiColony-class!") + } + + if (is.null(nDrones)) { + nDrones <- simParamBee$nFathers + } + + IDs <- as.character(getId(x)) + oneColony <- (isPop(drones)) && (length(IDs) == 1) && (is.null(crossPlan)) + dronePackages <- is.list(drones) + crossPlan_given <- !dronePackages && is.list(crossPlan) + crossPlan_create <- ifelse(!is.null(crossPlan) && !dronePackages, (crossPlan[1] == "create"), FALSE) + crossPlan_droneID <- (!is.null(crossPlan)) && !is.null(drones) + crossPlan_colonyID <- (!is.null(crossPlan)) && !is.null(droneColonies) + + + # Do all the tests here to simplify the function + if (crossPlan_droneID && !isPop(drones)) { + stop("When using a cross plan, drones must be supplied as a single Pop-class!") + } + if (crossPlan_colonyID && !isMultiColony(droneColonies)) { + stop("When using a cross plan, droneColonies must be supplied as a single MultiColony-class!") + } + if (!is.null(drones) && !is.null(droneColonies)) { + stop("You can provide either drones or droneColonies, but not both!") + } + if (is.null(drones) & is.null(droneColonies)) { + stop("You must provide either drones or droneColonies!") + } + if (!dronePackages & !isPop(drones) & is.null(droneColonies)) { + stop("The argument drones must be a Pop-class + or a list of drone Pop-class objects!") + } + if (crossPlan_given && !is.null(drones) && !all(unlist(crossPlan) %in% drones@id)) { + stop("Some drones from the crossPlan are missing in the drones population!") + } + if (dronePackages && length(IDs) != length(drones)) { #check for list of father pops + stop("Length of argument drones should match the number of virgin queens/colonies!") + } + if (!is.null(crossPlan) && all(is.null(drones), is.null(droneColonies))) { + stop("When providing a cross plan, you must also provide drones or droneColonies!") + } + if (crossPlan_given && !all(IDs %in% names(crossPlan))) { #Check for cross plan + stop("Cross plan must include all the virgin queens/colonies!") + } + if (isPop(x)) { + if (any(!isVirginQueen(x, simParamBee = simParamBee))) { + stop("Individuals in pop must be virgin queens!") + } + } + if (isColony(x) | isMultiColony(x)) { + if (any(isQueenPresent(x, simParamBee = simParamBee))) { + stop("Queen already present in the colony!") + } + if (any(!isVirginQueensPresent(x, simParamBee = simParamBee))) { + stop("No virgin queen(s) in the colony to cross!") + } + } + + # Convert everything to a Pop + if (isColony(x) | isMultiColony(x)) { + inputId <- getId(x) + if (isColony(x)) { + colony <- x + x <- pullCastePop_parallel(x, caste = "virginQueens", nInd = 1)$pulled + ID_by_input <- data.frame(inputId = inputId, + virginId = getId(x)) + } else if (isMultiColony(x)) { + multicolony <- x + x <- pullCastePop_parallel(x, caste = "virginQueens", nInd = 1)$pulled + ID_by_input <- data.frame(inputId = inputId, + virginId = unlist(sapply(x, FUN = function(y) getId(y)))) + x <- mergePops(x) + } + + } + IDs <- as.character(getId(x)) + #Now x is always a Pop + ret <- list() + nVirgin = nInd(x) + + if (is.function(nDrones)) { + nD = nDrones(n = nVirgin, ...) + } else { + nD = nDrones + } + + if (crossPlan_create | crossPlan_given) { + if (crossPlan_create) { + crossPlan <- createCrossPlan(x = x, + drones = drones, + droneColonies = droneColonies, + nDrones = nDrones, + spatial = spatial, + radius = radius, + simParamBee = simParamBee) + } + + if (crossPlan_given) { + names(crossPlan) <- ID_by_input$virginId[match(ID_by_input$inputId, names(crossPlan))] + } + + noMatches <- sapply(crossPlan, FUN = length) + if (0 %in% noMatches) { + msg <- "Crossing failed!" + if (checkCross == "warning") { + message(msg) + ret <- x + } else if (checkCross == "error") { + stop(msg) + } + } + } + + combine_list <- function(a, b) { + if (isPop(a)) { + c(list(a), list(b)) + } else { + c(a, list(b)) + } + } + + if (crossPlan_given | crossPlan_create) { + if (crossPlan_colonyID) { # WHAT IF ONE ELEMENT IS EMPTY + crossPlanDF <- data.frame(virginID = rep(names(crossPlan), unlist(sapply(crossPlan, length))), + DPC = unlist(crossPlan)) + + crossPlanDF_sample <- do.call("rbind", lapply(IDs, FUN = function(x) { + data.frame(virginID = x, DPC = sample(crossPlan[[x]], size = nD[which(x == IDs)], replace = TRUE))})) %>% + arrange(DPC) + crossPlanDF_DPCtable <- as.data.frame(table(crossPlanDF_sample$DPC)) %>% arrange(Var1) + colnames(crossPlanDF_DPCtable) <- c("DPC", "noDrones") + + selectedDPC = droneColonies[as.character(crossPlanDF_DPCtable$DPC)] + dronesByDPC <- createCastePop_parallel(selectedDPC, caste = "drones", + nInd = as.integer(crossPlanDF_DPCtable$noDrones), simParamBee = simParamBee) + dronesByDPC_DF <- data.frame(DPC = rep(names(dronesByDPC), as.vector(crossPlanDF_DPCtable$noDrones)), + droneID = unlist(sapply(dronesByDPC, FUN = function(x) getId(x)))) %>% + arrange(as.numeric(DPC)) + dronePop = mergePops(dronesByDPC) + + if (any(!crossPlanDF_sample$DPC == dronesByDPC_DF$DPC)) { + stop("Something went wrong with cross plan - drone matching!") + } + + dronesByVirgin_DF <- cbind(dronesByDPC_DF, crossPlanDF_sample[, c("virginID"), drop = F]) %>% + arrange(virginID) + dronesByVirgin_list <- lapply(IDs, FUN = function(x) dronesByVirgin_DF$droneID[dronesByVirgin_DF$virginID == x]) + names(dronesByVirgin_list) <- IDs + + dronesByVirgin <- foreach(virgin = IDs, .combine = combine_list) %dopar% { + dronePop[as.character(dronesByVirgin_list[[virgin]])] + } + } else if (crossPlan_droneID) { + dronesByVirgin <- foreach(virgin = IDs, .combine = combine_list) %dopar% { + drones[as.character(crossPlan[[virgin]])] + } + } + } + + # At this point, x is a Pop and dronesByVirgin are a list (so are they if they come if via drone packages) + if (oneColony) { + dronesByVirgin <- list(drones) + } + if (dronePackages) { + dronesByVirgin <- drones + } + + names(dronesByVirgin) <- IDs + nDronesByVirgin <- sapply(dronesByVirgin, FUN = function(x) nInd(x)) + + + #if (all(nDronesByVirgin > 0)) { #There was a mistake here - if the message is warning, this still needs to happen + if (!all(sapply(dronesByVirgin, + FUN = function(x) all(isDrone(x, simParamBee = simParamBee))))) { + stop("Individuals in drones must be drones!") + } + + if (nInd(x) != length(dronesByVirgin)) { + stop("Number of virgin queens does not match the length of the assigned drones!") + } + + for (id in IDs) { + simParamBee$changeCaste(id = id, caste = "queen") + } + + for (id in as.vector(Reduce("c", sapply(dronesByVirgin, FUN = function(x) getId(x))))) { + simParamBee$changeCaste(id = id, caste = "fathers") + } + + # All of the input has been transformed to a Pop + crossVirginQueen <- function(virginQueen, virginQueenDrones, simParamBee = NULL) { + virginQueen@misc$fathers[[1]] <- virginQueenDrones + virginQueen <- setMisc(x = virginQueen, node = "nWorkers", value = 0) + virginQueen <- setMisc(x = virginQueen, node = "nDrones", value = 0) + + virginQueen <- setMisc(x = virginQueen, node = "nHomBrood", value = 0) + # if (isCsdActive(simParamBee = simParamBee)) { #This does still not work it the CSD is turned on + # val <- calcQueensPHomBrood(x = virginQueen, simParamBee = simParamBee) + # } else { + # val <- NA + # } + # + # virginQueen <- setMisc(x = virginQueen, node = "pHomBrood", value = val) + return(virginQueen) + } + + # Add drones in the queens father slot + x <- foreach(ID = 1:length(IDs), .combine = combine_list) %dopar% { + crossVirginQueen(virginQueen = x[ID], virginQueenDrones = dronesByVirgin[[ID]], simParamBee = SP) + } + + + if (type == "Pop") { + ret <- mergePops(x) + } else if (type == "Colony") { + ret <- reQueen(x = colony, queen = x[1], simParamBee = simParamBee) + ret <- removeVirginQueens(ret, simParamBee = simParamBee) + } else if (type == "MultiColony") { + ret <- reQueen_parallel(x = multicolony, queen = mergePops(x), simParamBee = simParamBee) + ret <- removeCastePop_parallel(ret, caste = "virginQueens", simParamBee = simParamBee) + } + + validObject(ret) + return(ret) +} + #' @rdname setQueensYearOfBirth #' @title Set the queen's year of birth #' diff --git a/R/Functions_L2_Colony.R b/R/Functions_L2_Colony.R index 390e76f5..0cce1016 100644 --- a/R/Functions_L2_Colony.R +++ b/R/Functions_L2_Colony.R @@ -31,15 +31,19 @@ #' colony1 <- cross(colony1, drones = drones) #' colony1 #' @export -createColony <- function(x = NULL, simParamBee = NULL) { +createColony <- function(x = NULL, simParamBee = NULL, id = NULL) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } simParamBee$updateLastColonyId() + if (is.null(id)) { + id <- simParamBee$lastColonyId + } + if (is.null(x)) { colony <- new( Class = "Colony", - id = simParamBee$lastColonyId + id = id ) } else { if (!isPop(x)) { @@ -60,7 +64,7 @@ createColony <- function(x = NULL, simParamBee = NULL) { colony <- new( Class = "Colony", - id = simParamBee$lastColonyId, + id = id, queen = queen, location = c(0, 0), virginQueens = virginQueens @@ -71,6 +75,9 @@ createColony <- function(x = NULL, simParamBee = NULL) { return(colony) } + + + #' @rdname reQueen #' @title Re-queen #' @@ -180,6 +187,80 @@ reQueen <- function(x, queen, removeVirginQueens = TRUE, simParamBee = NULL) { return(x) } +#' @export +reQueen_parallel <- function(x, queen, removeVirginQueens = TRUE, simParamBee = NULL, nThreads = NULL) { + if (is.null(simParamBee)) { + simParamBee <- get(x = "SP", envir = .GlobalEnv) + } + if (is.null(nThreads)) { + nThreads = simParamBee$nThreads + } + if (!isPop(queen)) { + stop("Argument queen must be a Pop class object!") + } + if (!all(isVirginQueen(queen, simParamBee = simParamBee) | isQueen(queen, simParamBee = simParamBee))) { + stop("Individual in queen must be a virgin queen or a queen!") + } + if (isColony(x)) { + if (all(isQueen(queen, simParamBee = simParamBee))) { + if (nInd(queen) > 1) { + stop("You must provide just one queen for the colony!") + } + x@queen <- queen + if (removeVirginQueens) { + x <- removeVirginQueens(x, simParamBee = simParamBee) + } + } else { + x <- removeQueen(x, addVirginQueens = FALSE, simParamBee = simParamBee) + x@virginQueens <- queen + } + } else if (isMultiColony(x)) { + registerDoParallel(cores = nThreads) + nCol <- nColonies(x) + if (nInd(queen) < nCol) { + stop("Not enough queens provided!") + } + x@colonies = foreach(colony = seq_len(nCol)) %dopar% { + reQueen( + x = x[[colony]], + queen = queen[colony], + simParamBee = simParamBee + ) + } + } else { + stop("Argument x must be a Colony or MultiColony class object!") + } + validObject(x) + return(x) +} + +#' @rdname addCastePop_internal +#' @title An internal function to add a population in a caste slot of the colony +#' +#' @description Helper function that returns a colony to allow parallelisation, +#' only for internal use. +#' +#' @param colony \code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}} +#' @param pop \code{\link[AlphaSimR]{Pop-class}} with one or many individual +#' @param caste character +#' @param new logical +#' +#' @return \code{\link[SIMplyBee]{Colony-class}} +#' @export +addCastePop_internal <- function(pop, colony, caste, new = FALSE) { + if (!is.null(pop)) { + if (caste == "queen" & nInd(pop) > 1) { + stop("Cannot add more than one queen!") + } + } + if (is.null(slot(colony, caste)) | new) { + slot(colony, caste) <- pop + } else { + slot(colony, caste) <- c(slot(colony, caste), pop) + } + return(colony) +} + #' @rdname addCastePop #' @title Add caste individuals to the colony #' @@ -284,7 +365,7 @@ addCastePop <- function(x, caste = NULL, nInd = NULL, new = FALSE, } if (length(nInd) > 1) { warning("More than one value in the nInd argument, taking only the first value!") - p <- p[1] + nInd <- nInd[1] } if (is.function(nInd)) { nInd <- nInd(x, ...) @@ -345,23 +426,144 @@ addCastePop <- function(x, caste = NULL, nInd = NULL, new = FALSE, return(x) } +#' @export +addCastePop_parallel <- function(x, caste = NULL, nInd = NULL, new = FALSE, + year = NULL, simParamBee = NULL, + nThreads = NULL, ...) { + if (is.null(simParamBee)) { + simParamBee <- get(x = "SP", envir = .GlobalEnv) + } + if (is.null(nThreads)) { + nThreads = simParamBee$nThreads + } + if (length(caste) != 1) { + stop("Argument caste must be of length 1!") + } + if (is.null(nInd)) { + if (caste == "workers") { + nInd <- simParamBee$nWorkers + } else if (caste == "drones") { + nInd <- simParamBee$nDrones + } else if (caste == "virginQueens") { + nInd <- simParamBee$nVirginQueens + } + } + # doing "if (is.function(nInd))" below + if (isColony(x)) { + if (hasCollapsed(x)) { + stop(paste0("The colony ", getId(x), " collapsed, hence you can not add individuals (from the queen) to it!")) + } + if (length(nInd) > 1) { + warning("More than one value in the nInd argument, taking only the first value!") + nInd <- nInd[1] + } + if (0 < nInd) { + newInds <- createCastePop_parallel(x, nInd, + caste = caste, + year = year, simParamBee = simParamBee, + nThreads = nThreads + ) + if (caste == "workers") { + homInds <- newInds$nHomBrood + newInds <- newInds$workers + x@queen@misc$nWorkers[[1]] <- x@queen@misc$nWorkers[[1]] + nInd(newInds) + #x@queen@misc$nHomBrood[[1]] <- x@queen@misc$nHomBrood[[1]] + homInds + } + if (caste == "drones") { + x@queen@misc$nDrones[[1]] <- x@queen@misc$nDrones[[1]] + nInd(newInds) + } + if (is.null(slot(x, caste)) | new) { + slot(x, caste) <- newInds + } else { + slot(x, caste) <- c(slot(x, caste), newInds) + } + } else { + warning("The number of individuals to add is less than 0, hence adding nothing.") + } + } else if (isMultiColony(x)) { + nCol = nColonies(x) + + if (any(hasCollapsed(x))) { + stop(paste0("The colony ", getId(x), " collapsed, hence you can not add individuals (from the queen) to it!")) + } + + newInds <- createCastePop_parallel(x, nInd, + caste = caste, + year = year, simParamBee = simParamBee, + nThreads = nThreads, returnSP = FALSE, ...) + + + if (caste == "workers") { + homInds = lapply(newInds, function(x) { + if (is.null(x)) return(NULL) + x[['nHomBrood']] + }) + newInds = lapply(newInds, function(x) { + if (is.null(x)) return(NULL) + x[["workers"]] + }) + } + nInds = lapply(newInds, function(x) { + if (is.null(x)) return(NULL) + nInd(x) + }) + + x@colonies <- foreach(colony = seq_len(nCol)) %dopar% { + if (!is.null(nInds[[colony]])) { + if (caste == "workers") { + x[[colony]]@queen@misc$nWorkers[[1]] <- x[[colony]]@queen@misc$nWorkers[[1]] + nInds[[colony]] + x[[colony]]@queen@misc$nHomBrood[[1]] <- x[[colony]]@queen@misc$nHomBrood[[1]] + ifelse(is.null(homInds[[colony]]), 0, homInds[[colony]]) + } else if (caste == "drones") { + x[[colony]]@queen@misc$nDrones[[1]] <- x[[colony]]@queen@misc$nDrones[[1]] + nInds[[colony]] + } + addCastePop_internal(colony = x[[colony]], pop = newInds[[colony]], caste = caste, new = new) + } else { + x[[colony]] + } + } + } else { + stop("Argument x must be a Colony or MultiColony class object!") + } + validObject(x) + return(x) +} + #' @describeIn addCastePop Add workers to a colony #' @export -addWorkers <- function(x, nInd = NULL, new = FALSE, - exact = FALSE, simParamBee = NULL, ...) { +addWorkers<- function(x, nInd = NULL, new = FALSE, + simParamBee = NULL, ...) { ret <- addCastePop( x = x, caste = "workers", nInd = nInd, new = new, - exact = exact, simParamBee = simParamBee, ... + simParamBee = simParamBee, ... + ) + return(ret) +} +addWorkers_parallel <- function(x, nInd = NULL, new = FALSE, + simParamBee = NULL, nThreads = NULL, ...) { + ret <- addCastePop_parallel( + x = x, caste = "workers", nInd = nInd, new = new, + simParamBee = simParamBee, nThreads = nThreads, ... ) return(ret) } #' @describeIn addCastePop Add drones to a colony #' @export -addDrones <- function(x, nInd = NULL, new = FALSE, simParamBee = NULL, ...) { +addDrones <- function(x, nInd = NULL, new = FALSE, + simParamBee = NULL, ...) { ret <- addCastePop( x = x, caste = "drones", nInd = nInd, new = new, - simParamBee = simParamBee, ... + simParamBee = simParamBee, ... + ) + return(ret) +} + +addDrones_parallel <- function(x, nInd = NULL, new = FALSE, + simParamBee = NULL, nThreads = NULL, ...) { + ret <- addCastePop_parallel( + x = x, caste = "drones", nInd = nInd, new = new, + simParamBee = simParamBee, + nThreads = nThreads, ... ) return(ret) } @@ -372,7 +574,17 @@ addVirginQueens <- function(x, nInd = NULL, new = FALSE, year = NULL, simParamBee = NULL, ...) { ret <- addCastePop( x = x, caste = "virginQueens", nInd = nInd, new = new, - year = year, simParamBee = simParamBee, ... + year = year, simParamBee = simParamBee, nThreads = nThreads, ... + ) + return(ret) +} + + +addVirginQueens_parallel <- function(x, nInd = NULL, new = FALSE, + year = NULL, simParamBee = NULL, nThreads = NULL, ...) { + ret <- addCastePop_parallel( + x = x, caste = "virginQueens", nInd = nInd, new = new, + year = year, simParamBee = simParamBee, nThreads = nThreads, ... ) return(ret) } @@ -589,110 +801,341 @@ buildUp <- function(x, nWorkers = NULL, nDrones = NULL, return(x) } - -#' @rdname downsize -#' @title Reduce number of workers and remove all drones and virgin queens from -#' a Colony or MultiColony object -#' -#' @description Level 2 function that downsizes a Colony or MultiColony object -#' by removing a proportion of workers, all drones and all virgin queens. -#' Usually in the autumn, such an event occurs in preparation for the winter months. -#' -#' @param x \code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}} -#' @param p numeric, proportion of workers to be removed from the colony; if -#' \code{NULL} then \code{\link[SIMplyBee]{SimParamBee}$downsizeP} is used. -#' If input is \code{\link[SIMplyBee]{MultiColony-class}}, -#' the input could also be a vector of the same length as the number of colonies. If -#' a single value is provided, the same value will be applied to all the colonies -#' @param use character, all the options provided by \code{\link[AlphaSimR]{selectInd}}; -#' it guides the selection of workers that will be removed -#' @param new logical, should we remove all current workers and add a targeted -#' proportion anew (say, create winter workers) -#' @param simParamBee \code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters -#' @param ... additional arguments passed to \code{p} when this argument is a -#' function -#' -#' @return \code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}} with workers reduced and -#' drones/virgin queens removed -#' -#' @examples -#' founderGenomes <- quickHaplo(nInd = 4, nChr = 1, segSites = 50) -#' SP <- SimParamBee$new(founderGenomes) -#' \dontshow{SP$nThreads = 1L} -#' basePop <- createVirginQueens(founderGenomes) -#' drones <- createDrones(x = basePop[1], nInd = 100) -#' droneGroups <- pullDroneGroupsFromDCA(drones, n = 3, nDrones = 12) -#' -#' # Create and cross Colony and MultiColony class -#' colony <- createColony(x = basePop[2]) -#' colony <- cross(colony, drones = droneGroups[[1]]) -#' colony <- buildUp(colony) -#' apiary <- createMultiColony(basePop[3:4], n = 2) -#' apiary <- cross(apiary, drones = droneGroups[c(2, 3)]) -#' apiary <- buildUp(apiary) -#' -#' # Downsize -#' colony <- downsize(x = colony, new = TRUE, use = "rand") -#' colony -#' apiary <- downsize(x = apiary, new = TRUE, use = "rand") -#' apiary[[1]] -#' -#' # Downsize with different numbers -#' nWorkers(apiary); nDrones(apiary) -#' apiary <- downsize(x = apiary, p = c(0.5, 0.1), new = TRUE, use = "rand") -#' nWorkers(apiary); nDrones(apiary) #' @export -downsize <- function(x, p = NULL, use = "rand", new = FALSE, - simParamBee = NULL, ...) { +buildUp_parallel <- function(x, nWorkers = NULL, nDrones = NULL, + new = TRUE, resetEvents = FALSE, + simParamBee = NULL, nThreads = NULL, ...) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } - if (!is.logical(new)) { - stop("Argument new must be logical!") + if (is.null(nThreads)) { + nThreads = simParamBee$nThreads } - if (any(1 < p)) { - stop("p must not be higher than 1!") - } else if (any(p < 0)) { - stop("p must not be less than 0!") + # Workers + if (is.null(nWorkers)) { + nWorkers <- simParamBee$nWorkers + } + + if (is.null(nDrones)) { + nDrones <- simParamBee$nDrones + } + if (is.function(nDrones)) { + nDrones <- nDrones(x = x, ...) } + if (isColony(x)) { - if (hasCollapsed(x)) { - stop(paste0("The colony ", getId(x), " collapsed, hence you can not downsize it!")) - } - if (is.null(p)) { - p <- simParamBee$downsizeP + if (is.function(nWorkers)) { + nWorkers <- nWorkers(colony = x,...) } - if (is.function(p)) { - p <- p(x, ...) + if (hasCollapsed(x)) { + stop(paste0("The colony ", getId(x), " collapsed, hence you can not build it up!")) } - if (length(p) > 1) { - warning("More than one value in the p argument, taking only the first value!") - p <- p[1] + if (length(nWorkers) > 1) { + warning("More than one value in the nWorkers argument, taking only the first value!") + nWorkers <- nWorkers[1] } - if (new == TRUE) { - n <- round(nWorkers(x, simParamBee = simParamBee) * (1 - p)) - x <- addWorkers(x = x, nInd = n, new = TRUE, simParamBee = simParamBee) + if (new) { + n <- nWorkers } else { - x <- removeWorkers(x = x, p = p, use = use, simParamBee = simParamBee) + n <- nWorkers - nWorkers(x, simParamBee = simParamBee) } - x <- removeDrones(x = x, p = 1, simParamBee = simParamBee) - x <- removeVirginQueens(x = x, p = 1, simParamBee = simParamBee) - x@production <- FALSE - } else if (isMultiColony(x)) { - nCol <- nColonies(x) - nP <- length(p) - if (nP > 1 && nP < nCol) { - stop("Too few values in the p argument!") + + if (0 < n) { + x <- addWorkers_parallel( + x = x, nInd = n, new = new, + exact = exact, simParamBee = simParamBee, + nThreads = nThreads) + } else if (n < 0) { + x@workers <- getWorkers(x, nInd = nWorkers, simParamBee = simParamBee) } - if (nP > 1 && nP > nCol) { - warning(paste0("Too many values in the p argument, taking only the first ", nCol, "values!")) - p <- p[1:nCol] + + # Drones + if (length(nDrones) > 1) { + warning("More than one value in the nDrones argument, taking only the first value!") + nDrones <- nDrones[1] } - for (colony in seq_len(nCol)) { - if (is.null(p)) { - pColony <- NULL - } else { - pColony <- ifelse(nP == 1, p, p[colony]) + if (new) { + n <- nDrones + } else { + n <- nDrones - nDrones(x, simParamBee = simParamBee) + } + + if (0 < n) { + x <- addDrones_parallel( + x = x, nInd = n, new = new, + simParamBee = simParamBee, + nThreads = nThreads + ) + } else if (n < 0) { + x@drones <- getDrones(x, nInd = nDrones, simParamBee = simParamBee) + } + + # Events + if (resetEvents) { + x <- resetEvents(x) + } + x@production <- TRUE + } else if (isMultiColony(x)) { + registerDoParallel(cores = nThreads) + + if (any(hasCollapsed(x))) { + stop(paste0("Some colonies are collapsed, hence you can not build it up!")) + } + nCol <- nColonies(x) + nNWorkers <- length(nWorkers) + nNDrones <- length(nDrones) + if (nNWorkers > 1 && nNWorkers < nCol) { + stop("Too few values in the nWorkers argument!") + } + if (nNDrones > 1 && nNDrones < nCol) { + stop("Too few values in the nDrones argument!") + } + if (nNWorkers > 1 && nNWorkers > nCol) { + warning(paste0("Too many values in the nWorkers argument, taking only the first ", nCol, "values!")) + nWorkers <- nWorkers[1:nCol] + } + if (nNDrones > 1 && nNDrones > nCol) { + warning(paste0("Too many values in the nDrones argument, taking only the first ", nCol, "values!")) + nNDrones <- nNDrones[1:nCol] + } + + if (is.function(nWorkers)) { + nWorkers <- nWorkers(colony = x,...) + } + + if (new) { + n <- nWorkers + } else { + n <- nWorkers - nWorkers(x, simParamBee = simParamBee) + } + + if (sum(nWorkers) > 0) { + x = addWorkers_parallel( + x = x, nInd = n, new = new, + simParamBee = simParamBee, nThreads = nThreads) + # } else if (nWorkersColony < 0) { + # #THIS IS A PROBLEM _ THE FUNCTION NEEDSD TO RETURN COLONY getWorkers(x, nInd = nWorkers, simParamBee = simParamBee) + # } + # } THIS NEEDS TO GO INTO ADDCASTEPOP + } + if (sum(nDrones) > 0) { + x = addDrones_parallel( + x = x, nInd = n, new = new, + simParamBee = simParamBee, nThreads = nThreads) + # } else if (nDronesColony < 0) { + # #THIS IS A PROBLEM _ THE FUNCTION NEEDSD TO RETURN COLONY getWorkers(x, nInd = nWorkers, simParamBee = simParamBee) + # + } + x <- setEvents_parallel(x, slot = "production", value = TRUE) + if (resetEvents) { + x <- resetEvents_parallel(x) + } + + } else { + stop("Argument x must be a Colony or MultiColony class object!") + } + + validObject(x) + return(x) +} + +#' @export +buildUp_parallel_simplified <- function(x, nWorkers = NULL, nDrones = NULL, + new = TRUE, resetEvents = FALSE, + simParamBee = NULL, nThreads = NULL, ...) { + if (is.null(simParamBee)) { + simParamBee <- get(x = "SP", envir = .GlobalEnv) + } + if (is.null(nThreads)) { + nThreads = simParamBee$nThreads + } + # Workers + if (is.null(nWorkers)) { + nWorkers <- simParamBee$nWorkers + } + + if (is.null(nDrones)) { + nDrones <- simParamBee$nDrones + } + if (is.function(nDrones)) { + nDrones <- nDrones(x = x, ...) + } + + if (isColony(x) | isMultiColony(x)) { + registerDoParallel(cores = nThreads) + + if (isColony(x)) { + nCol = 1 + } else if (isMultiColony(x)) { + nCol = nColonies(x) + } + if (is.function(nWorkers)) { + nWorkers <- nWorkers(colony = x, n = nCol, ...) + } + nNWorkers = length(nWorkers) + if (nNWorkers > nCol) { + warning("More than one value in the nWorkers argument, taking only the first value!") + nWorkers <- nWorkers[1:nCol] + } + if (nNWorkers > 1 && nNWorkers < nCol) { + stop("Too few values in the nWorkers argument!") + } + if (new) { + nWorkers <- nWorkers + } else { + nWorkers <- nWorkers - nWorkers(x, simParamBee = simParamBee) + } + + # Drones + nNDrones = length(nDrones) + if (nNDrones > nCol) { + warning("More than one value in the nDrones argument, taking only the first value!") + nDrones <- nDrones[1:nCol] + } + if (nNDrones > 1 && nNDrones < nCol) { + stop("Too few values in the nDrones argument!") + } + if (new) { + nDrones <- nDrones + } else { + nDrones <- nDrones - nDrones(x, simParamBee = simParamBee) + } + + if (sum(nWorkers) > 0) { + x = addWorkers_parallel( + x = x, nInd = nWorkers, new = new, + simParamBee = simParamBee, nThreads = nThreads) + # } else if (nWorkersColony < 0) { + # #THIS IS A PROBLEM _ THE FUNCTION NEEDSD TO RETURN COLONY getWorkers(x, nInd = nWorkers, simParamBee = simParamBee) + # } + # } THIS NEEDS TO GO INTO ADDCASTEPOP + } + if (sum(nDrones) > 0) { + x = addDrones_parallel( + x = x, nInd = nDrones, new = new, + simParamBee = simParamBee, nThreads = nThreads) + # } else if (nDronesColony < 0) { + # #THIS IS A PROBLEM _ THE FUNCTION NEEDSD TO RETURN COLONY getWorkers(x, nInd = nWorkers, simParamBee = simParamBee) + # + } + + # Events + if (resetEvents) { + x <- resetEvents(x) + } + #x@production <- TRUE + } else { + stop("Argument x must be a Colony or MultiColony class object!") + } + validObject(x) + return(x) +} + + +#' @rdname downsize +#' @title Reduce number of workers and remove all drones and virgin queens from +#' a Colony or MultiColony object +#' +#' @description Level 2 function that downsizes a Colony or MultiColony object +#' by removing a proportion of workers, all drones and all virgin queens. +#' Usually in the autumn, such an event occurs in preparation for the winter months. +#' +#' @param x \code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}} +#' @param p numeric, proportion of workers to be removed from the colony; if +#' \code{NULL} then \code{\link[SIMplyBee]{SimParamBee}$downsizeP} is used. +#' If input is \code{\link[SIMplyBee]{MultiColony-class}}, +#' the input could also be a vector of the same length as the number of colonies. If +#' a single value is provided, the same value will be applied to all the colonies +#' @param use character, all the options provided by \code{\link[AlphaSimR]{selectInd}}; +#' it guides the selection of workers that will be removed +#' @param new logical, should we remove all current workers and add a targeted +#' proportion anew (say, create winter workers) +#' @param simParamBee \code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters +#' @param ... additional arguments passed to \code{p} when this argument is a +#' function +#' +#' @return \code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}} with workers reduced and +#' drones/virgin queens removed +#' +#' @examples +#' founderGenomes <- quickHaplo(nInd = 4, nChr = 1, segSites = 50) +#' SP <- SimParamBee$new(founderGenomes) +#' \dontshow{SP$nThreads = 1L} +#' basePop <- createVirginQueens(founderGenomes) +#' drones <- createDrones(x = basePop[1], nInd = 100) +#' droneGroups <- pullDroneGroupsFromDCA(drones, n = 3, nDrones = 12) +#' +#' # Create and cross Colony and MultiColony class +#' colony <- createColony(x = basePop[2]) +#' colony <- cross(colony, drones = droneGroups[[1]]) +#' colony <- buildUp(colony) +#' apiary <- createMultiColony(basePop[3:4], n = 2) +#' apiary <- cross(apiary, drones = droneGroups[c(2, 3)]) +#' apiary <- buildUp(apiary) +#' +#' # Downsize +#' colony <- downsize(x = colony, new = TRUE, use = "rand") +#' colony +#' apiary <- downsize(x = apiary, new = TRUE, use = "rand") +#' apiary[[1]] +#' +#' # Downsize with different numbers +#' nWorkers(apiary); nDrones(apiary) +#' apiary <- downsize(x = apiary, p = c(0.5, 0.1), new = TRUE, use = "rand") +#' nWorkers(apiary); nDrones(apiary) +#' @export +#' +downsize <- function(x, p = NULL, use = "rand", new = FALSE, + simParamBee = NULL, nThreads = NULL, ...) { + if (is.null(simParamBee)) { + simParamBee <- get(x = "SP", envir = .GlobalEnv) + } + if (!is.logical(new)) { + stop("Argument new must be logical!") + } + if (any(1 < p)) { + stop("p must not be higher than 1!") + } else if (any(p < 0)) { + stop("p must not be less than 0!") + } + if (isColony(x)) { + if (hasCollapsed(x)) { + stop(paste0("The colony ", getId(x), " collapsed, hence you can not downsize it!")) + } + if (is.null(p)) { + p <- simParamBee$downsizeP + } + if (is.function(p)) { + p <- p(x, ...) + } + if (length(p) > 1) { + warning("More than one value in the p argument, taking only the first value!") + p <- p[1] + } + if (new == TRUE) { + n <- round(nWorkers(x, simParamBee = simParamBee) * (1 - p)) + x <- addWorkers(x = x, nInd = n, new = TRUE, simParamBee = simParamBee) + } else { + x <- removeWorkers(x = x, p = p, use = use, simParamBee = simParamBee) + } + x <- removeDrones(x = x, p = 1, simParamBee = simParamBee) + x <- removeVirginQueens(x = x, p = 1, simParamBee = simParamBee) + x@production <- FALSE + } else if (isMultiColony(x)) { + nCol <- nColonies(x) + nP <- length(p) + if (nP > 1 && nP < nCol) { + stop("Too few values in the p argument!") + } + if (nP > 1 && nP > nCol) { + warning(paste0("Too many values in the p argument, taking only the first ", nCol, "values!")) + p <- p[1:nCol] + } + for (colony in seq_len(nCol)) { + if (is.null(p)) { + pColony <- NULL + } else { + pColony <- ifelse(nP == 1, p, p[colony]) } x[[colony]] <- downsize( x = x[[colony]], @@ -710,6 +1153,92 @@ downsize <- function(x, p = NULL, use = "rand", new = FALSE, return(x) } +#' @export +downsize_parallel <- function(x, p = NULL, use = "rand", new = FALSE, + simParamBee = NULL, nThreads = NULL, ...) { + if (is.null(simParamBee)) { + simParamBee <- get(x = "SP", envir = .GlobalEnv) + } + if (!is.logical(new)) { + stop("Argument new must be logical!") + } + if (is.null(nThreads)) { + nThreads = simParamBee$nThreads + } + if (any(1 < p)) { + stop("p must not be higher than 1!") + } else if (any(p < 0)) { + stop("p must not be less than 0!") + } + if (isColony(x)) { + if (hasCollapsed(x)) { + stop(paste0("The colony ", getId(x), " collapsed, hence you can not downsize it!")) + } + if (is.null(p)) { + p <- simParamBee$downsizeP + } + if (is.function(p)) { + p <- p(x, ...) + } + if (length(p) > 1) { + warning("More than one value in the p argument, taking only the first value!") + p <- p[1] + } + if (new == TRUE) { + n <- round(nWorkers(x, simParamBee = simParamBee) * (1 - p)) + x <- addWorkers(x = x, nInd = n, new = TRUE, simParamBee = simParamBee) + } else { + x <- removeWorkers(x = x, p = p, use = use, simParamBee = simParamBee) + } + x <- removeDrones(x = x, p = 1, simParamBee = simParamBee) + x <- removeVirginQueens(x = x, p = 1, simParamBee = simParamBee) + x@production <- FALSE + } else if (isMultiColony(x)) { + registerDoParallel(cores = nThreads) + nCol <- nColonies(x) + nP <- length(p) + + if (any(hasCollapsed(x))) { + stop("Some of hte colonies have collapsed, hence you can not downsize them!") + } + if (is.null(p)) { + p <- simParamBee$downsizeP + } + if (is.function(p)) { + p <- p(x, ...) + } + if (nP > 1 && nP < nCol) { + stop("Too few values in the p argument!") + } + if (nP > 1 && nP > nCol) { + warning(paste0("Too many values in the p argument, taking only the first ", nCol, "values!")) + p <- p[1:nCol] + } + if (new == TRUE) { + n <- round(nWorkers(x, simParamBee = simParamBee) * (1 - p)) + x <- addWorkers_parallel(x = x, nInd = n, new = TRUE, + simParamBee = simParamBee, + nThreads = nThreads) + } else { + x <- removeWorkers_parallel(x = x, p = p, use = use, + simParamBee = simParamBee, nThreads = nThreads) + } + x <- removeDrones_parallel(x = x, p = 1, simParamBee = simParamBee, nThreads = nThreads) + x <- removeVirginQueens_parallel(x = x, p = 1, simParamBee = simParamBee, nThreads = nThreads) + for (colony in 1:nCol) { + x[[colony]]@production <- FALSE + } + + } else { + stop("Argument x must be a Colony or MultiColony class object!") + } + + validObject(x) + return(x) +} + + + #' @rdname replaceCastePop #' @title Replace a proportion of caste individuals with new ones #' @@ -854,6 +1383,69 @@ replaceCastePop <- function(x, caste = NULL, p = 1, use = "rand", exact = TRUE, return(x) } + +#' @export +replaceCastePop_parallel <- function(x, caste = NULL, p = 1, use = "rand", exact = TRUE, + year = NULL, simParamBee = NULL) { + if (is.null(simParamBee)) { + simParamBee <- get(x = "SP", envir = .GlobalEnv) + } + if (length(caste) != 1) { + stop("Argument caste must be of length 1!") + } + if (any(1 < p)) { + stop("p must not be higher than 1!") + } else if (any(p < 0)) { + stop("p must not be less than 0!") + } + if (isColony(x) | isMultiColony(x)) { + nP = length(p) + if (isColony(x)) { + nCol = 1 + } else if (isMultiColony(x)) { + nCol = nColonies(x) + } + if (any(hasCollapsed(x))) { + stop(paste0("The colony or some of the colonies have collapsed, hence you can not replace individuals in it!")) + } + if (any(!isQueenPresent(x, simParamBee = simParamBee))) { + stop("Missing queen in at least one colony!") + } + if (nP > 1 && nP < nCol) { + stop("Too few values in the p argument!") + } + if (length(p) > nCol) { + warning(paste0("More than one value in the p argument, taking only the first ", nCol, " values!")) + p <- p[nCol] + } + nInd <- nCaste(x, caste, simParamBee = simParamBee) + if (any(nInd > 0)) { + nIndReplaced <- round(nInd * p) + if (any(nIndReplaced < nInd)) { + + x <- removeCastePop_parallel(x, + caste = caste, + p = p) + nIndAdd <- nInd - nCaste(x, caste, simParamBee = simParamBee) + x <- addCastePop_parallel(x, + caste = caste, + nInd = nIndAdd, + year = year, simParamBee = simParamBee + ) + } + } else { + x <- addCastePop_parallel( + x = x, caste = caste, nInd = nIndReplaced, new = TRUE, + year = year, simParamBee = simParamBee + ) + } + } else { + stop("Argument x must be a Colony or MultiColony class object!") + } + validObject(x) + return(x) +} + #' @describeIn replaceCastePop Replaces some workers in a colony #' @export replaceWorkers <- function(x, p = 1, use = "rand", exact = TRUE, simParamBee = NULL) { @@ -1017,32 +1609,121 @@ removeCastePop <- function(x, caste = NULL, p = 1, use = "rand", return(x) } +#' @export +removeCastePop_parallel <- function(x, caste = NULL, p = 1, use = "rand", + year = NULL, simParamBee = NULL, nThreads = NULL) { + if (is.null(simParamBee)) { + simParamBee <- get(x = "SP", envir = .GlobalEnv) + } + if (is.null(nThreads)) { + nThreads = simParamBee$nThreads + } + if (length(caste) != 1) { + stop("Argument caste must be of length 1!") + } + if (any(1 < p)) { + stop("p must not be higher than 1!") + } else if (any(p < 0)) { + stop("p must not be less than 0!") + } + if (isColony(x)) { + if (hasCollapsed(x)) { + stop(paste0("The colony ", getId(x), " collapsed, hence can not remove individuals from it!")) + } + if (length(p) > 1) { + warning("More than one value in the p argument, taking only the first value!") + p <- p[1] + } + if (p == 1) { + slot(x, caste) <- NULL + } else { + nIndStay <- round(nCaste(x, caste, simParamBee = simParamBee) * (1 - p)) + if (nIndStay > 0) { + slot(x, caste) <- selectInd( + pop = slot(x, caste), + nInd = nIndStay, + use = use, + simParam = simParamBee + ) + } else { + x <- removeCastePop(x, caste, simParamBee = simParamBee) + } + } + } else if (isMultiColony(x)) { + registerDoParallel(cores = nThreads) + nCol <- nColonies(x) + nP <- length(p) + if (nP > 1 && nP < nCol) { + stop("Too few values in the p argument!") + } + if (nP > 1 && nP > nCol) { + warning(paste0("Too many values in the p argument, taking only the first ", nCol, "values!")) + p <- p[1:nCol] + } + x@colonies <- foreach(colony = seq_len(nCol)) %dopar% { + if (is.null(p)) { + pColony <- NULL + } else { + pColony <- ifelse(nP == 1, p, p[colony]) + } + removeCastePop( + x = x[[colony]], caste = caste, + p = pColony, + use = use, + simParamBee = simParamBee + ) + } + } else { + stop("Argument x must be a Colony or MultiColony class object!") + } + validObject(x) + return(x) +} + #' @describeIn removeCastePop Remove queen from a colony #' @export -removeQueen <- function(x, addVirginQueens = FALSE, nVirginQueens = NULL, year = NULL, simParamBee = NULL) { +#' +removeQueen <- function(x, addVirginQueens = FALSE, nVirginQueens = NULL, year = NULL, simParamBee = NULL, nThreads = NULL) { ret <- removeCastePop(x = x, caste = "queen", p = 1, addVirginQueens = addVirginQueens, nVirginQueens = nVirginQueens, year = year, simParamBee = simParamBee) return(ret) } +removeQueen_parallel <- function(x, year = NULL, simParamBee = NULL, nThreads = NULL) { + ret <- removeCastePop_parallel(x = x, caste = "queen", p = 1, year = year, simParamBee = simParamBee, nThreads = nThreads) + return(ret) +} + #' @describeIn removeCastePop Remove workers from a colony #' @export -removeWorkers <- function(x, p = 1, use = "rand", simParamBee = NULL) { - ret <- removeCastePop(x = x, caste = "workers", p = p, use = use, simParamBee = simParamBee) +removeWorkers <- function(x, p = 1, use = "rand", simParamBee = NULL, nThreads = NULL) { + ret <- removeCastePop_parallel(x = x, caste = "workers", p = p, use = use, simParamBee = simParamBee, nThreads = nThreads) + return(ret) +} +removeWorkers_parallel <- function(x, p = 1, use = "rand", simParamBee = NULL, nThreads = NULL) { + ret <- removeCastePop_parallel(x = x, caste = "workers", p = p, use = use, simParamBee = simParamBee, nThreads = nThreads) return(ret) } #' @describeIn removeCastePop Remove workers from a colony #' @export -removeDrones <- function(x, p = 1, use = "rand", simParamBee = NULL) { - ret <- removeCastePop(x = x, caste = "drones", p = p, use = use, simParamBee = simParamBee) +removeDrones <- function(x, p = 1, use = "rand", simParamBee = NULL, nThreads = NULL) { + ret <- removeCastePop_parallel(x = x, caste = "drones", p = p, use = use, simParamBee = simParamBee, nThreads = nThreads) + return(ret) +} +removeDrones_parallel <- function(x, p = 1, use = "rand", simParamBee = NULL, nThreads = NULL) { + ret <- removeCastePop_parallel(x = x, caste = "drones", p = p, use = use, simParamBee = simParamBee, nThreads = nThreads) return(ret) } #' @describeIn removeCastePop Remove virgin queens from a colony #' @export -removeVirginQueens <- function(x, p = 1, use = "rand", simParamBee = NULL) { - ret <- removeCastePop(x = x, caste = "virginQueens", p = p, use = use, simParamBee = simParamBee) +removeVirginQueens_parallel <- function(x, p = 1, use = "rand", simParamBee = NULL, nThreads = NULL) { + ret <- removeCastePop_parallel(x = x, caste = "virginQueens", p = p, use = use, simParamBee = simParamBee, nThreads = nThreads) + return(ret) +} +removeVirginQueens <- function(x, p = 1, use = "rand", simParamBee = NULL, nThreads = NULL) { + ret <- removeCastePop_parallel(x = x, caste = "virginQueens", p = p, use = use, simParamBee = simParamBee, nThreads = nThreads) return(ret) } @@ -1155,6 +1836,46 @@ resetEvents <- function(x, collapse = NULL) { return(x) } +#' @export +resetEvents_parallel <- function(x, collapse = NULL, simParamBee = NULL, nThreads = NULL) { + if (is.null(simParamBee)) { + simParamBee <- get(x = "SP", envir = .GlobalEnv) + } + if (is.null(nThreads)) { + nThreads = simParamBee$nThreads + } + if (isColony(x)) { + x@swarm <- FALSE + x@split <- FALSE + x@supersedure <- FALSE + # Reset collapse only if asked (!is.null(collapse)) or if it was not yet + # turned on (is.null(x@collapse)) + if (is.null(collapse)) { + collapse <- is.null(x@collapse) + } + if (collapse) { + x@collapse <- FALSE + } + x@production <- FALSE + validObject(x) + } else if (isMultiColony(x)) { + registerDoParallel(cores = nThreads) + nCol <- nColonies(x) + x@colonies = foreach(colony = seq_len(nCol)) %dopar% { + resetEvents( + x = x[[colony]], + collapse = collapse, + simParamBee = simParamBee, + nThreads = 1 + ) + } + validObject(x) + } else { + stop("Argument x must be a Colony or MultiColony class object!") + } + return(x) +} + #' @rdname collapse #' @title Collapse #' @@ -1216,6 +1937,32 @@ collapse <- function(x) { return(x) } +#' @export +collapse_parallel <- function(x, simParamBee = NULL, nThreads = NULL) { + if (is.null(simParamBee)) { + simParamBee <- get(x = "SP", envir = .GlobalEnv) + } + if (is.null(nThreads)) { + nThreads = simParamBee$nThreads + } + if (isColony(x)) { + x@collapse <- TRUE + x@production <- FALSE + } else if (isMultiColony(x)) { + registerDoParallel(cores = nThreads) + nCol <- nColonies(x) + x@colonies = foreach(colony = seq_len(nCol)) %dopar% { + collapse(x = x[[colony]], + simParamBee = simParamBee, + nThreads = 1) + } + } else { + stop("Argument x must be a Colony or MultiColony class object!") + } + validObject(x) + return(x) +} + #' @rdname swarm #' @title Swarm #' @@ -1234,10 +1981,6 @@ collapse <- function(x) { #' the input could also be a vector of the same length as the number of colonies. If #' a single value is provided, the same value will be applied to all the colonies #' @param year numeric, year of birth for virgin queens -#' @param nVirginQueens integer, the number of virgin queens to be created in the -#' colony; of these one is randomly selected as the new virgin queen of the -#' remnant colony. If \code{NULL}, the value from \code{simParamBee$nVirginQueens} -#' is used #' @param sampleLocation logical, sample location of the swarm by taking #' the current colony location and adding deviates to each coordinate using #' \code{\link[SIMplyBee]{rcircle}} @@ -1288,7 +2031,7 @@ collapse <- function(x) { #' # Swarm only the pulled colonies #' (swarm(tmp$pulled, p = 0.6)) #' @export -swarm <- function(x, p = NULL, year = NULL, nVirginQueens = NULL, +swarm <- function(x, p = NULL, year = NULL, sampleLocation = TRUE, radius = NULL, simParamBee = NULL, ...) { if (is.null(simParamBee)) { @@ -1334,6 +2077,7 @@ swarm <- function(x, p = NULL, year = NULL, nVirginQueens = NULL, # https://github.com/HighlanderLab/SIMplyBee/issues/160 tmp <- pullWorkers(x = x, nInd = nWorkersSwarm, simParamBee = simParamBee) currentLocation <- getLocation(x) + if (sampleLocation) { newLocation <- c(currentLocation + rcircle(radius = radius)) # c() to convert row-matrix to a numeric vector @@ -1348,11 +2092,10 @@ swarm <- function(x, p = NULL, year = NULL, nVirginQueens = NULL, swarmColony <- setLocation(x = swarmColony, location = newLocation) tmpVirginQueen <- createVirginQueens( - x = x, nInd = nVirginQueens, + x = x, nInd = 1, year = year, simParamBee = simParamBee ) - tmpVirginQueen <- selectInd(tmpVirginQueen, nInd = 1, use = "rand", simParam = simParamBee) remnantColony <- createColony(x = tmpVirginQueen, simParamBee = simParamBee) remnantColony@workers <- getWorkers(tmp$remnant, simParamBee = simParamBee) @@ -1387,37 +2130,182 @@ swarm <- function(x, p = NULL, year = NULL, nVirginQueens = NULL, remnant = createMultiColony(simParamBee = simParamBee) ) } else { - ret <- list( - swarm = createMultiColony(n = nCol, simParamBee = simParamBee), - remnant = createMultiColony(n = nCol, simParamBee = simParamBee) - ) - for (colony in seq_len(nCol)) { - if (is.null(p)) { - pColony <- NULL - } else { - pColony <- ifelse(nP == 1, p, p[colony]) - } - tmp <- swarm(x[[colony]], - p = pColony, - year = year, - nVirginQueens = nVirginQueens, - sampleLocation = sampleLocation, - radius = radius, - simParamBee = simParamBee, ... + ret <- list( + swarm = createMultiColony(n = nCol, simParamBee = simParamBee), + remnant = createMultiColony(n = nCol, simParamBee = simParamBee) + ) + for (colony in seq_len(nCol)) { + if (is.null(p)) { + pColony <- NULL + } else { + pColony <- ifelse(nP == 1, p, p[colony]) + } + tmp <- swarm(x[[colony]], + p = pColony, + year = year, + sampleLocation = sampleLocation, + radius = radius, + simParamBee = simParamBee, ... + ) + ret$swarm[[colony]] <- tmp$swarm + ret$remnant[[colony]] <- tmp$remnant + } + } + } else { + stop("Argument x must be a Colony or MultiColony class object!") + } + + validObject(ret$swarmColony) + validObject(ret$remnantColony) + return(ret) +} + +#' @export +swarm_parallel <- function(x, p = NULL, year = NULL, + sampleLocation = TRUE, radius = NULL, + simParamBee = NULL, nThreads= NULL, ...) { + if (is.null(simParamBee)) { + simParamBee <- get(x = "SP", envir = .GlobalEnv) + } + if (isMultiColony(x)) { + parallel = TRUE + } + if (is.null(nThreads)) { + nThreads = simParamBee$nThreads + } + if (is.null(p)) { + p <- simParamBee$swarmP + } + if (is.null(radius)) { + radius <- simParamBee$swarmRadius + } + if (is.null(nVirginQueens)) { + nVirginQueens <- simParamBee$nVirginQueens + } + if (isColony(x) | isMultiColony(x)) { + if (isColony(x)) { + nCol = 1 + } else if (isMultiColony(x)) { + nCol = nColonies(x) + } + nP <- length(p) + + if (any(hasCollapsed(x))) { + stop(paste0("One of the collonies is collapsed, hence you can not split it!")) + } + if (any(!isQueenPresent(x, simParamBee = simParamBee))) { + stop("No queen present in one of the colonies!") + } + if (any(!isWorkersPresent(x, simParamBee = simParamBee))) { + stop("No workers present in one of the colonies!") + } + if (is.function(p)) { + p <- p(x, ...) + } else { + if (p < 0 | 1 < p) { + stop("p must be between 0 and 1 (inclusive)!") + } + if (length(p) > nCol) { + warning("More than one value in the p argument, taking only the first value!") + p <- p[nCol] + } + if (nP > 1 && nP < nCol) { + stop("Too few values in the p argument!") + } + } + if (is.function(nVirginQueens)) { + nVirginQueens <- nVirginQueens(x, ...) + } + nWorkers <- nWorkers(x, simParamBee = simParamBee) + nWorkersSwarm <- round(nWorkers * p) + + # TODO: Add use="something" to select pWorkers that swarm + # https://github.com/HighlanderLab/SIMplyBee/issues/160 + + tmpVirginQueen <- createCastePop_parallel( + x = x, nInd = 1, + year = year, + caste = "virginQueens", + simParamBee = simParamBee, + nThreads = nThreads + ) + + tmp <- pullCastePop_parallel(x = x, caste = "workers", + nInd = nWorkersSwarm, simParamBee = simParamBee, + nThreads = nThreads) + remnantColony <- tmp$remnant + remnantColony <- removeQueen_parallel(remnantColony, nThreads = nThreads) + if (isColony(x)) { + remnantColony <- reQueen_parallel(remnantColony, + queen = tmpVirginQueen, + simParamBee = simParamBee, + nThreads = nThreads) + } else { + remnantColony <- reQueen_parallel(remnantColony, + queen = mergePops(tmpVirginQueen), + simParamBee = simParamBee, + nThreads = nThreads) + } + currentLocation <- getLocation(x) + + if (sampleLocation) { + newLocation <- lapply(1:nCol, function(x) currentLocation[[x]] + rcircle(n = nCol, radius = radius)[x,]) + # c() to convert row-matrix to a numeric vector + } else { + newLocation <- currentLocation + } + + + if (isColony(x)) { + swarmColony <- createColony(x = x@queen, simParamBee = simParamBee) + # It's not re-queening, but the function also sets the colony id + + swarmColony@workers <- tmp$pulled + swarmColony <- setLocation(x = swarmColony, location = newLocation[[1]]) + + remnantColony <- setLocation(x = remnantColony, location = currentLocation) + + remnantColony@swarm <- TRUE + swarmColony@swarm <- TRUE + + remnantColony@production <- FALSE + swarmColony@production <- FALSE + + ret <- list(swarm = swarmColony, remnant = remnantColony) + } else if (isMultiColony(x)) { + if (nCol == 0) { + ret <- list( + swarm = createMultiColony_parallel(simParamBee = simParamBee), + remnant = createMultiColony_parallel(simParamBee = simParamBee) ) - ret$swarm[[colony]] <- tmp$swarm - ret$remnant[[colony]] <- tmp$remnant + } else { + ret <- list( + swarm = createMultiColony_parallel(x = getQueen(x, collapse = T), + simParamBee = simParamBee, nThreads = nThreads), + remnant = remnantColony + ) + + ret$swarm@colonies <- foreach(colony = seq_len(nCol)) %dopar% { + addCastePop_internal(colony = ret$swarm@colonies[[colony]], + pop = tmp$pulled[[colony]], caste = "workers") + } + + ret$remnant <- setEvents_parallel(ret$remnant, slot = "swarm", value = TRUE, nThreads = nThreads) + ret$swarm <- setEvents_parallel(ret$swarm, slot = "swarm", value = TRUE, nThreads = nThreads) + ret$swarm <- setEvents_parallel(ret$swarm, slot = "production", value = FALSE, nThreads = nThreads) + ret$remnant <- setEvents_parallel(ret$remnant, slot = "production", value = FALSE, nThreads = nThreads) } } } else { stop("Argument x must be a Colony or MultiColony class object!") } - validObject(ret$swarmColony) validObject(ret$remnantColony) return(ret) } + + #' @rdname supersede #' @title Supersede #' @@ -1474,10 +2362,13 @@ swarm <- function(x, p = NULL, year = NULL, nVirginQueens = NULL, #' # Swarm only the pulled colonies #' (supersede(tmp$pulled)) #' @export -supersede <- function(x, year = NULL, nVirginQueens = NULL, simParamBee = NULL, ...) { +supersede <- function(x, year = NULL, nVirginQueens = NULL, simParamBee = NULL, nThreads = NULL, ...) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } + if (is.null(nThreads)) { + nThreads = simParamBee$nThreads + } if (is.null(nVirginQueens)) { nVirginQueens <- simParamBee$nVirginQueens } @@ -1519,6 +2410,75 @@ supersede <- function(x, year = NULL, nVirginQueens = NULL, simParamBee = NULL, return(x) } +#' @export +supersede_parallel <- function(x, addVirginQueens = TRUE, year = NULL, simParamBee = NULL, nThreads = NULL, ...) { + if (is.null(simParamBee)) { + simParamBee <- get(x = "SP", envir = .GlobalEnv) + } + if (is.null(nThreads)) { + nThreads = simParamBee$nThreads + } + if (isColony(x)) { + parallel = FALSE + } else if (isMultiColony(x)) { + parallel = TRUE + } + if (is.null(nVirginQueens)) { + nVirginQueens <- simParamBee$nVirginQueens + } + if (isColony(x)) { + if (hasCollapsed(x)) { + stop(paste0("The colony ", getId(x), " collapsed, hence it can not supresede!")) + } + if (!isQueenPresent(x, simParamBee = simParamBee)) { + stop("No queen present in the colony!") + } + if (is.function(nVirginQueens)) { + nVirginQueens <- nVirginQueens(x, ...) + } + + if (!parallel) { + x <- addVirginQueens(x, nInd = 1) + } + x <- removeQueen_parallel(x, year = year, simParamBee = simParamBee, nThreads = nThreads) + # TODO: We could consider that a non-random virgin queen prevails (say the most + # aggressive one), by creating many virgin queens and then picking the + # one with highest pheno for competition or some other criteria + # https://github.com/HighlanderLab/SIMplyBee/issues/239 + x@supersedure <- TRUE + } else if (isMultiColony(x)) { + registerDoParallel(cores = nThreads) + nCol <- nColonies(x) + if (nCol == 0) { + x <- createMultiColony_parallel(simParamBee = simParamBee, nThreads = nThreads) + } else { + virginQueens = createCastePop_parallel(x, caste = "virginQueens", nInd = 1, nThreads = nThreads) + + combine_list <- function(a, b) { + if (length(a) == 1) { + c(list(a), list(b)) + } else { + c(a, list(b)) + } + } + x@colonies <- foreach(colony = seq_len(nCol), .combine = combine_list) %do% { + supersede_parallel(x[[colony]], + year = year, + simParamBee = simParamBee, + nThreads = nThreads, ... + ) + } + x@colonies <- foreach(colony = seq_len(nColonies(x))) %dopar% { + addCastePop_internal(colony = x[[colony]], pop = virginQueens[[colony]], caste = "virginQueens") + } + } + } else { + stop("Argument x must be a Colony or MultiColony class object!") + } + validObject(x) + return(x) +} + #' @rdname split #' @title Split colony in two MultiColony #' @@ -1683,6 +2643,147 @@ split <- function(x, p = NULL, year = NULL, simParamBee = NULL, ...) { return(ret) } +#' @export +split_parallel <- function(x, p = NULL, year = NULL, simParamBee = NULL, nThreads = NULL, ...) { + if (is.null(simParamBee)) { + simParamBee <- get(x = "SP", envir = .GlobalEnv) + } + if (is.null(nThreads)) { + nThreads = simParamBee$nThreads + } + if (is.null(p)) { + p <- simParamBee$splitP + } + if (isMultiColony(x)) { + parallel = TRUE + } + + if (isColony(x) | isMultiColony(x)) { + registerDoParallel(cores = nThreads) + if (isColony(x)) { + nCol = 1 + } else if (isMultiColony(x)) { + nCol = nColonies(x) + } + nP <- length(p) + + location = getLocation(x) + if (any(hasCollapsed(x))) { + stop(paste0("One of the collonies is collapsed, hence you can not split it!")) + } + if (any(!isQueenPresent(x, simParamBee = simParamBee))) { + stop("No queen present in one of the colonies!") + } + if (any(!isWorkersPresent(x, simParamBee = simParamBee))) { + stop("No workers present in one of the colonies!") + } + if (is.function(p)) { + p <- p(x, ...) + } else { + if (p < 0 | 1 < p) { + stop("p must be between 0 and 1 (inclusive)!") + } + if (length(p) > nCol) { + warning("More than one value in the p argument, taking only the first value!") + p <- p[nCol] + } + if (nP > 1 && nP < nCol) { + stop("Too few values in the p argument!") + } + } + nWorkers <- nWorkers(x, simParamBee = simParamBee) + nWorkersSplit <- round(nWorkers * p) + # TODO: Split colony at random by default, but we could make it as a + # function of some parameters + # https://github.com/HighlanderLab/SIMplyBee/issues/179 + tmp <- pullCastePop_parallel(x = x, caste = "workers", nInd = nWorkersSplit, simParamBee = simParamBee) #Tole je treba sparalelizirat + remnantColony <- tmp$remnant + + tmpVirginQueens <- createCastePop_parallel( + x = x, nInd = 1, + year = year, + caste = "virginQueens", + simParamBee = simParamBee, + nThreads = nThreads + ) + + if (isColony(x)) { + + # Workers raise virgin queens from eggs laid by the queen (assuming) that + # a frame of brood is also provided to the split and then one random virgin + # queen prevails, so we create just one + # TODO: Could consider that a non-random one prevails (say the most aggressive + # one), by creating many virgin queens and then picking the one with + # highest pheno for competition or some other criteria + # https://github.com/HighlanderLab/SIMplyBee/issues/239 + + splitColony <- createColony(x = tmpVirginQueens, simParamBee = simParamBee) + splitColony <- setLocation(x = splitColony, location = location) + + splitColony@workers <- tmp$pulled + + remnantColony@split <- TRUE + splitColony@split <- TRUE + + remnantColony@production <- TRUE + splitColony@production <- FALSE + + ret <- list(split = splitColony, remnant = remnantColony) + } else if (isMultiColony(x)) { + if (nCol == 0) { + ret <- list( + split = createMultiColony_parallel(simParamBee = simParamBee, nThreads = nThreads), + remnant = createMultiColony_parallel(simParamBee = simParamBee, nThreads = nThreads) + ) + } else { + ret <- list( + split = createMultiColony_parallel(x = mergePops(tmpVirginQueens), n = nCol, + simParamBee = simParamBee, nThreads = nThreads), + remnant = tmp$remnant + + ) + ret$split <- setLocation_parallel(x = ret$split, location = location, nThreads = nThreads) + + ret$split@colonies <- foreach(colony = seq_len(nCol)) %dopar% { + addCastePop_internal(colony = ret$split@colonies[[colony]], + pop = tmp$pulled[[colony]], caste = "workers") + } + ret$split <- setEvents_parallel(ret$split, slot = "split", value = TRUE, nThreads = nThreads) + ret$remnant <- setEvents_parallel(ret$remnant, slot = "split", value = TRUE, nThreads = nThreads) + ret$split <- setEvents_parallel(ret$split, slot = "production", value = FALSE, nThreads = nThreads) + ret$remnant <- setEvents_parallel(ret$remnant, slot = "production", value = TRUE, nThreads = nThreads) + } + } + } else { + stop("Argument x must be a Colony or MultiColony class object!") + } + validObject(ret$splitColony) + validObject(ret$remnantColony) + return(ret) +} + +#' @export +# Helpi function - put it in auxiliary +setEvents_parallel <- function(x, slot, value, nThreads = NULL, simParamBee = NULL) { + if (is.null(simParamBee)) { + simParamBee <- get(x = "SP", envir = .GlobalEnv) + } + if (is.null(nThreads)) { + nThreads = simParamBee$nThreads + } + if (isColony(x)) { + slot(x, slot) <- value + } + if (isMultiColony(x)) { + registerDoParallel(cores = nThreads) + x@colonies <- foreach(colony = seq_len(nColonies(x))) %dopar% { + setEvents_parallel(x[[colony]], slot, value) + } + } + return(x) +} + + #' @rdname combine #' @title Combine two colony objects #' @@ -1762,6 +2863,43 @@ combine <- function(strong, weak) { return(strong) } +#' @export +combine_parallel <- function(strong, weak, simParamBee = NULL, nThreads = NULL) { + if (isColony(strong) & isColony(weak)) { + if (is.null(simParamBee)) { + simParamBee <- get(x = "SP", envir = .GlobalEnv) + } + if (is.null(nThreads)) { + nThreads = simParamBee$nThreads + } + if (hasCollapsed(strong)) { + stop(paste0("The colony ", getId(strong), " (strong) has collapsed, hence you can not combine it!")) + } + if (hasCollapsed(weak)) { + stop(paste0("The colony ", getId(weak), " (weak) has collapsed, hence you can not combine it!")) + } + strong@workers <- c(strong@workers, weak@workers) + strong@drones <- c(strong@drones, weak@drones) + } else if (isMultiColony(strong) & isMultiColony(weak)) { + registerDoParallel(cores = nThreads) + if (nColonies(weak) == nColonies(strong)) { + nCol <- nColonies(weak) + strong@colonies <- foreach(colony = seq_len(nCol)) %dopar% { + combine(strong = strong[[colony]], + weak = weak[[colony]], + simParamBee = simParamBee, + nThreads = 1) + } + } else { + stop("Weak and strong MultiColony objects must be of the same length!") + } + } else { + stop("Argument strong and weak must both be either a Colony or MultiColony class objects!") + } + return(strong) +} + + #' @rdname setLocation #' @title Set colony location #' @@ -1870,3 +3008,80 @@ setLocation <- function(x, location = c(0, 0)) { validObject(x) return(x) } + +#' @export +setLocation_parallel <- function(x, location = c(0, 0), simParamBee = NULL, nThreads = NULL) { + if (is.null(simParamBee)) { + simParamBee <- get(x = "SP", envir = .GlobalEnv) + } + if (is.null(nThreads)) { + nThreads = simParamBee$nThreads + } + if (isColony(x)) { + if (is.list(location)) { # is.list() captures also is.data.frame() + stop("Argument location must be numeric, when x is a Colony class object!") + } + if (is.numeric(location) && length(location) != 2) { + stop("When argument location is a numeric, it must be of length 2!") + } + x@location <- location + } else if (isMultiColony(x)) { + registerDoParallel(cores = nThreads) + n <- nColonies(x) + if (!is.null(location)) { + if (is.numeric(location)) { + if (length(location) != 2) { + stop("When argument location is a numeric, it must be of length 2!") + } + } else if (is.data.frame(location)) { + if (nrow(location) != n) { + stop("When argument location is a data.frame, it must have as many rows as the number of colonies!") + } + if (ncol(location) != 2) { + stop("When argument location is a data.frame, it must have 2 columns!") + } + } else if (is.list(location)) { + if (length(location) != n) { + stop("When argument location is a list, it must be of length equal to the number of colonies!") + } + tmp <- sapply(X = location, FUN = length) + if (!all(tmp == 2)) { + stop("When argument location is a list, each list node must be of length 2!") + } + } else if (is.numeric(location)) { + if (length(location) != 2) { + stop("When argument location is a numeric, it must be of length 2!") + } + } else { + stop("Argument location must be numeric, list, or data.frame!") + } + } + combine_list <- function(a, b) { + if (length(a) == 1) { + c(list(a), list(b)) + } else { + c(a, list(b)) + } + } + x@colonies <- foreach(colony = seq_len(n), .combine = combine_list) %do% { + if (is.data.frame(location)) { + loc <- location[colony, ] + loc <- c(loc$x, loc$y) + } else if (is.list(location)) { + loc <- location[[colony]] + } else { + loc <- location + } + + if (!is.null(x[[colony]])) { + x[[colony]]@location <- loc + } + + x[[colony]] + } + } else { + stop("Argument x must be a Colony or MultiColony class object!") + } + validObject(x) + return(x) +} diff --git a/R/Functions_L3_Colonies.R b/R/Functions_L3_Colonies.R index b8dbc191..76002ac4 100644 --- a/R/Functions_L3_Colonies.R +++ b/R/Functions_L3_Colonies.R @@ -80,6 +80,46 @@ createMultiColony <- function(x = NULL, n = NULL, simParamBee = NULL) { return(ret) } +#' @export +createMultiColony_parallel <- function(x = NULL, n = NULL, simParamBee = NULL, nThreads = NULL) { + if (is.null(simParamBee)) { + simParamBee <- get(x = "SP", envir = .GlobalEnv) + } + if (is.null(nThreads)) { + nThreads = simParamBee$nThreads + } + registerDoParallel(cores = nThreads) + if (is.null(x)) { + if (is.null(n)) { + ret <- new(Class = "MultiColony") + } else { + ret <- new(Class = "MultiColony", colonies = vector(mode = "list", length = n)) + } + } else { + if (!isPop(x)) { + stop("Argument x must be a Pop class object!") + } + if (any(!(isVirginQueen(x, simParamBee = simParamBee) | isQueen(x, simParamBee = simParamBee)))) { + stop("Individuals in x must be virgin queens or queens!") + } + if (is.null(n)) { + n <- nInd(x) + } + if (nInd(x) < n) { + stop("Not enough individuals in the x to create n colonies!") + } + ret <- new(Class = "MultiColony", colonies = vector(mode = "list", length = n)) + ids = (simParamBee$lastColonyId+1):(simParamBee$lastColonyId + n) + ret@colonies <- foreach(colony = seq_len(n)) %dopar% { + createColony(x = x[colony], simParamBee = simParamBee, id = ids[colony]) + } + # WHY IS IT NOT UPDATING SP??? + simParamBee$updateLastColonyId(n = n) + } + validObject(ret) + return(ret) +} + #' @rdname selectColonies #' @title Select colonies from MultiColony object #' diff --git a/man/MultiColony-class.Rd b/man/MultiColony-class.Rd index d81e7d6f..c898062b 100644 --- a/man/MultiColony-class.Rd +++ b/man/MultiColony-class.Rd @@ -7,8 +7,8 @@ \alias{show,MultiColony-method} \alias{c,MultiColony-method} \alias{c,MultiColonyOrNULL-method} -\alias{[,MultiColony,integerOrNumericOrLogical-method} -\alias{[,MultiColony,character-method} +\alias{[,MultiColony,integerOrNumericOrLogical,ANY,ANY-method} +\alias{[,MultiColony,character,ANY,ANY-method} \alias{[[,MultiColony,integerOrNumericOrLogical-method} \alias{[[,MultiColony,character-method} \alias{[<-,MultiColony,integerOrNumericOrLogicalOrCharacter,ANY,MultiColony-method} @@ -23,9 +23,9 @@ isMultiColony(x) \S4method{c}{MultiColonyOrNULL}(x, ...) -\S4method{[}{MultiColony,integerOrNumericOrLogical}(x, i, j, drop) +\S4method{[}{MultiColony,integerOrNumericOrLogical,ANY,ANY}(x, i, j, drop) -\S4method{[}{MultiColony,character}(x, i, j, drop) +\S4method{[}{MultiColony,character,ANY,ANY}(x, i, j, drop) \S4method{[[}{MultiColony,integerOrNumericOrLogical}(x, i) diff --git a/man/SimParamBee.Rd b/man/SimParamBee.Rd index 664475f4..3507dbf8 100644 --- a/man/SimParamBee.Rd +++ b/man/SimParamBee.Rd @@ -317,6 +317,9 @@ generate this object} \item \href{#method-SimParamBee-new}{\code{SimParamBee$new()}} \item \href{#method-SimParamBee-addToCaste}{\code{SimParamBee$addToCaste()}} \item \href{#method-SimParamBee-changeCaste}{\code{SimParamBee$changeCaste()}} +\item \href{#method-SimParamBee-updatePedigree}{\code{SimParamBee$updatePedigree()}} +\item \href{#method-SimParamBee-updateCaste}{\code{SimParamBee$updateCaste()}} +\item \href{#method-SimParamBee-updateLastId}{\code{SimParamBee$updateLastId()}} \item \href{#method-SimParamBee-updateLastColonyId}{\code{SimParamBee$updateLastColonyId()}} \item \href{#method-SimParamBee-clone}{\code{SimParamBee$clone()}} } @@ -356,7 +359,6 @@ generate this object}
  • AlphaSimR::SimParam$switchGenMap()
  • AlphaSimR::SimParam$switchMaleMap()
  • AlphaSimR::SimParam$switchTrait()
    • -
  • AlphaSimR::SimParam$updateLastId()
    • }} @@ -532,6 +534,63 @@ SP$caste } +} +\if{html}{\out{
    }} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-SimParamBee-updatePedigree}{}}} +\subsection{Method \code{updatePedigree()}}{ +A function to update the pedigree. + For internal use only. +\subsection{Usage}{ +\if{html}{\out{
    }}\preformatted{SimParamBee$updatePedigree(pedigree)}\if{html}{\out{
    }} +} + +\subsection{Arguments}{ +\if{html}{\out{
    }} +\describe{ +\item{\code{pedigree}}{matrix, pedigree matrix to be added} +} +\if{html}{\out{
    }} +} +} +\if{html}{\out{
    }} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-SimParamBee-updateCaste}{}}} +\subsection{Method \code{updateCaste()}}{ +A function to update the caste + For internal use only. +\subsection{Usage}{ +\if{html}{\out{
    }}\preformatted{SimParamBee$updateCaste(caste)}\if{html}{\out{
    }} +} + +\subsection{Arguments}{ +\if{html}{\out{
    }} +\describe{ +\item{\code{caste}}{vector, named vector of castes to be added} +} +\if{html}{\out{
    }} +} +} +\if{html}{\out{
    }} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-SimParamBee-updateLastId}{}}} +\subsection{Method \code{updateLastId()}}{ +A function to update the last + ID everytime we create an individual + For internal use only. +\subsection{Usage}{ +\if{html}{\out{
    }}\preformatted{SimParamBee$updateLastId(n = 1)}\if{html}{\out{
    }} +} + +\subsection{Arguments}{ +\if{html}{\out{
    }} +\describe{ +\item{\code{n}}{integer, how many individuals to add} + +\item{\code{lastId}}{integer, last colony ID assigned} +} +\if{html}{\out{
    }} +} } \if{html}{\out{
    }} \if{html}{\out{}} @@ -541,12 +600,14 @@ A function to update the colony last ID everytime we create a Colony-class with createColony. For internal use only. \subsection{Usage}{ -\if{html}{\out{
    }}\preformatted{SimParamBee$updateLastColonyId()}\if{html}{\out{
    }} +\if{html}{\out{
    }}\preformatted{SimParamBee$updateLastColonyId(n = 1)}\if{html}{\out{
    }} } \subsection{Arguments}{ \if{html}{\out{
    }} \describe{ +\item{\code{n}}{integer, how many colonies to add} + \item{\code{lastColonyId}}{integer, last colony ID assigned} } \if{html}{\out{
    }} diff --git a/man/createCastePop.Rd b/man/createCastePop.Rd index 4766cbd1..1576aff7 100644 --- a/man/createCastePop.Rd +++ b/man/createCastePop.Rd @@ -19,9 +19,26 @@ createCastePop( ... ) -createWorkers(x, nInd = NULL, exact = FALSE, simParamBee = NULL, ...) +createWorkers( + x, + nInd = NULL, + exact = FALSE, + simParamBee = NULL, + returnSP = FALSE, + ids = NULL, + nThreads = NULL, + ... +) -createDrones(x, nInd = NULL, simParamBee = NULL, ...) +createDrones( + x, + nInd = NULL, + simParamBee = NULL, + returnSP = FALSE, + ids = NULL, + nThreads = NULL, + ... +) createVirginQueens( x, @@ -30,6 +47,9 @@ createVirginQueens( editCsd = TRUE, csdAlleles = NULL, simParamBee = NULL, + returnSP = FALSE, + ids = NULL, + nThreads = NULL, ... ) } diff --git a/man/createColony.Rd b/man/createColony.Rd index a8a96649..c4a24899 100644 --- a/man/createColony.Rd +++ b/man/createColony.Rd @@ -4,7 +4,7 @@ \alias{createColony} \title{Create a new Colony} \usage{ -createColony(x = NULL, simParamBee = NULL) +createColony(x = NULL, simParamBee = NULL, id = NULL) } \arguments{ \item{x}{\code{\link[AlphaSimR]{Pop-class}}, one queen or virgin queen(s)} diff --git a/man/downsize.Rd b/man/downsize.Rd index e418ad0b..e581e2f3 100644 --- a/man/downsize.Rd +++ b/man/downsize.Rd @@ -5,7 +5,15 @@ \title{Reduce number of workers and remove all drones and virgin queens from a Colony or MultiColony object} \usage{ -downsize(x, p = NULL, use = "rand", new = FALSE, simParamBee = NULL, ...) +downsize( + x, + p = NULL, + use = "rand", + new = FALSE, + simParamBee = NULL, + nThreads = NULL, + ... +) } \arguments{ \item{x}{\code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}}} diff --git a/man/removeCastePop.Rd b/man/removeCastePop.Rd index 9acecac0..6e07ea9b 100644 --- a/man/removeCastePop.Rd +++ b/man/removeCastePop.Rd @@ -5,7 +5,7 @@ \alias{removeQueen} \alias{removeWorkers} \alias{removeDrones} -\alias{removeVirginQueens} +\alias{removeVirginQueens_parallel} \title{Remove a proportion of caste individuals from a colony} \usage{ removeCastePop( @@ -24,14 +24,21 @@ removeQueen( addVirginQueens = FALSE, nVirginQueens = NULL, year = NULL, - simParamBee = NULL + simParamBee = NULL, + nThreads = NULL ) -removeWorkers(x, p = 1, use = "rand", simParamBee = NULL) +removeWorkers(x, p = 1, use = "rand", simParamBee = NULL, nThreads = NULL) -removeDrones(x, p = 1, use = "rand", simParamBee = NULL) +removeDrones(x, p = 1, use = "rand", simParamBee = NULL, nThreads = NULL) -removeVirginQueens(x, p = 1, use = "rand", simParamBee = NULL) +removeVirginQueens_parallel( + x, + p = 1, + use = "rand", + simParamBee = NULL, + nThreads = NULL +) } \arguments{ \item{x}{\code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}}} @@ -72,7 +79,7 @@ Level 2 function that removes a proportion of virgin queens of \item \code{removeDrones()}: Remove workers from a colony -\item \code{removeVirginQueens()}: Remove virgin queens from a colony +\item \code{removeVirginQueens_parallel()}: Remove virgin queens from a colony }} \examples{ diff --git a/man/supersede.Rd b/man/supersede.Rd index 04291135..90da056a 100644 --- a/man/supersede.Rd +++ b/man/supersede.Rd @@ -4,7 +4,14 @@ \alias{supersede} \title{Supersede} \usage{ -supersede(x, year = NULL, nVirginQueens = NULL, simParamBee = NULL, ...) +supersede( + x, + year = NULL, + nVirginQueens = NULL, + simParamBee = NULL, + nThreads = NULL, + ... +) } \arguments{ \item{x}{\code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}}} diff --git a/man/swarm.Rd b/man/swarm.Rd index e178fe26..34d2c198 100644 --- a/man/swarm.Rd +++ b/man/swarm.Rd @@ -8,7 +8,6 @@ swarm( x, p = NULL, year = NULL, - nVirginQueens = NULL, sampleLocation = TRUE, radius = NULL, simParamBee = NULL, @@ -26,11 +25,6 @@ a single value is provided, the same value will be applied to all the colonies} \item{year}{numeric, year of birth for virgin queens} -\item{nVirginQueens}{integer, the number of virgin queens to be created in the -colony; of these one is randomly selected as the new virgin queen of the -remnant colony. If \code{NULL}, the value from \code{simParamBee$nVirginQueens} -is used} - \item{sampleLocation}{logical, sample location of the swarm by taking the current colony location and adding deviates to each coordinate using \code{\link[SIMplyBee]{rcircle}}} From d0c561c4a20f007cd6484302623da967d4f59d23 Mon Sep 17 00:00:00 2001 From: janaobsteter Date: Wed, 9 Apr 2025 12:28:41 +0200 Subject: [PATCH 03/42] Adding export to cross_parallel --- NAMESPACE | 1 + R/Functions_L1_Pop.R | 1 + man/MultiColony-class.Rd | 4 ++-- 3 files changed, 4 insertions(+), 2 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index be1bdc2e..e2a34b3d 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -40,6 +40,7 @@ export(createMultiColony_parallel) export(createVirginQueens) export(createWorkers) export(cross) +export(cross_parallel) export(downsize) export(downsizePUnif) export(downsize_parallel) diff --git a/R/Functions_L1_Pop.R b/R/Functions_L1_Pop.R index 24fad680..f0e66d18 100644 --- a/R/Functions_L1_Pop.R +++ b/R/Functions_L1_Pop.R @@ -1902,6 +1902,7 @@ cross <- function(x, return(ret) } +#' @export cross_parallel <- function(x, crossPlan = NULL, drones = NULL, diff --git a/man/MultiColony-class.Rd b/man/MultiColony-class.Rd index c898062b..2ec3e8ad 100644 --- a/man/MultiColony-class.Rd +++ b/man/MultiColony-class.Rd @@ -7,8 +7,8 @@ \alias{show,MultiColony-method} \alias{c,MultiColony-method} \alias{c,MultiColonyOrNULL-method} -\alias{[,MultiColony,integerOrNumericOrLogical,ANY,ANY-method} -\alias{[,MultiColony,character,ANY,ANY-method} +\alias{[,MultiColony,integerOrNumericOrLogical-method} +\alias{[,MultiColony,character-method} \alias{[[,MultiColony,integerOrNumericOrLogical-method} \alias{[[,MultiColony,character-method} \alias{[<-,MultiColony,integerOrNumericOrLogicalOrCharacter,ANY,MultiColony-method} From da5b0de3b52cbc4b387e840d48d2ec329beb76c0 Mon Sep 17 00:00:00 2001 From: janaobsteter Date: Fri, 11 Apr 2025 13:49:12 +0200 Subject: [PATCH 04/42] renaming to enable switching from parallel (p) to non-parallel (np) --- R/Functions_L0_auxilary.R | 29 ---- R/Functions_L1_Pop.R | 114 ++++++++------- R/Functions_L2_Colony.R | 292 ++++++++++---------------------------- R/Functions_L3_Colonies.R | 4 +- 4 files changed, 142 insertions(+), 297 deletions(-) diff --git a/R/Functions_L0_auxilary.R b/R/Functions_L0_auxilary.R index 7c492e44..8de31c33 100644 --- a/R/Functions_L0_auxilary.R +++ b/R/Functions_L0_auxilary.R @@ -342,35 +342,6 @@ calcQueensPHomBrood <- function(x, simParamBee = NULL) { } -calcQueensPHomBrood_parallel <- function(x, simParamBee = NULL) { - if (is.null(simParamBee)) { - simParamBee <- get(x = "SP", envir = .GlobalEnv) - } - if (isPop(x)) { - ret <- rep(x = NA, times = nInd(x)) - for (ind in seq_len(nInd(x))) { - - queensCsd <- apply( - X = getCsdAlleles(x[ind], simParamBee = simParamBee), MARGIN = 1, - FUN = function(x) paste0(x, collapse = "") - ) - fathersCsd <- apply( - X = getCsdAlleles(x@misc$fathers[[ind]], simParamBee = simParamBee), MARGIN = 1, - FUN = function(x) paste0(x, collapse = "") - ) - nComb <- length(queensCsd) * length(fathersCsd) - ret[ind] <- sum(fathersCsd %in% queensCsd) / nComb - } - } else if (isColony(x)) { - ret <- calcQueensPHomBrood(x = x@queen) - } else if (isMultiColony(x)) { - ret <- sapply(X = x@colonies, FUN = calcQueensPHomBrood) - names(ret) <- getId(x) - } else { - stop("Argument x must be a Pop, Colony, or MultiColony class object!") - } - return(ret) -} #' @describeIn calcQueensPHomBrood Expected percentage of csd homozygous brood #' of a queen / colony diff --git a/R/Functions_L1_Pop.R b/R/Functions_L1_Pop.R index 24fad680..23f43b7d 100644 --- a/R/Functions_L1_Pop.R +++ b/R/Functions_L1_Pop.R @@ -397,11 +397,11 @@ getVirginQueens <- function(x, nInd = NULL, use = "rand", collapse = FALSE, simP # TODO: explore options for implementing difference between workers' and queens' # patrilines # https://github.com/HighlanderLab/SIMplyBee/issues/78 -createCastePop <- function(x, caste = NULL, nInd = NULL, - exact = TRUE, year = NULL, - editCsd = TRUE, csdAlleles = NULL, - simParamBee = NULL, - ...) { +createCastePop_np <- function(x, caste = NULL, nInd = NULL, + exact = TRUE, year = NULL, + editCsd = TRUE, csdAlleles = NULL, + simParamBee = NULL, + ...) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } @@ -557,14 +557,14 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, } #' @export -createCastePop_parallel <- function(x, caste = NULL, nInd = NULL, - year = NULL, - editCsd = TRUE, csdAlleles = NULL, - simParamBee = NULL, - returnSP = FALSE, - ids = NULL, - nThreads = NULL, - ...) { +createCastePop <- function(x, caste = NULL, nInd = NULL, + year = NULL, + editCsd = TRUE, csdAlleles = NULL, + simParamBee = NULL, + returnSP = FALSE, + ids = NULL, + nThreads = NULL, + ...) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } @@ -675,9 +675,9 @@ createCastePop_parallel <- function(x, caste = NULL, nInd = NULL, # } } else if (caste == "virginQueens") { # Creating virgin queens if input is a Colony - ret <- createCastePop_parallel(x = x, caste = "workers", - nInd = nInd, exact = TRUE, simParamBee = simParamBee, - returnSP = returnSP, ids = ids, nThreads = 1, ...) + ret <- createCastePop(x = x, caste = "workers", + nInd = nInd, exact = TRUE, simParamBee = simParamBee, + returnSP = returnSP, ids = ids, nThreads = 1, ...) simParamBee$changeCaste(id = ret$workers@id, caste = "virginQueens") if (!returnSP) { ret <- ret$workers @@ -770,7 +770,7 @@ createCastePop_parallel <- function(x, caste = NULL, nInd = NULL, } else { colonyIds = base::split(ids, rep(seq_along(nInd), nInd))[[as.character(colony)]] } - createCastePop_parallel( + createCastePop( x = x[[colony]], caste = caste, nInd = nIndColony, exact = exact, @@ -825,12 +825,13 @@ createCastePop_parallel <- function(x, caste = NULL, nInd = NULL, #' @describeIn createCastePop Create workers from a colony #' @export -createWorkers <- function(x, nInd = NULL, exact = FALSE, simParamBee = NULL, +createWorkers <- function(x, nInd = NULL, simParamBee = NULL, returnSP = FALSE, ids = NULL, nThreads = NULL, ...) { + ret <- createCastePop(x, caste = "workers", nInd = nInd, - exact = exact, simParamBee = simParamBee, + simParamBee = simParamBee, returnSP = FALSE, ids = NULL, nThreads = NULL, ...) @@ -1331,8 +1332,8 @@ pullDroneGroupsFromDCA <- function(DCA, n, nDrones = NULL, #' pullCastePop(apiary, caste = "queen", collapse = TRUE) #' pullCastePop(apiary, caste = "virginQueens", collapse = TRUE) #' @export -pullCastePop <- function(x, caste, nInd = NULL, use = "rand", - removeFathers = TRUE, collapse = FALSE, simParamBee = NULL) { +pullCastePop_np <- function(x, caste, nInd = NULL, use = "rand", + removeFathers = TRUE, collapse = FALSE, simParamBee = NULL) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } @@ -1410,9 +1411,9 @@ pullCastePop <- function(x, caste, nInd = NULL, use = "rand", } #' @export -pullCastePop_parallel <- function(x, caste, nInd = NULL, use = "rand", - removeFathers = TRUE, collapse = FALSE, simParamBee = NULL, - nThreads = NULL) { +pullCastePop <- function(x, caste, nInd = NULL, use = "rand", + removeFathers = TRUE, collapse = FALSE, simParamBee = NULL, + nThreads = NULL) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } @@ -1708,16 +1709,16 @@ pullVirginQueens <- function(x, nInd = NULL, use = "rand", collapse = FALSE, sim #' \code{\link[SIMplyBee]{createMatingStationDCA}} #' #' @export -cross <- function(x, - crossPlan = NULL, - drones = NULL, - droneColonies = NULL, - nDrones = NULL, - spatial = FALSE, - radius = NULL, - checkCross = "error", - simParamBee = NULL, - ...) { +cross_np <- function(x, + crossPlan = NULL, + drones = NULL, + droneColonies = NULL, + nDrones = NULL, + spatial = FALSE, + radius = NULL, + checkCross = "error", + simParamBee = NULL, + ...) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } @@ -1902,17 +1903,17 @@ cross <- function(x, return(ret) } -cross_parallel <- function(x, - crossPlan = NULL, - drones = NULL, - droneColonies = NULL, - nDrones = NULL, - spatial = FALSE, - radius = NULL, - checkCross = "error", - simParamBee = NULL, - nThreads = NULL, - ...) { +cross <- function(x, + crossPlan = NULL, + drones = NULL, + droneColonies = NULL, + nDrones = NULL, + spatial = FALSE, + radius = NULL, + checkCross = "error", + simParamBee = NULL, + nThreads = NULL, + ...) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } @@ -1992,12 +1993,12 @@ cross_parallel <- function(x, inputId <- getId(x) if (isColony(x)) { colony <- x - x <- pullCastePop_parallel(x, caste = "virginQueens", nInd = 1)$pulled + x <- pullCastePop(x, caste = "virginQueens", nInd = 1)$pulled ID_by_input <- data.frame(inputId = inputId, virginId = getId(x)) } else if (isMultiColony(x)) { multicolony <- x - x <- pullCastePop_parallel(x, caste = "virginQueens", nInd = 1)$pulled + x <- pullCastePop(x, caste = "virginQueens", nInd = 1)$pulled ID_by_input <- data.frame(inputId = inputId, virginId = unlist(sapply(x, FUN = function(y) getId(y)))) x <- mergePops(x) @@ -2015,6 +2016,17 @@ cross_parallel <- function(x, nD = nDrones } + if ((length(nD) == 1) & nVirgin > 1) { + nD = rep(nD, nVirgin) + } + if ((length(nD) != 1) & (length(nD) < nVirgin)) { + stop("Too few values in the nDrones argument!") + } + if (length(nD) > 1 && length(nD) > nVirgin) { + warning(paste0("Too many values in the nDrones argument, taking only the first ", nVirgin, "values!")) + nD <- nD[1:nVirgin] + } + if (crossPlan_create | crossPlan_given) { if (crossPlan_create) { crossPlan <- createCrossPlan(x = x, @@ -2062,8 +2074,8 @@ cross_parallel <- function(x, colnames(crossPlanDF_DPCtable) <- c("DPC", "noDrones") selectedDPC = droneColonies[as.character(crossPlanDF_DPCtable$DPC)] - dronesByDPC <- createCastePop_parallel(selectedDPC, caste = "drones", - nInd = as.integer(crossPlanDF_DPCtable$noDrones), simParamBee = simParamBee) + dronesByDPC <- createCastePop(selectedDPC, caste = "drones", + nInd = as.integer(crossPlanDF_DPCtable$noDrones), simParamBee = simParamBee) dronesByDPC_DF <- data.frame(DPC = rep(names(dronesByDPC), as.vector(crossPlanDF_DPCtable$noDrones)), droneID = unlist(sapply(dronesByDPC, FUN = function(x) getId(x)))) %>% arrange(as.numeric(DPC)) @@ -2147,8 +2159,8 @@ cross_parallel <- function(x, ret <- reQueen(x = colony, queen = x[1], simParamBee = simParamBee) ret <- removeVirginQueens(ret, simParamBee = simParamBee) } else if (type == "MultiColony") { - ret <- reQueen_parallel(x = multicolony, queen = mergePops(x), simParamBee = simParamBee) - ret <- removeCastePop_parallel(ret, caste = "virginQueens", simParamBee = simParamBee) + ret <- reQueen(x = multicolony, queen = mergePops(x), simParamBee = simParamBee) + ret <- removeCastePop(ret, caste = "virginQueens", simParamBee = simParamBee) } validObject(ret) diff --git a/R/Functions_L2_Colony.R b/R/Functions_L2_Colony.R index 0cce1016..55c71390 100644 --- a/R/Functions_L2_Colony.R +++ b/R/Functions_L2_Colony.R @@ -145,7 +145,7 @@ createColony <- function(x = NULL, simParamBee = NULL, id = NULL) { #' getCasteId(apiary, caste = "virginQueens") #' #' @export -reQueen <- function(x, queen, removeVirginQueens = TRUE, simParamBee = NULL) { +reQueen_np <- function(x, queen, removeVirginQueens = TRUE, simParamBee = NULL) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } @@ -188,7 +188,7 @@ reQueen <- function(x, queen, removeVirginQueens = TRUE, simParamBee = NULL) { } #' @export -reQueen_parallel <- function(x, queen, removeVirginQueens = TRUE, simParamBee = NULL, nThreads = NULL) { +reQueen_p <- function(x, queen, removeVirginQueens = TRUE, simParamBee = NULL, nThreads = NULL) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } @@ -338,7 +338,7 @@ addCastePop_internal <- function(pop, colony, caste, new = FALSE) { #' nWorkers(addWorkers(apiary, nInd = c(50, 100))) #' #' @export -addCastePop <- function(x, caste = NULL, nInd = NULL, new = FALSE, +addCastePop_np <- function(x, caste = NULL, nInd = NULL, new = FALSE, exact = FALSE, year = NULL, simParamBee = NULL, ...) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) @@ -427,7 +427,7 @@ addCastePop <- function(x, caste = NULL, nInd = NULL, new = FALSE, } #' @export -addCastePop_parallel <- function(x, caste = NULL, nInd = NULL, new = FALSE, +addCastePop_p <- function(x, caste = NULL, nInd = NULL, new = FALSE, year = NULL, simParamBee = NULL, nThreads = NULL, ...) { if (is.null(simParamBee)) { @@ -458,7 +458,7 @@ addCastePop_parallel <- function(x, caste = NULL, nInd = NULL, new = FALSE, nInd <- nInd[1] } if (0 < nInd) { - newInds <- createCastePop_parallel(x, nInd, + newInds <- createCastePop(x, nInd, caste = caste, year = year, simParamBee = simParamBee, nThreads = nThreads @@ -487,7 +487,7 @@ addCastePop_parallel <- function(x, caste = NULL, nInd = NULL, new = FALSE, stop(paste0("The colony ", getId(x), " collapsed, hence you can not add individuals (from the queen) to it!")) } - newInds <- createCastePop_parallel(x, nInd, + newInds <- createCastePop(x, nInd, caste = caste, year = year, simParamBee = simParamBee, nThreads = nThreads, returnSP = FALSE, ...) @@ -530,7 +530,7 @@ addCastePop_parallel <- function(x, caste = NULL, nInd = NULL, new = FALSE, #' @describeIn addCastePop Add workers to a colony #' @export -addWorkers<- function(x, nInd = NULL, new = FALSE, +addWorkers <- function(x, nInd = NULL, new = FALSE, simParamBee = NULL, ...) { ret <- addCastePop( x = x, caste = "workers", nInd = nInd, new = new, @@ -538,29 +538,12 @@ addWorkers<- function(x, nInd = NULL, new = FALSE, ) return(ret) } -addWorkers_parallel <- function(x, nInd = NULL, new = FALSE, - simParamBee = NULL, nThreads = NULL, ...) { - ret <- addCastePop_parallel( - x = x, caste = "workers", nInd = nInd, new = new, - simParamBee = simParamBee, nThreads = nThreads, ... - ) - return(ret) -} #' @describeIn addCastePop Add drones to a colony #' @export addDrones <- function(x, nInd = NULL, new = FALSE, - simParamBee = NULL, ...) { - ret <- addCastePop( - x = x, caste = "drones", nInd = nInd, new = new, - simParamBee = simParamBee, ... - ) - return(ret) -} - -addDrones_parallel <- function(x, nInd = NULL, new = FALSE, simParamBee = NULL, nThreads = NULL, ...) { - ret <- addCastePop_parallel( + ret <- addCastePop( x = x, caste = "drones", nInd = nInd, new = new, simParamBee = simParamBee, nThreads = nThreads, ... @@ -571,18 +554,8 @@ addDrones_parallel <- function(x, nInd = NULL, new = FALSE, #' @describeIn addCastePop Add virgin queens to a colony #' @export addVirginQueens <- function(x, nInd = NULL, new = FALSE, - year = NULL, simParamBee = NULL, ...) { - ret <- addCastePop( - x = x, caste = "virginQueens", nInd = nInd, new = new, - year = year, simParamBee = simParamBee, nThreads = nThreads, ... - ) - return(ret) -} - - -addVirginQueens_parallel <- function(x, nInd = NULL, new = FALSE, year = NULL, simParamBee = NULL, nThreads = NULL, ...) { - ret <- addCastePop_parallel( + ret <- addCastePop( x = x, caste = "virginQueens", nInd = nInd, new = new, year = year, simParamBee = simParamBee, nThreads = nThreads, ... ) @@ -686,7 +659,7 @@ addVirginQueens_parallel <- function(x, nInd = NULL, new = FALSE, #' # Queen's counters #' getMisc(getQueen(buildUp(colony))) #' @export -buildUp <- function(x, nWorkers = NULL, nDrones = NULL, +buildUp_np <- function(x, nWorkers = NULL, nDrones = NULL, new = TRUE, exact = FALSE, resetEvents = FALSE, simParamBee = NULL, ...) { if (is.null(simParamBee)) { @@ -802,7 +775,7 @@ buildUp <- function(x, nWorkers = NULL, nDrones = NULL, } #' @export -buildUp_parallel <- function(x, nWorkers = NULL, nDrones = NULL, +buildUp_p <- function(x, nWorkers = NULL, nDrones = NULL, new = TRUE, resetEvents = FALSE, simParamBee = NULL, nThreads = NULL, ...) { if (is.null(simParamBee)) { @@ -841,7 +814,7 @@ buildUp_parallel <- function(x, nWorkers = NULL, nDrones = NULL, } if (0 < n) { - x <- addWorkers_parallel( + x <- addWorkers( x = x, nInd = n, new = new, exact = exact, simParamBee = simParamBee, nThreads = nThreads) @@ -861,7 +834,7 @@ buildUp_parallel <- function(x, nWorkers = NULL, nDrones = NULL, } if (0 < n) { - x <- addDrones_parallel( + x <- addDrones( x = x, nInd = n, new = new, simParamBee = simParamBee, nThreads = nThreads @@ -910,7 +883,7 @@ buildUp_parallel <- function(x, nWorkers = NULL, nDrones = NULL, } if (sum(nWorkers) > 0) { - x = addWorkers_parallel( + x = addWorkers( x = x, nInd = n, new = new, simParamBee = simParamBee, nThreads = nThreads) # } else if (nWorkersColony < 0) { @@ -919,16 +892,16 @@ buildUp_parallel <- function(x, nWorkers = NULL, nDrones = NULL, # } THIS NEEDS TO GO INTO ADDCASTEPOP } if (sum(nDrones) > 0) { - x = addDrones_parallel( + x = addDrones( x = x, nInd = n, new = new, simParamBee = simParamBee, nThreads = nThreads) # } else if (nDronesColony < 0) { # #THIS IS A PROBLEM _ THE FUNCTION NEEDSD TO RETURN COLONY getWorkers(x, nInd = nWorkers, simParamBee = simParamBee) # } - x <- setEvents_parallel(x, slot = "production", value = TRUE) + x <- setEvents(x, slot = "production", value = TRUE) if (resetEvents) { - x <- resetEvents_parallel(x) + x <- resetEvents(x) } } else { @@ -939,99 +912,6 @@ buildUp_parallel <- function(x, nWorkers = NULL, nDrones = NULL, return(x) } -#' @export -buildUp_parallel_simplified <- function(x, nWorkers = NULL, nDrones = NULL, - new = TRUE, resetEvents = FALSE, - simParamBee = NULL, nThreads = NULL, ...) { - if (is.null(simParamBee)) { - simParamBee <- get(x = "SP", envir = .GlobalEnv) - } - if (is.null(nThreads)) { - nThreads = simParamBee$nThreads - } - # Workers - if (is.null(nWorkers)) { - nWorkers <- simParamBee$nWorkers - } - - if (is.null(nDrones)) { - nDrones <- simParamBee$nDrones - } - if (is.function(nDrones)) { - nDrones <- nDrones(x = x, ...) - } - - if (isColony(x) | isMultiColony(x)) { - registerDoParallel(cores = nThreads) - - if (isColony(x)) { - nCol = 1 - } else if (isMultiColony(x)) { - nCol = nColonies(x) - } - if (is.function(nWorkers)) { - nWorkers <- nWorkers(colony = x, n = nCol, ...) - } - nNWorkers = length(nWorkers) - if (nNWorkers > nCol) { - warning("More than one value in the nWorkers argument, taking only the first value!") - nWorkers <- nWorkers[1:nCol] - } - if (nNWorkers > 1 && nNWorkers < nCol) { - stop("Too few values in the nWorkers argument!") - } - if (new) { - nWorkers <- nWorkers - } else { - nWorkers <- nWorkers - nWorkers(x, simParamBee = simParamBee) - } - - # Drones - nNDrones = length(nDrones) - if (nNDrones > nCol) { - warning("More than one value in the nDrones argument, taking only the first value!") - nDrones <- nDrones[1:nCol] - } - if (nNDrones > 1 && nNDrones < nCol) { - stop("Too few values in the nDrones argument!") - } - if (new) { - nDrones <- nDrones - } else { - nDrones <- nDrones - nDrones(x, simParamBee = simParamBee) - } - - if (sum(nWorkers) > 0) { - x = addWorkers_parallel( - x = x, nInd = nWorkers, new = new, - simParamBee = simParamBee, nThreads = nThreads) - # } else if (nWorkersColony < 0) { - # #THIS IS A PROBLEM _ THE FUNCTION NEEDSD TO RETURN COLONY getWorkers(x, nInd = nWorkers, simParamBee = simParamBee) - # } - # } THIS NEEDS TO GO INTO ADDCASTEPOP - } - if (sum(nDrones) > 0) { - x = addDrones_parallel( - x = x, nInd = nDrones, new = new, - simParamBee = simParamBee, nThreads = nThreads) - # } else if (nDronesColony < 0) { - # #THIS IS A PROBLEM _ THE FUNCTION NEEDSD TO RETURN COLONY getWorkers(x, nInd = nWorkers, simParamBee = simParamBee) - # - } - - # Events - if (resetEvents) { - x <- resetEvents(x) - } - #x@production <- TRUE - } else { - stop("Argument x must be a Colony or MultiColony class object!") - } - validObject(x) - return(x) -} - - #' @rdname downsize #' @title Reduce number of workers and remove all drones and virgin queens from #' a Colony or MultiColony object @@ -1085,7 +965,7 @@ buildUp_parallel_simplified <- function(x, nWorkers = NULL, nDrones = NULL, #' nWorkers(apiary); nDrones(apiary) #' @export #' -downsize <- function(x, p = NULL, use = "rand", new = FALSE, +downsize_np <- function(x, p = NULL, use = "rand", new = FALSE, simParamBee = NULL, nThreads = NULL, ...) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) @@ -1154,7 +1034,7 @@ downsize <- function(x, p = NULL, use = "rand", new = FALSE, } #' @export -downsize_parallel <- function(x, p = NULL, use = "rand", new = FALSE, +downsize_p <- function(x, p = NULL, use = "rand", new = FALSE, simParamBee = NULL, nThreads = NULL, ...) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) @@ -1216,15 +1096,15 @@ downsize_parallel <- function(x, p = NULL, use = "rand", new = FALSE, } if (new == TRUE) { n <- round(nWorkers(x, simParamBee = simParamBee) * (1 - p)) - x <- addWorkers_parallel(x = x, nInd = n, new = TRUE, + x <- addWorkers(x = x, nInd = n, new = TRUE, simParamBee = simParamBee, nThreads = nThreads) } else { - x <- removeWorkers_parallel(x = x, p = p, use = use, + x <- removeWorkers(x = x, p = p, use = use, simParamBee = simParamBee, nThreads = nThreads) } - x <- removeDrones_parallel(x = x, p = 1, simParamBee = simParamBee, nThreads = nThreads) - x <- removeVirginQueens_parallel(x = x, p = 1, simParamBee = simParamBee, nThreads = nThreads) + x <- removeDrones(x = x, p = 1, simParamBee = simParamBee, nThreads = nThreads) + x <- removeVirginQueens(x = x, p = 1, simParamBee = simParamBee, nThreads = nThreads) for (colony in 1:nCol) { x[[colony]]@production <- FALSE } @@ -1297,7 +1177,7 @@ downsize_parallel <- function(x, p = NULL, use = "rand", new = FALSE, #' apiary <- replaceWorkers(apiary, p = 0.5) #' getCasteId(apiary, caste="workers") #' @export -replaceCastePop <- function(x, caste = NULL, p = 1, use = "rand", exact = TRUE, +replaceCastePop_np <- function(x, caste = NULL, p = 1, use = "rand", exact = TRUE, year = NULL, simParamBee = NULL) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) @@ -1385,7 +1265,7 @@ replaceCastePop <- function(x, caste = NULL, p = 1, use = "rand", exact = TRUE, #' @export -replaceCastePop_parallel <- function(x, caste = NULL, p = 1, use = "rand", exact = TRUE, +replaceCastePop_p <- function(x, caste = NULL, p = 1, use = "rand", exact = TRUE, year = NULL, simParamBee = NULL) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) @@ -1423,18 +1303,18 @@ replaceCastePop_parallel <- function(x, caste = NULL, p = 1, use = "rand", exact nIndReplaced <- round(nInd * p) if (any(nIndReplaced < nInd)) { - x <- removeCastePop_parallel(x, + x <- removeCastePop(x, caste = caste, p = p) nIndAdd <- nInd - nCaste(x, caste, simParamBee = simParamBee) - x <- addCastePop_parallel(x, + x <- addCastePop(x, caste = caste, nInd = nIndAdd, year = year, simParamBee = simParamBee ) } } else { - x <- addCastePop_parallel( + x <- addCastePop( x = x, caste = caste, nInd = nIndReplaced, new = TRUE, year = year, simParamBee = simParamBee ) @@ -1534,7 +1414,7 @@ replaceVirginQueens <- function(x, p = 1, use = "rand", simParamBee = NULL) { #' nWorkers(apiary) #' nWorkers(removeWorkers(apiary, p = c(0.1, 0.5))) #' @export -removeCastePop <- function(x, caste = NULL, p = 1, use = "rand", +removeCastePop_np <- function(x, caste = NULL, p = 1, use = "rand", addVirginQueens = FALSE, nVirginQueens = NULL, year = NULL, simParamBee = NULL) { if (is.null(simParamBee)) { @@ -1610,7 +1490,7 @@ removeCastePop <- function(x, caste = NULL, p = 1, use = "rand", } #' @export -removeCastePop_parallel <- function(x, caste = NULL, p = 1, use = "rand", +removeCastePop_p <- function(x, caste = NULL, p = 1, use = "rand", year = NULL, simParamBee = NULL, nThreads = NULL) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) @@ -1683,47 +1563,29 @@ removeCastePop_parallel <- function(x, caste = NULL, p = 1, use = "rand", #' @describeIn removeCastePop Remove queen from a colony #' @export #' -removeQueen <- function(x, addVirginQueens = FALSE, nVirginQueens = NULL, year = NULL, simParamBee = NULL, nThreads = NULL) { - ret <- removeCastePop(x = x, caste = "queen", p = 1, addVirginQueens = addVirginQueens, - nVirginQueens = nVirginQueens, year = year, simParamBee = simParamBee) - return(ret) -} - -removeQueen_parallel <- function(x, year = NULL, simParamBee = NULL, nThreads = NULL) { - ret <- removeCastePop_parallel(x = x, caste = "queen", p = 1, year = year, simParamBee = simParamBee, nThreads = nThreads) +removeQueen <- function(x, year = NULL, simParamBee = NULL, nThreads = NULL) { + ret <- removeCastePop(x = x, caste = "queen", p = 1, year = year, simParamBee = simParamBee, nThreads = nThreads) return(ret) } #' @describeIn removeCastePop Remove workers from a colony #' @export removeWorkers <- function(x, p = 1, use = "rand", simParamBee = NULL, nThreads = NULL) { - ret <- removeCastePop_parallel(x = x, caste = "workers", p = p, use = use, simParamBee = simParamBee, nThreads = nThreads) - return(ret) -} -removeWorkers_parallel <- function(x, p = 1, use = "rand", simParamBee = NULL, nThreads = NULL) { - ret <- removeCastePop_parallel(x = x, caste = "workers", p = p, use = use, simParamBee = simParamBee, nThreads = nThreads) + ret <- removeCastePop(x = x, caste = "workers", p = p, use = use, simParamBee = simParamBee, nThreads = nThreads) return(ret) } #' @describeIn removeCastePop Remove workers from a colony #' @export removeDrones <- function(x, p = 1, use = "rand", simParamBee = NULL, nThreads = NULL) { - ret <- removeCastePop_parallel(x = x, caste = "drones", p = p, use = use, simParamBee = simParamBee, nThreads = nThreads) - return(ret) -} -removeDrones_parallel <- function(x, p = 1, use = "rand", simParamBee = NULL, nThreads = NULL) { - ret <- removeCastePop_parallel(x = x, caste = "drones", p = p, use = use, simParamBee = simParamBee, nThreads = nThreads) + ret <- removeCastePop(x = x, caste = "drones", p = p, use = use, simParamBee = simParamBee, nThreads = nThreads) return(ret) } #' @describeIn removeCastePop Remove virgin queens from a colony #' @export -removeVirginQueens_parallel <- function(x, p = 1, use = "rand", simParamBee = NULL, nThreads = NULL) { - ret <- removeCastePop_parallel(x = x, caste = "virginQueens", p = p, use = use, simParamBee = simParamBee, nThreads = nThreads) - return(ret) -} removeVirginQueens <- function(x, p = 1, use = "rand", simParamBee = NULL, nThreads = NULL) { - ret <- removeCastePop_parallel(x = x, caste = "virginQueens", p = p, use = use, simParamBee = simParamBee, nThreads = nThreads) + ret <- removeCastePop(x = x, caste = "virginQueens", p = p, use = use, simParamBee = simParamBee, nThreads = nThreads) return(ret) } @@ -1806,7 +1668,7 @@ removeVirginQueens <- function(x, p = 1, use = "rand", simParamBee = NULL, nThre #' hasSplit(remnants[[1]]) #' resetEvents(remnants)[[1]] #' @export -resetEvents <- function(x, collapse = NULL) { +resetEvents_np <- function(x, collapse = NULL) { if (isColony(x)) { x@swarm <- FALSE x@split <- FALSE @@ -1837,7 +1699,7 @@ resetEvents <- function(x, collapse = NULL) { } #' @export -resetEvents_parallel <- function(x, collapse = NULL, simParamBee = NULL, nThreads = NULL) { +resetEvents_p <- function(x, collapse = NULL, simParamBee = NULL, nThreads = NULL) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } @@ -1921,7 +1783,7 @@ resetEvents_parallel <- function(x, collapse = NULL, simParamBee = NULL, nThread #' apiaryLeft <- tmp$remnant #' hasCollapsed(apiaryLeft) #' @export -collapse <- function(x) { +collapse_np <- function(x) { if (isColony(x)) { x@collapse <- TRUE x@production <- FALSE @@ -1938,7 +1800,7 @@ collapse <- function(x) { } #' @export -collapse_parallel <- function(x, simParamBee = NULL, nThreads = NULL) { +collapse_p <- function(x, simParamBee = NULL, nThreads = NULL) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } @@ -2031,7 +1893,7 @@ collapse_parallel <- function(x, simParamBee = NULL, nThreads = NULL) { #' # Swarm only the pulled colonies #' (swarm(tmp$pulled, p = 0.6)) #' @export -swarm <- function(x, p = NULL, year = NULL, +swarm_np <- function(x, p = NULL, year = NULL, sampleLocation = TRUE, radius = NULL, simParamBee = NULL, ...) { if (is.null(simParamBee)) { @@ -2161,7 +2023,7 @@ swarm <- function(x, p = NULL, year = NULL, } #' @export -swarm_parallel <- function(x, p = NULL, year = NULL, +swarm_p <- function(x, p = NULL, year = NULL, sampleLocation = TRUE, radius = NULL, simParamBee = NULL, nThreads= NULL, ...) { if (is.null(simParamBee)) { @@ -2222,7 +2084,7 @@ swarm_parallel <- function(x, p = NULL, year = NULL, # TODO: Add use="something" to select pWorkers that swarm # https://github.com/HighlanderLab/SIMplyBee/issues/160 - tmpVirginQueen <- createCastePop_parallel( + tmpVirginQueen <- createCastePop( x = x, nInd = 1, year = year, caste = "virginQueens", @@ -2230,18 +2092,18 @@ swarm_parallel <- function(x, p = NULL, year = NULL, nThreads = nThreads ) - tmp <- pullCastePop_parallel(x = x, caste = "workers", + tmp <- pullCastePop(x = x, caste = "workers", nInd = nWorkersSwarm, simParamBee = simParamBee, nThreads = nThreads) remnantColony <- tmp$remnant - remnantColony <- removeQueen_parallel(remnantColony, nThreads = nThreads) + remnantColony <- removeQueen(remnantColony, nThreads = nThreads) if (isColony(x)) { - remnantColony <- reQueen_parallel(remnantColony, + remnantColony <- reQueen(remnantColony, queen = tmpVirginQueen, simParamBee = simParamBee, nThreads = nThreads) } else { - remnantColony <- reQueen_parallel(remnantColony, + remnantColony <- reQueen(remnantColony, queen = mergePops(tmpVirginQueen), simParamBee = simParamBee, nThreads = nThreads) @@ -2275,12 +2137,12 @@ swarm_parallel <- function(x, p = NULL, year = NULL, } else if (isMultiColony(x)) { if (nCol == 0) { ret <- list( - swarm = createMultiColony_parallel(simParamBee = simParamBee), - remnant = createMultiColony_parallel(simParamBee = simParamBee) + swarm = createMultiColony(simParamBee = simParamBee), + remnant = createMultiColony(simParamBee = simParamBee) ) } else { ret <- list( - swarm = createMultiColony_parallel(x = getQueen(x, collapse = T), + swarm = createMultiColony(x = getQueen(x, collapse = T), simParamBee = simParamBee, nThreads = nThreads), remnant = remnantColony ) @@ -2290,10 +2152,10 @@ swarm_parallel <- function(x, p = NULL, year = NULL, pop = tmp$pulled[[colony]], caste = "workers") } - ret$remnant <- setEvents_parallel(ret$remnant, slot = "swarm", value = TRUE, nThreads = nThreads) - ret$swarm <- setEvents_parallel(ret$swarm, slot = "swarm", value = TRUE, nThreads = nThreads) - ret$swarm <- setEvents_parallel(ret$swarm, slot = "production", value = FALSE, nThreads = nThreads) - ret$remnant <- setEvents_parallel(ret$remnant, slot = "production", value = FALSE, nThreads = nThreads) + ret$remnant <- setEvents(ret$remnant, slot = "swarm", value = TRUE, nThreads = nThreads) + ret$swarm <- setEvents(ret$swarm, slot = "swarm", value = TRUE, nThreads = nThreads) + ret$swarm <- setEvents(ret$swarm, slot = "production", value = FALSE, nThreads = nThreads) + ret$remnant <- setEvents(ret$remnant, slot = "production", value = FALSE, nThreads = nThreads) } } } else { @@ -2362,7 +2224,7 @@ swarm_parallel <- function(x, p = NULL, year = NULL, #' # Swarm only the pulled colonies #' (supersede(tmp$pulled)) #' @export -supersede <- function(x, year = NULL, nVirginQueens = NULL, simParamBee = NULL, nThreads = NULL, ...) { +supersede_np <- function(x, year = NULL, nVirginQueens = NULL, simParamBee = NULL, nThreads = NULL, ...) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } @@ -2411,7 +2273,7 @@ supersede <- function(x, year = NULL, nVirginQueens = NULL, simParamBee = NULL, } #' @export -supersede_parallel <- function(x, addVirginQueens = TRUE, year = NULL, simParamBee = NULL, nThreads = NULL, ...) { +supersede_p <- function(x, addVirginQueens = TRUE, year = NULL, simParamBee = NULL, nThreads = NULL, ...) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } @@ -2440,7 +2302,7 @@ supersede_parallel <- function(x, addVirginQueens = TRUE, year = NULL, simParamB if (!parallel) { x <- addVirginQueens(x, nInd = 1) } - x <- removeQueen_parallel(x, year = year, simParamBee = simParamBee, nThreads = nThreads) + x <- removeQueen(x, year = year, simParamBee = simParamBee, nThreads = nThreads) # TODO: We could consider that a non-random virgin queen prevails (say the most # aggressive one), by creating many virgin queens and then picking the # one with highest pheno for competition or some other criteria @@ -2450,9 +2312,9 @@ supersede_parallel <- function(x, addVirginQueens = TRUE, year = NULL, simParamB registerDoParallel(cores = nThreads) nCol <- nColonies(x) if (nCol == 0) { - x <- createMultiColony_parallel(simParamBee = simParamBee, nThreads = nThreads) + x <- createMultiColony(simParamBee = simParamBee, nThreads = nThreads) } else { - virginQueens = createCastePop_parallel(x, caste = "virginQueens", nInd = 1, nThreads = nThreads) + virginQueens = createCastePop(x, caste = "virginQueens", nInd = 1, nThreads = nThreads) combine_list <- function(a, b) { if (length(a) == 1) { @@ -2462,7 +2324,7 @@ supersede_parallel <- function(x, addVirginQueens = TRUE, year = NULL, simParamB } } x@colonies <- foreach(colony = seq_len(nCol), .combine = combine_list) %do% { - supersede_parallel(x[[colony]], + supersede(x[[colony]], year = year, simParamBee = simParamBee, nThreads = nThreads, ... @@ -2540,7 +2402,7 @@ supersede_parallel <- function(x, addVirginQueens = TRUE, year = NULL, simParamB #' # Split only the pulled colonies #' (split(tmp$pulled, p = 0.5)) #' @export -split <- function(x, p = NULL, year = NULL, simParamBee = NULL, ...) { +split_np <- function(x, p = NULL, year = NULL, simParamBee = NULL, ...) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } @@ -2644,7 +2506,7 @@ split <- function(x, p = NULL, year = NULL, simParamBee = NULL, ...) { } #' @export -split_parallel <- function(x, p = NULL, year = NULL, simParamBee = NULL, nThreads = NULL, ...) { +split_p <- function(x, p = NULL, year = NULL, simParamBee = NULL, nThreads = NULL, ...) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } @@ -2696,10 +2558,10 @@ split_parallel <- function(x, p = NULL, year = NULL, simParamBee = NULL, nThread # TODO: Split colony at random by default, but we could make it as a # function of some parameters # https://github.com/HighlanderLab/SIMplyBee/issues/179 - tmp <- pullCastePop_parallel(x = x, caste = "workers", nInd = nWorkersSplit, simParamBee = simParamBee) #Tole je treba sparalelizirat + tmp <- pullCastePop(x = x, caste = "workers", nInd = nWorkersSplit, simParamBee = simParamBee) #Tole je treba sparalelizirat remnantColony <- tmp$remnant - tmpVirginQueens <- createCastePop_parallel( + tmpVirginQueens <- createCastePop( x = x, nInd = 1, year = year, caste = "virginQueens", @@ -2732,26 +2594,26 @@ split_parallel <- function(x, p = NULL, year = NULL, simParamBee = NULL, nThread } else if (isMultiColony(x)) { if (nCol == 0) { ret <- list( - split = createMultiColony_parallel(simParamBee = simParamBee, nThreads = nThreads), - remnant = createMultiColony_parallel(simParamBee = simParamBee, nThreads = nThreads) + split = createMultiColony(simParamBee = simParamBee, nThreads = nThreads), + remnant = createMultiColony(simParamBee = simParamBee, nThreads = nThreads) ) } else { ret <- list( - split = createMultiColony_parallel(x = mergePops(tmpVirginQueens), n = nCol, + split = createMultiColony(x = mergePops(tmpVirginQueens), n = nCol, simParamBee = simParamBee, nThreads = nThreads), remnant = tmp$remnant ) - ret$split <- setLocation_parallel(x = ret$split, location = location, nThreads = nThreads) + ret$split <- setLocation(x = ret$split, location = location, nThreads = nThreads) ret$split@colonies <- foreach(colony = seq_len(nCol)) %dopar% { addCastePop_internal(colony = ret$split@colonies[[colony]], pop = tmp$pulled[[colony]], caste = "workers") } - ret$split <- setEvents_parallel(ret$split, slot = "split", value = TRUE, nThreads = nThreads) - ret$remnant <- setEvents_parallel(ret$remnant, slot = "split", value = TRUE, nThreads = nThreads) - ret$split <- setEvents_parallel(ret$split, slot = "production", value = FALSE, nThreads = nThreads) - ret$remnant <- setEvents_parallel(ret$remnant, slot = "production", value = TRUE, nThreads = nThreads) + ret$split <- setEvents(ret$split, slot = "split", value = TRUE, nThreads = nThreads) + ret$remnant <- setEvents(ret$remnant, slot = "split", value = TRUE, nThreads = nThreads) + ret$split <- setEvents(ret$split, slot = "production", value = FALSE, nThreads = nThreads) + ret$remnant <- setEvents(ret$remnant, slot = "production", value = TRUE, nThreads = nThreads) } } } else { @@ -2764,7 +2626,7 @@ split_parallel <- function(x, p = NULL, year = NULL, simParamBee = NULL, nThread #' @export # Helpi function - put it in auxiliary -setEvents_parallel <- function(x, slot, value, nThreads = NULL, simParamBee = NULL) { +setEvents <- function(x, slot, value, nThreads = NULL, simParamBee = NULL) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } @@ -2777,7 +2639,7 @@ setEvents_parallel <- function(x, slot, value, nThreads = NULL, simParamBee = NU if (isMultiColony(x)) { registerDoParallel(cores = nThreads) x@colonies <- foreach(colony = seq_len(nColonies(x))) %dopar% { - setEvents_parallel(x[[colony]], slot, value) + setEvents(x[[colony]], slot, value) } } return(x) @@ -2838,7 +2700,7 @@ setEvents_parallel <- function(x, slot, value, nThreads = NULL, simParamBee = NU #' nDrones(apiary1); nDrones(apiary2) #' rm(apiary2) #' @export -combine <- function(strong, weak) { +combine_np <- function(strong, weak) { if (isColony(strong) & isColony(weak)) { if (hasCollapsed(strong)) { stop(paste0("The colony ", getId(strong), " (strong) has collapsed, hence you can not combine it!")) @@ -2864,7 +2726,7 @@ combine <- function(strong, weak) { } #' @export -combine_parallel <- function(strong, weak, simParamBee = NULL, nThreads = NULL) { +combine_p <- function(strong, weak, simParamBee = NULL, nThreads = NULL) { if (isColony(strong) & isColony(weak)) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) @@ -2950,7 +2812,7 @@ combine_parallel <- function(strong, weak, simParamBee = NULL, nThreads = NULL) #' apiary <- setLocation(apiary, location = locDF) #' getLocation(apiary) #' @export -setLocation <- function(x, location = c(0, 0)) { +setLocation_np <- function(x, location = c(0, 0)) { if (isColony(x)) { if (is.list(location)) { # is.list() captures also is.data.frame() stop("Argument location must be numeric, when x is a Colony class object!") @@ -3010,7 +2872,7 @@ setLocation <- function(x, location = c(0, 0)) { } #' @export -setLocation_parallel <- function(x, location = c(0, 0), simParamBee = NULL, nThreads = NULL) { +setLocation_p <- function(x, location = c(0, 0), simParamBee = NULL, nThreads = NULL) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } diff --git a/R/Functions_L3_Colonies.R b/R/Functions_L3_Colonies.R index 76002ac4..8a9e5108 100644 --- a/R/Functions_L3_Colonies.R +++ b/R/Functions_L3_Colonies.R @@ -48,7 +48,7 @@ #' apiary[[2]] #' #' @export -createMultiColony <- function(x = NULL, n = NULL, simParamBee = NULL) { +createMultiColony_np <- function(x = NULL, n = NULL, simParamBee = NULL) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } @@ -81,7 +81,7 @@ createMultiColony <- function(x = NULL, n = NULL, simParamBee = NULL) { } #' @export -createMultiColony_parallel <- function(x = NULL, n = NULL, simParamBee = NULL, nThreads = NULL) { +createMultiColony <- function(x = NULL, n = NULL, simParamBee = NULL, nThreads = NULL) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } From 377f4994f8c8477e8b26223c5b195e574afe8246 Mon Sep 17 00:00:00 2001 From: janaobsteter Date: Fri, 11 Apr 2025 13:55:20 +0200 Subject: [PATCH 05/42] renaming to enable switching from parallel (p) to non-parallel (np) --- R/Functions_L0_auxilary.R | 29 ++++ R/Functions_L1_Pop.R | 110 +++++++------- R/Functions_L2_Colony.R | 292 ++++++++++++++++++++++++++++---------- R/Functions_L3_Colonies.R | 2 +- 4 files changed, 294 insertions(+), 139 deletions(-) diff --git a/R/Functions_L0_auxilary.R b/R/Functions_L0_auxilary.R index 8de31c33..7c492e44 100644 --- a/R/Functions_L0_auxilary.R +++ b/R/Functions_L0_auxilary.R @@ -342,6 +342,35 @@ calcQueensPHomBrood <- function(x, simParamBee = NULL) { } +calcQueensPHomBrood_parallel <- function(x, simParamBee = NULL) { + if (is.null(simParamBee)) { + simParamBee <- get(x = "SP", envir = .GlobalEnv) + } + if (isPop(x)) { + ret <- rep(x = NA, times = nInd(x)) + for (ind in seq_len(nInd(x))) { + + queensCsd <- apply( + X = getCsdAlleles(x[ind], simParamBee = simParamBee), MARGIN = 1, + FUN = function(x) paste0(x, collapse = "") + ) + fathersCsd <- apply( + X = getCsdAlleles(x@misc$fathers[[ind]], simParamBee = simParamBee), MARGIN = 1, + FUN = function(x) paste0(x, collapse = "") + ) + nComb <- length(queensCsd) * length(fathersCsd) + ret[ind] <- sum(fathersCsd %in% queensCsd) / nComb + } + } else if (isColony(x)) { + ret <- calcQueensPHomBrood(x = x@queen) + } else if (isMultiColony(x)) { + ret <- sapply(X = x@colonies, FUN = calcQueensPHomBrood) + names(ret) <- getId(x) + } else { + stop("Argument x must be a Pop, Colony, or MultiColony class object!") + } + return(ret) +} #' @describeIn calcQueensPHomBrood Expected percentage of csd homozygous brood #' of a queen / colony diff --git a/R/Functions_L1_Pop.R b/R/Functions_L1_Pop.R index 23f43b7d..a6fe243c 100644 --- a/R/Functions_L1_Pop.R +++ b/R/Functions_L1_Pop.R @@ -398,10 +398,10 @@ getVirginQueens <- function(x, nInd = NULL, use = "rand", collapse = FALSE, simP # patrilines # https://github.com/HighlanderLab/SIMplyBee/issues/78 createCastePop_np <- function(x, caste = NULL, nInd = NULL, - exact = TRUE, year = NULL, - editCsd = TRUE, csdAlleles = NULL, - simParamBee = NULL, - ...) { + exact = TRUE, year = NULL, + editCsd = TRUE, csdAlleles = NULL, + simParamBee = NULL, + ...) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } @@ -557,14 +557,14 @@ createCastePop_np <- function(x, caste = NULL, nInd = NULL, } #' @export -createCastePop <- function(x, caste = NULL, nInd = NULL, - year = NULL, - editCsd = TRUE, csdAlleles = NULL, - simParamBee = NULL, - returnSP = FALSE, - ids = NULL, - nThreads = NULL, - ...) { +createCastePop_p <- function(x, caste = NULL, nInd = NULL, + year = NULL, + editCsd = TRUE, csdAlleles = NULL, + simParamBee = NULL, + returnSP = FALSE, + ids = NULL, + nThreads = NULL, + ...) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } @@ -675,9 +675,9 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, # } } else if (caste == "virginQueens") { # Creating virgin queens if input is a Colony - ret <- createCastePop(x = x, caste = "workers", - nInd = nInd, exact = TRUE, simParamBee = simParamBee, - returnSP = returnSP, ids = ids, nThreads = 1, ...) + ret <- createCastePop_p(x = x, caste = "workers", + nInd = nInd, exact = TRUE, simParamBee = simParamBee, + returnSP = returnSP, ids = ids, nThreads = 1, ...) simParamBee$changeCaste(id = ret$workers@id, caste = "virginQueens") if (!returnSP) { ret <- ret$workers @@ -694,7 +694,6 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, simParamBee$addToCaste(id = drones@id, caste = "drones") if (returnSP) { - print("Adding") ret <- vector(mode = "list", length = 3) names(ret) <- c("drones", "pedigree", "caste") ret$pedigree = simParamBee$pedigree[drones@id, , drop = F] @@ -770,7 +769,7 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, } else { colonyIds = base::split(ids, rep(seq_along(nInd), nInd))[[as.character(colony)]] } - createCastePop( + createCastePop_p( x = x[[colony]], caste = caste, nInd = nIndColony, exact = exact, @@ -825,13 +824,12 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, #' @describeIn createCastePop Create workers from a colony #' @export -createWorkers <- function(x, nInd = NULL, simParamBee = NULL, +createWorkers <- function(x, nInd = NULL, exact = FALSE, simParamBee = NULL, returnSP = FALSE, ids = NULL, nThreads = NULL, ...) { - ret <- createCastePop(x, caste = "workers", nInd = nInd, - simParamBee = simParamBee, + exact = exact, simParamBee = simParamBee, returnSP = FALSE, ids = NULL, nThreads = NULL, ...) @@ -1333,7 +1331,7 @@ pullDroneGroupsFromDCA <- function(DCA, n, nDrones = NULL, #' pullCastePop(apiary, caste = "virginQueens", collapse = TRUE) #' @export pullCastePop_np <- function(x, caste, nInd = NULL, use = "rand", - removeFathers = TRUE, collapse = FALSE, simParamBee = NULL) { + removeFathers = TRUE, collapse = FALSE, simParamBee = NULL) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } @@ -1411,9 +1409,9 @@ pullCastePop_np <- function(x, caste, nInd = NULL, use = "rand", } #' @export -pullCastePop <- function(x, caste, nInd = NULL, use = "rand", - removeFathers = TRUE, collapse = FALSE, simParamBee = NULL, - nThreads = NULL) { +pullCastePop_p <- function(x, caste, nInd = NULL, use = "rand", + removeFathers = TRUE, collapse = FALSE, simParamBee = NULL, + nThreads = NULL) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } @@ -1710,15 +1708,15 @@ pullVirginQueens <- function(x, nInd = NULL, use = "rand", collapse = FALSE, sim #' #' @export cross_np <- function(x, - crossPlan = NULL, - drones = NULL, - droneColonies = NULL, - nDrones = NULL, - spatial = FALSE, - radius = NULL, - checkCross = "error", - simParamBee = NULL, - ...) { + crossPlan = NULL, + drones = NULL, + droneColonies = NULL, + nDrones = NULL, + spatial = FALSE, + radius = NULL, + checkCross = "error", + simParamBee = NULL, + ...) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } @@ -1903,17 +1901,18 @@ cross_np <- function(x, return(ret) } -cross <- function(x, - crossPlan = NULL, - drones = NULL, - droneColonies = NULL, - nDrones = NULL, - spatial = FALSE, - radius = NULL, - checkCross = "error", - simParamBee = NULL, - nThreads = NULL, - ...) { +#' @export +cross_p <- function(x, + crossPlan = NULL, + drones = NULL, + droneColonies = NULL, + nDrones = NULL, + spatial = FALSE, + radius = NULL, + checkCross = "error", + simParamBee = NULL, + nThreads = NULL, + ...) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } @@ -1993,12 +1992,12 @@ cross <- function(x, inputId <- getId(x) if (isColony(x)) { colony <- x - x <- pullCastePop(x, caste = "virginQueens", nInd = 1)$pulled + x <- pullCastePop_p(x, caste = "virginQueens", nInd = 1)$pulled ID_by_input <- data.frame(inputId = inputId, virginId = getId(x)) } else if (isMultiColony(x)) { multicolony <- x - x <- pullCastePop(x, caste = "virginQueens", nInd = 1)$pulled + x <- pullCastePop_p(x, caste = "virginQueens", nInd = 1)$pulled ID_by_input <- data.frame(inputId = inputId, virginId = unlist(sapply(x, FUN = function(y) getId(y)))) x <- mergePops(x) @@ -2016,17 +2015,6 @@ cross <- function(x, nD = nDrones } - if ((length(nD) == 1) & nVirgin > 1) { - nD = rep(nD, nVirgin) - } - if ((length(nD) != 1) & (length(nD) < nVirgin)) { - stop("Too few values in the nDrones argument!") - } - if (length(nD) > 1 && length(nD) > nVirgin) { - warning(paste0("Too many values in the nDrones argument, taking only the first ", nVirgin, "values!")) - nD <- nD[1:nVirgin] - } - if (crossPlan_create | crossPlan_given) { if (crossPlan_create) { crossPlan <- createCrossPlan(x = x, @@ -2074,8 +2062,8 @@ cross <- function(x, colnames(crossPlanDF_DPCtable) <- c("DPC", "noDrones") selectedDPC = droneColonies[as.character(crossPlanDF_DPCtable$DPC)] - dronesByDPC <- createCastePop(selectedDPC, caste = "drones", - nInd = as.integer(crossPlanDF_DPCtable$noDrones), simParamBee = simParamBee) + dronesByDPC <- createCastePop_p(selectedDPC, caste = "drones", + nInd = as.integer(crossPlanDF_DPCtable$noDrones), simParamBee = simParamBee) dronesByDPC_DF <- data.frame(DPC = rep(names(dronesByDPC), as.vector(crossPlanDF_DPCtable$noDrones)), droneID = unlist(sapply(dronesByDPC, FUN = function(x) getId(x)))) %>% arrange(as.numeric(DPC)) @@ -2159,8 +2147,8 @@ cross <- function(x, ret <- reQueen(x = colony, queen = x[1], simParamBee = simParamBee) ret <- removeVirginQueens(ret, simParamBee = simParamBee) } else if (type == "MultiColony") { - ret <- reQueen(x = multicolony, queen = mergePops(x), simParamBee = simParamBee) - ret <- removeCastePop(ret, caste = "virginQueens", simParamBee = simParamBee) + ret <- reQueen_p(x = multicolony, queen = mergePops(x), simParamBee = simParamBee) + ret <- removeCastePop_p(ret, caste = "virginQueens", simParamBee = simParamBee) } validObject(ret) diff --git a/R/Functions_L2_Colony.R b/R/Functions_L2_Colony.R index 55c71390..0cce1016 100644 --- a/R/Functions_L2_Colony.R +++ b/R/Functions_L2_Colony.R @@ -145,7 +145,7 @@ createColony <- function(x = NULL, simParamBee = NULL, id = NULL) { #' getCasteId(apiary, caste = "virginQueens") #' #' @export -reQueen_np <- function(x, queen, removeVirginQueens = TRUE, simParamBee = NULL) { +reQueen <- function(x, queen, removeVirginQueens = TRUE, simParamBee = NULL) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } @@ -188,7 +188,7 @@ reQueen_np <- function(x, queen, removeVirginQueens = TRUE, simParamBee = NULL) } #' @export -reQueen_p <- function(x, queen, removeVirginQueens = TRUE, simParamBee = NULL, nThreads = NULL) { +reQueen_parallel <- function(x, queen, removeVirginQueens = TRUE, simParamBee = NULL, nThreads = NULL) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } @@ -338,7 +338,7 @@ addCastePop_internal <- function(pop, colony, caste, new = FALSE) { #' nWorkers(addWorkers(apiary, nInd = c(50, 100))) #' #' @export -addCastePop_np <- function(x, caste = NULL, nInd = NULL, new = FALSE, +addCastePop <- function(x, caste = NULL, nInd = NULL, new = FALSE, exact = FALSE, year = NULL, simParamBee = NULL, ...) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) @@ -427,7 +427,7 @@ addCastePop_np <- function(x, caste = NULL, nInd = NULL, new = FALSE, } #' @export -addCastePop_p <- function(x, caste = NULL, nInd = NULL, new = FALSE, +addCastePop_parallel <- function(x, caste = NULL, nInd = NULL, new = FALSE, year = NULL, simParamBee = NULL, nThreads = NULL, ...) { if (is.null(simParamBee)) { @@ -458,7 +458,7 @@ addCastePop_p <- function(x, caste = NULL, nInd = NULL, new = FALSE, nInd <- nInd[1] } if (0 < nInd) { - newInds <- createCastePop(x, nInd, + newInds <- createCastePop_parallel(x, nInd, caste = caste, year = year, simParamBee = simParamBee, nThreads = nThreads @@ -487,7 +487,7 @@ addCastePop_p <- function(x, caste = NULL, nInd = NULL, new = FALSE, stop(paste0("The colony ", getId(x), " collapsed, hence you can not add individuals (from the queen) to it!")) } - newInds <- createCastePop(x, nInd, + newInds <- createCastePop_parallel(x, nInd, caste = caste, year = year, simParamBee = simParamBee, nThreads = nThreads, returnSP = FALSE, ...) @@ -530,7 +530,7 @@ addCastePop_p <- function(x, caste = NULL, nInd = NULL, new = FALSE, #' @describeIn addCastePop Add workers to a colony #' @export -addWorkers <- function(x, nInd = NULL, new = FALSE, +addWorkers<- function(x, nInd = NULL, new = FALSE, simParamBee = NULL, ...) { ret <- addCastePop( x = x, caste = "workers", nInd = nInd, new = new, @@ -538,12 +538,29 @@ addWorkers <- function(x, nInd = NULL, new = FALSE, ) return(ret) } +addWorkers_parallel <- function(x, nInd = NULL, new = FALSE, + simParamBee = NULL, nThreads = NULL, ...) { + ret <- addCastePop_parallel( + x = x, caste = "workers", nInd = nInd, new = new, + simParamBee = simParamBee, nThreads = nThreads, ... + ) + return(ret) +} #' @describeIn addCastePop Add drones to a colony #' @export addDrones <- function(x, nInd = NULL, new = FALSE, - simParamBee = NULL, nThreads = NULL, ...) { + simParamBee = NULL, ...) { ret <- addCastePop( + x = x, caste = "drones", nInd = nInd, new = new, + simParamBee = simParamBee, ... + ) + return(ret) +} + +addDrones_parallel <- function(x, nInd = NULL, new = FALSE, + simParamBee = NULL, nThreads = NULL, ...) { + ret <- addCastePop_parallel( x = x, caste = "drones", nInd = nInd, new = new, simParamBee = simParamBee, nThreads = nThreads, ... @@ -554,7 +571,7 @@ addDrones <- function(x, nInd = NULL, new = FALSE, #' @describeIn addCastePop Add virgin queens to a colony #' @export addVirginQueens <- function(x, nInd = NULL, new = FALSE, - year = NULL, simParamBee = NULL, nThreads = NULL, ...) { + year = NULL, simParamBee = NULL, ...) { ret <- addCastePop( x = x, caste = "virginQueens", nInd = nInd, new = new, year = year, simParamBee = simParamBee, nThreads = nThreads, ... @@ -562,6 +579,16 @@ addVirginQueens <- function(x, nInd = NULL, new = FALSE, return(ret) } + +addVirginQueens_parallel <- function(x, nInd = NULL, new = FALSE, + year = NULL, simParamBee = NULL, nThreads = NULL, ...) { + ret <- addCastePop_parallel( + x = x, caste = "virginQueens", nInd = nInd, new = new, + year = year, simParamBee = simParamBee, nThreads = nThreads, ... + ) + return(ret) +} + #' @rdname buildUp #' @title Build up Colony or MultiColony object by adding (raising) workers and drones #' @@ -659,7 +686,7 @@ addVirginQueens <- function(x, nInd = NULL, new = FALSE, #' # Queen's counters #' getMisc(getQueen(buildUp(colony))) #' @export -buildUp_np <- function(x, nWorkers = NULL, nDrones = NULL, +buildUp <- function(x, nWorkers = NULL, nDrones = NULL, new = TRUE, exact = FALSE, resetEvents = FALSE, simParamBee = NULL, ...) { if (is.null(simParamBee)) { @@ -775,7 +802,7 @@ buildUp_np <- function(x, nWorkers = NULL, nDrones = NULL, } #' @export -buildUp_p <- function(x, nWorkers = NULL, nDrones = NULL, +buildUp_parallel <- function(x, nWorkers = NULL, nDrones = NULL, new = TRUE, resetEvents = FALSE, simParamBee = NULL, nThreads = NULL, ...) { if (is.null(simParamBee)) { @@ -814,7 +841,7 @@ buildUp_p <- function(x, nWorkers = NULL, nDrones = NULL, } if (0 < n) { - x <- addWorkers( + x <- addWorkers_parallel( x = x, nInd = n, new = new, exact = exact, simParamBee = simParamBee, nThreads = nThreads) @@ -834,7 +861,7 @@ buildUp_p <- function(x, nWorkers = NULL, nDrones = NULL, } if (0 < n) { - x <- addDrones( + x <- addDrones_parallel( x = x, nInd = n, new = new, simParamBee = simParamBee, nThreads = nThreads @@ -883,7 +910,7 @@ buildUp_p <- function(x, nWorkers = NULL, nDrones = NULL, } if (sum(nWorkers) > 0) { - x = addWorkers( + x = addWorkers_parallel( x = x, nInd = n, new = new, simParamBee = simParamBee, nThreads = nThreads) # } else if (nWorkersColony < 0) { @@ -892,16 +919,16 @@ buildUp_p <- function(x, nWorkers = NULL, nDrones = NULL, # } THIS NEEDS TO GO INTO ADDCASTEPOP } if (sum(nDrones) > 0) { - x = addDrones( + x = addDrones_parallel( x = x, nInd = n, new = new, simParamBee = simParamBee, nThreads = nThreads) # } else if (nDronesColony < 0) { # #THIS IS A PROBLEM _ THE FUNCTION NEEDSD TO RETURN COLONY getWorkers(x, nInd = nWorkers, simParamBee = simParamBee) # } - x <- setEvents(x, slot = "production", value = TRUE) + x <- setEvents_parallel(x, slot = "production", value = TRUE) if (resetEvents) { - x <- resetEvents(x) + x <- resetEvents_parallel(x) } } else { @@ -912,6 +939,99 @@ buildUp_p <- function(x, nWorkers = NULL, nDrones = NULL, return(x) } +#' @export +buildUp_parallel_simplified <- function(x, nWorkers = NULL, nDrones = NULL, + new = TRUE, resetEvents = FALSE, + simParamBee = NULL, nThreads = NULL, ...) { + if (is.null(simParamBee)) { + simParamBee <- get(x = "SP", envir = .GlobalEnv) + } + if (is.null(nThreads)) { + nThreads = simParamBee$nThreads + } + # Workers + if (is.null(nWorkers)) { + nWorkers <- simParamBee$nWorkers + } + + if (is.null(nDrones)) { + nDrones <- simParamBee$nDrones + } + if (is.function(nDrones)) { + nDrones <- nDrones(x = x, ...) + } + + if (isColony(x) | isMultiColony(x)) { + registerDoParallel(cores = nThreads) + + if (isColony(x)) { + nCol = 1 + } else if (isMultiColony(x)) { + nCol = nColonies(x) + } + if (is.function(nWorkers)) { + nWorkers <- nWorkers(colony = x, n = nCol, ...) + } + nNWorkers = length(nWorkers) + if (nNWorkers > nCol) { + warning("More than one value in the nWorkers argument, taking only the first value!") + nWorkers <- nWorkers[1:nCol] + } + if (nNWorkers > 1 && nNWorkers < nCol) { + stop("Too few values in the nWorkers argument!") + } + if (new) { + nWorkers <- nWorkers + } else { + nWorkers <- nWorkers - nWorkers(x, simParamBee = simParamBee) + } + + # Drones + nNDrones = length(nDrones) + if (nNDrones > nCol) { + warning("More than one value in the nDrones argument, taking only the first value!") + nDrones <- nDrones[1:nCol] + } + if (nNDrones > 1 && nNDrones < nCol) { + stop("Too few values in the nDrones argument!") + } + if (new) { + nDrones <- nDrones + } else { + nDrones <- nDrones - nDrones(x, simParamBee = simParamBee) + } + + if (sum(nWorkers) > 0) { + x = addWorkers_parallel( + x = x, nInd = nWorkers, new = new, + simParamBee = simParamBee, nThreads = nThreads) + # } else if (nWorkersColony < 0) { + # #THIS IS A PROBLEM _ THE FUNCTION NEEDSD TO RETURN COLONY getWorkers(x, nInd = nWorkers, simParamBee = simParamBee) + # } + # } THIS NEEDS TO GO INTO ADDCASTEPOP + } + if (sum(nDrones) > 0) { + x = addDrones_parallel( + x = x, nInd = nDrones, new = new, + simParamBee = simParamBee, nThreads = nThreads) + # } else if (nDronesColony < 0) { + # #THIS IS A PROBLEM _ THE FUNCTION NEEDSD TO RETURN COLONY getWorkers(x, nInd = nWorkers, simParamBee = simParamBee) + # + } + + # Events + if (resetEvents) { + x <- resetEvents(x) + } + #x@production <- TRUE + } else { + stop("Argument x must be a Colony or MultiColony class object!") + } + validObject(x) + return(x) +} + + #' @rdname downsize #' @title Reduce number of workers and remove all drones and virgin queens from #' a Colony or MultiColony object @@ -965,7 +1085,7 @@ buildUp_p <- function(x, nWorkers = NULL, nDrones = NULL, #' nWorkers(apiary); nDrones(apiary) #' @export #' -downsize_np <- function(x, p = NULL, use = "rand", new = FALSE, +downsize <- function(x, p = NULL, use = "rand", new = FALSE, simParamBee = NULL, nThreads = NULL, ...) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) @@ -1034,7 +1154,7 @@ downsize_np <- function(x, p = NULL, use = "rand", new = FALSE, } #' @export -downsize_p <- function(x, p = NULL, use = "rand", new = FALSE, +downsize_parallel <- function(x, p = NULL, use = "rand", new = FALSE, simParamBee = NULL, nThreads = NULL, ...) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) @@ -1096,15 +1216,15 @@ downsize_p <- function(x, p = NULL, use = "rand", new = FALSE, } if (new == TRUE) { n <- round(nWorkers(x, simParamBee = simParamBee) * (1 - p)) - x <- addWorkers(x = x, nInd = n, new = TRUE, + x <- addWorkers_parallel(x = x, nInd = n, new = TRUE, simParamBee = simParamBee, nThreads = nThreads) } else { - x <- removeWorkers(x = x, p = p, use = use, + x <- removeWorkers_parallel(x = x, p = p, use = use, simParamBee = simParamBee, nThreads = nThreads) } - x <- removeDrones(x = x, p = 1, simParamBee = simParamBee, nThreads = nThreads) - x <- removeVirginQueens(x = x, p = 1, simParamBee = simParamBee, nThreads = nThreads) + x <- removeDrones_parallel(x = x, p = 1, simParamBee = simParamBee, nThreads = nThreads) + x <- removeVirginQueens_parallel(x = x, p = 1, simParamBee = simParamBee, nThreads = nThreads) for (colony in 1:nCol) { x[[colony]]@production <- FALSE } @@ -1177,7 +1297,7 @@ downsize_p <- function(x, p = NULL, use = "rand", new = FALSE, #' apiary <- replaceWorkers(apiary, p = 0.5) #' getCasteId(apiary, caste="workers") #' @export -replaceCastePop_np <- function(x, caste = NULL, p = 1, use = "rand", exact = TRUE, +replaceCastePop <- function(x, caste = NULL, p = 1, use = "rand", exact = TRUE, year = NULL, simParamBee = NULL) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) @@ -1265,7 +1385,7 @@ replaceCastePop_np <- function(x, caste = NULL, p = 1, use = "rand", exact = TRU #' @export -replaceCastePop_p <- function(x, caste = NULL, p = 1, use = "rand", exact = TRUE, +replaceCastePop_parallel <- function(x, caste = NULL, p = 1, use = "rand", exact = TRUE, year = NULL, simParamBee = NULL) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) @@ -1303,18 +1423,18 @@ replaceCastePop_p <- function(x, caste = NULL, p = 1, use = "rand", exact = TRUE nIndReplaced <- round(nInd * p) if (any(nIndReplaced < nInd)) { - x <- removeCastePop(x, + x <- removeCastePop_parallel(x, caste = caste, p = p) nIndAdd <- nInd - nCaste(x, caste, simParamBee = simParamBee) - x <- addCastePop(x, + x <- addCastePop_parallel(x, caste = caste, nInd = nIndAdd, year = year, simParamBee = simParamBee ) } } else { - x <- addCastePop( + x <- addCastePop_parallel( x = x, caste = caste, nInd = nIndReplaced, new = TRUE, year = year, simParamBee = simParamBee ) @@ -1414,7 +1534,7 @@ replaceVirginQueens <- function(x, p = 1, use = "rand", simParamBee = NULL) { #' nWorkers(apiary) #' nWorkers(removeWorkers(apiary, p = c(0.1, 0.5))) #' @export -removeCastePop_np <- function(x, caste = NULL, p = 1, use = "rand", +removeCastePop <- function(x, caste = NULL, p = 1, use = "rand", addVirginQueens = FALSE, nVirginQueens = NULL, year = NULL, simParamBee = NULL) { if (is.null(simParamBee)) { @@ -1490,7 +1610,7 @@ removeCastePop_np <- function(x, caste = NULL, p = 1, use = "rand", } #' @export -removeCastePop_p <- function(x, caste = NULL, p = 1, use = "rand", +removeCastePop_parallel <- function(x, caste = NULL, p = 1, use = "rand", year = NULL, simParamBee = NULL, nThreads = NULL) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) @@ -1563,29 +1683,47 @@ removeCastePop_p <- function(x, caste = NULL, p = 1, use = "rand", #' @describeIn removeCastePop Remove queen from a colony #' @export #' -removeQueen <- function(x, year = NULL, simParamBee = NULL, nThreads = NULL) { - ret <- removeCastePop(x = x, caste = "queen", p = 1, year = year, simParamBee = simParamBee, nThreads = nThreads) +removeQueen <- function(x, addVirginQueens = FALSE, nVirginQueens = NULL, year = NULL, simParamBee = NULL, nThreads = NULL) { + ret <- removeCastePop(x = x, caste = "queen", p = 1, addVirginQueens = addVirginQueens, + nVirginQueens = nVirginQueens, year = year, simParamBee = simParamBee) + return(ret) +} + +removeQueen_parallel <- function(x, year = NULL, simParamBee = NULL, nThreads = NULL) { + ret <- removeCastePop_parallel(x = x, caste = "queen", p = 1, year = year, simParamBee = simParamBee, nThreads = nThreads) return(ret) } #' @describeIn removeCastePop Remove workers from a colony #' @export removeWorkers <- function(x, p = 1, use = "rand", simParamBee = NULL, nThreads = NULL) { - ret <- removeCastePop(x = x, caste = "workers", p = p, use = use, simParamBee = simParamBee, nThreads = nThreads) + ret <- removeCastePop_parallel(x = x, caste = "workers", p = p, use = use, simParamBee = simParamBee, nThreads = nThreads) + return(ret) +} +removeWorkers_parallel <- function(x, p = 1, use = "rand", simParamBee = NULL, nThreads = NULL) { + ret <- removeCastePop_parallel(x = x, caste = "workers", p = p, use = use, simParamBee = simParamBee, nThreads = nThreads) return(ret) } #' @describeIn removeCastePop Remove workers from a colony #' @export removeDrones <- function(x, p = 1, use = "rand", simParamBee = NULL, nThreads = NULL) { - ret <- removeCastePop(x = x, caste = "drones", p = p, use = use, simParamBee = simParamBee, nThreads = nThreads) + ret <- removeCastePop_parallel(x = x, caste = "drones", p = p, use = use, simParamBee = simParamBee, nThreads = nThreads) + return(ret) +} +removeDrones_parallel <- function(x, p = 1, use = "rand", simParamBee = NULL, nThreads = NULL) { + ret <- removeCastePop_parallel(x = x, caste = "drones", p = p, use = use, simParamBee = simParamBee, nThreads = nThreads) return(ret) } #' @describeIn removeCastePop Remove virgin queens from a colony #' @export +removeVirginQueens_parallel <- function(x, p = 1, use = "rand", simParamBee = NULL, nThreads = NULL) { + ret <- removeCastePop_parallel(x = x, caste = "virginQueens", p = p, use = use, simParamBee = simParamBee, nThreads = nThreads) + return(ret) +} removeVirginQueens <- function(x, p = 1, use = "rand", simParamBee = NULL, nThreads = NULL) { - ret <- removeCastePop(x = x, caste = "virginQueens", p = p, use = use, simParamBee = simParamBee, nThreads = nThreads) + ret <- removeCastePop_parallel(x = x, caste = "virginQueens", p = p, use = use, simParamBee = simParamBee, nThreads = nThreads) return(ret) } @@ -1668,7 +1806,7 @@ removeVirginQueens <- function(x, p = 1, use = "rand", simParamBee = NULL, nThre #' hasSplit(remnants[[1]]) #' resetEvents(remnants)[[1]] #' @export -resetEvents_np <- function(x, collapse = NULL) { +resetEvents <- function(x, collapse = NULL) { if (isColony(x)) { x@swarm <- FALSE x@split <- FALSE @@ -1699,7 +1837,7 @@ resetEvents_np <- function(x, collapse = NULL) { } #' @export -resetEvents_p <- function(x, collapse = NULL, simParamBee = NULL, nThreads = NULL) { +resetEvents_parallel <- function(x, collapse = NULL, simParamBee = NULL, nThreads = NULL) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } @@ -1783,7 +1921,7 @@ resetEvents_p <- function(x, collapse = NULL, simParamBee = NULL, nThreads = NUL #' apiaryLeft <- tmp$remnant #' hasCollapsed(apiaryLeft) #' @export -collapse_np <- function(x) { +collapse <- function(x) { if (isColony(x)) { x@collapse <- TRUE x@production <- FALSE @@ -1800,7 +1938,7 @@ collapse_np <- function(x) { } #' @export -collapse_p <- function(x, simParamBee = NULL, nThreads = NULL) { +collapse_parallel <- function(x, simParamBee = NULL, nThreads = NULL) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } @@ -1893,7 +2031,7 @@ collapse_p <- function(x, simParamBee = NULL, nThreads = NULL) { #' # Swarm only the pulled colonies #' (swarm(tmp$pulled, p = 0.6)) #' @export -swarm_np <- function(x, p = NULL, year = NULL, +swarm <- function(x, p = NULL, year = NULL, sampleLocation = TRUE, radius = NULL, simParamBee = NULL, ...) { if (is.null(simParamBee)) { @@ -2023,7 +2161,7 @@ swarm_np <- function(x, p = NULL, year = NULL, } #' @export -swarm_p <- function(x, p = NULL, year = NULL, +swarm_parallel <- function(x, p = NULL, year = NULL, sampleLocation = TRUE, radius = NULL, simParamBee = NULL, nThreads= NULL, ...) { if (is.null(simParamBee)) { @@ -2084,7 +2222,7 @@ swarm_p <- function(x, p = NULL, year = NULL, # TODO: Add use="something" to select pWorkers that swarm # https://github.com/HighlanderLab/SIMplyBee/issues/160 - tmpVirginQueen <- createCastePop( + tmpVirginQueen <- createCastePop_parallel( x = x, nInd = 1, year = year, caste = "virginQueens", @@ -2092,18 +2230,18 @@ swarm_p <- function(x, p = NULL, year = NULL, nThreads = nThreads ) - tmp <- pullCastePop(x = x, caste = "workers", + tmp <- pullCastePop_parallel(x = x, caste = "workers", nInd = nWorkersSwarm, simParamBee = simParamBee, nThreads = nThreads) remnantColony <- tmp$remnant - remnantColony <- removeQueen(remnantColony, nThreads = nThreads) + remnantColony <- removeQueen_parallel(remnantColony, nThreads = nThreads) if (isColony(x)) { - remnantColony <- reQueen(remnantColony, + remnantColony <- reQueen_parallel(remnantColony, queen = tmpVirginQueen, simParamBee = simParamBee, nThreads = nThreads) } else { - remnantColony <- reQueen(remnantColony, + remnantColony <- reQueen_parallel(remnantColony, queen = mergePops(tmpVirginQueen), simParamBee = simParamBee, nThreads = nThreads) @@ -2137,12 +2275,12 @@ swarm_p <- function(x, p = NULL, year = NULL, } else if (isMultiColony(x)) { if (nCol == 0) { ret <- list( - swarm = createMultiColony(simParamBee = simParamBee), - remnant = createMultiColony(simParamBee = simParamBee) + swarm = createMultiColony_parallel(simParamBee = simParamBee), + remnant = createMultiColony_parallel(simParamBee = simParamBee) ) } else { ret <- list( - swarm = createMultiColony(x = getQueen(x, collapse = T), + swarm = createMultiColony_parallel(x = getQueen(x, collapse = T), simParamBee = simParamBee, nThreads = nThreads), remnant = remnantColony ) @@ -2152,10 +2290,10 @@ swarm_p <- function(x, p = NULL, year = NULL, pop = tmp$pulled[[colony]], caste = "workers") } - ret$remnant <- setEvents(ret$remnant, slot = "swarm", value = TRUE, nThreads = nThreads) - ret$swarm <- setEvents(ret$swarm, slot = "swarm", value = TRUE, nThreads = nThreads) - ret$swarm <- setEvents(ret$swarm, slot = "production", value = FALSE, nThreads = nThreads) - ret$remnant <- setEvents(ret$remnant, slot = "production", value = FALSE, nThreads = nThreads) + ret$remnant <- setEvents_parallel(ret$remnant, slot = "swarm", value = TRUE, nThreads = nThreads) + ret$swarm <- setEvents_parallel(ret$swarm, slot = "swarm", value = TRUE, nThreads = nThreads) + ret$swarm <- setEvents_parallel(ret$swarm, slot = "production", value = FALSE, nThreads = nThreads) + ret$remnant <- setEvents_parallel(ret$remnant, slot = "production", value = FALSE, nThreads = nThreads) } } } else { @@ -2224,7 +2362,7 @@ swarm_p <- function(x, p = NULL, year = NULL, #' # Swarm only the pulled colonies #' (supersede(tmp$pulled)) #' @export -supersede_np <- function(x, year = NULL, nVirginQueens = NULL, simParamBee = NULL, nThreads = NULL, ...) { +supersede <- function(x, year = NULL, nVirginQueens = NULL, simParamBee = NULL, nThreads = NULL, ...) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } @@ -2273,7 +2411,7 @@ supersede_np <- function(x, year = NULL, nVirginQueens = NULL, simParamBee = NUL } #' @export -supersede_p <- function(x, addVirginQueens = TRUE, year = NULL, simParamBee = NULL, nThreads = NULL, ...) { +supersede_parallel <- function(x, addVirginQueens = TRUE, year = NULL, simParamBee = NULL, nThreads = NULL, ...) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } @@ -2302,7 +2440,7 @@ supersede_p <- function(x, addVirginQueens = TRUE, year = NULL, simParamBee = NU if (!parallel) { x <- addVirginQueens(x, nInd = 1) } - x <- removeQueen(x, year = year, simParamBee = simParamBee, nThreads = nThreads) + x <- removeQueen_parallel(x, year = year, simParamBee = simParamBee, nThreads = nThreads) # TODO: We could consider that a non-random virgin queen prevails (say the most # aggressive one), by creating many virgin queens and then picking the # one with highest pheno for competition or some other criteria @@ -2312,9 +2450,9 @@ supersede_p <- function(x, addVirginQueens = TRUE, year = NULL, simParamBee = NU registerDoParallel(cores = nThreads) nCol <- nColonies(x) if (nCol == 0) { - x <- createMultiColony(simParamBee = simParamBee, nThreads = nThreads) + x <- createMultiColony_parallel(simParamBee = simParamBee, nThreads = nThreads) } else { - virginQueens = createCastePop(x, caste = "virginQueens", nInd = 1, nThreads = nThreads) + virginQueens = createCastePop_parallel(x, caste = "virginQueens", nInd = 1, nThreads = nThreads) combine_list <- function(a, b) { if (length(a) == 1) { @@ -2324,7 +2462,7 @@ supersede_p <- function(x, addVirginQueens = TRUE, year = NULL, simParamBee = NU } } x@colonies <- foreach(colony = seq_len(nCol), .combine = combine_list) %do% { - supersede(x[[colony]], + supersede_parallel(x[[colony]], year = year, simParamBee = simParamBee, nThreads = nThreads, ... @@ -2402,7 +2540,7 @@ supersede_p <- function(x, addVirginQueens = TRUE, year = NULL, simParamBee = NU #' # Split only the pulled colonies #' (split(tmp$pulled, p = 0.5)) #' @export -split_np <- function(x, p = NULL, year = NULL, simParamBee = NULL, ...) { +split <- function(x, p = NULL, year = NULL, simParamBee = NULL, ...) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } @@ -2506,7 +2644,7 @@ split_np <- function(x, p = NULL, year = NULL, simParamBee = NULL, ...) { } #' @export -split_p <- function(x, p = NULL, year = NULL, simParamBee = NULL, nThreads = NULL, ...) { +split_parallel <- function(x, p = NULL, year = NULL, simParamBee = NULL, nThreads = NULL, ...) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } @@ -2558,10 +2696,10 @@ split_p <- function(x, p = NULL, year = NULL, simParamBee = NULL, nThreads = NUL # TODO: Split colony at random by default, but we could make it as a # function of some parameters # https://github.com/HighlanderLab/SIMplyBee/issues/179 - tmp <- pullCastePop(x = x, caste = "workers", nInd = nWorkersSplit, simParamBee = simParamBee) #Tole je treba sparalelizirat + tmp <- pullCastePop_parallel(x = x, caste = "workers", nInd = nWorkersSplit, simParamBee = simParamBee) #Tole je treba sparalelizirat remnantColony <- tmp$remnant - tmpVirginQueens <- createCastePop( + tmpVirginQueens <- createCastePop_parallel( x = x, nInd = 1, year = year, caste = "virginQueens", @@ -2594,26 +2732,26 @@ split_p <- function(x, p = NULL, year = NULL, simParamBee = NULL, nThreads = NUL } else if (isMultiColony(x)) { if (nCol == 0) { ret <- list( - split = createMultiColony(simParamBee = simParamBee, nThreads = nThreads), - remnant = createMultiColony(simParamBee = simParamBee, nThreads = nThreads) + split = createMultiColony_parallel(simParamBee = simParamBee, nThreads = nThreads), + remnant = createMultiColony_parallel(simParamBee = simParamBee, nThreads = nThreads) ) } else { ret <- list( - split = createMultiColony(x = mergePops(tmpVirginQueens), n = nCol, + split = createMultiColony_parallel(x = mergePops(tmpVirginQueens), n = nCol, simParamBee = simParamBee, nThreads = nThreads), remnant = tmp$remnant ) - ret$split <- setLocation(x = ret$split, location = location, nThreads = nThreads) + ret$split <- setLocation_parallel(x = ret$split, location = location, nThreads = nThreads) ret$split@colonies <- foreach(colony = seq_len(nCol)) %dopar% { addCastePop_internal(colony = ret$split@colonies[[colony]], pop = tmp$pulled[[colony]], caste = "workers") } - ret$split <- setEvents(ret$split, slot = "split", value = TRUE, nThreads = nThreads) - ret$remnant <- setEvents(ret$remnant, slot = "split", value = TRUE, nThreads = nThreads) - ret$split <- setEvents(ret$split, slot = "production", value = FALSE, nThreads = nThreads) - ret$remnant <- setEvents(ret$remnant, slot = "production", value = TRUE, nThreads = nThreads) + ret$split <- setEvents_parallel(ret$split, slot = "split", value = TRUE, nThreads = nThreads) + ret$remnant <- setEvents_parallel(ret$remnant, slot = "split", value = TRUE, nThreads = nThreads) + ret$split <- setEvents_parallel(ret$split, slot = "production", value = FALSE, nThreads = nThreads) + ret$remnant <- setEvents_parallel(ret$remnant, slot = "production", value = TRUE, nThreads = nThreads) } } } else { @@ -2626,7 +2764,7 @@ split_p <- function(x, p = NULL, year = NULL, simParamBee = NULL, nThreads = NUL #' @export # Helpi function - put it in auxiliary -setEvents <- function(x, slot, value, nThreads = NULL, simParamBee = NULL) { +setEvents_parallel <- function(x, slot, value, nThreads = NULL, simParamBee = NULL) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } @@ -2639,7 +2777,7 @@ setEvents <- function(x, slot, value, nThreads = NULL, simParamBee = NULL) { if (isMultiColony(x)) { registerDoParallel(cores = nThreads) x@colonies <- foreach(colony = seq_len(nColonies(x))) %dopar% { - setEvents(x[[colony]], slot, value) + setEvents_parallel(x[[colony]], slot, value) } } return(x) @@ -2700,7 +2838,7 @@ setEvents <- function(x, slot, value, nThreads = NULL, simParamBee = NULL) { #' nDrones(apiary1); nDrones(apiary2) #' rm(apiary2) #' @export -combine_np <- function(strong, weak) { +combine <- function(strong, weak) { if (isColony(strong) & isColony(weak)) { if (hasCollapsed(strong)) { stop(paste0("The colony ", getId(strong), " (strong) has collapsed, hence you can not combine it!")) @@ -2726,7 +2864,7 @@ combine_np <- function(strong, weak) { } #' @export -combine_p <- function(strong, weak, simParamBee = NULL, nThreads = NULL) { +combine_parallel <- function(strong, weak, simParamBee = NULL, nThreads = NULL) { if (isColony(strong) & isColony(weak)) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) @@ -2812,7 +2950,7 @@ combine_p <- function(strong, weak, simParamBee = NULL, nThreads = NULL) { #' apiary <- setLocation(apiary, location = locDF) #' getLocation(apiary) #' @export -setLocation_np <- function(x, location = c(0, 0)) { +setLocation <- function(x, location = c(0, 0)) { if (isColony(x)) { if (is.list(location)) { # is.list() captures also is.data.frame() stop("Argument location must be numeric, when x is a Colony class object!") @@ -2872,7 +3010,7 @@ setLocation_np <- function(x, location = c(0, 0)) { } #' @export -setLocation_p <- function(x, location = c(0, 0), simParamBee = NULL, nThreads = NULL) { +setLocation_parallel <- function(x, location = c(0, 0), simParamBee = NULL, nThreads = NULL) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } diff --git a/R/Functions_L3_Colonies.R b/R/Functions_L3_Colonies.R index 8a9e5108..f237c294 100644 --- a/R/Functions_L3_Colonies.R +++ b/R/Functions_L3_Colonies.R @@ -81,7 +81,7 @@ createMultiColony_np <- function(x = NULL, n = NULL, simParamBee = NULL) { } #' @export -createMultiColony <- function(x = NULL, n = NULL, simParamBee = NULL, nThreads = NULL) { +createMultiColony_p <- function(x = NULL, n = NULL, simParamBee = NULL, nThreads = NULL) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } From 04d4d0db30e8aa5255ede98daea9d981cb8af03e Mon Sep 17 00:00:00 2001 From: janaobsteter Date: Fri, 11 Apr 2025 14:12:23 +0200 Subject: [PATCH 06/42] Adding correct NAMESPACE --- NAMESPACE | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index be1bdc2e..2c1c0bef 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -28,18 +28,19 @@ export(collapse) export(collapse_parallel) export(combine) export(combine_parallel) -export(createCastePop) -export(createCastePop_parallel) +export(createCastePop_np) +export(createCastePop_p) export(createColony) export(createCrossPlan) export(createDCA) export(createDrones) export(createMatingStationDCA) -export(createMultiColony) -export(createMultiColony_parallel) +export(createMultiColony_np) +export(createMultiColony_p) export(createVirginQueens) export(createWorkers) -export(cross) +export(cross_np) +export(cross_p) export(downsize) export(downsizePUnif) export(downsize_parallel) @@ -176,8 +177,8 @@ export(nWorkersColonyPhenotype) export(nWorkersPoisson) export(nWorkersTruncPoisson) export(pHomBrood) -export(pullCastePop) -export(pullCastePop_parallel) +export(pullCastePop_np) +export(pullCastePop_p) export(pullColonies) export(pullDroneGroupsFromDCA) export(pullDrones) From 5c668a39cc6ac074003c29d747b79f280c9e565c Mon Sep 17 00:00:00 2001 From: janaobsteter Date: Fri, 11 Apr 2025 14:21:48 +0200 Subject: [PATCH 07/42] Correcting L2 --- R/Functions_L2_Colony.R | 289 +++++++++++----------------------------- 1 file changed, 80 insertions(+), 209 deletions(-) diff --git a/R/Functions_L2_Colony.R b/R/Functions_L2_Colony.R index 0cce1016..44572889 100644 --- a/R/Functions_L2_Colony.R +++ b/R/Functions_L2_Colony.R @@ -145,7 +145,7 @@ createColony <- function(x = NULL, simParamBee = NULL, id = NULL) { #' getCasteId(apiary, caste = "virginQueens") #' #' @export -reQueen <- function(x, queen, removeVirginQueens = TRUE, simParamBee = NULL) { +reQueen_np <- function(x, queen, removeVirginQueens = TRUE, simParamBee = NULL) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } @@ -188,7 +188,7 @@ reQueen <- function(x, queen, removeVirginQueens = TRUE, simParamBee = NULL) { } #' @export -reQueen_parallel <- function(x, queen, removeVirginQueens = TRUE, simParamBee = NULL, nThreads = NULL) { +reQueen <- function(x, queen, removeVirginQueens = TRUE, simParamBee = NULL, nThreads = NULL) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } @@ -338,7 +338,7 @@ addCastePop_internal <- function(pop, colony, caste, new = FALSE) { #' nWorkers(addWorkers(apiary, nInd = c(50, 100))) #' #' @export -addCastePop <- function(x, caste = NULL, nInd = NULL, new = FALSE, +addCastePop_np <- function(x, caste = NULL, nInd = NULL, new = FALSE, exact = FALSE, year = NULL, simParamBee = NULL, ...) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) @@ -427,7 +427,7 @@ addCastePop <- function(x, caste = NULL, nInd = NULL, new = FALSE, } #' @export -addCastePop_parallel <- function(x, caste = NULL, nInd = NULL, new = FALSE, +addCastePop <- function(x, caste = NULL, nInd = NULL, new = FALSE, year = NULL, simParamBee = NULL, nThreads = NULL, ...) { if (is.null(simParamBee)) { @@ -458,7 +458,7 @@ addCastePop_parallel <- function(x, caste = NULL, nInd = NULL, new = FALSE, nInd <- nInd[1] } if (0 < nInd) { - newInds <- createCastePop_parallel(x, nInd, + newInds <- createCastePop(x, nInd, caste = caste, year = year, simParamBee = simParamBee, nThreads = nThreads @@ -487,7 +487,7 @@ addCastePop_parallel <- function(x, caste = NULL, nInd = NULL, new = FALSE, stop(paste0("The colony ", getId(x), " collapsed, hence you can not add individuals (from the queen) to it!")) } - newInds <- createCastePop_parallel(x, nInd, + newInds <- createCastePop(x, nInd, caste = caste, year = year, simParamBee = simParamBee, nThreads = nThreads, returnSP = FALSE, ...) @@ -530,7 +530,7 @@ addCastePop_parallel <- function(x, caste = NULL, nInd = NULL, new = FALSE, #' @describeIn addCastePop Add workers to a colony #' @export -addWorkers<- function(x, nInd = NULL, new = FALSE, +addWorkers_np <- function(x, nInd = NULL, new = FALSE, simParamBee = NULL, ...) { ret <- addCastePop( x = x, caste = "workers", nInd = nInd, new = new, @@ -538,9 +538,10 @@ addWorkers<- function(x, nInd = NULL, new = FALSE, ) return(ret) } -addWorkers_parallel <- function(x, nInd = NULL, new = FALSE, + +addWorkers <- function(x, nInd = NULL, new = FALSE, simParamBee = NULL, nThreads = NULL, ...) { - ret <- addCastePop_parallel( + ret <- addCastePop( x = x, caste = "workers", nInd = nInd, new = new, simParamBee = simParamBee, nThreads = nThreads, ... ) @@ -550,17 +551,8 @@ addWorkers_parallel <- function(x, nInd = NULL, new = FALSE, #' @describeIn addCastePop Add drones to a colony #' @export addDrones <- function(x, nInd = NULL, new = FALSE, - simParamBee = NULL, ...) { - ret <- addCastePop( - x = x, caste = "drones", nInd = nInd, new = new, - simParamBee = simParamBee, ... - ) - return(ret) -} - -addDrones_parallel <- function(x, nInd = NULL, new = FALSE, simParamBee = NULL, nThreads = NULL, ...) { - ret <- addCastePop_parallel( + ret <- addCastePop( x = x, caste = "drones", nInd = nInd, new = new, simParamBee = simParamBee, nThreads = nThreads, ... @@ -571,18 +563,8 @@ addDrones_parallel <- function(x, nInd = NULL, new = FALSE, #' @describeIn addCastePop Add virgin queens to a colony #' @export addVirginQueens <- function(x, nInd = NULL, new = FALSE, - year = NULL, simParamBee = NULL, ...) { - ret <- addCastePop( - x = x, caste = "virginQueens", nInd = nInd, new = new, - year = year, simParamBee = simParamBee, nThreads = nThreads, ... - ) - return(ret) -} - - -addVirginQueens_parallel <- function(x, nInd = NULL, new = FALSE, year = NULL, simParamBee = NULL, nThreads = NULL, ...) { - ret <- addCastePop_parallel( + ret <- addCastePop( x = x, caste = "virginQueens", nInd = nInd, new = new, year = year, simParamBee = simParamBee, nThreads = nThreads, ... ) @@ -686,7 +668,7 @@ addVirginQueens_parallel <- function(x, nInd = NULL, new = FALSE, #' # Queen's counters #' getMisc(getQueen(buildUp(colony))) #' @export -buildUp <- function(x, nWorkers = NULL, nDrones = NULL, +buildUp_np <- function(x, nWorkers = NULL, nDrones = NULL, new = TRUE, exact = FALSE, resetEvents = FALSE, simParamBee = NULL, ...) { if (is.null(simParamBee)) { @@ -802,7 +784,7 @@ buildUp <- function(x, nWorkers = NULL, nDrones = NULL, } #' @export -buildUp_parallel <- function(x, nWorkers = NULL, nDrones = NULL, +buildUp <- function(x, nWorkers = NULL, nDrones = NULL, new = TRUE, resetEvents = FALSE, simParamBee = NULL, nThreads = NULL, ...) { if (is.null(simParamBee)) { @@ -841,7 +823,7 @@ buildUp_parallel <- function(x, nWorkers = NULL, nDrones = NULL, } if (0 < n) { - x <- addWorkers_parallel( + x <- addWorkers( x = x, nInd = n, new = new, exact = exact, simParamBee = simParamBee, nThreads = nThreads) @@ -861,7 +843,7 @@ buildUp_parallel <- function(x, nWorkers = NULL, nDrones = NULL, } if (0 < n) { - x <- addDrones_parallel( + x <- addDrones( x = x, nInd = n, new = new, simParamBee = simParamBee, nThreads = nThreads @@ -910,7 +892,7 @@ buildUp_parallel <- function(x, nWorkers = NULL, nDrones = NULL, } if (sum(nWorkers) > 0) { - x = addWorkers_parallel( + x = addWorkers( x = x, nInd = n, new = new, simParamBee = simParamBee, nThreads = nThreads) # } else if (nWorkersColony < 0) { @@ -919,16 +901,16 @@ buildUp_parallel <- function(x, nWorkers = NULL, nDrones = NULL, # } THIS NEEDS TO GO INTO ADDCASTEPOP } if (sum(nDrones) > 0) { - x = addDrones_parallel( + x = addDrones( x = x, nInd = n, new = new, simParamBee = simParamBee, nThreads = nThreads) # } else if (nDronesColony < 0) { # #THIS IS A PROBLEM _ THE FUNCTION NEEDSD TO RETURN COLONY getWorkers(x, nInd = nWorkers, simParamBee = simParamBee) # } - x <- setEvents_parallel(x, slot = "production", value = TRUE) + x <- setEvents(x, slot = "production", value = TRUE) if (resetEvents) { - x <- resetEvents_parallel(x) + x <- resetEvents(x) } } else { @@ -939,99 +921,6 @@ buildUp_parallel <- function(x, nWorkers = NULL, nDrones = NULL, return(x) } -#' @export -buildUp_parallel_simplified <- function(x, nWorkers = NULL, nDrones = NULL, - new = TRUE, resetEvents = FALSE, - simParamBee = NULL, nThreads = NULL, ...) { - if (is.null(simParamBee)) { - simParamBee <- get(x = "SP", envir = .GlobalEnv) - } - if (is.null(nThreads)) { - nThreads = simParamBee$nThreads - } - # Workers - if (is.null(nWorkers)) { - nWorkers <- simParamBee$nWorkers - } - - if (is.null(nDrones)) { - nDrones <- simParamBee$nDrones - } - if (is.function(nDrones)) { - nDrones <- nDrones(x = x, ...) - } - - if (isColony(x) | isMultiColony(x)) { - registerDoParallel(cores = nThreads) - - if (isColony(x)) { - nCol = 1 - } else if (isMultiColony(x)) { - nCol = nColonies(x) - } - if (is.function(nWorkers)) { - nWorkers <- nWorkers(colony = x, n = nCol, ...) - } - nNWorkers = length(nWorkers) - if (nNWorkers > nCol) { - warning("More than one value in the nWorkers argument, taking only the first value!") - nWorkers <- nWorkers[1:nCol] - } - if (nNWorkers > 1 && nNWorkers < nCol) { - stop("Too few values in the nWorkers argument!") - } - if (new) { - nWorkers <- nWorkers - } else { - nWorkers <- nWorkers - nWorkers(x, simParamBee = simParamBee) - } - - # Drones - nNDrones = length(nDrones) - if (nNDrones > nCol) { - warning("More than one value in the nDrones argument, taking only the first value!") - nDrones <- nDrones[1:nCol] - } - if (nNDrones > 1 && nNDrones < nCol) { - stop("Too few values in the nDrones argument!") - } - if (new) { - nDrones <- nDrones - } else { - nDrones <- nDrones - nDrones(x, simParamBee = simParamBee) - } - - if (sum(nWorkers) > 0) { - x = addWorkers_parallel( - x = x, nInd = nWorkers, new = new, - simParamBee = simParamBee, nThreads = nThreads) - # } else if (nWorkersColony < 0) { - # #THIS IS A PROBLEM _ THE FUNCTION NEEDSD TO RETURN COLONY getWorkers(x, nInd = nWorkers, simParamBee = simParamBee) - # } - # } THIS NEEDS TO GO INTO ADDCASTEPOP - } - if (sum(nDrones) > 0) { - x = addDrones_parallel( - x = x, nInd = nDrones, new = new, - simParamBee = simParamBee, nThreads = nThreads) - # } else if (nDronesColony < 0) { - # #THIS IS A PROBLEM _ THE FUNCTION NEEDSD TO RETURN COLONY getWorkers(x, nInd = nWorkers, simParamBee = simParamBee) - # - } - - # Events - if (resetEvents) { - x <- resetEvents(x) - } - #x@production <- TRUE - } else { - stop("Argument x must be a Colony or MultiColony class object!") - } - validObject(x) - return(x) -} - - #' @rdname downsize #' @title Reduce number of workers and remove all drones and virgin queens from #' a Colony or MultiColony object @@ -1085,7 +974,7 @@ buildUp_parallel_simplified <- function(x, nWorkers = NULL, nDrones = NULL, #' nWorkers(apiary); nDrones(apiary) #' @export #' -downsize <- function(x, p = NULL, use = "rand", new = FALSE, +downsize_np <- function(x, p = NULL, use = "rand", new = FALSE, simParamBee = NULL, nThreads = NULL, ...) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) @@ -1154,7 +1043,7 @@ downsize <- function(x, p = NULL, use = "rand", new = FALSE, } #' @export -downsize_parallel <- function(x, p = NULL, use = "rand", new = FALSE, +downsize <- function(x, p = NULL, use = "rand", new = FALSE, simParamBee = NULL, nThreads = NULL, ...) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) @@ -1216,15 +1105,15 @@ downsize_parallel <- function(x, p = NULL, use = "rand", new = FALSE, } if (new == TRUE) { n <- round(nWorkers(x, simParamBee = simParamBee) * (1 - p)) - x <- addWorkers_parallel(x = x, nInd = n, new = TRUE, + x <- addWorkers(x = x, nInd = n, new = TRUE, simParamBee = simParamBee, nThreads = nThreads) } else { - x <- removeWorkers_parallel(x = x, p = p, use = use, + x <- removeWorkers(x = x, p = p, use = use, simParamBee = simParamBee, nThreads = nThreads) } - x <- removeDrones_parallel(x = x, p = 1, simParamBee = simParamBee, nThreads = nThreads) - x <- removeVirginQueens_parallel(x = x, p = 1, simParamBee = simParamBee, nThreads = nThreads) + x <- removeDrones(x = x, p = 1, simParamBee = simParamBee, nThreads = nThreads) + x <- removeVirginQueens(x = x, p = 1, simParamBee = simParamBee, nThreads = nThreads) for (colony in 1:nCol) { x[[colony]]@production <- FALSE } @@ -1297,7 +1186,7 @@ downsize_parallel <- function(x, p = NULL, use = "rand", new = FALSE, #' apiary <- replaceWorkers(apiary, p = 0.5) #' getCasteId(apiary, caste="workers") #' @export -replaceCastePop <- function(x, caste = NULL, p = 1, use = "rand", exact = TRUE, +replaceCastePop_np <- function(x, caste = NULL, p = 1, use = "rand", exact = TRUE, year = NULL, simParamBee = NULL) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) @@ -1385,7 +1274,7 @@ replaceCastePop <- function(x, caste = NULL, p = 1, use = "rand", exact = TRUE, #' @export -replaceCastePop_parallel <- function(x, caste = NULL, p = 1, use = "rand", exact = TRUE, +replaceCastePop <- function(x, caste = NULL, p = 1, use = "rand", exact = TRUE, year = NULL, simParamBee = NULL) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) @@ -1423,18 +1312,18 @@ replaceCastePop_parallel <- function(x, caste = NULL, p = 1, use = "rand", exact nIndReplaced <- round(nInd * p) if (any(nIndReplaced < nInd)) { - x <- removeCastePop_parallel(x, + x <- removeCastePop(x, caste = caste, p = p) nIndAdd <- nInd - nCaste(x, caste, simParamBee = simParamBee) - x <- addCastePop_parallel(x, + x <- addCastePop(x, caste = caste, nInd = nIndAdd, year = year, simParamBee = simParamBee ) } } else { - x <- addCastePop_parallel( + x <- addCastePop( x = x, caste = caste, nInd = nIndReplaced, new = TRUE, year = year, simParamBee = simParamBee ) @@ -1534,7 +1423,7 @@ replaceVirginQueens <- function(x, p = 1, use = "rand", simParamBee = NULL) { #' nWorkers(apiary) #' nWorkers(removeWorkers(apiary, p = c(0.1, 0.5))) #' @export -removeCastePop <- function(x, caste = NULL, p = 1, use = "rand", +removeCastePop_np <- function(x, caste = NULL, p = 1, use = "rand", addVirginQueens = FALSE, nVirginQueens = NULL, year = NULL, simParamBee = NULL) { if (is.null(simParamBee)) { @@ -1610,7 +1499,7 @@ removeCastePop <- function(x, caste = NULL, p = 1, use = "rand", } #' @export -removeCastePop_parallel <- function(x, caste = NULL, p = 1, use = "rand", +removeCastePop <- function(x, caste = NULL, p = 1, use = "rand", year = NULL, simParamBee = NULL, nThreads = NULL) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) @@ -1683,47 +1572,29 @@ removeCastePop_parallel <- function(x, caste = NULL, p = 1, use = "rand", #' @describeIn removeCastePop Remove queen from a colony #' @export #' -removeQueen <- function(x, addVirginQueens = FALSE, nVirginQueens = NULL, year = NULL, simParamBee = NULL, nThreads = NULL) { - ret <- removeCastePop(x = x, caste = "queen", p = 1, addVirginQueens = addVirginQueens, - nVirginQueens = nVirginQueens, year = year, simParamBee = simParamBee) - return(ret) -} - -removeQueen_parallel <- function(x, year = NULL, simParamBee = NULL, nThreads = NULL) { - ret <- removeCastePop_parallel(x = x, caste = "queen", p = 1, year = year, simParamBee = simParamBee, nThreads = nThreads) +removeQueen <- function(x, year = NULL, simParamBee = NULL, nThreads = NULL) { + ret <- removeCastePop(x = x, caste = "queen", p = 1, year = year, simParamBee = simParamBee, nThreads = nThreads) return(ret) } #' @describeIn removeCastePop Remove workers from a colony #' @export removeWorkers <- function(x, p = 1, use = "rand", simParamBee = NULL, nThreads = NULL) { - ret <- removeCastePop_parallel(x = x, caste = "workers", p = p, use = use, simParamBee = simParamBee, nThreads = nThreads) - return(ret) -} -removeWorkers_parallel <- function(x, p = 1, use = "rand", simParamBee = NULL, nThreads = NULL) { - ret <- removeCastePop_parallel(x = x, caste = "workers", p = p, use = use, simParamBee = simParamBee, nThreads = nThreads) + ret <- removeCastePop(x = x, caste = "workers", p = p, use = use, simParamBee = simParamBee, nThreads = nThreads) return(ret) } #' @describeIn removeCastePop Remove workers from a colony #' @export removeDrones <- function(x, p = 1, use = "rand", simParamBee = NULL, nThreads = NULL) { - ret <- removeCastePop_parallel(x = x, caste = "drones", p = p, use = use, simParamBee = simParamBee, nThreads = nThreads) - return(ret) -} -removeDrones_parallel <- function(x, p = 1, use = "rand", simParamBee = NULL, nThreads = NULL) { - ret <- removeCastePop_parallel(x = x, caste = "drones", p = p, use = use, simParamBee = simParamBee, nThreads = nThreads) + ret <- removeCastePop(x = x, caste = "drones", p = p, use = use, simParamBee = simParamBee, nThreads = nThreads) return(ret) } #' @describeIn removeCastePop Remove virgin queens from a colony #' @export -removeVirginQueens_parallel <- function(x, p = 1, use = "rand", simParamBee = NULL, nThreads = NULL) { - ret <- removeCastePop_parallel(x = x, caste = "virginQueens", p = p, use = use, simParamBee = simParamBee, nThreads = nThreads) - return(ret) -} removeVirginQueens <- function(x, p = 1, use = "rand", simParamBee = NULL, nThreads = NULL) { - ret <- removeCastePop_parallel(x = x, caste = "virginQueens", p = p, use = use, simParamBee = simParamBee, nThreads = nThreads) + ret <- removeCastePop(x = x, caste = "virginQueens", p = p, use = use, simParamBee = simParamBee, nThreads = nThreads) return(ret) } @@ -1806,7 +1677,7 @@ removeVirginQueens <- function(x, p = 1, use = "rand", simParamBee = NULL, nThre #' hasSplit(remnants[[1]]) #' resetEvents(remnants)[[1]] #' @export -resetEvents <- function(x, collapse = NULL) { +resetEvents_np <- function(x, collapse = NULL) { if (isColony(x)) { x@swarm <- FALSE x@split <- FALSE @@ -1837,7 +1708,7 @@ resetEvents <- function(x, collapse = NULL) { } #' @export -resetEvents_parallel <- function(x, collapse = NULL, simParamBee = NULL, nThreads = NULL) { +resetEvents <- function(x, collapse = NULL, simParamBee = NULL, nThreads = NULL) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } @@ -1921,7 +1792,7 @@ resetEvents_parallel <- function(x, collapse = NULL, simParamBee = NULL, nThread #' apiaryLeft <- tmp$remnant #' hasCollapsed(apiaryLeft) #' @export -collapse <- function(x) { +collapse_np <- function(x) { if (isColony(x)) { x@collapse <- TRUE x@production <- FALSE @@ -1938,7 +1809,7 @@ collapse <- function(x) { } #' @export -collapse_parallel <- function(x, simParamBee = NULL, nThreads = NULL) { +collapse <- function(x, simParamBee = NULL, nThreads = NULL) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } @@ -2031,7 +1902,7 @@ collapse_parallel <- function(x, simParamBee = NULL, nThreads = NULL) { #' # Swarm only the pulled colonies #' (swarm(tmp$pulled, p = 0.6)) #' @export -swarm <- function(x, p = NULL, year = NULL, +swarm_np <- function(x, p = NULL, year = NULL, sampleLocation = TRUE, radius = NULL, simParamBee = NULL, ...) { if (is.null(simParamBee)) { @@ -2161,7 +2032,7 @@ swarm <- function(x, p = NULL, year = NULL, } #' @export -swarm_parallel <- function(x, p = NULL, year = NULL, +swarm <- function(x, p = NULL, year = NULL, sampleLocation = TRUE, radius = NULL, simParamBee = NULL, nThreads= NULL, ...) { if (is.null(simParamBee)) { @@ -2222,7 +2093,7 @@ swarm_parallel <- function(x, p = NULL, year = NULL, # TODO: Add use="something" to select pWorkers that swarm # https://github.com/HighlanderLab/SIMplyBee/issues/160 - tmpVirginQueen <- createCastePop_parallel( + tmpVirginQueen <- createCastePop( x = x, nInd = 1, year = year, caste = "virginQueens", @@ -2230,18 +2101,18 @@ swarm_parallel <- function(x, p = NULL, year = NULL, nThreads = nThreads ) - tmp <- pullCastePop_parallel(x = x, caste = "workers", + tmp <- pullCastePop(x = x, caste = "workers", nInd = nWorkersSwarm, simParamBee = simParamBee, nThreads = nThreads) remnantColony <- tmp$remnant - remnantColony <- removeQueen_parallel(remnantColony, nThreads = nThreads) + remnantColony <- removeQueen(remnantColony, nThreads = nThreads) if (isColony(x)) { - remnantColony <- reQueen_parallel(remnantColony, + remnantColony <- reQueen(remnantColony, queen = tmpVirginQueen, simParamBee = simParamBee, nThreads = nThreads) } else { - remnantColony <- reQueen_parallel(remnantColony, + remnantColony <- reQueen(remnantColony, queen = mergePops(tmpVirginQueen), simParamBee = simParamBee, nThreads = nThreads) @@ -2275,12 +2146,12 @@ swarm_parallel <- function(x, p = NULL, year = NULL, } else if (isMultiColony(x)) { if (nCol == 0) { ret <- list( - swarm = createMultiColony_parallel(simParamBee = simParamBee), - remnant = createMultiColony_parallel(simParamBee = simParamBee) + swarm = createMultiColony(simParamBee = simParamBee), + remnant = createMultiColony(simParamBee = simParamBee) ) } else { ret <- list( - swarm = createMultiColony_parallel(x = getQueen(x, collapse = T), + swarm = createMultiColony(x = getQueen(x, collapse = T), simParamBee = simParamBee, nThreads = nThreads), remnant = remnantColony ) @@ -2290,10 +2161,10 @@ swarm_parallel <- function(x, p = NULL, year = NULL, pop = tmp$pulled[[colony]], caste = "workers") } - ret$remnant <- setEvents_parallel(ret$remnant, slot = "swarm", value = TRUE, nThreads = nThreads) - ret$swarm <- setEvents_parallel(ret$swarm, slot = "swarm", value = TRUE, nThreads = nThreads) - ret$swarm <- setEvents_parallel(ret$swarm, slot = "production", value = FALSE, nThreads = nThreads) - ret$remnant <- setEvents_parallel(ret$remnant, slot = "production", value = FALSE, nThreads = nThreads) + ret$remnant <- setEvents(ret$remnant, slot = "swarm", value = TRUE, nThreads = nThreads) + ret$swarm <- setEvents(ret$swarm, slot = "swarm", value = TRUE, nThreads = nThreads) + ret$swarm <- setEvents(ret$swarm, slot = "production", value = FALSE, nThreads = nThreads) + ret$remnant <- setEvents(ret$remnant, slot = "production", value = FALSE, nThreads = nThreads) } } } else { @@ -2362,7 +2233,7 @@ swarm_parallel <- function(x, p = NULL, year = NULL, #' # Swarm only the pulled colonies #' (supersede(tmp$pulled)) #' @export -supersede <- function(x, year = NULL, nVirginQueens = NULL, simParamBee = NULL, nThreads = NULL, ...) { +supersede_np <- function(x, year = NULL, nVirginQueens = NULL, simParamBee = NULL, nThreads = NULL, ...) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } @@ -2411,7 +2282,7 @@ supersede <- function(x, year = NULL, nVirginQueens = NULL, simParamBee = NULL, } #' @export -supersede_parallel <- function(x, addVirginQueens = TRUE, year = NULL, simParamBee = NULL, nThreads = NULL, ...) { +supersede <- function(x, addVirginQueens = TRUE, year = NULL, simParamBee = NULL, nThreads = NULL, ...) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } @@ -2440,7 +2311,7 @@ supersede_parallel <- function(x, addVirginQueens = TRUE, year = NULL, simParamB if (!parallel) { x <- addVirginQueens(x, nInd = 1) } - x <- removeQueen_parallel(x, year = year, simParamBee = simParamBee, nThreads = nThreads) + x <- removeQueen(x, year = year, simParamBee = simParamBee, nThreads = nThreads) # TODO: We could consider that a non-random virgin queen prevails (say the most # aggressive one), by creating many virgin queens and then picking the # one with highest pheno for competition or some other criteria @@ -2450,9 +2321,9 @@ supersede_parallel <- function(x, addVirginQueens = TRUE, year = NULL, simParamB registerDoParallel(cores = nThreads) nCol <- nColonies(x) if (nCol == 0) { - x <- createMultiColony_parallel(simParamBee = simParamBee, nThreads = nThreads) + x <- createMultiColony(simParamBee = simParamBee, nThreads = nThreads) } else { - virginQueens = createCastePop_parallel(x, caste = "virginQueens", nInd = 1, nThreads = nThreads) + virginQueens = createCastePop(x, caste = "virginQueens", nInd = 1, nThreads = nThreads) combine_list <- function(a, b) { if (length(a) == 1) { @@ -2462,7 +2333,7 @@ supersede_parallel <- function(x, addVirginQueens = TRUE, year = NULL, simParamB } } x@colonies <- foreach(colony = seq_len(nCol), .combine = combine_list) %do% { - supersede_parallel(x[[colony]], + supersede(x[[colony]], year = year, simParamBee = simParamBee, nThreads = nThreads, ... @@ -2540,7 +2411,7 @@ supersede_parallel <- function(x, addVirginQueens = TRUE, year = NULL, simParamB #' # Split only the pulled colonies #' (split(tmp$pulled, p = 0.5)) #' @export -split <- function(x, p = NULL, year = NULL, simParamBee = NULL, ...) { +split_np <- function(x, p = NULL, year = NULL, simParamBee = NULL, ...) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } @@ -2644,7 +2515,7 @@ split <- function(x, p = NULL, year = NULL, simParamBee = NULL, ...) { } #' @export -split_parallel <- function(x, p = NULL, year = NULL, simParamBee = NULL, nThreads = NULL, ...) { +split <- function(x, p = NULL, year = NULL, simParamBee = NULL, nThreads = NULL, ...) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } @@ -2696,10 +2567,10 @@ split_parallel <- function(x, p = NULL, year = NULL, simParamBee = NULL, nThread # TODO: Split colony at random by default, but we could make it as a # function of some parameters # https://github.com/HighlanderLab/SIMplyBee/issues/179 - tmp <- pullCastePop_parallel(x = x, caste = "workers", nInd = nWorkersSplit, simParamBee = simParamBee) #Tole je treba sparalelizirat + tmp <- pullCastePop(x = x, caste = "workers", nInd = nWorkersSplit, simParamBee = simParamBee) #Tole je treba sparalelizirat remnantColony <- tmp$remnant - tmpVirginQueens <- createCastePop_parallel( + tmpVirginQueens <- createCastePop( x = x, nInd = 1, year = year, caste = "virginQueens", @@ -2732,26 +2603,26 @@ split_parallel <- function(x, p = NULL, year = NULL, simParamBee = NULL, nThread } else if (isMultiColony(x)) { if (nCol == 0) { ret <- list( - split = createMultiColony_parallel(simParamBee = simParamBee, nThreads = nThreads), - remnant = createMultiColony_parallel(simParamBee = simParamBee, nThreads = nThreads) + split = createMultiColony(simParamBee = simParamBee, nThreads = nThreads), + remnant = createMultiColony(simParamBee = simParamBee, nThreads = nThreads) ) } else { ret <- list( - split = createMultiColony_parallel(x = mergePops(tmpVirginQueens), n = nCol, + split = createMultiColony(x = mergePops(tmpVirginQueens), n = nCol, simParamBee = simParamBee, nThreads = nThreads), remnant = tmp$remnant ) - ret$split <- setLocation_parallel(x = ret$split, location = location, nThreads = nThreads) + ret$split <- setLocation(x = ret$split, location = location, nThreads = nThreads) ret$split@colonies <- foreach(colony = seq_len(nCol)) %dopar% { addCastePop_internal(colony = ret$split@colonies[[colony]], pop = tmp$pulled[[colony]], caste = "workers") } - ret$split <- setEvents_parallel(ret$split, slot = "split", value = TRUE, nThreads = nThreads) - ret$remnant <- setEvents_parallel(ret$remnant, slot = "split", value = TRUE, nThreads = nThreads) - ret$split <- setEvents_parallel(ret$split, slot = "production", value = FALSE, nThreads = nThreads) - ret$remnant <- setEvents_parallel(ret$remnant, slot = "production", value = TRUE, nThreads = nThreads) + ret$split <- setEvents(ret$split, slot = "split", value = TRUE, nThreads = nThreads) + ret$remnant <- setEvents(ret$remnant, slot = "split", value = TRUE, nThreads = nThreads) + ret$split <- setEvents(ret$split, slot = "production", value = FALSE, nThreads = nThreads) + ret$remnant <- setEvents(ret$remnant, slot = "production", value = TRUE, nThreads = nThreads) } } } else { @@ -2764,7 +2635,7 @@ split_parallel <- function(x, p = NULL, year = NULL, simParamBee = NULL, nThread #' @export # Helpi function - put it in auxiliary -setEvents_parallel <- function(x, slot, value, nThreads = NULL, simParamBee = NULL) { +setEvents <- function(x, slot, value, nThreads = NULL, simParamBee = NULL) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } @@ -2777,7 +2648,7 @@ setEvents_parallel <- function(x, slot, value, nThreads = NULL, simParamBee = NU if (isMultiColony(x)) { registerDoParallel(cores = nThreads) x@colonies <- foreach(colony = seq_len(nColonies(x))) %dopar% { - setEvents_parallel(x[[colony]], slot, value) + setEvents(x[[colony]], slot, value) } } return(x) @@ -2838,7 +2709,7 @@ setEvents_parallel <- function(x, slot, value, nThreads = NULL, simParamBee = NU #' nDrones(apiary1); nDrones(apiary2) #' rm(apiary2) #' @export -combine <- function(strong, weak) { +combine_np <- function(strong, weak) { if (isColony(strong) & isColony(weak)) { if (hasCollapsed(strong)) { stop(paste0("The colony ", getId(strong), " (strong) has collapsed, hence you can not combine it!")) @@ -2864,7 +2735,7 @@ combine <- function(strong, weak) { } #' @export -combine_parallel <- function(strong, weak, simParamBee = NULL, nThreads = NULL) { +combine <- function(strong, weak, simParamBee = NULL, nThreads = NULL) { if (isColony(strong) & isColony(weak)) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) @@ -2950,7 +2821,7 @@ combine_parallel <- function(strong, weak, simParamBee = NULL, nThreads = NULL) #' apiary <- setLocation(apiary, location = locDF) #' getLocation(apiary) #' @export -setLocation <- function(x, location = c(0, 0)) { +setLocation_np <- function(x, location = c(0, 0)) { if (isColony(x)) { if (is.list(location)) { # is.list() captures also is.data.frame() stop("Argument location must be numeric, when x is a Colony class object!") @@ -3010,7 +2881,7 @@ setLocation <- function(x, location = c(0, 0)) { } #' @export -setLocation_parallel <- function(x, location = c(0, 0), simParamBee = NULL, nThreads = NULL) { +setLocation <- function(x, location = c(0, 0), simParamBee = NULL, nThreads = NULL) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } From 6403cd030109d188c053dc39644225d04dd06916 Mon Sep 17 00:00:00 2001 From: janaobsteter Date: Fri, 11 Apr 2025 14:22:11 +0200 Subject: [PATCH 08/42] Correcting L2 --- NAMESPACE | 33 ++++++++++++++++----------------- 1 file changed, 16 insertions(+), 17 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 2c1c0bef..95c16b9d 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -3,17 +3,16 @@ export(SimParamBee) export(addCastePop) export(addCastePop_internal) -export(addCastePop_parallel) +export(addCastePop_np) export(addDrones) export(addVirginQueens) -export(addWorkers) +export(addWorkers_np) export(areDronesPresent) export(areFathersPresent) export(areVirginQueensPresent) export(areWorkersPresent) export(buildUp) -export(buildUp_parallel) -export(buildUp_parallel_simplified) +export(buildUp_np) export(calcBeeAlleleFreq) export(calcBeeGRMIbd) export(calcBeeGRMIbs) @@ -25,9 +24,9 @@ export(calcPerformanceCriterion) export(calcQueensPHomBrood) export(calcSelectionCriterion) export(collapse) -export(collapse_parallel) +export(collapse_np) export(combine) -export(combine_parallel) +export(combine_np) export(createCastePop_np) export(createCastePop_p) export(createColony) @@ -43,7 +42,7 @@ export(cross_np) export(cross_p) export(downsize) export(downsizePUnif) -export(downsize_parallel) +export(downsize_np) export(getCaste) export(getCasteId) export(getCastePop) @@ -188,39 +187,39 @@ export(pullVirginQueens) export(pullWorkers) export(rcircle) export(reQueen) -export(reQueen_parallel) +export(reQueen_np) export(reduceDroneGeno) export(reduceDroneHaplo) export(removeCastePop) -export(removeCastePop_parallel) +export(removeCastePop_np) export(removeColonies) export(removeDrones) export(removeQueen) -export(removeVirginQueens_parallel) +export(removeVirginQueens) export(removeWorkers) export(replaceCastePop) -export(replaceCastePop_parallel) +export(replaceCastePop_np) export(replaceDrones) export(replaceVirginQueens) export(replaceWorkers) export(resetEvents) -export(resetEvents_parallel) +export(resetEvents_np) export(selectColonies) -export(setEvents_parallel) +export(setEvents) export(setLocation) -export(setLocation_parallel) +export(setLocation_np) export(setMisc) export(setQueensYearOfBirth) export(simulateHoneyBeeGenomes) export(split) export(splitPColonyStrength) export(splitPUnif) -export(split_parallel) +export(split_np) export(supersede) -export(supersede_parallel) +export(supersede_np) export(swarm) export(swarmPUnif) -export(swarm_parallel) +export(swarm_np) exportClasses(Colony) exportClasses(MultiColony) import(AlphaSimR) From 7176b74d53248ae18347ced5f4fcc2404f3394a5 Mon Sep 17 00:00:00 2001 From: janaobsteter Date: Fri, 11 Apr 2025 14:31:18 +0200 Subject: [PATCH 09/42] Correcting L2 --- NAMESPACE | 26 +++++++++++++------------- R/Functions_L2_Colony.R | 26 +++++++++++++------------- 2 files changed, 26 insertions(+), 26 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 95c16b9d..f9c0a662 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,9 +1,9 @@ # Generated by roxygen2: do not edit by hand export(SimParamBee) -export(addCastePop) export(addCastePop_internal) export(addCastePop_np) +export(addCastePop_p) export(addDrones) export(addVirginQueens) export(addWorkers_np) @@ -11,8 +11,8 @@ export(areDronesPresent) export(areFathersPresent) export(areVirginQueensPresent) export(areWorkersPresent) -export(buildUp) export(buildUp_np) +export(buildUp_p) export(calcBeeAlleleFreq) export(calcBeeGRMIbd) export(calcBeeGRMIbs) @@ -23,10 +23,10 @@ export(calcInheritanceCriterion) export(calcPerformanceCriterion) export(calcQueensPHomBrood) export(calcSelectionCriterion) -export(collapse) export(collapse_np) -export(combine) +export(collapse_p) export(combine_np) +export(combine_p) export(createCastePop_np) export(createCastePop_p) export(createColony) @@ -40,9 +40,9 @@ export(createVirginQueens) export(createWorkers) export(cross_np) export(cross_p) -export(downsize) export(downsizePUnif) export(downsize_np) +export(downsize_p) export(getCaste) export(getCasteId) export(getCastePop) @@ -186,40 +186,40 @@ export(pullQueen) export(pullVirginQueens) export(pullWorkers) export(rcircle) -export(reQueen) export(reQueen_np) +export(reQueen_p) export(reduceDroneGeno) export(reduceDroneHaplo) -export(removeCastePop) export(removeCastePop_np) +export(removeCastePop_p) export(removeColonies) export(removeDrones) export(removeQueen) export(removeVirginQueens) export(removeWorkers) -export(replaceCastePop) export(replaceCastePop_np) +export(replaceCastePop_p) export(replaceDrones) export(replaceVirginQueens) export(replaceWorkers) -export(resetEvents) export(resetEvents_np) +export(resetEvents_p) export(selectColonies) export(setEvents) -export(setLocation) export(setLocation_np) +export(setLocation_p) export(setMisc) export(setQueensYearOfBirth) export(simulateHoneyBeeGenomes) -export(split) export(splitPColonyStrength) export(splitPUnif) export(split_np) -export(supersede) +export(split_p) export(supersede_np) -export(swarm) +export(supersede_p) export(swarmPUnif) export(swarm_np) +export(swarm_p) exportClasses(Colony) exportClasses(MultiColony) import(AlphaSimR) diff --git a/R/Functions_L2_Colony.R b/R/Functions_L2_Colony.R index 44572889..3d3699cb 100644 --- a/R/Functions_L2_Colony.R +++ b/R/Functions_L2_Colony.R @@ -188,7 +188,7 @@ reQueen_np <- function(x, queen, removeVirginQueens = TRUE, simParamBee = NULL) } #' @export -reQueen <- function(x, queen, removeVirginQueens = TRUE, simParamBee = NULL, nThreads = NULL) { +reQueen_p <- function(x, queen, removeVirginQueens = TRUE, simParamBee = NULL, nThreads = NULL) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } @@ -427,7 +427,7 @@ addCastePop_np <- function(x, caste = NULL, nInd = NULL, new = FALSE, } #' @export -addCastePop <- function(x, caste = NULL, nInd = NULL, new = FALSE, +addCastePop_p <- function(x, caste = NULL, nInd = NULL, new = FALSE, year = NULL, simParamBee = NULL, nThreads = NULL, ...) { if (is.null(simParamBee)) { @@ -784,7 +784,7 @@ buildUp_np <- function(x, nWorkers = NULL, nDrones = NULL, } #' @export -buildUp <- function(x, nWorkers = NULL, nDrones = NULL, +buildUp_p <- function(x, nWorkers = NULL, nDrones = NULL, new = TRUE, resetEvents = FALSE, simParamBee = NULL, nThreads = NULL, ...) { if (is.null(simParamBee)) { @@ -1043,7 +1043,7 @@ downsize_np <- function(x, p = NULL, use = "rand", new = FALSE, } #' @export -downsize <- function(x, p = NULL, use = "rand", new = FALSE, +downsize_p <- function(x, p = NULL, use = "rand", new = FALSE, simParamBee = NULL, nThreads = NULL, ...) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) @@ -1274,7 +1274,7 @@ replaceCastePop_np <- function(x, caste = NULL, p = 1, use = "rand", exact = TRU #' @export -replaceCastePop <- function(x, caste = NULL, p = 1, use = "rand", exact = TRUE, +replaceCastePop_p <- function(x, caste = NULL, p = 1, use = "rand", exact = TRUE, year = NULL, simParamBee = NULL) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) @@ -1499,7 +1499,7 @@ removeCastePop_np <- function(x, caste = NULL, p = 1, use = "rand", } #' @export -removeCastePop <- function(x, caste = NULL, p = 1, use = "rand", +removeCastePop_p <- function(x, caste = NULL, p = 1, use = "rand", year = NULL, simParamBee = NULL, nThreads = NULL) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) @@ -1708,7 +1708,7 @@ resetEvents_np <- function(x, collapse = NULL) { } #' @export -resetEvents <- function(x, collapse = NULL, simParamBee = NULL, nThreads = NULL) { +resetEvents_p <- function(x, collapse = NULL, simParamBee = NULL, nThreads = NULL) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } @@ -1809,7 +1809,7 @@ collapse_np <- function(x) { } #' @export -collapse <- function(x, simParamBee = NULL, nThreads = NULL) { +collapse_p <- function(x, simParamBee = NULL, nThreads = NULL) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } @@ -2032,7 +2032,7 @@ swarm_np <- function(x, p = NULL, year = NULL, } #' @export -swarm <- function(x, p = NULL, year = NULL, +swarm_p <- function(x, p = NULL, year = NULL, sampleLocation = TRUE, radius = NULL, simParamBee = NULL, nThreads= NULL, ...) { if (is.null(simParamBee)) { @@ -2282,7 +2282,7 @@ supersede_np <- function(x, year = NULL, nVirginQueens = NULL, simParamBee = NUL } #' @export -supersede <- function(x, addVirginQueens = TRUE, year = NULL, simParamBee = NULL, nThreads = NULL, ...) { +supersede_p <- function(x, addVirginQueens = TRUE, year = NULL, simParamBee = NULL, nThreads = NULL, ...) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } @@ -2515,7 +2515,7 @@ split_np <- function(x, p = NULL, year = NULL, simParamBee = NULL, ...) { } #' @export -split <- function(x, p = NULL, year = NULL, simParamBee = NULL, nThreads = NULL, ...) { +split_p <- function(x, p = NULL, year = NULL, simParamBee = NULL, nThreads = NULL, ...) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } @@ -2735,7 +2735,7 @@ combine_np <- function(strong, weak) { } #' @export -combine <- function(strong, weak, simParamBee = NULL, nThreads = NULL) { +combine_p <- function(strong, weak, simParamBee = NULL, nThreads = NULL) { if (isColony(strong) & isColony(weak)) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) @@ -2881,7 +2881,7 @@ setLocation_np <- function(x, location = c(0, 0)) { } #' @export -setLocation <- function(x, location = c(0, 0), simParamBee = NULL, nThreads = NULL) { +setLocation_p <- function(x, location = c(0, 0), simParamBee = NULL, nThreads = NULL) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } From 842d98d2e9efded5af13986978d7177e417887db Mon Sep 17 00:00:00 2001 From: janaobsteter Date: Mon, 14 Apr 2025 14:24:27 +0200 Subject: [PATCH 10/42] Changing removeQueen to not include nTHreads --- R/Functions_L2_Colony.R | 24 +++++++++++++++--------- 1 file changed, 15 insertions(+), 9 deletions(-) diff --git a/R/Functions_L2_Colony.R b/R/Functions_L2_Colony.R index 3d3699cb..4cdc55ff 100644 --- a/R/Functions_L2_Colony.R +++ b/R/Functions_L2_Colony.R @@ -1358,7 +1358,7 @@ replaceDrones <- function(x, p = 1, use = "rand", simParamBee = NULL) { #' @describeIn replaceCastePop Replaces some virgin queens in a colony #' @export -replaceVirginQueens <- function(x, p = 1, use = "rand", simParamBee = NULL) { +replaceVirginQueens_np <- function(x, p = 1, use = "rand", simParamBee = NULL) { ret <- replaceCastePop( x = x, caste = "virginQueens", p = p, use = use, simParamBee = simParamBee @@ -1366,6 +1366,7 @@ replaceVirginQueens <- function(x, p = 1, use = "rand", simParamBee = NULL) { return(ret) } + #' @rdname removeCastePop #' @title Remove a proportion of caste individuals from a colony #' @@ -1572,29 +1573,34 @@ removeCastePop_p <- function(x, caste = NULL, p = 1, use = "rand", #' @describeIn removeCastePop Remove queen from a colony #' @export #' -removeQueen <- function(x, year = NULL, simParamBee = NULL, nThreads = NULL) { - ret <- removeCastePop(x = x, caste = "queen", p = 1, year = year, simParamBee = simParamBee, nThreads = nThreads) +removeQueen <- function(x, year = NULL, simParamBee = NULL) { + ret <- removeCastePop(x = x, caste = "queen", p = 1, year = year, simParamBee = simParamBee) return(ret) } + #' @describeIn removeCastePop Remove workers from a colony #' @export -removeWorkers <- function(x, p = 1, use = "rand", simParamBee = NULL, nThreads = NULL) { - ret <- removeCastePop(x = x, caste = "workers", p = p, use = use, simParamBee = simParamBee, nThreads = nThreads) +removeWorkers <- function(x, p = 1, use = "rand", simParamBee = NULL) { + ret <- removeCastePop(x = x, caste = "workers", p = p, use = use, simParamBee = simParamBee) return(ret) } + + #' @describeIn removeCastePop Remove workers from a colony #' @export -removeDrones <- function(x, p = 1, use = "rand", simParamBee = NULL, nThreads = NULL) { - ret <- removeCastePop(x = x, caste = "drones", p = p, use = use, simParamBee = simParamBee, nThreads = nThreads) +removeDrones <- function(x, p = 1, use = "rand", simParamBee = NULL) { + ret <- removeCastePop(x = x, caste = "drones", p = p, use = use, simParamBee = simParamBee) return(ret) } + + #' @describeIn removeCastePop Remove virgin queens from a colony #' @export -removeVirginQueens <- function(x, p = 1, use = "rand", simParamBee = NULL, nThreads = NULL) { - ret <- removeCastePop(x = x, caste = "virginQueens", p = p, use = use, simParamBee = simParamBee, nThreads = nThreads) +removeVirginQueens <- function(x, p = 1, use = "rand", simParamBee = NULL) { + ret <- removeCastePop(x = x, caste = "virginQueens", p = p, use = use, simParamBee = simParamBee) return(ret) } From aa2fc6bb16293eeb6b884fadcfc9cf4e8dc57f9e Mon Sep 17 00:00:00 2001 From: janaobsteter Date: Tue, 15 Apr 2025 09:24:05 +0200 Subject: [PATCH 11/42] Removing non-parallel versions --- NAMESPACE | 53 +- R/Functions_L1_Pop.R | 454 +---------------- R/Functions_L2_Colony.R | 993 ++------------------------------------ R/Functions_L3_Colonies.R | 35 +- man/MultiColony-class.Rd | 8 +- man/addCastePop.Rd | 29 +- man/buildUp.Rd | 10 +- man/collapse.Rd | 2 +- man/combine.Rd | 2 +- man/createCastePop.Rd | 14 +- man/createMultiColony.Rd | 2 +- man/cross.Rd | 1 + man/pullCastePop.Rd | 3 +- man/reQueen.Rd | 8 +- man/removeCastePop.Rd | 36 +- man/resetEvents.Rd | 2 +- man/setLocation.Rd | 2 +- man/split.Rd | 2 +- man/supersede.Rd | 12 +- man/swarm.Rd | 1 + 20 files changed, 145 insertions(+), 1524 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index f9c0a662..ca22c22c 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,18 +1,16 @@ # Generated by roxygen2: do not edit by hand export(SimParamBee) +export(addCastePop) export(addCastePop_internal) -export(addCastePop_np) -export(addCastePop_p) export(addDrones) export(addVirginQueens) -export(addWorkers_np) +export(addWorkers) export(areDronesPresent) export(areFathersPresent) export(areVirginQueensPresent) export(areWorkersPresent) -export(buildUp_np) -export(buildUp_p) +export(buildUp) export(calcBeeAlleleFreq) export(calcBeeGRMIbd) export(calcBeeGRMIbs) @@ -23,26 +21,20 @@ export(calcInheritanceCriterion) export(calcPerformanceCriterion) export(calcQueensPHomBrood) export(calcSelectionCriterion) -export(collapse_np) -export(collapse_p) -export(combine_np) -export(combine_p) -export(createCastePop_np) -export(createCastePop_p) +export(collapse) +export(combine) +export(createCastePop) export(createColony) export(createCrossPlan) export(createDCA) export(createDrones) export(createMatingStationDCA) -export(createMultiColony_np) -export(createMultiColony_p) +export(createMultiColony) export(createVirginQueens) export(createWorkers) -export(cross_np) -export(cross_p) +export(cross) +export(downsize) export(downsizePUnif) -export(downsize_np) -export(downsize_p) export(getCaste) export(getCasteId) export(getCastePop) @@ -176,8 +168,7 @@ export(nWorkersColonyPhenotype) export(nWorkersPoisson) export(nWorkersTruncPoisson) export(pHomBrood) -export(pullCastePop_np) -export(pullCastePop_p) +export(pullCastePop) export(pullColonies) export(pullDroneGroupsFromDCA) export(pullDrones) @@ -186,40 +177,32 @@ export(pullQueen) export(pullVirginQueens) export(pullWorkers) export(rcircle) -export(reQueen_np) -export(reQueen_p) +export(reQueen) export(reduceDroneGeno) export(reduceDroneHaplo) -export(removeCastePop_np) -export(removeCastePop_p) +export(removeCastePop) export(removeColonies) export(removeDrones) export(removeQueen) export(removeVirginQueens) export(removeWorkers) -export(replaceCastePop_np) -export(replaceCastePop_p) +export(replaceCastePop) export(replaceDrones) export(replaceVirginQueens) export(replaceWorkers) -export(resetEvents_np) -export(resetEvents_p) +export(resetEvents) export(selectColonies) export(setEvents) -export(setLocation_np) -export(setLocation_p) +export(setLocation) export(setMisc) export(setQueensYearOfBirth) export(simulateHoneyBeeGenomes) +export(split) export(splitPColonyStrength) export(splitPUnif) -export(split_np) -export(split_p) -export(supersede_np) -export(supersede_p) +export(supersede) +export(swarm) export(swarmPUnif) -export(swarm_np) -export(swarm_p) exportClasses(Colony) exportClasses(MultiColony) import(AlphaSimR) diff --git a/R/Functions_L1_Pop.R b/R/Functions_L1_Pop.R index a6fe243c..469ebef1 100644 --- a/R/Functions_L1_Pop.R +++ b/R/Functions_L1_Pop.R @@ -397,167 +397,7 @@ getVirginQueens <- function(x, nInd = NULL, use = "rand", collapse = FALSE, simP # TODO: explore options for implementing difference between workers' and queens' # patrilines # https://github.com/HighlanderLab/SIMplyBee/issues/78 -createCastePop_np <- function(x, caste = NULL, nInd = NULL, - exact = TRUE, year = NULL, - editCsd = TRUE, csdAlleles = NULL, - simParamBee = NULL, - ...) { - if (is.null(simParamBee)) { - simParamBee <- get(x = "SP", envir = .GlobalEnv) - } - if (is.null(nInd)) { - if (caste == "virginQueens") { - nInd <- simParamBee$nVirginQueens - } else if (caste == "workers") { - nInd <- simParamBee$nWorkers - } else if (caste == "drones") { - nInd <- simParamBee$nDrones - } - } - if (is.function(nInd)) { - nInd <- nInd(x, ...) - } else { - if (!is.null(nInd) && any(nInd < 0)) { - stop("nInd must be non-negative or NULL!") - } - } - # doing "if (is.function(nInd))" below - if (isMapPop(x)) { - if (caste != "virginQueens") { # Creating virgin queens if input is a MapPop - stop("MapPop-class can only be used to create virgin queens!") - } - ret <- newPop(x, simParam = simParamBee) - if (!is.null(simParamBee$csdChr)) { - if (editCsd) { - ret <- editCsdLocus(ret, alleles = csdAlleles, simParamBee = simParamBee) - } - } - ret@sex[] <- "F" - simParamBee$changeCaste(id = ret@id, caste = "virginQueens") - if (!is.null(year)) { - ret <- setQueensYearOfBirth(x = ret, year = year, simParamBee = simParamBee) - } - } else if (isPop(x)) { - if (caste != "drones") { # Creating drones if input is a Pop - stop("Pop-class can only be used to create drones!") - } - if (any(!(isVirginQueen(x, simParamBee = simParamBee) | isQueen(x, simParamBee = simParamBee)))) { - stop("Individuals in x must be virgin queens or queens!") - } - if (length(nInd) == 1) { - # Diploid version - a hack, but it works - ret <- makeDH(pop = x, nDH = nInd, keepParents = FALSE, simParam = simParamBee) - } else { - if (length(nInd) < nInd(x)) { - stop("Too few values in the nInd argument!") - } - if (length(nInd) > 1 && length(nInd) > nInd(x)) { - warning(paste0("Too many values in the nInd argument, taking only the first ", nInd(x), "values!")) - nInd <- nInd[1:nInd(x)] - } - ret <- list() - for (virginQueen in 1:nInd(x)) { - ret[[virginQueen]] <- makeDH(pop = x[virginQueen], nDH = nInd[virginQueen], keepParents = FALSE, simParam = simParamBee) - } - ret <- mergePops(ret) - } - ret@sex[] <- "M" - simParamBee$addToCaste(id = ret@id, caste = "drones") - } else if (isColony(x)) { - if (!isQueenPresent(x, simParamBee = simParamBee)) { - stop("Missing queen!") - } - if (length(nInd) > 1) { - warning("More than one value in the nInd argument, taking only the first value!") - nInd <- nInd[1] - } - if (caste == "workers") { - ret <- vector(mode = "list", length = 2) - names(ret) <- c("workers", "nHomBrood") - workers <- combineBeeGametes( - queen = getQueen(x, simParamBee = simParamBee), drones = getFathers(x, simParamBee = simParamBee), - nProgeny = nInd, simParamBee = simParamBee - ) - if (isCsdActive(simParamBee = simParamBee)) { - sel <- isCsdHeterozygous(pop = workers, simParamBee = simParamBee) - ret$workers <- workers[sel] - ret$nHomBrood <- nInd - sum(sel) - if (exact) { - if (nInd(ret$workers) < nInd) { - nMiss <- nInd - nInd(ret$workers) - while (0 < nMiss) { - workers <- combineBeeGametes( - queen = getQueen(x, simParamBee = simParamBee), - drones = getFathers(x, simParamBee = simParamBee), - nProgeny = nMiss, - simParamBee = simParamBee - ) - sel <- isCsdHeterozygous(pop = workers, simParamBee = simParamBee) - ret$workers <- c(ret$workers, workers[sel]) - ret$nHomBrood <- ret$nHomBrood + sum(!sel) - nMiss <- nInd - nInd(ret$workers) - } - } - } - } else { - ret$workers <- workers - ret$nHomBrood <- NA - } - ret$workers@sex[] <- "F" - simParamBee$addToCaste(id = ret$workers@id, caste = "workers") - } else if (caste == "virginQueens") { # Creating virgin queens if input is a Colony - ret <- createCastePop(x = x, caste = "workers", - nInd = nInd, exact = TRUE, simParamBee = simParamBee)$workers - ret@sex[] <- "F" - simParamBee$changeCaste(id = ret@id, caste = "virginQueens") - if (!is.null(year)) { - ret <- setQueensYearOfBirth(x = ret, year = year, simParamBee = simParamBee) - } - } else if (caste == "drones") { # Creating drones if input is a Colony - ret <- makeDH( - pop = getQueen(x, simParamBee = simParamBee), nDH = nInd, keepParents = FALSE, - simParam = simParamBee - ) - ret@sex[] <- "M" - simParamBee$addToCaste(id = ret@id, caste = "drones") - } - } else if (isMultiColony(x)) { - nCol <- nColonies(x) - nNInd <- length(nInd) - if (nNInd > 1 && nNInd < nCol) { - stop("Too few values in the nInd argument!") - } - if (nNInd > 1 && nNInd > nCol) { - warning(paste0("Too many values in the nInd argument, taking only the first ", nCol, "values!")) - nInd <- nInd[1:nCol] - } - ret <- vector(mode = "list", length = nCol) - for (colony in seq_len(nCol)) { - if (is.null(nInd)) { - nIndColony <- NULL - } else { - nIndColony <- ifelse(nNInd == 1, nInd, nInd[colony]) - } - ret[[colony]] <- createCastePop( - x = x[[colony]], caste = caste, - nInd = nIndColony, - exact = exact, - year = year, - editCsd = TRUE, csdAlleles = NULL, - simParamBee = simParamBee, ... - ) - - } - names(ret) <- getId(x) - } else { - stop("Argument x must be a Map-Pop (only for virgin queens), - Pop (only for drones), Colony, or MultiColony class object!") - } - return(ret) -} - -#' @export -createCastePop_p <- function(x, caste = NULL, nInd = NULL, +createCastePop <- function(x, caste = NULL, nInd = NULL, year = NULL, editCsd = TRUE, csdAlleles = NULL, simParamBee = NULL, @@ -675,7 +515,7 @@ createCastePop_p <- function(x, caste = NULL, nInd = NULL, # } } else if (caste == "virginQueens") { # Creating virgin queens if input is a Colony - ret <- createCastePop_p(x = x, caste = "workers", + ret <- createCastePop(x = x, caste = "workers", nInd = nInd, exact = TRUE, simParamBee = simParamBee, returnSP = returnSP, ids = ids, nThreads = 1, ...) simParamBee$changeCaste(id = ret$workers@id, caste = "virginQueens") @@ -769,7 +609,7 @@ createCastePop_p <- function(x, caste = NULL, nInd = NULL, } else { colonyIds = base::split(ids, rep(seq_along(nInd), nInd))[[as.character(colony)]] } - createCastePop_p( + createCastePop( x = x[[colony]], caste = caste, nInd = nIndColony, exact = exact, @@ -1330,86 +1170,7 @@ pullDroneGroupsFromDCA <- function(DCA, n, nDrones = NULL, #' pullCastePop(apiary, caste = "queen", collapse = TRUE) #' pullCastePop(apiary, caste = "virginQueens", collapse = TRUE) #' @export -pullCastePop_np <- function(x, caste, nInd = NULL, use = "rand", - removeFathers = TRUE, collapse = FALSE, simParamBee = NULL) { - if (is.null(simParamBee)) { - simParamBee <- get(x = "SP", envir = .GlobalEnv) - } - if (length(caste) > 1) { - stop("Argument caste can be only of length 1!") - } - if (any(nInd < 0)) { - stop("nInd must be non-negative or NULL!") - } - if (isColony(x)) { - if (length(nInd) > 1) { - warning("More than one value in the nInd argument, taking only the first value!") - nInd <- nInd[1] - } - if (is.null(slot(x, caste))) { - ret <- list(pulled = NULL, remnant = x) - } else { - if (is.null(nInd)) { - nInd <- nInd(slot(x, caste)) - } - tmp <- pullInd(pop = slot(x, caste), nInd = nInd, use = use, simParamBee = simParamBee) - if (caste == "queen") { - slot(x, caste) <- NULL - } else { - slot(x, caste) <- tmp$remnant - } - if (caste == "drones" && removeFathers) { - test <- isDrone(tmp$pulled, simParamBee = simParamBee) - if (any(!test)) { - tmp$pulled <- tmp$pulled[test] - } - } - ret <- list(pulled = tmp$pulled, remnant = x) - } - } else if (isMultiColony(x)) { - nCol <- nColonies(x) - nNInd <- length(nInd) - if (nNInd > 1 && nNInd < nCol) { - stop("Too few values in the nInd argument!") - } - if (nNInd > 1 && nNInd > nCol) { - warning(paste0("Too many values in the nInd argument, taking only the first ", nCol, "values!")) - nInd <- nInd[1:nCol] - } - ret <- vector(mode = "list", length = 2) - names(ret) <- c("pulled", "remnant") - ret$pulled <- vector(mode = "list", length = nCol) - names(ret$pulled) <- getId(x) - ret$remnant <- x - for (colony in seq_len(nCol)) { - if (is.null(nInd)) { - nIndColony <- NULL - } else { - nIndColony <- ifelse(nNInd == 1, nInd, nInd[colony]) - } - tmp <- pullCastePop(x = x[[colony]], - caste = caste, - nInd = nIndColony, - use = use, - removeFathers = removeFathers, - collapse = collapse, - simParamBee = simParamBee) - if (!is.null(tmp$pulled)) { - ret$pulled[[colony]] <- tmp$pulled - } - ret$remnant[[colony]] <- tmp$remnant - } - if (collapse) { - ret$pulled <- mergePops(ret$pulled) - } - } else { - stop("Argument x must be a Colony or MultiColony class object!") - } - return(ret) -} - -#' @export -pullCastePop_p <- function(x, caste, nInd = NULL, use = "rand", +pullCastePop <- function(x, caste, nInd = NULL, use = "rand", removeFathers = TRUE, collapse = FALSE, simParamBee = NULL, nThreads = NULL) { if (is.null(simParamBee)) { @@ -1707,202 +1468,7 @@ pullVirginQueens <- function(x, nInd = NULL, use = "rand", collapse = FALSE, sim #' \code{\link[SIMplyBee]{createMatingStationDCA}} #' #' @export -cross_np <- function(x, - crossPlan = NULL, - drones = NULL, - droneColonies = NULL, - nDrones = NULL, - spatial = FALSE, - radius = NULL, - checkCross = "error", - simParamBee = NULL, - ...) { - if (is.null(simParamBee)) { - simParamBee <- get(x = "SP", envir = .GlobalEnv) - } - if (is.null(nDrones)) { - nDrones <- simParamBee$nFathers - } - if (is.function(nDrones)) { - nD <- nDrones(...) - } else { - nD <- nDrones - } - - IDs <- as.character(getId(x)) - oneColony <- (isPop(drones)) && (length(IDs) == 1) && (is.null(crossPlan)) - dronePackages <- is.list(drones) - crossPlan_given <- !dronePackages && is.list(crossPlan) - crossPlan_create <- ifelse(!is.null(crossPlan) && !dronePackages, (crossPlan[1] == "create"), FALSE) - crossPlan_droneID <- (!is.null(crossPlan)) && !is.null(drones) - crossPlan_colonyID <- (!is.null(crossPlan)) && !is.null(droneColonies) - - - # Do all the tests here to simplify the function - if (crossPlan_droneID && !isPop(drones)) { - stop("When using a cross plan, drones must be supplied as a single Pop-class!") - } - if (crossPlan_colonyID && !isMultiColony(droneColonies)) { - stop("When using a cross plan, droneColonies must be supplied as a single MultiColony-class!") - } - if (!is.null(drones) && !is.null(droneColonies)) { - stop("You can provide either drones or droneColonies, but not both!") - } - if (is.null(drones) & is.null(droneColonies)) { - stop("You must provide either drones or droneColonies!") - } - if (!dronePackages & !isPop(drones) & is.null(droneColonies)) { - stop("The argument drones must be a Pop-class - or a list of drone Pop-class objects!") - } - if (crossPlan_given && !is.null(drones) && !all(unlist(crossPlan) %in% drones@id)) { - stop("Some drones from the crossPlan are missing in the drones population!") - } - if (dronePackages && length(IDs) != length(drones)) { #check for list of father pops - stop("Length of argument drones should match the number of virgin queens/colonies!") - } - if (!is.null(crossPlan) && all(is.null(drones), is.null(droneColonies))) { - stop("When providing a cross plan, you must also provide drones or droneColonies!") - } - if (crossPlan_given && !all(IDs %in% names(crossPlan))) { #Check for cross plan - stop("Cross plan must include all the virgin queens/colonies!") - } - if (isPop(x)) { - if (any(!isVirginQueen(x, simParamBee = simParamBee))) { - stop("Individuals in pop must be virgin queens!") - } - } - if (isColony(x) | isMultiColony(x)) { - if (any(isQueenPresent(x, simParamBee = simParamBee))) { - stop("Queen already present in the colony!") - } - if (any(!isVirginQueensPresent(x, simParamBee = simParamBee))) { - stop("No virgin queen(s) in the colony to cross!") - } - } - - - if (crossPlan_create) { - crossPlan <- createCrossPlan(x = x, - drones = drones, - droneColonies = droneColonies, - nDrones = nDrones, - spatial = spatial, - radius = radius, - simParamBee = simParamBee) - noMatches <- sapply(crossPlan, FUN = length) - if (0 %in% noMatches) { - message("There are no potential crosses for some colonies! The cross() will fail - unless argument checkCross is set to 'warning'.") - } - } - if (isPop(x) | isColony(x)) { - ret <- list() - for (virgin in seq_len(length(IDs))) { - virginID <- IDs[virgin] - if (oneColony) { - virginQueenDrones <- drones - } else if (dronePackages) { - virginQueenDrones <- drones[[virgin]] - } else if (crossPlan_given | crossPlan_create) { - if (crossPlan_droneID) { - virginQueenDrones <- drones[crossPlan[[virginID]]] - } else if (crossPlan_colonyID) { - virginMatches <- crossPlan[[virginID]] - if (length(virginMatches) > 0) { - nD <- ifelse(is.function(nDrones), nDrones(...), nDrones) - selectedDPQ <- table(sample(virginMatches, size = nD, replace = TRUE)) - virginQueenDrones <- mergePops(createDrones(droneColonies[names(selectedDPQ)], - nInd = selectedDPQ, simParamBee = simParamBee)) - } else { - virginQueenDrones <- new("Pop") - } - } - } - - if (any((virginQueenDrones@nInd == 0), (length(virginQueenDrones@nInd) == 0))) { - msg <- "Crossing failed!" - if (checkCross == "warning") { - message(msg) - ret <- x - } else if (checkCross == "error") { - stop(msg) - } - } else if (virginQueenDrones@nInd > 0) { - if (!all(isDrone(virginQueenDrones, simParamBee = simParamBee))) { - stop("Individuals in drones must be drones!") - } - if (isPop(x)) { - virginQueen <- x[virgin] - } else if (isColony(x)) { - virginQueen <- selectInd(x@virginQueens, nInd = 1, use = "rand", simParam = simParamBee) - } - - virginQueen@misc$fathers[[1]] <- virginQueenDrones - - simParamBee$changeCaste(id = virginQueen@id, caste = "queen") - simParamBee$changeCaste(id = virginQueenDrones@id, caste = "fathers") - - virginQueen <- setMisc(x = virginQueen, node = "nWorkers", value = 0) - virginQueen <- setMisc(x = virginQueen, node = "nDrones", value = 0) - virginQueen <- setMisc(x = virginQueen, node = "nHomBrood", value = 0) - if (isCsdActive(simParamBee = simParamBee)) { - val <- calcQueensPHomBrood(x = virginQueen, simParamBee = simParamBee) - } else { - val <- NA - } - virginQueen <- setMisc(x = virginQueen, node = "pHomBrood", value = val) - - if (isPop(x)) { - ret[[virgin]] <- virginQueen - } else if (isColony(x)) { - x <- reQueen(x = x, queen = virginQueen, simParamBee = simParamBee) - x <- removeVirginQueens(x, simParamBee = simParamBee) - ret <- x - } - } - } - if (isPop(x)) { - ret <- mergePops(ret) - } - } else if (isMultiColony(x)) { - nCol <- nColonies(x) - if (nCol == 0) { - ret <- createMultiColony(simParamBee = simParamBee) - } else { - ret <- createMultiColony(n = nCol, simParamBee = simParamBee) - for (colony in seq_len(nCol)) { - if (oneColony) { - colonyDrones <- drones - } else if (dronePackages) { - colonyDrones <- drones[[colony]] - } else { - if (crossPlan_colonyID) { - colonyDrones <- NULL - } else if(crossPlan_droneID) { - colonyDrones <- drones - } - } - ret[[colony]] <- cross( - x = x[[colony]], - drones = colonyDrones, - crossPlan = crossPlan, - droneColonies = droneColonies, - nDrones = nDrones, - spatial = spatial, - radius = radius, - checkCross = checkCross, - simParamBee = simParamBee - ) - } - } - } - validObject(ret) - return(ret) -} - -#' @export -cross_p <- function(x, +cross <- function(x, crossPlan = NULL, drones = NULL, droneColonies = NULL, @@ -1992,12 +1558,12 @@ cross_p <- function(x, inputId <- getId(x) if (isColony(x)) { colony <- x - x <- pullCastePop_p(x, caste = "virginQueens", nInd = 1)$pulled + x <- pullCastePop(x, caste = "virginQueens", nInd = 1)$pulled ID_by_input <- data.frame(inputId = inputId, virginId = getId(x)) } else if (isMultiColony(x)) { multicolony <- x - x <- pullCastePop_p(x, caste = "virginQueens", nInd = 1)$pulled + x <- pullCastePop(x, caste = "virginQueens", nInd = 1)$pulled ID_by_input <- data.frame(inputId = inputId, virginId = unlist(sapply(x, FUN = function(y) getId(y)))) x <- mergePops(x) @@ -2062,7 +1628,7 @@ cross_p <- function(x, colnames(crossPlanDF_DPCtable) <- c("DPC", "noDrones") selectedDPC = droneColonies[as.character(crossPlanDF_DPCtable$DPC)] - dronesByDPC <- createCastePop_p(selectedDPC, caste = "drones", + dronesByDPC <- createCastePop(selectedDPC, caste = "drones", nInd = as.integer(crossPlanDF_DPCtable$noDrones), simParamBee = simParamBee) dronesByDPC_DF <- data.frame(DPC = rep(names(dronesByDPC), as.vector(crossPlanDF_DPCtable$noDrones)), droneID = unlist(sapply(dronesByDPC, FUN = function(x) getId(x)))) %>% @@ -2147,8 +1713,8 @@ cross_p <- function(x, ret <- reQueen(x = colony, queen = x[1], simParamBee = simParamBee) ret <- removeVirginQueens(ret, simParamBee = simParamBee) } else if (type == "MultiColony") { - ret <- reQueen_p(x = multicolony, queen = mergePops(x), simParamBee = simParamBee) - ret <- removeCastePop_p(ret, caste = "virginQueens", simParamBee = simParamBee) + ret <- reQueen(x = multicolony, queen = mergePops(x), simParamBee = simParamBee) + ret <- removeCastePop(ret, caste = "virginQueens", simParamBee = simParamBee) } validObject(ret) diff --git a/R/Functions_L2_Colony.R b/R/Functions_L2_Colony.R index 4cdc55ff..033ca8bc 100644 --- a/R/Functions_L2_Colony.R +++ b/R/Functions_L2_Colony.R @@ -145,50 +145,7 @@ createColony <- function(x = NULL, simParamBee = NULL, id = NULL) { #' getCasteId(apiary, caste = "virginQueens") #' #' @export -reQueen_np <- function(x, queen, removeVirginQueens = TRUE, simParamBee = NULL) { - if (is.null(simParamBee)) { - simParamBee <- get(x = "SP", envir = .GlobalEnv) - } - if (!isPop(queen)) { - stop("Argument queen must be a Pop class object!") - } - if (!all(isVirginQueen(queen, simParamBee = simParamBee) | isQueen(queen, simParamBee = simParamBee))) { - stop("Individual in queen must be a virgin queen or a queen!") - } - if (isColony(x)) { - if (all(isQueen(queen, simParamBee = simParamBee))) { - if (nInd(queen) > 1) { - stop("You must provide just one queen for the colony!") - } - x@queen <- queen - if (removeVirginQueens) { - x <- removeVirginQueens(x, simParamBee = simParamBee) - } - } else { - x <- removeQueen(x, addVirginQueens = FALSE, simParamBee = simParamBee) - x@virginQueens <- queen - } - } else if (isMultiColony(x)) { - nCol <- nColonies(x) - if (nInd(queen) < nCol) { - stop("Not enough queens provided!") - } - for (colony in seq_len(nCol)) { - x[[colony]] <- reQueen( - x = x[[colony]], - queen = queen[colony], - simParamBee = simParamBee - ) - } - } else { - stop("Argument x must be a Colony or MultiColony class object!") - } - validObject(x) - return(x) -} - -#' @export -reQueen_p <- function(x, queen, removeVirginQueens = TRUE, simParamBee = NULL, nThreads = NULL) { +reQueen <- function(x, queen, removeVirginQueens = TRUE, simParamBee = NULL, nThreads = NULL) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } @@ -338,96 +295,7 @@ addCastePop_internal <- function(pop, colony, caste, new = FALSE) { #' nWorkers(addWorkers(apiary, nInd = c(50, 100))) #' #' @export -addCastePop_np <- function(x, caste = NULL, nInd = NULL, new = FALSE, - exact = FALSE, year = NULL, simParamBee = NULL, ...) { - if (is.null(simParamBee)) { - simParamBee <- get(x = "SP", envir = .GlobalEnv) - } - if (length(caste) != 1) { - stop("Argument caste must be of length 1!") - } - if (is.null(nInd)) { - if (caste == "workers") { - nInd <- simParamBee$nWorkers - } else if (caste == "drones") { - nInd <- simParamBee$nDrones - } else if (caste == "virginQueens") { - nInd <- simParamBee$nVirginQueens - } - } - # doing "if (is.function(nInd))" below - if (isColony(x)) { - if (hasCollapsed(x)) { - stop(paste0("The colony ", getId(x), " collapsed, hence you can not add individuals (from the queen) to it!")) - } - if (!isQueenPresent(x, simParamBee = simParamBee)) { - stop("Missing queen!") - } - if (length(nInd) > 1) { - warning("More than one value in the nInd argument, taking only the first value!") - nInd <- nInd[1] - } - if (is.function(nInd)) { - nInd <- nInd(x, ...) - } else { - if (!is.null(nInd) && nInd < 0) { - stop("nInd must be non-negative or NULL!") - } - } - if (0 < nInd) { - newInds <- createCastePop(x, nInd, - caste = caste, exact = exact, - year = year, simParamBee = simParamBee - ) - if (caste == "workers") { - homInds <- newInds$nHomBrood - newInds <- newInds$workers - x@queen@misc$nWorkers[[1]] <- x@queen@misc$nWorkers[[1]] + nInd(newInds) - x@queen@misc$nHomBrood[[1]] <- x@queen@misc$nHomBrood[[1]] + homInds - } - if (caste == "drones") { - x@queen@misc$nDrones[[1]] <- x@queen@misc$nDrones[[1]] + nInd(newInds) - } - if (is.null(slot(x, caste)) | new) { - slot(x, caste) <- newInds - } else { - slot(x, caste) <- c(slot(x, caste), newInds) - } - } else { - warning("The number of individuals to add is less than 0, hence adding nothing.") - } - } else if (isMultiColony(x)) { - nCol <- nColonies(x) - nNInd <- length(nInd) - if (nNInd > 1 && nNInd < nCol) { - stop("Too few values in the nInd argument!") - } - if (nNInd > 1 && nNInd > nCol) { - warning(paste0("Too many values in the nInd argument, taking only the first ", nCol, "values!")) - nInd <- nInd[1:nCol] - } - for (colony in seq_len(nCol)) { - if (is.null(nInd)) { - nIndColony <- NULL - } else { - nIndColony <- ifelse(nNInd == 1, nInd, nInd[colony]) - } - x[[colony]] <- addCastePop( - x = x[[colony]], caste = caste, - nInd = nIndColony, - new = new, - exact = exact, simParamBee = simParamBee, ... - ) - } - } else { - stop("Argument x must be a Colony or MultiColony class object!") - } - validObject(x) - return(x) -} - -#' @export -addCastePop_p <- function(x, caste = NULL, nInd = NULL, new = FALSE, +addCastePop <- function(x, caste = NULL, nInd = NULL, new = FALSE, year = NULL, simParamBee = NULL, nThreads = NULL, ...) { if (is.null(simParamBee)) { @@ -530,15 +398,6 @@ addCastePop_p <- function(x, caste = NULL, nInd = NULL, new = FALSE, #' @describeIn addCastePop Add workers to a colony #' @export -addWorkers_np <- function(x, nInd = NULL, new = FALSE, - simParamBee = NULL, ...) { - ret <- addCastePop( - x = x, caste = "workers", nInd = nInd, new = new, - simParamBee = simParamBee, ... - ) - return(ret) -} - addWorkers <- function(x, nInd = NULL, new = FALSE, simParamBee = NULL, nThreads = NULL, ...) { ret <- addCastePop( @@ -668,123 +527,7 @@ addVirginQueens <- function(x, nInd = NULL, new = FALSE, #' # Queen's counters #' getMisc(getQueen(buildUp(colony))) #' @export -buildUp_np <- function(x, nWorkers = NULL, nDrones = NULL, - new = TRUE, exact = FALSE, resetEvents = FALSE, - simParamBee = NULL, ...) { - if (is.null(simParamBee)) { - simParamBee <- get(x = "SP", envir = .GlobalEnv) - } - # Workers - if (is.null(nWorkers)) { - nWorkers <- simParamBee$nWorkers - } - - if (is.null(nDrones)) { - nDrones <- simParamBee$nDrones - } - if (is.function(nDrones)) { - nDrones <- nDrones(x = x, ...) - } - - if (isColony(x)) { - if (is.function(nWorkers)) { - nWorkers <- nWorkers(colony = x,...) - } - if (hasCollapsed(x)) { - stop(paste0("The colony ", getId(x), " collapsed, hence you can not build it up!")) - } - if (length(nWorkers) > 1) { - warning("More than one value in the nWorkers argument, taking only the first value!") - nWorkers <- nWorkers[1] - } - if (new) { - n <- nWorkers - } else { - n <- nWorkers - nWorkers(x, simParamBee = simParamBee) - } - - if (0 < n) { - x <- addWorkers( - x = x, nInd = n, new = new, - exact = exact, simParamBee = simParamBee) - } else if (n < 0) { - x@workers <- getWorkers(x, nInd = nWorkers, simParamBee = simParamBee) - } - - # Drones - if (length(nDrones) > 1) { - warning("More than one value in the nDrones argument, taking only the first value!") - nDrones <- nDrones[1] - } - if (new) { - n <- nDrones - } else { - n <- nDrones - nDrones(x, simParamBee = simParamBee) - } - - if (0 < n) { - x <- addDrones( - x = x, nInd = n, new = new, - simParamBee = simParamBee - ) - } else if (n < 0) { - x@drones <- getDrones(x, nInd = nDrones, simParamBee = simParamBee) - } - - # Events - if (resetEvents) { - x <- resetEvents(x) - } - x@production <- TRUE - } else if (isMultiColony(x)) { - nCol <- nColonies(x) - nNWorkers <- length(nWorkers) - nNDrones <- length(nDrones) - if (nNWorkers > 1 && nNWorkers < nCol) { - stop("Too few values in the nWorkers argument!") - } - if (nNDrones > 1 && nNDrones < nCol) { - stop("Too few values in the nDrones argument!") - } - if (nNWorkers > 1 && nNWorkers > nCol) { - warning(paste0("Too many values in the nWorkers argument, taking only the first ", nCol, "values!")) - nWorkers <- nWorkers[1:nCol] - } - if (nNDrones > 1 && nNDrones > nCol) { - warning(paste0("Too many values in the nDrones argument, taking only the first ", nCol, "values!")) - nNDrones <- nNDrones[1:nCol] - } - for (colony in seq_len(nCol)) { - if (is.null(nWorkers)) { - nWorkersColony <- NULL - } else { - nWorkersColony <- ifelse(nNWorkers == 1, nWorkers, nWorkers[colony]) - } - if (is.null(nDrones)) { - nDronesColony <- NULL - } else { - nDronesColony <- ifelse(nNDrones == 1, nDrones, nDrones[colony]) - } - x[[colony]] <- buildUp( - x = x[[colony]], - nWorkers = nWorkersColony, - nDrones = nDronesColony, - new = new, - exact = exact, - resetEvents = resetEvents, - simParamBee = simParamBee, ... - ) - } - } else { - stop("Argument x must be a Colony or MultiColony class object!") - } - - validObject(x) - return(x) -} - -#' @export -buildUp_p <- function(x, nWorkers = NULL, nDrones = NULL, +buildUp <- function(x, nWorkers = NULL, nDrones = NULL, new = TRUE, resetEvents = FALSE, simParamBee = NULL, nThreads = NULL, ...) { if (is.null(simParamBee)) { @@ -974,14 +717,17 @@ buildUp_p <- function(x, nWorkers = NULL, nDrones = NULL, #' nWorkers(apiary); nDrones(apiary) #' @export #' -downsize_np <- function(x, p = NULL, use = "rand", new = FALSE, - simParamBee = NULL, nThreads = NULL, ...) { +downsize <- function(x, p = NULL, use = "rand", new = FALSE, + simParamBee = NULL, nThreads = NULL, ...) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } if (!is.logical(new)) { stop("Argument new must be logical!") } + if (is.null(nThreads)) { + nThreads = simParamBee$nThreads + } if (any(1 < p)) { stop("p must not be higher than 1!") } else if (any(p < 0)) { @@ -1011,8 +757,19 @@ downsize_np <- function(x, p = NULL, use = "rand", new = FALSE, x <- removeVirginQueens(x = x, p = 1, simParamBee = simParamBee) x@production <- FALSE } else if (isMultiColony(x)) { + registerDoParallel(cores = nThreads) nCol <- nColonies(x) nP <- length(p) + + if (any(hasCollapsed(x))) { + stop("Some of hte colonies have collapsed, hence you can not downsize them!") + } + if (is.null(p)) { + p <- simParamBee$downsizeP + } + if (is.function(p)) { + p <- p(x, ...) + } if (nP > 1 && nP < nCol) { stop("Too few values in the p argument!") } @@ -1020,104 +777,21 @@ downsize_np <- function(x, p = NULL, use = "rand", new = FALSE, warning(paste0("Too many values in the p argument, taking only the first ", nCol, "values!")) p <- p[1:nCol] } - for (colony in seq_len(nCol)) { - if (is.null(p)) { - pColony <- NULL - } else { - pColony <- ifelse(nP == 1, p, p[colony]) - } - x[[colony]] <- downsize( - x = x[[colony]], - p = pColony, - use = use, - new = new, - simParamBee = simParamBee, ... - ) + if (new == TRUE) { + n <- round(nWorkers(x, simParamBee = simParamBee) * (1 - p)) + x <- addWorkers(x = x, nInd = n, new = TRUE, + simParamBee = simParamBee, + nThreads = nThreads) + } else { + x <- removeWorkers(x = x, p = p, use = use, + simParamBee = simParamBee, nThreads = nThreads) + } + x <- removeDrones(x = x, p = 1, simParamBee = simParamBee, nThreads = nThreads) + x <- removeVirginQueens(x = x, p = 1, simParamBee = simParamBee, nThreads = nThreads) + for (colony in 1:nCol) { + x[[colony]]@production <- FALSE } - } else { - stop("Argument x must be a Colony or MultiColony class object!") - } - - validObject(x) - return(x) -} - -#' @export -downsize_p <- function(x, p = NULL, use = "rand", new = FALSE, - simParamBee = NULL, nThreads = NULL, ...) { - if (is.null(simParamBee)) { - simParamBee <- get(x = "SP", envir = .GlobalEnv) - } - if (!is.logical(new)) { - stop("Argument new must be logical!") - } - if (is.null(nThreads)) { - nThreads = simParamBee$nThreads - } - if (any(1 < p)) { - stop("p must not be higher than 1!") - } else if (any(p < 0)) { - stop("p must not be less than 0!") - } - if (isColony(x)) { - if (hasCollapsed(x)) { - stop(paste0("The colony ", getId(x), " collapsed, hence you can not downsize it!")) - } - if (is.null(p)) { - p <- simParamBee$downsizeP - } - if (is.function(p)) { - p <- p(x, ...) - } - if (length(p) > 1) { - warning("More than one value in the p argument, taking only the first value!") - p <- p[1] - } - if (new == TRUE) { - n <- round(nWorkers(x, simParamBee = simParamBee) * (1 - p)) - x <- addWorkers(x = x, nInd = n, new = TRUE, simParamBee = simParamBee) - } else { - x <- removeWorkers(x = x, p = p, use = use, simParamBee = simParamBee) - } - x <- removeDrones(x = x, p = 1, simParamBee = simParamBee) - x <- removeVirginQueens(x = x, p = 1, simParamBee = simParamBee) - x@production <- FALSE - } else if (isMultiColony(x)) { - registerDoParallel(cores = nThreads) - nCol <- nColonies(x) - nP <- length(p) - - if (any(hasCollapsed(x))) { - stop("Some of hte colonies have collapsed, hence you can not downsize them!") - } - if (is.null(p)) { - p <- simParamBee$downsizeP - } - if (is.function(p)) { - p <- p(x, ...) - } - if (nP > 1 && nP < nCol) { - stop("Too few values in the p argument!") - } - if (nP > 1 && nP > nCol) { - warning(paste0("Too many values in the p argument, taking only the first ", nCol, "values!")) - p <- p[1:nCol] - } - if (new == TRUE) { - n <- round(nWorkers(x, simParamBee = simParamBee) * (1 - p)) - x <- addWorkers(x = x, nInd = n, new = TRUE, - simParamBee = simParamBee, - nThreads = nThreads) - } else { - x <- removeWorkers(x = x, p = p, use = use, - simParamBee = simParamBee, nThreads = nThreads) - } - x <- removeDrones(x = x, p = 1, simParamBee = simParamBee, nThreads = nThreads) - x <- removeVirginQueens(x = x, p = 1, simParamBee = simParamBee, nThreads = nThreads) - for (colony in 1:nCol) { - x[[colony]]@production <- FALSE - } - + } else { stop("Argument x must be a Colony or MultiColony class object!") } @@ -1186,95 +860,7 @@ downsize_p <- function(x, p = NULL, use = "rand", new = FALSE, #' apiary <- replaceWorkers(apiary, p = 0.5) #' getCasteId(apiary, caste="workers") #' @export -replaceCastePop_np <- function(x, caste = NULL, p = 1, use = "rand", exact = TRUE, - year = NULL, simParamBee = NULL) { - if (is.null(simParamBee)) { - simParamBee <- get(x = "SP", envir = .GlobalEnv) - } - if (length(caste) != 1) { - stop("Argument caste must be of length 1!") - } - if (any(1 < p)) { - stop("p must not be higher than 1!") - } else if (any(p < 0)) { - stop("p must not be less than 0!") - } - if (isColony(x)) { - if (hasCollapsed(x)) { - stop(paste0("The colony ", getId(x), " collapsed, hence you can not replace individuals in it!")) - } - if (!isQueenPresent(x, simParamBee = simParamBee)) { - stop("Missing queen!") - } - if (length(p) > 1) { - warning("More than one value in the p argument, taking only the first value!") - p <- p[1] - } - nInd <- nCaste(x, caste, simParamBee = simParamBee) - if (nInd > 0) { - nIndReplaced <- round(nInd * p) - if (nIndReplaced < nInd) { - nIndStay <- nInd - nIndReplaced - if (nIndReplaced > 0) { - tmp <- createCastePop(x, - caste = caste, - nInd = nIndReplaced, exact = exact, - year = year, simParamBee = simParamBee - ) - if (caste == "workers") { - x@queen@misc$nWorkers[[1]] <- x@queen@misc$nWorkers[[1]] + nIndReplaced - x@queen@misc$nHomBrood[[1]] <- x@queen@misc$nHomBrood[[1]] + tmp$nHomBrood - tmp <- tmp$workers - } - if (caste == "drones") { - x@queen@misc$nDrones[[1]] <- x@queen@misc$nDrones[[1]] + nIndReplaced - } - - slot(x, caste) <- c( - selectInd(slot(x, caste), nInd = nIndStay, use = use, simParam = simParamBee), - tmp - ) - } - } else { - x <- addCastePop( - x = x, caste = caste, nInd = nIndReplaced, new = TRUE, - year = year, simParamBee = simParamBee - ) - } - } - } else if (isMultiColony(x)) { - nCol <- nColonies(x) - nP <- length(p) - if (nP > 1 && nP < nCol) { - stop("Too few values in the p argument!") - } - if (nP > 1 && nP > nCol) { - warning(paste0("Too many values in the p argument, taking only the first ", nCol, "values!")) - p <- p[1:nCol] - } - for (colony in seq_len(nCol)) { - if (is.null(p)) { - pColony <- NULL - } else { - pColony <- ifelse(nP == 1, p, p[colony]) - } - x[[colony]] <- replaceCastePop( - x = x[[colony]], caste = caste, - p = pColony, - use = use, year = year, - simParamBee = simParamBee - ) - } - } else { - stop("Argument x must be a Colony or MultiColony class object!") - } - validObject(x) - return(x) -} - - -#' @export -replaceCastePop_p <- function(x, caste = NULL, p = 1, use = "rand", exact = TRUE, +replaceCastePop <- function(x, caste = NULL, p = 1, use = "rand", exact = TRUE, year = NULL, simParamBee = NULL) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) @@ -1358,7 +944,7 @@ replaceDrones <- function(x, p = 1, use = "rand", simParamBee = NULL) { #' @describeIn replaceCastePop Replaces some virgin queens in a colony #' @export -replaceVirginQueens_np <- function(x, p = 1, use = "rand", simParamBee = NULL) { +replaceVirginQueens <- function(x, p = 1, use = "rand", simParamBee = NULL) { ret <- replaceCastePop( x = x, caste = "virginQueens", p = p, use = use, simParamBee = simParamBee @@ -1424,83 +1010,7 @@ replaceVirginQueens_np <- function(x, p = 1, use = "rand", simParamBee = NULL) { #' nWorkers(apiary) #' nWorkers(removeWorkers(apiary, p = c(0.1, 0.5))) #' @export -removeCastePop_np <- function(x, caste = NULL, p = 1, use = "rand", - addVirginQueens = FALSE, nVirginQueens = NULL, - year = NULL, simParamBee = NULL) { - if (is.null(simParamBee)) { - simParamBee <- get(x = "SP", envir = .GlobalEnv) - } - if (length(caste) != 1) { - stop("Argument caste must be of length 1!") - } - if (any(1 < p)) { - stop("p must not be higher than 1!") - } else if (any(p < 0)) { - stop("p must not be less than 0!") - } - if (isColony(x)) { - if (hasCollapsed(x)) { - stop(paste0("The colony ", getId(x), " collapsed, hence can not remove individuals from it!")) - } - if (length(p) > 1) { - warning("More than one value in the p argument, taking only the first value!") - p <- p[1] - } - if (caste == "queen") { - if (addVirginQueens) { - if (is.null(nVirginQueens)) { - nVirginQueens <- simParamBee$nVirginQueens - } - x <- addVirginQueens(x, nInd = nVirginQueens, year = year, simParamBee = simParamBee) - } - } - if (p == 1) { - slot(x, caste) <- NULL - } else { - nIndStay <- round(nCaste(x, caste, simParamBee = simParamBee) * (1 - p)) - if (nIndStay > 0) { - slot(x, caste) <- selectInd( - pop = slot(x, caste), - nInd = nIndStay, - use = use, - simParam = simParamBee - ) - } else { - x <- removeCastePop(x, caste, simParamBee = simParamBee) - } - } - } else if (isMultiColony(x)) { - nCol <- nColonies(x) - nP <- length(p) - if (nP > 1 && nP < nCol) { - stop("Too few values in the p argument!") - } - if (nP > 1 && nP > nCol) { - warning(paste0("Too many values in the p argument, taking only the first ", nCol, "values!")) - p <- p[1:nCol] - } - for (colony in seq_len(nCol)) { - if (is.null(p)) { - pColony <- NULL - } else { - pColony <- ifelse(nP == 1, p, p[colony]) - } - x[[colony]] <- removeCastePop( - x = x[[colony]], caste = caste, - p = pColony, - use = use, - simParamBee = simParamBee - ) - } - } else { - stop("Argument x must be a Colony or MultiColony class object!") - } - validObject(x) - return(x) -} - -#' @export -removeCastePop_p <- function(x, caste = NULL, p = 1, use = "rand", +removeCastePop <- function(x, caste = NULL, p = 1, use = "rand", year = NULL, simParamBee = NULL, nThreads = NULL) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) @@ -1683,38 +1193,7 @@ removeVirginQueens <- function(x, p = 1, use = "rand", simParamBee = NULL) { #' hasSplit(remnants[[1]]) #' resetEvents(remnants)[[1]] #' @export -resetEvents_np <- function(x, collapse = NULL) { - if (isColony(x)) { - x@swarm <- FALSE - x@split <- FALSE - x@supersedure <- FALSE - # Reset collapse only if asked (!is.null(collapse)) or if it was not yet - # turned on (is.null(x@collapse)) - if (is.null(collapse)) { - collapse <- is.null(x@collapse) - } - if (collapse) { - x@collapse <- FALSE - } - x@production <- FALSE - validObject(x) - } else if (isMultiColony(x)) { - nCol <- nColonies(x) - for (colony in seq_len(nCol)) { - x[[colony]] <- resetEvents( - x = x[[colony]], - collapse = collapse - ) - } - validObject(x) - } else { - stop("Argument x must be a Colony or MultiColony class object!") - } - return(x) -} - -#' @export -resetEvents_p <- function(x, collapse = NULL, simParamBee = NULL, nThreads = NULL) { +resetEvents <- function(x, collapse = NULL, simParamBee = NULL, nThreads = NULL) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } @@ -1798,24 +1277,7 @@ resetEvents_p <- function(x, collapse = NULL, simParamBee = NULL, nThreads = NUL #' apiaryLeft <- tmp$remnant #' hasCollapsed(apiaryLeft) #' @export -collapse_np <- function(x) { - if (isColony(x)) { - x@collapse <- TRUE - x@production <- FALSE - } else if (isMultiColony(x)) { - nCol <- nColonies(x) - for (colony in seq_len(nCol)) { - x[[colony]] <- collapse(x = x[[colony]]) - } - } else { - stop("Argument x must be a Colony or MultiColony class object!") - } - validObject(x) - return(x) -} - -#' @export -collapse_p <- function(x, simParamBee = NULL, nThreads = NULL) { +collapse <- function(x, simParamBee = NULL, nThreads = NULL) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } @@ -1908,137 +1370,7 @@ collapse_p <- function(x, simParamBee = NULL, nThreads = NULL) { #' # Swarm only the pulled colonies #' (swarm(tmp$pulled, p = 0.6)) #' @export -swarm_np <- function(x, p = NULL, year = NULL, - sampleLocation = TRUE, radius = NULL, - simParamBee = NULL, ...) { - if (is.null(simParamBee)) { - simParamBee <- get(x = "SP", envir = .GlobalEnv) - } - if (is.null(p)) { - p <- simParamBee$swarmP - } - if (is.null(radius)) { - radius <- simParamBee$swarmRadius - } - if (is.null(nVirginQueens)) { - nVirginQueens <- simParamBee$nVirginQueens - } - if (isColony(x)) { - if (hasCollapsed(x)) { - stop(paste0("The colony ", getId(x), " collapsed, hence it can not swarm!")) - } - if (!isQueenPresent(x, simParamBee = simParamBee)) { - stop("No queen present in the colony!") - } - if (!isWorkersPresent(x, simParamBee = simParamBee)) { - stop("No workers present in the colony!") - } - if (is.function(p)) { - p <- p(x, ...) - } else { - if (p < 0 | 1 < p) { - stop("p must be between 0 and 1 (inclusive)!") - } - if (length(p) > 1) { - warning("More than one value in the p argument, taking only the first value!") - p <- p[1] - } - } - if (is.function(nVirginQueens)) { - nVirginQueens <- nVirginQueens(x, ...) - } - nWorkers <- nWorkers(x, simParamBee = simParamBee) - nWorkersSwarm <- round(nWorkers * p) - - # TODO: Add use="something" to select pWorkers that swarm - # https://github.com/HighlanderLab/SIMplyBee/issues/160 - tmp <- pullWorkers(x = x, nInd = nWorkersSwarm, simParamBee = simParamBee) - currentLocation <- getLocation(x) - - if (sampleLocation) { - newLocation <- c(currentLocation + rcircle(radius = radius)) - # c() to convert row-matrix to a numeric vector - } else { - newLocation <- currentLocation - } - - swarmColony <- createColony(x = x@queen, simParamBee = simParamBee) - # It's not re-queening, but the function also sets the colony id - - swarmColony@workers <- tmp$pulled - swarmColony <- setLocation(x = swarmColony, location = newLocation) - - tmpVirginQueen <- createVirginQueens( - x = x, nInd = 1, - year = year, - simParamBee = simParamBee - ) - - remnantColony <- createColony(x = tmpVirginQueen, simParamBee = simParamBee) - remnantColony@workers <- getWorkers(tmp$remnant, simParamBee = simParamBee) - remnantColony@drones <- getDrones(x, simParamBee = simParamBee) - # Workers raise virgin queens from eggs laid by the queen and one random - # virgin queen prevails, so we create just one - # Could consider that a non-random one prevails (say the more aggressive one), - # by creating many virgin queens and then picking the one with highest - # gv/pheno for competition or some other criteria (patri-lineage) - - remnantColony <- setLocation(x = remnantColony, location = currentLocation) - - remnantColony@swarm <- TRUE - swarmColony@swarm <- TRUE - remnantColony@production <- FALSE - swarmColony@production <- FALSE - - ret <- list(swarm = swarmColony, remnant = remnantColony) - } else if (isMultiColony(x)) { - nCol <- nColonies(x) - nP <- length(p) - if (nP > 1 && nP < nCol) { - stop("Too few values in the p argument!") - } - if (nP > 1 && nP > nCol) { - warning(paste0("Too many values in the p argument, taking only the first ", nCol, "values!")) - p <- p[1:nCol] - } - if (nCol == 0) { - ret <- list( - swarm = createMultiColony(simParamBee = simParamBee), - remnant = createMultiColony(simParamBee = simParamBee) - ) - } else { - ret <- list( - swarm = createMultiColony(n = nCol, simParamBee = simParamBee), - remnant = createMultiColony(n = nCol, simParamBee = simParamBee) - ) - for (colony in seq_len(nCol)) { - if (is.null(p)) { - pColony <- NULL - } else { - pColony <- ifelse(nP == 1, p, p[colony]) - } - tmp <- swarm(x[[colony]], - p = pColony, - year = year, - sampleLocation = sampleLocation, - radius = radius, - simParamBee = simParamBee, ... - ) - ret$swarm[[colony]] <- tmp$swarm - ret$remnant[[colony]] <- tmp$remnant - } - } - } else { - stop("Argument x must be a Colony or MultiColony class object!") - } - - validObject(ret$swarmColony) - validObject(ret$remnantColony) - return(ret) -} - -#' @export -swarm_p <- function(x, p = NULL, year = NULL, +swarm <- function(x, p = NULL, year = NULL, sampleLocation = TRUE, radius = NULL, simParamBee = NULL, nThreads= NULL, ...) { if (is.null(simParamBee)) { @@ -2239,56 +1571,7 @@ swarm_p <- function(x, p = NULL, year = NULL, #' # Swarm only the pulled colonies #' (supersede(tmp$pulled)) #' @export -supersede_np <- function(x, year = NULL, nVirginQueens = NULL, simParamBee = NULL, nThreads = NULL, ...) { - if (is.null(simParamBee)) { - simParamBee <- get(x = "SP", envir = .GlobalEnv) - } - if (is.null(nThreads)) { - nThreads = simParamBee$nThreads - } - if (is.null(nVirginQueens)) { - nVirginQueens <- simParamBee$nVirginQueens - } - if (isColony(x)) { - if (hasCollapsed(x)) { - stop(paste0("The colony ", getId(x), " collapsed, hence it can not supresede!")) - } - if (!isQueenPresent(x, simParamBee = simParamBee)) { - stop("No queen present in the colony!") - } - if (is.function(nVirginQueens)) { - nVirginQueens <- nVirginQueens(x, ...) - } - x <- removeQueen(x, addVirginQueens = TRUE, nVirginQueens = nVirginQueens, - year = year, simParamBee = simParamBee) - x@virginQueens <- selectInd(x@virginQueens, nInd = 1, use = "rand", simParam = simParamBee) - # TODO: We could consider that a non-random virgin queen prevails (say the most - # aggressive one), by creating many virgin queens and then picking the - # one with highest pheno for competition or some other criteria - # https://github.com/HighlanderLab/SIMplyBee/issues/239 - x@supersedure <- TRUE - } else if (isMultiColony(x)) { - nCol <- nColonies(x) - if (nCol == 0) { - x <- createMultiColony(simParamBee = simParamBee) - } else { - for (colony in seq_len(nCol)) { - x[[colony]] <- supersede(x[[colony]], - year = year, - nVirginQueens = nVirginQueens, - simParamBee = simParamBee, ... - ) - } - } - } else { - stop("Argument x must be a Colony or MultiColony class object!") - } - validObject(x) - return(x) -} - -#' @export -supersede_p <- function(x, addVirginQueens = TRUE, year = NULL, simParamBee = NULL, nThreads = NULL, ...) { +supersede <- function(x, addVirginQueens = TRUE, year = NULL, simParamBee = NULL, nThreads = NULL, ...) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } @@ -2417,111 +1700,7 @@ supersede_p <- function(x, addVirginQueens = TRUE, year = NULL, simParamBee = NU #' # Split only the pulled colonies #' (split(tmp$pulled, p = 0.5)) #' @export -split_np <- function(x, p = NULL, year = NULL, simParamBee = NULL, ...) { - if (is.null(simParamBee)) { - simParamBee <- get(x = "SP", envir = .GlobalEnv) - } - if (is.null(p)) { - p <- simParamBee$splitP - } - if (isColony(x)) { - if (hasCollapsed(x)) { - stop(paste0("The colony ", getId(x), " collapsed, hence you can not split it!")) - } - if (!isQueenPresent(x, simParamBee = simParamBee)) { - stop("No queen present in the colony!") - } - if (!isWorkersPresent(x, simParamBee = simParamBee)) { - stop("No workers present in the colony!") - } - if (is.function(p)) { - p <- p(x, ...) - } else { - if (p < 0 | 1 < p) { - stop("p must be between 0 and 1 (inclusive)!") - } - if (length(p) > 1) { - warning("More than one value in the p argument, taking only the first value!") - p <- p[1] - } - } - nWorkers <- nWorkers(x, simParamBee = simParamBee) - nWorkersSplit <- round(nWorkers * p) - # TODO: Split colony at random by default, but we could make it as a - # function of some parameters - # https://github.com/HighlanderLab/SIMplyBee/issues/179 - tmp <- pullWorkers(x = x, nInd = nWorkersSplit, simParamBee = simParamBee) - remnantColony <- tmp$remnant - tmpVirginQueens <- createVirginQueens( - x = x, nInd = 1, - year = year, - simParamBee = simParamBee - ) - # Workers raise virgin queens from eggs laid by the queen (assuming) that - # a frame of brood is also provided to the split and then one random virgin - # queen prevails, so we create just one - # TODO: Could consider that a non-random one prevails (say the most aggressive - # one), by creating many virgin queens and then picking the one with - # highest pheno for competition or some other criteria - # https://github.com/HighlanderLab/SIMplyBee/issues/239 - - splitColony <- createColony(x = tmpVirginQueens, simParamBee = simParamBee) - splitColony@workers <- tmp$pulled - splitColony <- setLocation(x = splitColony, location = getLocation(splitColony)) - - remnantColony@split <- TRUE - splitColony@split <- TRUE - - remnantColony@production <- TRUE - splitColony@production <- FALSE - - ret <- list(split = splitColony, remnant = remnantColony) - } else if (isMultiColony(x)) { - nCol <- nColonies(x) - nP <- length(p) - if (nP > 1 && nP < nCol) { - stop("Too few values in the p argument!") - } - if (nP > 1 && nP > nCol) { - warning(paste0("Too many values in the nInd argument, taking only the first ", nCol, "values!")) - p <- p[1:nCol] - } - if (nCol == 0) { - ret <- list( - split = createMultiColony(simParamBee = simParamBee), - remnant = createMultiColony(simParamBee = simParamBee) - ) - } else { - ret <- list( - split = createMultiColony(n = nCol, simParamBee = simParamBee), - remnant = createMultiColony(n = nCol, simParamBee = simParamBee) - ) - for (colony in seq_len(nCol)) { - if (is.null(p)) { - pColony <- NULL - } else { - pColony <- ifelse(nP == 1, p, p[colony]) - } - tmp <- split(x[[colony]], - p = pColony, - year = year, - simParamBee = simParamBee, ... - ) - ret$split[[colony]] <- tmp$split - ret$remnant[[colony]] <- tmp$remnant - } - } - } else { - stop("Argument x must be a Colony or MultiColony class object!") - } - - validObject(ret$splitColony) - validObject(ret$remnantColony) - return(ret) -} - -#' @export -split_p <- function(x, p = NULL, year = NULL, simParamBee = NULL, nThreads = NULL, ...) { +split <- function(x, p = NULL, year = NULL, simParamBee = NULL, nThreads = NULL, ...) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } @@ -2715,33 +1894,7 @@ setEvents <- function(x, slot, value, nThreads = NULL, simParamBee = NULL) { #' nDrones(apiary1); nDrones(apiary2) #' rm(apiary2) #' @export -combine_np <- function(strong, weak) { - if (isColony(strong) & isColony(weak)) { - if (hasCollapsed(strong)) { - stop(paste0("The colony ", getId(strong), " (strong) has collapsed, hence you can not combine it!")) - } - if (hasCollapsed(weak)) { - stop(paste0("The colony ", getId(weak), " (weak) has collapsed, hence you can not combine it!")) - } - strong@workers <- c(strong@workers, weak@workers) - strong@drones <- c(strong@drones, weak@drones) - } else if (isMultiColony(strong) & isMultiColony(weak)) { - if (nColonies(weak) == nColonies(strong)) { - nCol <- nColonies(weak) - for (colony in seq_len(nCol)) { - strong[[colony]] <- combine(strong = strong[[colony]], weak = weak[[colony]]) - } - } else { - stop("Weak and strong MultiColony objects must be of the same length!") - } - } else { - stop("Argument strong and weak must both be either a Colony or MultiColony class objects!") - } - return(strong) -} - -#' @export -combine_p <- function(strong, weak, simParamBee = NULL, nThreads = NULL) { +combine <- function(strong, weak, simParamBee = NULL, nThreads = NULL) { if (isColony(strong) & isColony(weak)) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) @@ -2827,67 +1980,7 @@ combine_p <- function(strong, weak, simParamBee = NULL, nThreads = NULL) { #' apiary <- setLocation(apiary, location = locDF) #' getLocation(apiary) #' @export -setLocation_np <- function(x, location = c(0, 0)) { - if (isColony(x)) { - if (is.list(location)) { # is.list() captures also is.data.frame() - stop("Argument location must be numeric, when x is a Colony class object!") - } - if (is.numeric(location) && length(location) != 2) { - stop("When argument location is a numeric, it must be of length 2!") - } - x@location <- location - } else if (isMultiColony(x)) { - n <- nColonies(x) - if (!is.null(location)) { - if (is.numeric(location)) { - if (length(location) != 2) { - stop("When argument location is a numeric, it must be of length 2!") - } - } else if (is.data.frame(location)) { - if (nrow(location) != n) { - stop("When argument location is a data.frame, it must have as many rows as the number of colonies!") - } - if (ncol(location) != 2) { - stop("When argument location is a data.frame, it must have 2 columns!") - } - } else if (is.list(location)) { - if (length(location) != n) { - stop("When argument location is a list, it must be of length equal to the number of colonies!") - } - tmp <- sapply(X = location, FUN = length) - if (!all(tmp == 2)) { - stop("When argument location is a list, each list node must be of length 2!") - } - } else if (is.numeric(location)) { - if (length(location) != 2) { - stop("When argument location is a numeric, it must be of length 2!") - } - } else { - stop("Argument location must be numeric, list, or data.frame!") - } - } - for (colony in seq_len(n)) { - if (is.data.frame(location)) { - loc <- location[colony, ] - loc <- c(loc$x, loc$y) - } else if (is.list(location)) { - loc <- location[[colony]] - } else { - loc <- location - } - if (!is.null(x[[colony]])) { - x[[colony]]@location <- loc - } - } - } else { - stop("Argument x must be a Colony or MultiColony class object!") - } - validObject(x) - return(x) -} - -#' @export -setLocation_p <- function(x, location = c(0, 0), simParamBee = NULL, nThreads = NULL) { +setLocation <- function(x, location = c(0, 0), simParamBee = NULL, nThreads = NULL) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } diff --git a/R/Functions_L3_Colonies.R b/R/Functions_L3_Colonies.R index f237c294..9fc14f21 100644 --- a/R/Functions_L3_Colonies.R +++ b/R/Functions_L3_Colonies.R @@ -48,40 +48,7 @@ #' apiary[[2]] #' #' @export -createMultiColony_np <- function(x = NULL, n = NULL, simParamBee = NULL) { - if (is.null(simParamBee)) { - simParamBee <- get(x = "SP", envir = .GlobalEnv) - } - if (is.null(x)) { - if (is.null(n)) { - ret <- new(Class = "MultiColony") - } else { - ret <- new(Class = "MultiColony", colonies = vector(mode = "list", length = n)) - } - } else { - if (!isPop(x)) { - stop("Argument x must be a Pop class object!") - } - if (any(!(isVirginQueen(x, simParamBee = simParamBee) | isQueen(x, simParamBee = simParamBee)))) { - stop("Individuals in x must be virgin queens or queens!") - } - if (is.null(n)) { - n <- nInd(x) - } - if (nInd(x) < n) { - stop("Not enough individuals in the x to create n colonies!") - } - ret <- new(Class = "MultiColony", colonies = vector(mode = "list", length = n)) - for (colony in seq_len(n)) { - ret[[colony]] <- createColony(x = x[colony], simParamBee = simParamBee) - } - } - validObject(ret) - return(ret) -} - -#' @export -createMultiColony_p <- function(x = NULL, n = NULL, simParamBee = NULL, nThreads = NULL) { +createMultiColony <- function(x = NULL, n = NULL, simParamBee = NULL, nThreads = NULL) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } diff --git a/man/MultiColony-class.Rd b/man/MultiColony-class.Rd index c898062b..d81e7d6f 100644 --- a/man/MultiColony-class.Rd +++ b/man/MultiColony-class.Rd @@ -7,8 +7,8 @@ \alias{show,MultiColony-method} \alias{c,MultiColony-method} \alias{c,MultiColonyOrNULL-method} -\alias{[,MultiColony,integerOrNumericOrLogical,ANY,ANY-method} -\alias{[,MultiColony,character,ANY,ANY-method} +\alias{[,MultiColony,integerOrNumericOrLogical-method} +\alias{[,MultiColony,character-method} \alias{[[,MultiColony,integerOrNumericOrLogical-method} \alias{[[,MultiColony,character-method} \alias{[<-,MultiColony,integerOrNumericOrLogicalOrCharacter,ANY,MultiColony-method} @@ -23,9 +23,9 @@ isMultiColony(x) \S4method{c}{MultiColonyOrNULL}(x, ...) -\S4method{[}{MultiColony,integerOrNumericOrLogical,ANY,ANY}(x, i, j, drop) +\S4method{[}{MultiColony,integerOrNumericOrLogical}(x, i, j, drop) -\S4method{[}{MultiColony,character,ANY,ANY}(x, i, j, drop) +\S4method{[}{MultiColony,character}(x, i, j, drop) \S4method{[[}{MultiColony,integerOrNumericOrLogical}(x, i) diff --git a/man/addCastePop.Rd b/man/addCastePop.Rd index 6d6e36f7..ae52903d 100644 --- a/man/addCastePop.Rd +++ b/man/addCastePop.Rd @@ -12,15 +12,29 @@ addCastePop( caste = NULL, nInd = NULL, new = FALSE, - exact = FALSE, year = NULL, simParamBee = NULL, + nThreads = NULL, ... ) -addWorkers(x, nInd = NULL, new = FALSE, simParamBee = NULL, ...) +addWorkers( + x, + nInd = NULL, + new = FALSE, + simParamBee = NULL, + nThreads = NULL, + ... +) -addDrones(x, nInd = NULL, new = FALSE, simParamBee = NULL, ...) +addDrones( + x, + nInd = NULL, + new = FALSE, + simParamBee = NULL, + nThreads = NULL, + ... +) addVirginQueens( x, @@ -28,6 +42,7 @@ addVirginQueens( new = FALSE, year = NULL, simParamBee = NULL, + nThreads = NULL, ... ) } @@ -45,15 +60,15 @@ a single value is provided, the same value will be used for all the colonies.} \item{new}{logical, should the number of individuals be added to the caste population anew or should we only top-up the existing number of individuals to \code{nInd}} -\item{exact}{logical, only relevant when adding workers - if the csd locus is turned -on and exact is \code{TRUE}, we add the exact specified number of viable workers -(heterozygous at the csd locus)} - \item{year}{numeric, only relevant when adding virgin queens - year of birth for virgin queens} \item{simParamBee}{\code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters} \item{...}{additional arguments passed to \code{nInd} when this argument is a function} + +\item{exact}{logical, only relevant when adding workers - if the csd locus is turned +on and exact is \code{TRUE}, we add the exact specified number of viable workers +(heterozygous at the csd locus)} } \value{ \code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}} with diff --git a/man/buildUp.Rd b/man/buildUp.Rd index 5e280a04..3ebe1012 100644 --- a/man/buildUp.Rd +++ b/man/buildUp.Rd @@ -9,9 +9,9 @@ buildUp( nWorkers = NULL, nDrones = NULL, new = TRUE, - exact = FALSE, resetEvents = FALSE, simParamBee = NULL, + nThreads = NULL, ... ) } @@ -34,10 +34,6 @@ a single value is provided, the same value will be applied to all the colonies.} should we only top-up the existing number of workers and drones to \code{nWorkers} and \code{nDrones} (see details)} -\item{exact}{logical, if the csd locus is turned on and exact is \code{TRUE}, -create the exact specified number of only viable workers (heterozygous on -the csd locus)} - \item{resetEvents}{logical, call \code{\link[SIMplyBee]{resetEvents}} as part of the build up} @@ -45,6 +41,10 @@ build up} \item{...}{additional arguments passed to \code{nWorkers} or \code{nDrones} when these arguments are a function} + +\item{exact}{logical, if the csd locus is turned on and exact is \code{TRUE}, +create the exact specified number of only viable workers (heterozygous on +the csd locus)} } \value{ \code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}} with workers and diff --git a/man/collapse.Rd b/man/collapse.Rd index e00a37b2..5d9170a0 100644 --- a/man/collapse.Rd +++ b/man/collapse.Rd @@ -4,7 +4,7 @@ \alias{collapse} \title{Collapse} \usage{ -collapse(x) +collapse(x, simParamBee = NULL, nThreads = NULL) } \arguments{ \item{x}{\code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}}} diff --git a/man/combine.Rd b/man/combine.Rd index c14a3a67..44a3cebc 100644 --- a/man/combine.Rd +++ b/man/combine.Rd @@ -4,7 +4,7 @@ \alias{combine} \title{Combine two colony objects} \usage{ -combine(strong, weak) +combine(strong, weak, simParamBee = NULL, nThreads = NULL) } \arguments{ \item{strong}{\code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}}} diff --git a/man/createCastePop.Rd b/man/createCastePop.Rd index 1576aff7..f32e923a 100644 --- a/man/createCastePop.Rd +++ b/man/createCastePop.Rd @@ -11,11 +11,13 @@ createCastePop( x, caste = NULL, nInd = NULL, - exact = TRUE, year = NULL, editCsd = TRUE, csdAlleles = NULL, simParamBee = NULL, + returnSP = FALSE, + ids = NULL, + nThreads = NULL, ... ) @@ -67,11 +69,6 @@ only used when \code{x} is \code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}}, when \code{x} is \code{link[AlphaSimR]{MapPop-class}} all individuals in \code{x} are converted into virgin queens} -\item{exact}{logical, only relevant when creating workers, -if the csd locus is active and exact is \code{TRUE}, -create the exactly specified number of viable workers (heterozygous on the -csd locus)} - \item{year}{numeric, year of birth for virgin queens} \item{editCsd}{logical (only active when \code{x} is \code{link[AlphaSimR]{MapPop-class}}), @@ -91,6 +88,11 @@ ensure heterozygosity at the csd locus.} \item{simParamBee}{\code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters} \item{...}{additional arguments passed to \code{nInd} when this argument is a function} + +\item{exact}{logical, only relevant when creating workers, +if the csd locus is active and exact is \code{TRUE}, +create the exactly specified number of viable workers (heterozygous on the +csd locus)} } \value{ when \code{x} is \code{\link[AlphaSimR]{MapPop-class}} returns diff --git a/man/createMultiColony.Rd b/man/createMultiColony.Rd index 21f2bc14..642242e4 100644 --- a/man/createMultiColony.Rd +++ b/man/createMultiColony.Rd @@ -4,7 +4,7 @@ \alias{createMultiColony} \title{Create MultiColony object} \usage{ -createMultiColony(x = NULL, n = NULL, simParamBee = NULL) +createMultiColony(x = NULL, n = NULL, simParamBee = NULL, nThreads = NULL) } \arguments{ \item{x}{\code{\link[AlphaSimR]{Pop-class}}, virgin queens or queens for the colonies diff --git a/man/cross.Rd b/man/cross.Rd index 8b4ee5fe..cca298da 100644 --- a/man/cross.Rd +++ b/man/cross.Rd @@ -15,6 +15,7 @@ cross( radius = NULL, checkCross = "error", simParamBee = NULL, + nThreads = NULL, ... ) } diff --git a/man/pullCastePop.Rd b/man/pullCastePop.Rd index dcf63748..0d554804 100644 --- a/man/pullCastePop.Rd +++ b/man/pullCastePop.Rd @@ -15,7 +15,8 @@ pullCastePop( use = "rand", removeFathers = TRUE, collapse = FALSE, - simParamBee = NULL + simParamBee = NULL, + nThreads = NULL ) pullQueen(x, collapse = FALSE, simParamBee = NULL) diff --git a/man/reQueen.Rd b/man/reQueen.Rd index e90abb52..91ccf2cf 100644 --- a/man/reQueen.Rd +++ b/man/reQueen.Rd @@ -4,7 +4,13 @@ \alias{reQueen} \title{Re-queen} \usage{ -reQueen(x, queen, removeVirginQueens = TRUE, simParamBee = NULL) +reQueen( + x, + queen, + removeVirginQueens = TRUE, + simParamBee = NULL, + nThreads = NULL +) } \arguments{ \item{x}{\code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}}} diff --git a/man/removeCastePop.Rd b/man/removeCastePop.Rd index 6e07ea9b..b451f387 100644 --- a/man/removeCastePop.Rd +++ b/man/removeCastePop.Rd @@ -5,7 +5,7 @@ \alias{removeQueen} \alias{removeWorkers} \alias{removeDrones} -\alias{removeVirginQueens_parallel} +\alias{removeVirginQueens} \title{Remove a proportion of caste individuals from a colony} \usage{ removeCastePop( @@ -13,32 +13,18 @@ removeCastePop( caste = NULL, p = 1, use = "rand", - addVirginQueens = FALSE, - nVirginQueens = NULL, - year = NULL, - simParamBee = NULL -) - -removeQueen( - x, - addVirginQueens = FALSE, - nVirginQueens = NULL, year = NULL, simParamBee = NULL, nThreads = NULL ) -removeWorkers(x, p = 1, use = "rand", simParamBee = NULL, nThreads = NULL) +removeQueen(x, year = NULL, simParamBee = NULL) -removeDrones(x, p = 1, use = "rand", simParamBee = NULL, nThreads = NULL) +removeWorkers(x, p = 1, use = "rand", simParamBee = NULL) -removeVirginQueens_parallel( - x, - p = 1, - use = "rand", - simParamBee = NULL, - nThreads = NULL -) +removeDrones(x, p = 1, use = "rand", simParamBee = NULL) + +removeVirginQueens(x, p = 1, use = "rand", simParamBee = NULL) } \arguments{ \item{x}{\code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}}} @@ -52,6 +38,10 @@ a single value is provided, the same value will be applied to all the colonies} \item{use}{character, all the options provided by \code{\link[AlphaSimR]{selectInd}} - guides selection of virgins queens that will stay when \code{p < 1}} +\item{year}{numeric, only relevant when adding virgin queens - year of birth for virgin queens} + +\item{simParamBee}{\code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters} + \item{addVirginQueens}{logical, whether virgin queens should be added; only used when removing the queen from the colony} @@ -59,10 +49,6 @@ used when removing the queen from the colony} colony; only used when removing the queen from the colony. If \code{0}, no virgin queens are added; If \code{NULL}, the value from \code{simParamBee$nVirginQueens} is used} - -\item{year}{numeric, only relevant when adding virgin queens - year of birth for virgin queens} - -\item{simParamBee}{\code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters} } \value{ \code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}} without virgin queens @@ -79,7 +65,7 @@ Level 2 function that removes a proportion of virgin queens of \item \code{removeDrones()}: Remove workers from a colony -\item \code{removeVirginQueens_parallel()}: Remove virgin queens from a colony +\item \code{removeVirginQueens()}: Remove virgin queens from a colony }} \examples{ diff --git a/man/resetEvents.Rd b/man/resetEvents.Rd index 2e8b6642..4aa327eb 100644 --- a/man/resetEvents.Rd +++ b/man/resetEvents.Rd @@ -4,7 +4,7 @@ \alias{resetEvents} \title{Reset colony events} \usage{ -resetEvents(x, collapse = NULL) +resetEvents(x, collapse = NULL, simParamBee = NULL, nThreads = NULL) } \arguments{ \item{x}{\code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}}} diff --git a/man/setLocation.Rd b/man/setLocation.Rd index a9ee600d..88efe66e 100644 --- a/man/setLocation.Rd +++ b/man/setLocation.Rd @@ -4,7 +4,7 @@ \alias{setLocation} \title{Set colony location} \usage{ -setLocation(x, location = c(0, 0)) +setLocation(x, location = c(0, 0), simParamBee = NULL, nThreads = NULL) } \arguments{ \item{x}{\code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}}} diff --git a/man/split.Rd b/man/split.Rd index 7def12fb..63c92f4c 100644 --- a/man/split.Rd +++ b/man/split.Rd @@ -4,7 +4,7 @@ \alias{split} \title{Split colony in two MultiColony} \usage{ -split(x, p = NULL, year = NULL, simParamBee = NULL, ...) +split(x, p = NULL, year = NULL, simParamBee = NULL, nThreads = NULL, ...) } \arguments{ \item{x}{\code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}}} diff --git a/man/supersede.Rd b/man/supersede.Rd index 90da056a..0f958ba8 100644 --- a/man/supersede.Rd +++ b/man/supersede.Rd @@ -6,8 +6,8 @@ \usage{ supersede( x, + addVirginQueens = TRUE, year = NULL, - nVirginQueens = NULL, simParamBee = NULL, nThreads = NULL, ... @@ -18,15 +18,15 @@ supersede( \item{year}{numeric, year of birth for virgin queens} -\item{nVirginQueens}{integer, the number of virgin queens to be created in the -colony; of these one is randomly selected as the new virgin queen of the -remnant colony. If \code{NULL}, the value from \code{simParamBee$nVirginQueens} -is used} - \item{simParamBee}{\code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters} \item{...}{additional arguments passed to \code{nVirginQueens} when this argument is a function} + +\item{nVirginQueens}{integer, the number of virgin queens to be created in the +colony; of these one is randomly selected as the new virgin queen of the +remnant colony. If \code{NULL}, the value from \code{simParamBee$nVirginQueens} +is used} } \value{ \code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}} with the diff --git a/man/swarm.Rd b/man/swarm.Rd index 34d2c198..b7988ef3 100644 --- a/man/swarm.Rd +++ b/man/swarm.Rd @@ -11,6 +11,7 @@ swarm( sampleLocation = TRUE, radius = NULL, simParamBee = NULL, + nThreads = NULL, ... ) } From b501b19930c3134c96e0fa7d93ab608412d2d4b8 Mon Sep 17 00:00:00 2001 From: janaobsteter Date: Tue, 15 Apr 2025 09:32:36 +0200 Subject: [PATCH 12/42] Addding nThreads --- R/Functions_L2_Colony.R | 31 +++++++++++++++++-------------- man/removeCastePop.Rd | 8 ++++---- man/replaceCastePop.Rd | 19 ++++++++++++++++--- 3 files changed, 37 insertions(+), 21 deletions(-) diff --git a/R/Functions_L2_Colony.R b/R/Functions_L2_Colony.R index 033ca8bc..bf51bee8 100644 --- a/R/Functions_L2_Colony.R +++ b/R/Functions_L2_Colony.R @@ -923,31 +923,34 @@ replaceCastePop <- function(x, caste = NULL, p = 1, use = "rand", exact = TRUE, #' @describeIn replaceCastePop Replaces some workers in a colony #' @export -replaceWorkers <- function(x, p = 1, use = "rand", exact = TRUE, simParamBee = NULL) { +replaceWorkers <- function(x, p = 1, use = "rand", exact = TRUE, simParamBee = NULL, nThreads = NULL) { ret <- replaceCastePop( x = x, caste = "workers", p = p, use = use, exact = exact, - simParamBee = simParamBee + simParamBee = simParamBee, + nThreads = nThreads ) return(ret) } #' @describeIn replaceCastePop Replaces some drones in a colony #' @export -replaceDrones <- function(x, p = 1, use = "rand", simParamBee = NULL) { +replaceDrones <- function(x, p = 1, use = "rand", simParamBee = NULL, nThreads = NULL) { ret <- replaceCastePop( x = x, caste = "drones", p = p, - use = use, simParamBee = simParamBee + use = use, simParamBee = simParamBee, + nThreads = nThreads ) return(ret) } #' @describeIn replaceCastePop Replaces some virgin queens in a colony #' @export -replaceVirginQueens <- function(x, p = 1, use = "rand", simParamBee = NULL) { +replaceVirginQueens <- function(x, p = 1, use = "rand", simParamBee = NULL, nThreads = NULL) { ret <- replaceCastePop( x = x, caste = "virginQueens", p = p, - use = use, simParamBee = simParamBee + use = use, simParamBee = simParamBee, + nThreads = nThreads ) return(ret) } @@ -1083,16 +1086,16 @@ removeCastePop <- function(x, caste = NULL, p = 1, use = "rand", #' @describeIn removeCastePop Remove queen from a colony #' @export #' -removeQueen <- function(x, year = NULL, simParamBee = NULL) { - ret <- removeCastePop(x = x, caste = "queen", p = 1, year = year, simParamBee = simParamBee) +removeQueen <- function(x, year = NULL, simParamBee = NULL, nThreads = NULL) { + ret <- removeCastePop(x = x, caste = "queen", p = 1, year = year, simParamBee = simParamBee, nThreads = nThreads) return(ret) } #' @describeIn removeCastePop Remove workers from a colony #' @export -removeWorkers <- function(x, p = 1, use = "rand", simParamBee = NULL) { - ret <- removeCastePop(x = x, caste = "workers", p = p, use = use, simParamBee = simParamBee) +removeWorkers <- function(x, p = 1, use = "rand", simParamBee = NULL, nThreads = NULL) { + ret <- removeCastePop(x = x, caste = "workers", p = p, use = use, simParamBee = simParamBee, nThreads = nThreads) return(ret) } @@ -1100,8 +1103,8 @@ removeWorkers <- function(x, p = 1, use = "rand", simParamBee = NULL) { #' @describeIn removeCastePop Remove workers from a colony #' @export -removeDrones <- function(x, p = 1, use = "rand", simParamBee = NULL) { - ret <- removeCastePop(x = x, caste = "drones", p = p, use = use, simParamBee = simParamBee) +removeDrones <- function(x, p = 1, use = "rand", simParamBee = NULL, nThreads = NULL) { + ret <- removeCastePop(x = x, caste = "drones", p = p, use = use, simParamBee = simParamBee, nThreads = nThreads) return(ret) } @@ -1109,8 +1112,8 @@ removeDrones <- function(x, p = 1, use = "rand", simParamBee = NULL) { #' @describeIn removeCastePop Remove virgin queens from a colony #' @export -removeVirginQueens <- function(x, p = 1, use = "rand", simParamBee = NULL) { - ret <- removeCastePop(x = x, caste = "virginQueens", p = p, use = use, simParamBee = simParamBee) +removeVirginQueens <- function(x, p = 1, use = "rand", simParamBee = NULL, nThreads = NULL) { + ret <- removeCastePop(x = x, caste = "virginQueens", p = p, use = use, simParamBee = simParamBee, nThreads = nThreads) return(ret) } diff --git a/man/removeCastePop.Rd b/man/removeCastePop.Rd index b451f387..f725e16a 100644 --- a/man/removeCastePop.Rd +++ b/man/removeCastePop.Rd @@ -18,13 +18,13 @@ removeCastePop( nThreads = NULL ) -removeQueen(x, year = NULL, simParamBee = NULL) +removeQueen(x, year = NULL, simParamBee = NULL, nThreads = NULL) -removeWorkers(x, p = 1, use = "rand", simParamBee = NULL) +removeWorkers(x, p = 1, use = "rand", simParamBee = NULL, nThreads = NULL) -removeDrones(x, p = 1, use = "rand", simParamBee = NULL) +removeDrones(x, p = 1, use = "rand", simParamBee = NULL, nThreads = NULL) -removeVirginQueens(x, p = 1, use = "rand", simParamBee = NULL) +removeVirginQueens(x, p = 1, use = "rand", simParamBee = NULL, nThreads = NULL) } \arguments{ \item{x}{\code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}}} diff --git a/man/replaceCastePop.Rd b/man/replaceCastePop.Rd index bd2c3756..c447e113 100644 --- a/man/replaceCastePop.Rd +++ b/man/replaceCastePop.Rd @@ -17,11 +17,24 @@ replaceCastePop( simParamBee = NULL ) -replaceWorkers(x, p = 1, use = "rand", exact = TRUE, simParamBee = NULL) +replaceWorkers( + x, + p = 1, + use = "rand", + exact = TRUE, + simParamBee = NULL, + nThreads = NULL +) -replaceDrones(x, p = 1, use = "rand", simParamBee = NULL) +replaceDrones(x, p = 1, use = "rand", simParamBee = NULL, nThreads = NULL) -replaceVirginQueens(x, p = 1, use = "rand", simParamBee = NULL) +replaceVirginQueens( + x, + p = 1, + use = "rand", + simParamBee = NULL, + nThreads = NULL +) } \arguments{ \item{x}{\code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}}} From 997449f109a068285f60a0b4ecdbc1c8b7564115 Mon Sep 17 00:00:00 2001 From: janaobsteter Date: Tue, 15 Apr 2025 09:35:16 +0200 Subject: [PATCH 13/42] Solving nThreads inconsistencies --- R/Functions_L2_Colony.R | 7 +++++-- man/replaceCastePop.Rd | 3 ++- 2 files changed, 7 insertions(+), 3 deletions(-) diff --git a/R/Functions_L2_Colony.R b/R/Functions_L2_Colony.R index bf51bee8..42e462ac 100644 --- a/R/Functions_L2_Colony.R +++ b/R/Functions_L2_Colony.R @@ -168,7 +168,7 @@ reQueen <- function(x, queen, removeVirginQueens = TRUE, simParamBee = NULL, nTh x <- removeVirginQueens(x, simParamBee = simParamBee) } } else { - x <- removeQueen(x, addVirginQueens = FALSE, simParamBee = simParamBee) + x <- removeQueen(x, simParamBee = simParamBee) x@virginQueens <- queen } } else if (isMultiColony(x)) { @@ -861,10 +861,13 @@ downsize <- function(x, p = NULL, use = "rand", new = FALSE, #' getCasteId(apiary, caste="workers") #' @export replaceCastePop <- function(x, caste = NULL, p = 1, use = "rand", exact = TRUE, - year = NULL, simParamBee = NULL) { + year = NULL, simParamBee = NULL, nThreads = NULL) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } + if (is.null(nThreads)) { + nThreads = simParamBee$nThreads + } if (length(caste) != 1) { stop("Argument caste must be of length 1!") } diff --git a/man/replaceCastePop.Rd b/man/replaceCastePop.Rd index c447e113..4120be51 100644 --- a/man/replaceCastePop.Rd +++ b/man/replaceCastePop.Rd @@ -14,7 +14,8 @@ replaceCastePop( use = "rand", exact = TRUE, year = NULL, - simParamBee = NULL + simParamBee = NULL, + nThreads = NULL ) replaceWorkers( From 510b7ca31c23f31994a15b1589c3d035336bd05d Mon Sep 17 00:00:00 2001 From: janaobsteter Date: Tue, 22 Apr 2025 10:46:31 +0200 Subject: [PATCH 14/42] Setting nThreads = 1 before creating individuals --- R/Functions_L1_Pop.R | 27 ++++++++++++++++++++------- 1 file changed, 20 insertions(+), 7 deletions(-) diff --git a/R/Functions_L1_Pop.R b/R/Functions_L1_Pop.R index 469ebef1..ca4e4d41 100644 --- a/R/Functions_L1_Pop.R +++ b/R/Functions_L1_Pop.R @@ -459,20 +459,25 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, } ret <- list() for (virginQueen in 1:nInd(x)) { - ret[[virginQueen]] <- makeDH(pop = x[virginQueen], nDH = nInd[virginQueen], keepParents = FALSE, simParam = simParamBee) + ret[[virginQueen]] <- makeDH(pop = x[virginQueen], nDH = nInd[virginQueen], + keepParents = FALSE, simParam = simParamBee) } ret <- mergePops(ret) } ret@sex[] <- "M" simParamBee$addToCaste(id = ret@id, caste = "drones") } else if (isColony(x)) { - if (!isQueenPresent(x, simParamBee = simParamBee)) { - stop("Missing queen!") - } + originalThreads = simParamBee$nThreads + simParamBee$nThreads = 1 + if (length(nInd) > 1) { warning("More than one value in the nInd argument, taking only the first value!") nInd <- nInd[1] } + if (!isQueenPresent(x, simParamBee = simParamBee)) { + stop("Missing queen!") + } + if (nInd > 0) { if (caste == "workers") { if (!returnSP) { @@ -482,8 +487,10 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, ret <- vector(mode = "list", length = 4) names(ret) <- c("workers", "nHomBrood", "pedigree", "caste") } + simParamBee$nThreads = 1 ret$workers <- combineBeeGametes( - queen = getQueen(x, simParamBee = simParamBee), drones = getFathers(x, simParamBee = simParamBee), + queen = getQueen(x, simParamBee = simParamBee), + drones = getFathers(x, simParamBee = simParamBee), nProgeny = nInd, simParamBee = simParamBee ) @@ -526,10 +533,12 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, ret <- setQueensYearOfBirth(x = ret, year = year, simParamBee = simParamBee) } } else if (caste == "drones") { # Creating drones if input is a Colony + drones <- makeDH( pop = getQueen(x, simParamBee = simParamBee), nDH = nInd, keepParents = FALSE, simParam = simParamBee ) + drones@sex[] <- "M" simParamBee$addToCaste(id = drones@id, caste = "drones") @@ -560,7 +569,9 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, } else { ret <- NULL } + simParamBee$nThreads = originalThreads } else if (isMultiColony(x)) { + print("Multicolony") registerDoParallel(cores = nThreads) if (is.null(nInd)) { string = paste0("n", toupper(substr(caste, 1, 1)), substr(caste, 2, nchar(caste))) @@ -589,6 +600,7 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, combine_list <- function(a, b) { if (!is.null(names(a))) { + "Combine first" c(list(a), list(b)) } else { if ((is.null(a) | is.null(b)) & !(is.null(a) & is.null(b))) { @@ -602,6 +614,7 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, } ret <- foreach(colony = seq_len(nCol), .combine=combine_list) %dopar% { + print("Foreach") nIndColony <- ifelse(nNInd == 1, nInd, nInd[colony]) if (nIndColony > 0) { if (nNInd == 1) { @@ -612,12 +625,11 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, createCastePop( x = x[[colony]], caste = caste, nInd = nIndColony, - exact = exact, year = year, editCsd = TRUE, csdAlleles = NULL, simParamBee = simParamBee, returnSP = TRUE, - ids = as.character(colonyIds), ... + ids = as.character(colonyIds) ) } else { NULL @@ -734,6 +746,7 @@ combineBeeGametes <- function(queen, drones, nProgeny = 1, simParamBee = NULL) { if (nInd(queen) > 1) { stop("At the moment we only cater for crosses with a single queen!") } + print("Starting randcross2") ret <- randCross2( females = queen, males = drones, nCrosses = nProgeny, nProgeny = 1, balance = FALSE, From 18308795adad681eb1dc1ea32648b4f20916e255 Mon Sep 17 00:00:00 2001 From: janaobsteter Date: Tue, 22 Apr 2025 11:05:41 +0200 Subject: [PATCH 15/42] Removing print statements --- R/Functions_L1_Pop.R | 3 --- 1 file changed, 3 deletions(-) diff --git a/R/Functions_L1_Pop.R b/R/Functions_L1_Pop.R index ca4e4d41..db443c54 100644 --- a/R/Functions_L1_Pop.R +++ b/R/Functions_L1_Pop.R @@ -571,7 +571,6 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, } simParamBee$nThreads = originalThreads } else if (isMultiColony(x)) { - print("Multicolony") registerDoParallel(cores = nThreads) if (is.null(nInd)) { string = paste0("n", toupper(substr(caste, 1, 1)), substr(caste, 2, nchar(caste))) @@ -614,7 +613,6 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, } ret <- foreach(colony = seq_len(nCol), .combine=combine_list) %dopar% { - print("Foreach") nIndColony <- ifelse(nNInd == 1, nInd, nInd[colony]) if (nIndColony > 0) { if (nNInd == 1) { @@ -746,7 +744,6 @@ combineBeeGametes <- function(queen, drones, nProgeny = 1, simParamBee = NULL) { if (nInd(queen) > 1) { stop("At the moment we only cater for crosses with a single queen!") } - print("Starting randcross2") ret <- randCross2( females = queen, males = drones, nCrosses = nProgeny, nProgeny = 1, balance = FALSE, From f35401a35fd3d6ef8f374d5490a53ad952bd1c5e Mon Sep 17 00:00:00 2001 From: janaobsteter Date: Fri, 25 Apr 2025 16:45:21 +0200 Subject: [PATCH 16/42] Solving the issue of spatial mating in cross --- R/Functions_L1_Pop.R | 66 ++++++++++++++++++++++++++++++-------------- 1 file changed, 45 insertions(+), 21 deletions(-) diff --git a/R/Functions_L1_Pop.R b/R/Functions_L1_Pop.R index db443c54..04c915ea 100644 --- a/R/Functions_L1_Pop.R +++ b/R/Functions_L1_Pop.R @@ -398,13 +398,13 @@ getVirginQueens <- function(x, nInd = NULL, use = "rand", collapse = FALSE, simP # patrilines # https://github.com/HighlanderLab/SIMplyBee/issues/78 createCastePop <- function(x, caste = NULL, nInd = NULL, - year = NULL, - editCsd = TRUE, csdAlleles = NULL, - simParamBee = NULL, - returnSP = FALSE, - ids = NULL, - nThreads = NULL, - ...) { + year = NULL, + editCsd = TRUE, csdAlleles = NULL, + simParamBee = NULL, + returnSP = FALSE, + ids = NULL, + nThreads = NULL, + ...) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } @@ -500,6 +500,7 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, if (returnSP) { ret$pedigree = simParamBee$pedigree[ret$workers@id, , drop = F] ret$caste = simParamBee$caste[ret$workers@id, drop = F] + #TODO: ret$recHist = simParamBee$recHist[ret$workers@id] } if (!is.null(ids)) { @@ -523,8 +524,8 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, } else if (caste == "virginQueens") { # Creating virgin queens if input is a Colony ret <- createCastePop(x = x, caste = "workers", - nInd = nInd, exact = TRUE, simParamBee = simParamBee, - returnSP = returnSP, ids = ids, nThreads = 1, ...) + nInd = nInd, exact = TRUE, simParamBee = simParamBee, + returnSP = returnSP, ids = ids, nThreads = 1, ...) simParamBee$changeCaste(id = ret$workers@id, caste = "virginQueens") if (!returnSP) { ret <- ret$workers @@ -1181,8 +1182,8 @@ pullDroneGroupsFromDCA <- function(DCA, n, nDrones = NULL, #' pullCastePop(apiary, caste = "virginQueens", collapse = TRUE) #' @export pullCastePop <- function(x, caste, nInd = NULL, use = "rand", - removeFathers = TRUE, collapse = FALSE, simParamBee = NULL, - nThreads = NULL) { + removeFathers = TRUE, collapse = FALSE, simParamBee = NULL, + nThreads = NULL) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } @@ -1479,16 +1480,16 @@ pullVirginQueens <- function(x, nInd = NULL, use = "rand", collapse = FALSE, sim #' #' @export cross <- function(x, - crossPlan = NULL, - drones = NULL, - droneColonies = NULL, - nDrones = NULL, - spatial = FALSE, - radius = NULL, - checkCross = "error", - simParamBee = NULL, - nThreads = NULL, - ...) { + crossPlan = NULL, + drones = NULL, + droneColonies = NULL, + nDrones = NULL, + spatial = FALSE, + radius = NULL, + checkCross = "error", + simParamBee = NULL, + nThreads = NULL, + ...) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } @@ -1563,6 +1564,29 @@ cross <- function(x, } } + if (crossPlan_create | crossPlan_given) { + if (crossPlan_create) { + crossPlan <- createCrossPlan(x = x, + drones = drones, + droneColonies = droneColonies, + nDrones = nDrones, + spatial = spatial, + radius = radius, + simParamBee = simParamBee) + } + + noMatches <- sapply(crossPlan, FUN = length) + if (0 %in% noMatches) { + msg <- "Crossing failed!" + if (checkCross == "warning") { + message(msg) + ret <- x + } else if (checkCross == "error") { + stop(msg) + } + } + } + # Convert everything to a Pop if (isColony(x) | isMultiColony(x)) { inputId <- getId(x) From cfe9d38fb7db3fa29e465985842a36d4c6b4202a Mon Sep 17 00:00:00 2001 From: janaobsteter Date: Wed, 28 May 2025 14:04:31 +0200 Subject: [PATCH 17/42] Addded collecting recHist and fixed isCsdHeterozygous --- R/Class-SimParamBee.R | 9 +++ R/Functions_L1_Pop.R | 129 ++++++++++++++++++++++-------------------- R/SIMplyBee.R | 2 + 3 files changed, 80 insertions(+), 60 deletions(-) diff --git a/R/Class-SimParamBee.R b/R/Class-SimParamBee.R index aa5c0d31..44e72d1a 100644 --- a/R/Class-SimParamBee.R +++ b/R/Class-SimParamBee.R @@ -434,6 +434,15 @@ SimParamBee <- R6Class( invisible(self) }, + #' @description A function to update the recHist + #' For internal use only. + #' + #' @param recHist matrix, recHist list to be added + updateRecHist = function(recHist) { + private$.recHist = c(private$.recHist, recHist) + invisible(self) + }, + #' @description A function to update the caste #' For internal use only. #' diff --git a/R/Functions_L1_Pop.R b/R/Functions_L1_Pop.R index 04c915ea..008d6f5f 100644 --- a/R/Functions_L1_Pop.R +++ b/R/Functions_L1_Pop.R @@ -327,7 +327,7 @@ getVirginQueens <- function(x, nInd = NULL, use = "rand", collapse = FALSE, simP #' founderGenomes <- quickHaplo(nInd = 4, nChr = 1, segSites = 50) #' SP <- SimParamBee$new(founderGenomes) #' \dontshow{SP$nThreads = 1L} -#' SP$setTrackRec(TRUE) +#' SP$setTrackRec(isTrackRec = TRUE) #' SP$setTrackPed(isTrackPed = TRUE) #' #' # Create virgin queens on a MapPop @@ -484,8 +484,8 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, ret <- vector(mode = "list", length = 2) names(ret) <- c("workers", "nHomBrood") } else { - ret <- vector(mode = "list", length = 4) - names(ret) <- c("workers", "nHomBrood", "pedigree", "caste") + ret <- vector(mode = "list", length = 5) + names(ret) <- c("workers", "nHomBrood", "pedigree", "caste", "recHist") } simParamBee$nThreads = 1 ret$workers <- combineBeeGametes( @@ -498,9 +498,13 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, ret$workers@sex[] <- "F" if (returnSP) { - ret$pedigree = simParamBee$pedigree[ret$workers@id, , drop = F] ret$caste = simParamBee$caste[ret$workers@id, drop = F] - #TODO: ret$recHist = simParamBee$recHist[ret$workers@id] + if (simParamBee$isTrackPed) { + ret$pedigree = simParamBee$pedigree[ret$workers@id, , drop = F] + } + if (simParamBee$isTrackRec) { + ret$recHist = simParamBee$recHist[ret$workers@iid] + } } if (!is.null(ids)) { @@ -511,18 +515,23 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, stop("Too many IDs provided!") } ret$workers@id = ids + ret$workers@iid = as.integer(ids) if (returnSP) { - rownames(ret$pedigree) = ids names(ret$caste) = ids + if (simParamBee$isTrackPed) { + rownames(ret$pedigree) <- ids + } + if (simParamBee$isTrackRec) { + names(ret$recHist) <- ids + } } } - # THIS DOES STILL NOT WORK!!! - # if (isCsdActive(simParamBee = simParamBee)) { - # ret$nHomBrood <- sum(!isCsdHeterozygous(ret$workers)) / nInd(ret$workers) - # } + if (isCsdActive(simParamBee = simParamBee)) { + ret$nHomBrood <- sum(!isCsdHeterozygous(ret$workers, simParamBee = simParamBee)) / nInd(ret$workers) + } - } else if (caste == "virginQueens") { # Creating virgin queens if input is a Colony + } else if (caste == "virginQueens") { ret <- createCastePop(x = x, caste = "workers", nInd = nInd, exact = TRUE, simParamBee = simParamBee, returnSP = returnSP, ids = ids, nThreads = 1, ...) @@ -533,7 +542,7 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, if (!is.null(year)) { ret <- setQueensYearOfBirth(x = ret, year = year, simParamBee = simParamBee) } - } else if (caste == "drones") { # Creating drones if input is a Colony + } else if (caste == "drones") { drones <- makeDH( pop = getQueen(x, simParamBee = simParamBee), nDH = nInd, keepParents = FALSE, @@ -544,10 +553,15 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, simParamBee$addToCaste(id = drones@id, caste = "drones") if (returnSP) { - ret <- vector(mode = "list", length = 3) - names(ret) <- c("drones", "pedigree", "caste") - ret$pedigree = simParamBee$pedigree[drones@id, , drop = F] + ret <- vector(mode = "list", length = 4) + names(ret) <- c("drones", "pedigree", "caste", "recHist") ret$caste = simParamBee$caste[drones@id, drop = F] + if (simParamBee$isTrackPed) { + ret$pedigree = simParamBee$pedigree[drones@id, , drop = F] + } + if (simParamBee$isTrackRec) { + ret$recHist = simParamBee$recHist[drones@iid] + } } if (!is.null(ids)) { @@ -555,9 +569,15 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, stop("Not enough IDs provided") } drones@id = ids + drones@iid = as.integer(ids) if (returnSP) { - rownames(ret$pedigree) = ids names(ret$caste) = ids + if (simParamBee$isTrackPed) { + rownames(ret$pedigree) = ids + } + if (simParamBee$isTrackRec) { + names(ret$recHist) = ids + } } } @@ -637,13 +657,10 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, simParamBee$updateLastId(n = totalNInd) names(ret) <- getId(x) - # Add to simParamBee: pedigree, caste, trackRecHis? + # Add to simParamBee: pedigree, caste, trackRecHis notNull = sapply(ret, FUN = function(x) !is.null(x)) - Pedigree = do.call("rbind", lapply(ret[notNull], '[[', "pedigree")) - simParamBee$updatePedigree(pedigree = Pedigree) - - # Update caste + # Extend caste Caste = do.call("c", lapply(ret[notNull], '[[', "caste")) if (caste == "virginQueens") { Caste = rep("virginQueens", length(Caste)) @@ -652,16 +669,28 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, names(Caste) = Names simParamBee$updateCaste(caste = Caste) + # Extend pedigree + if (simParamBee$isTrackPed) { + Pedigree = do.call("rbind", lapply(ret[notNull], '[[', "pedigree")) + simParamBee$updatePedigree(pedigree = Pedigree) + } + + # Extend recHist + if (simParamBee$isTrackRec) { + RecHist = do.call("c", lapply(ret[notNull], '[[', "recHist")) + simParamBee$updateRecHist(recHist = RecHist) + } + if (!returnSP) { if (caste %in% c("drones", "virginQueens")) { ret = lapply(ret, FUN = function(x) { if (is.null(x)) return(NULL) # Return NULL if the element is NULL - x[!names(x) %in% c("pedigree", "caste")][[1]] + x[!names(x) %in% c("pedigree", "caste", "recHist")][[1]] }) } else { ret = lapply(ret, FUN = function(x) { - if (is.null(x)) return(NULL) # Return NULL if the element is NULL - x[!names(x) %in% c("pedigree", "caste")] + if (is.null(x)) return(NULL) + x[!names(x) %in% c("pedigree", "caste", "recHist")] }) } } @@ -681,9 +710,9 @@ createWorkers <- function(x, nInd = NULL, exact = FALSE, simParamBee = NULL, nThreads = NULL, ...) { ret <- createCastePop(x, caste = "workers", nInd = nInd, exact = exact, simParamBee = simParamBee, - returnSP = FALSE, - ids = NULL, - nThreads = NULL, ...) + returnSP = returnSP, + ids = ids, + nThreads = nThreads, ...) return(ret) } @@ -695,9 +724,9 @@ createDrones <- function(x, nInd = NULL, simParamBee = NULL, nThreads = NULL, ...) { ret <- createCastePop(x, caste = "drones", nInd = nInd, simParamBee = simParamBee, - returnSP = FALSE, - ids = NULL, - nThreads = NULL, ...) + returnSP = returnSP, + ids = ids, + nThreads = nThreads, ...) return(ret) } @@ -714,9 +743,9 @@ createVirginQueens <- function(x, nInd = NULL, ret <- createCastePop(x, caste = "virginQueens", nInd = nInd, year = year, editCsd = editCsd, csdAlleles = csdAlleles, simParamBee = simParamBee, - returnSP = FALSE, - ids = NULL, - nThreads = NULL, ...) + returnSP = returnSP, + ids = ids, + nThreads = nThreads, ...) return(ret) } @@ -1604,43 +1633,23 @@ cross <- function(x, } } + IDs <- as.character(getId(x)) #Now x is always a Pop ret <- list() nVirgin = nInd(x) + #Rename crossPlan + if (crossPlan_create | crossPlan_given) { + names(crossPlan) <- ID_by_input$virginId[match(ID_by_input$inputId, names(crossPlan))] + } + if (is.function(nDrones)) { nD = nDrones(n = nVirgin, ...) } else { nD = nDrones } - if (crossPlan_create | crossPlan_given) { - if (crossPlan_create) { - crossPlan <- createCrossPlan(x = x, - drones = drones, - droneColonies = droneColonies, - nDrones = nDrones, - spatial = spatial, - radius = radius, - simParamBee = simParamBee) - } - - if (crossPlan_given) { - names(crossPlan) <- ID_by_input$virginId[match(ID_by_input$inputId, names(crossPlan))] - } - - noMatches <- sapply(crossPlan, FUN = length) - if (0 %in% noMatches) { - msg <- "Crossing failed!" - if (checkCross == "warning") { - message(msg) - ret <- x - } else if (checkCross == "error") { - stop(msg) - } - } - } combine_list <- function(a, b) { if (isPop(a)) { @@ -1663,7 +1672,7 @@ cross <- function(x, selectedDPC = droneColonies[as.character(crossPlanDF_DPCtable$DPC)] dronesByDPC <- createCastePop(selectedDPC, caste = "drones", - nInd = as.integer(crossPlanDF_DPCtable$noDrones), simParamBee = simParamBee) + nInd = as.integer(crossPlanDF_DPCtable$noDrones), simParamBee = simParamBee) dronesByDPC_DF <- data.frame(DPC = rep(names(dronesByDPC), as.vector(crossPlanDF_DPCtable$noDrones)), droneID = unlist(sapply(dronesByDPC, FUN = function(x) getId(x)))) %>% arrange(as.numeric(DPC)) diff --git a/R/SIMplyBee.R b/R/SIMplyBee.R index ce9260f8..20e60684 100644 --- a/R/SIMplyBee.R +++ b/R/SIMplyBee.R @@ -7,6 +7,8 @@ #' @importFrom stats rnorm rbeta runif rpois na.omit #' @importFrom extraDistr rtpois #' @importFrom utils packageVersion +#' @importFrom foreach foreach +#' @importFrom doParallel registerDoParallel # see https://r-pkgs.org/namespace.html on description what to import/depend/... #' @description From 4f69148775bba685ee0de9d160ebdc672e68f074 Mon Sep 17 00:00:00 2001 From: Gregor Gorjanc Date: Wed, 28 May 2025 15:22:15 +0200 Subject: [PATCH 18/42] Minor edits for my OCD --- R/Functions_L0_auxilary.R | 2 +- R/Functions_L1_Pop.R | 58 +++++++++++++++++++-------------------- R/Functions_L2_Colony.R | 38 ++++++++++++------------- R/Functions_L3_Colonies.R | 4 +-- 4 files changed, 51 insertions(+), 51 deletions(-) diff --git a/R/Functions_L0_auxilary.R b/R/Functions_L0_auxilary.R index 7c492e44..66ad56e2 100644 --- a/R/Functions_L0_auxilary.R +++ b/R/Functions_L0_auxilary.R @@ -6369,7 +6369,7 @@ editCsdLocus <- function(pop, alleles = NULL, simParamBee = NULL) { alleles <- expand.grid(as.data.frame(matrix(rep(0:1, length(csdSites)), nrow = 2, byrow = FALSE))) # Sample two different alleles (without replacement) for each individual nAlleles <- simParamBee$nCsdAlleles - alleles <- sapply(seq_len(pop@nInd), FUN = function(x) list(alleles[sample(nAlleles, size = 2, replace = F), ])) + alleles <- sapply(seq_len(pop@nInd), FUN = function(x) list(alleles[sample(nAlleles, size = 2, replace = FALSE), ])) } if (pop@nInd != length(alleles)) { diff --git a/R/Functions_L1_Pop.R b/R/Functions_L1_Pop.R index 008d6f5f..9b038d3d 100644 --- a/R/Functions_L1_Pop.R +++ b/R/Functions_L1_Pop.R @@ -409,7 +409,7 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, simParamBee <- get(x = "SP", envir = .GlobalEnv) } if (is.null(nThreads)) { - nThreads = simParamBee$nThreads + nThreads <- simParamBee$nThreads } if (is.null(nInd)) { if (caste == "virginQueens") { @@ -467,8 +467,8 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, ret@sex[] <- "M" simParamBee$addToCaste(id = ret@id, caste = "drones") } else if (isColony(x)) { - originalThreads = simParamBee$nThreads - simParamBee$nThreads = 1 + originalThreads <- simParamBee$nThreads + simParamBee$nThreads <- 1 if (length(nInd) > 1) { warning("More than one value in the nInd argument, taking only the first value!") @@ -487,7 +487,7 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, ret <- vector(mode = "list", length = 5) names(ret) <- c("workers", "nHomBrood", "pedigree", "caste", "recHist") } - simParamBee$nThreads = 1 + simParamBee$nThreads <- 1 ret$workers <- combineBeeGametes( queen = getQueen(x, simParamBee = simParamBee), drones = getFathers(x, simParamBee = simParamBee), @@ -498,12 +498,12 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, ret$workers@sex[] <- "F" if (returnSP) { - ret$caste = simParamBee$caste[ret$workers@id, drop = F] + ret$caste <- simParamBee$caste[ret$workers@id, drop = FALSE] if (simParamBee$isTrackPed) { - ret$pedigree = simParamBee$pedigree[ret$workers@id, , drop = F] + ret$pedigree <- simParamBee$pedigree[ret$workers@id, , drop = FALSE] } if (simParamBee$isTrackRec) { - ret$recHist = simParamBee$recHist[ret$workers@iid] + ret$recHist <- simParamBee$recHist[ret$workers@iid] } } @@ -514,10 +514,10 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, if (nInd(ret$workers) > length(ids)) { stop("Too many IDs provided!") } - ret$workers@id = ids - ret$workers@iid = as.integer(ids) + ret$workers@id <- ids + ret$workers@iid <- as.integer(ids) if (returnSP) { - names(ret$caste) = ids + names(ret$caste) <- ids if (simParamBee$isTrackPed) { rownames(ret$pedigree) <- ids } @@ -555,12 +555,12 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, if (returnSP) { ret <- vector(mode = "list", length = 4) names(ret) <- c("drones", "pedigree", "caste", "recHist") - ret$caste = simParamBee$caste[drones@id, drop = F] + ret$caste <- simParamBee$caste[drones@id, drop = FALSE] if (simParamBee$isTrackPed) { - ret$pedigree = simParamBee$pedigree[drones@id, , drop = F] + ret$pedigree <- simParamBee$pedigree[drones@id, , drop = FALSE] } if (simParamBee$isTrackRec) { - ret$recHist = simParamBee$recHist[drones@iid] + ret$recHist <- simParamBee$recHist[drones@iid] } } @@ -571,26 +571,26 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, drones@id = ids drones@iid = as.integer(ids) if (returnSP) { - names(ret$caste) = ids + names(ret$caste) <- ids if (simParamBee$isTrackPed) { - rownames(ret$pedigree) = ids + rownames(ret$pedigree) <- ids } if (simParamBee$isTrackRec) { - names(ret$recHist) = ids + names(ret$recHist) <- ids } } } if (returnSP) { - ret$drones= drones + ret$drones <-drones } else { - ret = drones + ret <- drones } } } else { ret <- NULL } - simParamBee$nThreads = originalThreads + simParamBee$nThreads <- originalThreads } else if (isMultiColony(x)) { registerDoParallel(cores = nThreads) if (is.null(nInd)) { @@ -657,21 +657,21 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, simParamBee$updateLastId(n = totalNInd) names(ret) <- getId(x) - # Add to simParamBee: pedigree, caste, trackRecHis + # Add to simParamBee: pedigree, caste, recHist notNull = sapply(ret, FUN = function(x) !is.null(x)) # Extend caste - Caste = do.call("c", lapply(ret[notNull], '[[', "caste")) + Caste <- do.call("c", lapply(ret[notNull], '[[', "caste")) if (caste == "virginQueens") { - Caste = rep("virginQueens", length(Caste)) + Caste <- rep("virginQueens", length(Caste)) } - Names = do.call("c", lapply(ret[notNull], function(x) names(x$caste))) - names(Caste) = Names + Names <- do.call("c", lapply(ret[notNull], function(x) names(x$caste))) + names(Caste) <- Names simParamBee$updateCaste(caste = Caste) # Extend pedigree if (simParamBee$isTrackPed) { - Pedigree = do.call("rbind", lapply(ret[notNull], '[[', "pedigree")) + Pedigree <- do.call("rbind", lapply(ret[notNull], '[[', "pedigree")) simParamBee$updatePedigree(pedigree = Pedigree) } @@ -1217,7 +1217,7 @@ pullCastePop <- function(x, caste, nInd = NULL, use = "rand", simParamBee <- get(x = "SP", envir = .GlobalEnv) } if (is.null(nThreads)) { - nThreads = simParamBee$nThreads + nThreads <- simParamBee$nThreads } if (length(caste) > 1) { stop("Argument caste can be only of length 1!") @@ -1523,7 +1523,7 @@ cross <- function(x, simParamBee <- get(x = "SP", envir = .GlobalEnv) } if (is.null(nThreads)) { - nThreads = simParamBee$nThreads + nThreads <- simParamBee$nThreads } registerDoParallel(cores = nThreads) @@ -1639,7 +1639,7 @@ cross <- function(x, ret <- list() nVirgin = nInd(x) - #Rename crossPlan + # Rename crossPlan if (crossPlan_create | crossPlan_given) { names(crossPlan) <- ID_by_input$virginId[match(ID_by_input$inputId, names(crossPlan))] } @@ -1682,7 +1682,7 @@ cross <- function(x, stop("Something went wrong with cross plan - drone matching!") } - dronesByVirgin_DF <- cbind(dronesByDPC_DF, crossPlanDF_sample[, c("virginID"), drop = F]) %>% + dronesByVirgin_DF <- cbind(dronesByDPC_DF, crossPlanDF_sample[, c("virginID"), drop = FALSE]) %>% arrange(virginID) dronesByVirgin_list <- lapply(IDs, FUN = function(x) dronesByVirgin_DF$droneID[dronesByVirgin_DF$virginID == x]) names(dronesByVirgin_list) <- IDs diff --git a/R/Functions_L2_Colony.R b/R/Functions_L2_Colony.R index 42e462ac..038b3ed9 100644 --- a/R/Functions_L2_Colony.R +++ b/R/Functions_L2_Colony.R @@ -362,16 +362,16 @@ addCastePop <- function(x, caste = NULL, nInd = NULL, new = FALSE, if (caste == "workers") { - homInds = lapply(newInds, function(x) { + homInds <- lapply(newInds, function(x) { if (is.null(x)) return(NULL) x[['nHomBrood']] }) - newInds = lapply(newInds, function(x) { + newInds <- lapply(newInds, function(x) { if (is.null(x)) return(NULL) x[["workers"]] }) } - nInds = lapply(newInds, function(x) { + nInds <- lapply(newInds, function(x) { if (is.null(x)) return(NULL) nInd(x) }) @@ -635,7 +635,7 @@ buildUp <- function(x, nWorkers = NULL, nDrones = NULL, } if (sum(nWorkers) > 0) { - x = addWorkers( + x <- addWorkers( x = x, nInd = n, new = new, simParamBee = simParamBee, nThreads = nThreads) # } else if (nWorkersColony < 0) { @@ -644,7 +644,7 @@ buildUp <- function(x, nWorkers = NULL, nDrones = NULL, # } THIS NEEDS TO GO INTO ADDCASTEPOP } if (sum(nDrones) > 0) { - x = addDrones( + x <- addDrones( x = x, nInd = n, new = new, simParamBee = simParamBee, nThreads = nThreads) # } else if (nDronesColony < 0) { @@ -877,11 +877,11 @@ replaceCastePop <- function(x, caste = NULL, p = 1, use = "rand", exact = TRUE, stop("p must not be less than 0!") } if (isColony(x) | isMultiColony(x)) { - nP = length(p) + nP <- length(p) if (isColony(x)) { - nCol = 1 + nCol <- 1 } else if (isMultiColony(x)) { - nCol = nColonies(x) + nCol <- nColonies(x) } if (any(hasCollapsed(x))) { stop(paste0("The colony or some of the colonies have collapsed, hence you can not replace individuals in it!")) @@ -1383,10 +1383,10 @@ swarm <- function(x, p = NULL, year = NULL, simParamBee <- get(x = "SP", envir = .GlobalEnv) } if (isMultiColony(x)) { - parallel = TRUE + parallel <- TRUE } if (is.null(nThreads)) { - nThreads = simParamBee$nThreads + nThreads <- simParamBee$nThreads } if (is.null(p)) { p <- simParamBee$swarmP @@ -1399,9 +1399,9 @@ swarm <- function(x, p = NULL, year = NULL, } if (isColony(x) | isMultiColony(x)) { if (isColony(x)) { - nCol = 1 + nCol <- 1 } else if (isMultiColony(x)) { - nCol = nColonies(x) + nCol <- nColonies(x) } nP <- length(p) @@ -1585,9 +1585,9 @@ supersede <- function(x, addVirginQueens = TRUE, year = NULL, simParamBee = NULL nThreads = simParamBee$nThreads } if (isColony(x)) { - parallel = FALSE + parallel <- FALSE } else if (isMultiColony(x)) { - parallel = TRUE + parallel <- TRUE } if (is.null(nVirginQueens)) { nVirginQueens <- simParamBee$nVirginQueens @@ -1618,7 +1618,7 @@ supersede <- function(x, addVirginQueens = TRUE, year = NULL, simParamBee = NULL if (nCol == 0) { x <- createMultiColony(simParamBee = simParamBee, nThreads = nThreads) } else { - virginQueens = createCastePop(x, caste = "virginQueens", nInd = 1, nThreads = nThreads) + virginQueens <- createCastePop(x, caste = "virginQueens", nInd = 1, nThreads = nThreads) combine_list <- function(a, b) { if (length(a) == 1) { @@ -1717,19 +1717,19 @@ split <- function(x, p = NULL, year = NULL, simParamBee = NULL, nThreads = NULL, p <- simParamBee$splitP } if (isMultiColony(x)) { - parallel = TRUE + parallel <- TRUE } if (isColony(x) | isMultiColony(x)) { registerDoParallel(cores = nThreads) if (isColony(x)) { - nCol = 1 + nCol <- 1 } else if (isMultiColony(x)) { - nCol = nColonies(x) + nCol <- nColonies(x) } nP <- length(p) - location = getLocation(x) + location <- getLocation(x) if (any(hasCollapsed(x))) { stop(paste0("One of the collonies is collapsed, hence you can not split it!")) } diff --git a/R/Functions_L3_Colonies.R b/R/Functions_L3_Colonies.R index 9fc14f21..deff2472 100644 --- a/R/Functions_L3_Colonies.R +++ b/R/Functions_L3_Colonies.R @@ -53,7 +53,7 @@ createMultiColony <- function(x = NULL, n = NULL, simParamBee = NULL, nThreads = simParamBee <- get(x = "SP", envir = .GlobalEnv) } if (is.null(nThreads)) { - nThreads = simParamBee$nThreads + nThreads <- simParamBee$nThreads } registerDoParallel(cores = nThreads) if (is.null(x)) { @@ -76,7 +76,7 @@ createMultiColony <- function(x = NULL, n = NULL, simParamBee = NULL, nThreads = stop("Not enough individuals in the x to create n colonies!") } ret <- new(Class = "MultiColony", colonies = vector(mode = "list", length = n)) - ids = (simParamBee$lastColonyId+1):(simParamBee$lastColonyId + n) + ids <- (simParamBee$lastColonyId+1):(simParamBee$lastColonyId + n) ret@colonies <- foreach(colony = seq_len(n)) %dopar% { createColony(x = x[colony], simParamBee = simParamBee, id = ids[colony]) } From 8b0a1308ee0af45828b0e720d91b7aea421a79b9 Mon Sep 17 00:00:00 2001 From: janaobsteter Date: Wed, 28 May 2025 15:23:59 +0200 Subject: [PATCH 19/42] Adding docs --- R/Functions_L1_Pop.R | 8 +++- R/Functions_L2_Colony.R | 77 ++++++++++++++++++++++++++------------- R/Functions_L3_Colonies.R | 2 +- 3 files changed, 59 insertions(+), 28 deletions(-) diff --git a/R/Functions_L1_Pop.R b/R/Functions_L1_Pop.R index 008d6f5f..87a49c38 100644 --- a/R/Functions_L1_Pop.R +++ b/R/Functions_L1_Pop.R @@ -313,6 +313,10 @@ getVirginQueens <- function(x, nInd = NULL, use = "rand", collapse = FALSE, simP #' in \code{\link[SIMplyBee]{SimParamBee}}. The two csd alleles must be different to #' ensure heterozygosity at the csd locus. #' @param simParamBee \code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters +#' @param returnSP logical, whether to return the pedigree, caste, and recHist information +#' for each created population (used internally for parallel computing) +#' @param ids character, IDs of the individuals that are going to be created +#' @param nThreads integer, number of cores to use for parallel computing (over colonies) #' @param ... additional arguments passed to \code{nInd} when this argument is a function #' #' @return when \code{x} is \code{\link[AlphaSimR]{MapPop-class}} returns @@ -595,7 +599,7 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, registerDoParallel(cores = nThreads) if (is.null(nInd)) { string = paste0("n", toupper(substr(caste, 1, 1)), substr(caste, 2, nchar(caste))) - nInd <- simParaBee[[string]] + nInd <- simParamBee[[string]] } nCol <- nColonies(x) @@ -1158,6 +1162,7 @@ pullDroneGroupsFromDCA <- function(DCA, n, nDrones = NULL, #' @param collapse logical, whether to return a single merged population #' for the pulled individuals (does not affect the remnant colonies) #' @param simParamBee \code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters +#' @param nThreads integer, number of cores to use for parallel computing (over colonies) #' #' @seealso \code{\link[SIMplyBee]{pullQueen}}, \code{\link[SIMplyBee]{pullVirginQueens}}, #' \code{\link[SIMplyBee]{pullWorkers}}, and \code{\link[SIMplyBee]{pullDrones}} @@ -1371,6 +1376,7 @@ pullVirginQueens <- function(x, nInd = NULL, use = "rand", collapse = FALSE, sim #' only needed when \code{spatial = TRUE} #' @param checkCross character, throw a warning (when \code{checkCross = "warning"}), #' @param simParamBee \code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters +#' @param nThreads integer, number of cores to use for parallel computing (over colonies) #' @param ... other arguments for \code{nDrones}, when \code{nDrones} is a function #' #' @details This function changes caste for the mated drones to fathers, and diff --git a/R/Functions_L2_Colony.R b/R/Functions_L2_Colony.R index 42e462ac..07881e61 100644 --- a/R/Functions_L2_Colony.R +++ b/R/Functions_L2_Colony.R @@ -94,6 +94,7 @@ createColony <- function(x = NULL, simParamBee = NULL, id = NULL) { #' \code{TRUE} since bee-keepers tend to remove any virgin queen cells #' to ensure the provided queen prevails (see details) #' @param simParamBee \code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters +#' @param nThreads integer, number of cores to use for parallel computing (over colonies) #' #' @details If the provided queen is mated, then she is saved in the queen slot #' of the colony. If she is not mated, then she is saved in the virgin queen @@ -235,11 +236,9 @@ addCastePop_internal <- function(pop, colony, caste, new = FALSE) { #' a single value is provided, the same value will be used for all the colonies. #' @param new logical, should the number of individuals be added to the caste population #' anew or should we only top-up the existing number of individuals to \code{nInd} -#' @param exact logical, only relevant when adding workers - if the csd locus is turned -#' on and exact is \code{TRUE}, we add the exact specified number of viable workers -#' (heterozygous at the csd locus) #' @param year numeric, only relevant when adding virgin queens - year of birth for virgin queens #' @param simParamBee \code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters +#' @param nThreads integer, number of cores to use for parallel computing (over colonies) #' @param ... additional arguments passed to \code{nInd} when this argument is a function #' #' @details This function increases queen's \code{nWorkers} and \code{nHomBrood} @@ -451,9 +450,6 @@ addVirginQueens <- function(x, nInd = NULL, new = FALSE, #' @param new logical, should the number of workers and drones be added anew or #' should we only top-up the existing number of workers and drones to #' \code{nWorkers} and \code{nDrones} (see details) -#' @param exact logical, if the csd locus is turned on and exact is \code{TRUE}, -#' create the exact specified number of only viable workers (heterozygous on -#' the csd locus) #' @param resetEvents logical, call \code{\link[SIMplyBee]{resetEvents}} as part of the #' build up #' @param simParamBee \code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters @@ -568,7 +564,7 @@ buildUp <- function(x, nWorkers = NULL, nDrones = NULL, if (0 < n) { x <- addWorkers( x = x, nInd = n, new = new, - exact = exact, simParamBee = simParamBee, + simParamBee = simParamBee, nThreads = nThreads) } else if (n < 0) { x@workers <- getWorkers(x, nInd = nWorkers, simParamBee = simParamBee) @@ -638,18 +634,11 @@ buildUp <- function(x, nWorkers = NULL, nDrones = NULL, x = addWorkers( x = x, nInd = n, new = new, simParamBee = simParamBee, nThreads = nThreads) - # } else if (nWorkersColony < 0) { - # #THIS IS A PROBLEM _ THE FUNCTION NEEDSD TO RETURN COLONY getWorkers(x, nInd = nWorkers, simParamBee = simParamBee) - # } - # } THIS NEEDS TO GO INTO ADDCASTEPOP } if (sum(nDrones) > 0) { x = addDrones( x = x, nInd = n, new = new, simParamBee = simParamBee, nThreads = nThreads) - # } else if (nDronesColony < 0) { - # #THIS IS A PROBLEM _ THE FUNCTION NEEDSD TO RETURN COLONY getWorkers(x, nInd = nWorkers, simParamBee = simParamBee) - # } x <- setEvents(x, slot = "production", value = TRUE) if (resetEvents) { @@ -818,13 +807,10 @@ downsize <- function(x, p = NULL, use = "rand", new = FALSE, #' a single value is provided, the same value will be applied to all the colonies #' @param use character, all the options provided by \code{\link[AlphaSimR]{selectInd}} - #' guides selection of caste individuals that stay when \code{p < 1} -#' @param exact logical, only relevant when adding workers - if the csd locus is turned -#' on and exact is \code{TRUE}, we replace the exact specified number of viable workers -#' (heterozygous at the csd locus). You probably want this set to TRUE since you want to -#' replace with the same number of workers. #' @param year numeric, only relevant when replacing virgin queens, #' year of birth for virgin queens #' @param simParamBee \code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters +#' @param nThreads integer, number of cores to use for parallel computing (over colonies) #' #' @return \code{\link[SIMplyBee]{Colony-class}} or or \code{\link[SIMplyBee]{MultiColony-class}} with #' replaced virgin queens @@ -860,7 +846,7 @@ downsize <- function(x, p = NULL, use = "rand", new = FALSE, #' apiary <- replaceWorkers(apiary, p = 0.5) #' getCasteId(apiary, caste="workers") #' @export -replaceCastePop <- function(x, caste = NULL, p = 1, use = "rand", exact = TRUE, +replaceCastePop <- function(x, caste = NULL, p = 1, use = "rand", year = NULL, simParamBee = NULL, nThreads = NULL) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) @@ -926,10 +912,10 @@ replaceCastePop <- function(x, caste = NULL, p = 1, use = "rand", exact = TRUE, #' @describeIn replaceCastePop Replaces some workers in a colony #' @export -replaceWorkers <- function(x, p = 1, use = "rand", exact = TRUE, simParamBee = NULL, nThreads = NULL) { +replaceWorkers <- function(x, p = 1, use = "rand", simParamBee = NULL, nThreads = NULL) { ret <- replaceCastePop( x = x, caste = "workers", p = p, - use = use, exact = exact, + use = use, simParamBee = simParamBee, nThreads = nThreads ) @@ -980,6 +966,7 @@ replaceVirginQueens <- function(x, p = 1, use = "rand", simParamBee = NULL, nThr #' is used #' @param year numeric, only relevant when adding virgin queens - year of birth for virgin queens #' @param simParamBee \code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters +#' @param nThreads integer, number of cores to use for parallel computing (over colonies) #' #' @return \code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}} without virgin queens #' @@ -1133,6 +1120,8 @@ removeVirginQueens <- function(x, p = 1, use = "rand", simParamBee = NULL, nThre #' up a new colony, which the default of \code{NULL} caters for; otherwise, a #' collapsed colony should be left collapsed forever, unless you force #' resetting this event with \code{collapse = TRUE}) +#' @param simParamBee \code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters +#' @param nThreads integer, number of cores to use for parallel computing (over colonies) #' #' @return \code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}} with #' events reset @@ -1249,6 +1238,9 @@ resetEvents <- function(x, collapse = NULL, simParamBee = NULL, nThreads = NULL) #' #' @return \code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}} with the collapse #' event set to \code{TRUE} +#' @param simParamBee \code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters +#' @param nThreads integer, number of cores to use for parallel computing (over colonies) +#' #' #' @details You should use this function in an edge-case when you #' want to indicate that the colony has collapsed, but you still want to @@ -1536,6 +1528,7 @@ swarm <- function(x, p = NULL, year = NULL, #' remnant colony. If \code{NULL}, the value from \code{simParamBee$nVirginQueens} #' is used #' @param simParamBee \code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters +#' @param nThreads integer, number of cores to use for parallel computing (over colonies) #' @param ... additional arguments passed to \code{nVirginQueens} when this #' argument is a function #' @@ -1627,7 +1620,7 @@ supersede <- function(x, addVirginQueens = TRUE, year = NULL, simParamBee = NULL c(a, list(b)) } } - x@colonies <- foreach(colony = seq_len(nCol), .combine = combine_list) %do% { + x@colonies <- foreach(colony = seq_len(nCol), .combine = combine_list) %dopar% { supersede(x[[colony]], year = year, simParamBee = simParamBee, @@ -1663,6 +1656,7 @@ supersede <- function(x, addVirginQueens = TRUE, year = NULL, simParamBee = NULL #' a single value is provided, the same value will be applied to all the colonies #' @param year numeric, year of birth for virgin queens #' @param simParamBee \code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters +#' @param nThreads integer, number of cores to use for parallel computing (over colonies) #' @param ... additional arguments passed to \code{p} when this argument is a #' function #' @@ -1758,7 +1752,7 @@ split <- function(x, p = NULL, year = NULL, simParamBee = NULL, nThreads = NULL, # TODO: Split colony at random by default, but we could make it as a # function of some parameters # https://github.com/HighlanderLab/SIMplyBee/issues/179 - tmp <- pullCastePop(x = x, caste = "workers", nInd = nWorkersSplit, simParamBee = simParamBee) #Tole je treba sparalelizirat + tmp <- pullCastePop(x = x, caste = "workers", nInd = nWorkersSplit, simParamBee = simParamBee) remnantColony <- tmp$remnant tmpVirginQueens <- createCastePop( @@ -1824,8 +1818,35 @@ split <- function(x, p = NULL, year = NULL, simParamBee = NULL, nThreads = NULL, return(ret) } -#' @export -# Helpi function - put it in auxiliary +#' @rdname setEvents +#' @title Set colony events +#' +#' @description Helper Level 2 function that populates the events slot. Not interded +#' for external use, intended for internal use in parallel computing +#' +#' @param x \code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}} +#' @param slot character, which event to set +#' @param value logical, the value for the event +#' @param nThreads integer, number of cores to use for parallel computing (over colonies) +#' @param simParamBee \code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters +#' +#' @return \code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}} with +#' events reset +#' +#' @examples +#' founderGenomes <- quickHaplo(nInd = 5, nChr = 1, segSites = 50) +#' SP <- SimParamBee$new(founderGenomes) +#' \dontshow{SP$nThreads = 1L} +#' basePop <- createVirginQueens(founderGenomes) +#' +#' drones <- createDrones(x = basePop[1], nInd = 100) +#' droneGroups <- pullDroneGroupsFromDCA(drones, n = 5, nDrones = nFathersPoisson) +#' +#' # Create and cross Colony and MultiColony class +#' colony <- createColony(x = basePop[2]) +#' colony <- cross(colony, drones = droneGroups[[1]]) +#' apiary <- createMultiColony(basePop[4:5]) +#' SIMplyBee:::setEvents(apiary, slot = "swarm", value = c(TRUE, TRUE)) setEvents <- function(x, slot, value, nThreads = NULL, simParamBee = NULL) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) @@ -1858,6 +1879,8 @@ setEvents <- function(x, slot, value, nThreads = NULL, simParamBee = NULL) { #' #' @param strong \code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}} #' @param weak \code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}} +#' @param simParamBee \code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters +#' @param nThreads integer, number of cores to use for parallel computing (over colonies) #' #' @return a combined \code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}} #' @@ -1948,6 +1971,8 @@ combine <- function(strong, weak, simParamBee = NULL, nThreads = NULL) { #' \code{c(x1, y1)} (the same location set to all colonies), #' \code{list(c(x1, y1), c(x2, y2))}, or #' \code{data.frame(x = c(x1, x2), y = c(y1, y2))} +#' @param simParamBee \code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters +#' @param nThreads integer, number of cores to use for parallel computing (over colonies) #' #' @return \code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}} with set #' location @@ -2039,7 +2064,7 @@ setLocation <- function(x, location = c(0, 0), simParamBee = NULL, nThreads = NU c(a, list(b)) } } - x@colonies <- foreach(colony = seq_len(n), .combine = combine_list) %do% { + x@colonies <- foreach(colony = seq_len(n), .combine = combine_list) %dopar% { if (is.data.frame(location)) { loc <- location[colony, ] loc <- c(loc$x, loc$y) diff --git a/R/Functions_L3_Colonies.R b/R/Functions_L3_Colonies.R index 9fc14f21..2969f788 100644 --- a/R/Functions_L3_Colonies.R +++ b/R/Functions_L3_Colonies.R @@ -13,6 +13,7 @@ #' given then \code{\link[SIMplyBee]{MultiColony-class}} is created with \code{n} #' \code{NULL}) individual colony - this is mostly useful for programming) #' @param simParamBee \code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters +#' @param nThreads integer, number of cores to use for parallel computing (over colonies) #' #' @details When both \code{x} and \code{n} are \code{NULL}, then a #' \code{\link[SIMplyBee]{MultiColony-class}} with 0 colonies is created. @@ -80,7 +81,6 @@ createMultiColony <- function(x = NULL, n = NULL, simParamBee = NULL, nThreads = ret@colonies <- foreach(colony = seq_len(n)) %dopar% { createColony(x = x[colony], simParamBee = simParamBee, id = ids[colony]) } - # WHY IS IT NOT UPDATING SP??? simParamBee$updateLastColonyId(n = n) } validObject(ret) From 691017b062e4ee563619486d9c22752691ab8ecf Mon Sep 17 00:00:00 2001 From: Gregor Gorjanc Date: Wed, 28 May 2025 15:49:58 +0200 Subject: [PATCH 20/42] Polishing code --- R/Functions_L1_Pop.R | 42 ++++++++++++++++++++--------------------- R/Functions_L2_Colony.R | 42 ++++++++++++++++++++--------------------- 2 files changed, 42 insertions(+), 42 deletions(-) diff --git a/R/Functions_L1_Pop.R b/R/Functions_L1_Pop.R index 389d47a1..52a09105 100644 --- a/R/Functions_L1_Pop.R +++ b/R/Functions_L1_Pop.R @@ -218,8 +218,8 @@ getFathers <- function(x, nInd = NULL, use = "rand", collapse = FALSE, simParamB if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } - if (isPop(x)) { # DO WE WANT TO PUT THIS IN getCastePop??? - ret = lapply(X = x@misc$fathers, + if (isPop(x)) { # TODO: DO WE WANT TO PUT THIS IN getCastePop??? + ret <- lapply(X = x@misc$fathers, FUN = function(z){ if(is.null(z)){ ret = NULL @@ -315,7 +315,8 @@ getVirginQueens <- function(x, nInd = NULL, use = "rand", collapse = FALSE, simP #' @param simParamBee \code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters #' @param returnSP logical, whether to return the pedigree, caste, and recHist information #' for each created population (used internally for parallel computing) -#' @param ids character, IDs of the individuals that are going to be created +#' @param ids character, IDs of the individuals that are going to be created (used internally +#' for parallel computing) #' @param nThreads integer, number of cores to use for parallel computing (over colonies) #' @param ... additional arguments passed to \code{nInd} when this argument is a function #' @@ -687,12 +688,12 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, if (!returnSP) { if (caste %in% c("drones", "virginQueens")) { - ret = lapply(ret, FUN = function(x) { + ret <- lapply(ret, FUN = function(x) { if (is.null(x)) return(NULL) # Return NULL if the element is NULL x[!names(x) %in% c("pedigree", "caste", "recHist")][[1]] }) } else { - ret = lapply(ret, FUN = function(x) { + ret <- lapply(ret, FUN = function(x) { if (is.null(x)) return(NULL) x[!names(x) %in% c("pedigree", "caste", "recHist")] }) @@ -1641,9 +1642,9 @@ cross <- function(x, } IDs <- as.character(getId(x)) - #Now x is always a Pop + # Now x is always a Pop ret <- list() - nVirgin = nInd(x) + nVirgin <- nInd(x) # Rename crossPlan if (crossPlan_create | crossPlan_given) { @@ -1651,9 +1652,9 @@ cross <- function(x, } if (is.function(nDrones)) { - nD = nDrones(n = nVirgin, ...) + nD <- nDrones(n = nVirgin, ...) } else { - nD = nDrones + nD <- nDrones } @@ -1666,7 +1667,7 @@ cross <- function(x, } if (crossPlan_given | crossPlan_create) { - if (crossPlan_colonyID) { # WHAT IF ONE ELEMENT IS EMPTY + if (crossPlan_colonyID) { # TODO: WHAT IF ONE ELEMENT IS EMPTY crossPlanDF <- data.frame(virginID = rep(names(crossPlan), unlist(sapply(crossPlan, length))), DPC = unlist(crossPlan)) @@ -1736,17 +1737,16 @@ cross <- function(x, # All of the input has been transformed to a Pop crossVirginQueen <- function(virginQueen, virginQueenDrones, simParamBee = NULL) { virginQueen@misc$fathers[[1]] <- virginQueenDrones - virginQueen <- setMisc(x = virginQueen, node = "nWorkers", value = 0) - virginQueen <- setMisc(x = virginQueen, node = "nDrones", value = 0) - - virginQueen <- setMisc(x = virginQueen, node = "nHomBrood", value = 0) - # if (isCsdActive(simParamBee = simParamBee)) { #This does still not work it the CSD is turned on - # val <- calcQueensPHomBrood(x = virginQueen, simParamBee = simParamBee) - # } else { - # val <- NA - # } - # - # virginQueen <- setMisc(x = virginQueen, node = "pHomBrood", value = val) + virginQueen@misc$nWorkers <- 0 + virginQueen@misc$nDrones <- 0 + virginQueen@misc$nHomBrood <- 0 + + if (isCsdActive(simParamBee = simParamBee)) { + val <- calcQueensPHomBrood(x = virginQueen, simParamBee = simParamBee) + } else { + val <- NA + } + virginQueen@misc$pHomBrood <- val return(virginQueen) } diff --git a/R/Functions_L2_Colony.R b/R/Functions_L2_Colony.R index 48211d41..61e42dff 100644 --- a/R/Functions_L2_Colony.R +++ b/R/Functions_L2_Colony.R @@ -151,7 +151,7 @@ reQueen <- function(x, queen, removeVirginQueens = TRUE, simParamBee = NULL, nTh simParamBee <- get(x = "SP", envir = .GlobalEnv) } if (is.null(nThreads)) { - nThreads = simParamBee$nThreads + nThreads <- simParamBee$nThreads } if (!isPop(queen)) { stop("Argument queen must be a Pop class object!") @@ -301,7 +301,7 @@ addCastePop <- function(x, caste = NULL, nInd = NULL, new = FALSE, simParamBee <- get(x = "SP", envir = .GlobalEnv) } if (is.null(nThreads)) { - nThreads = simParamBee$nThreads + nThreads <- simParamBee$nThreads } if (length(caste) != 1) { stop("Argument caste must be of length 1!") @@ -334,7 +334,7 @@ addCastePop <- function(x, caste = NULL, nInd = NULL, new = FALSE, homInds <- newInds$nHomBrood newInds <- newInds$workers x@queen@misc$nWorkers[[1]] <- x@queen@misc$nWorkers[[1]] + nInd(newInds) - #x@queen@misc$nHomBrood[[1]] <- x@queen@misc$nHomBrood[[1]] + homInds + x@queen@misc$nHomBrood[[1]] <- x@queen@misc$nHomBrood[[1]] + homInds } if (caste == "drones") { x@queen@misc$nDrones[[1]] <- x@queen@misc$nDrones[[1]] + nInd(newInds) @@ -348,7 +348,7 @@ addCastePop <- function(x, caste = NULL, nInd = NULL, new = FALSE, warning("The number of individuals to add is less than 0, hence adding nothing.") } } else if (isMultiColony(x)) { - nCol = nColonies(x) + nCol <- nColonies(x) if (any(hasCollapsed(x))) { stop(paste0("The colony ", getId(x), " collapsed, hence you can not add individuals (from the queen) to it!")) @@ -530,7 +530,7 @@ buildUp <- function(x, nWorkers = NULL, nDrones = NULL, simParamBee <- get(x = "SP", envir = .GlobalEnv) } if (is.null(nThreads)) { - nThreads = simParamBee$nThreads + nThreads <- simParamBee$nThreads } # Workers if (is.null(nWorkers)) { @@ -715,7 +715,7 @@ downsize <- function(x, p = NULL, use = "rand", new = FALSE, stop("Argument new must be logical!") } if (is.null(nThreads)) { - nThreads = simParamBee$nThreads + nThreads <- simParamBee$nThreads } if (any(1 < p)) { stop("p must not be higher than 1!") @@ -852,7 +852,7 @@ replaceCastePop <- function(x, caste = NULL, p = 1, use = "rand", simParamBee <- get(x = "SP", envir = .GlobalEnv) } if (is.null(nThreads)) { - nThreads = simParamBee$nThreads + nThreads <- simParamBee$nThreads } if (length(caste) != 1) { stop("Argument caste must be of length 1!") @@ -1009,7 +1009,7 @@ removeCastePop <- function(x, caste = NULL, p = 1, use = "rand", simParamBee <- get(x = "SP", envir = .GlobalEnv) } if (is.null(nThreads)) { - nThreads = simParamBee$nThreads + nThreads <- simParamBee$nThreads } if (length(caste) != 1) { stop("Argument caste must be of length 1!") @@ -1193,7 +1193,7 @@ resetEvents <- function(x, collapse = NULL, simParamBee = NULL, nThreads = NULL) simParamBee <- get(x = "SP", envir = .GlobalEnv) } if (is.null(nThreads)) { - nThreads = simParamBee$nThreads + nThreads <- simParamBee$nThreads } if (isColony(x)) { x@swarm <- FALSE @@ -1212,7 +1212,7 @@ resetEvents <- function(x, collapse = NULL, simParamBee = NULL, nThreads = NULL) } else if (isMultiColony(x)) { registerDoParallel(cores = nThreads) nCol <- nColonies(x) - x@colonies = foreach(colony = seq_len(nCol)) %dopar% { + x@colonies <- foreach(colony = seq_len(nCol)) %dopar% { resetEvents( x = x[[colony]], collapse = collapse, @@ -1280,7 +1280,7 @@ collapse <- function(x, simParamBee = NULL, nThreads = NULL) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } if (is.null(nThreads)) { - nThreads = simParamBee$nThreads + nThreads <- simParamBee$nThreads } if (isColony(x)) { x@collapse <- TRUE @@ -1288,7 +1288,7 @@ collapse <- function(x, simParamBee = NULL, nThreads = NULL) { } else if (isMultiColony(x)) { registerDoParallel(cores = nThreads) nCol <- nColonies(x) - x@colonies = foreach(colony = seq_len(nCol)) %dopar% { + x@colonies <- foreach(colony = seq_len(nCol)) %dopar% { collapse(x = x[[colony]], simParamBee = simParamBee, nThreads = 1) @@ -1482,14 +1482,14 @@ swarm <- function(x, p = NULL, year = NULL, } else if (isMultiColony(x)) { if (nCol == 0) { ret <- list( - swarm = createMultiColony(simParamBee = simParamBee), - remnant = createMultiColony(simParamBee = simParamBee) + swarm <- createMultiColony(simParamBee = simParamBee), + remnant <- createMultiColony(simParamBee = simParamBee) ) } else { ret <- list( - swarm = createMultiColony(x = getQueen(x, collapse = T), + swarm <- createMultiColony(x = getQueen(x, collapse = TRUE), simParamBee = simParamBee, nThreads = nThreads), - remnant = remnantColony + remnant <- remnantColony ) ret$swarm@colonies <- foreach(colony = seq_len(nCol)) %dopar% { @@ -1575,7 +1575,7 @@ supersede <- function(x, addVirginQueens = TRUE, year = NULL, simParamBee = NULL simParamBee <- get(x = "SP", envir = .GlobalEnv) } if (is.null(nThreads)) { - nThreads = simParamBee$nThreads + nThreads <- simParamBee$nThreads } if (isColony(x)) { parallel <- FALSE @@ -1705,7 +1705,7 @@ split <- function(x, p = NULL, year = NULL, simParamBee = NULL, nThreads = NULL, simParamBee <- get(x = "SP", envir = .GlobalEnv) } if (is.null(nThreads)) { - nThreads = simParamBee$nThreads + nThreads <- simParamBee$nThreads } if (is.null(p)) { p <- simParamBee$splitP @@ -1852,7 +1852,7 @@ setEvents <- function(x, slot, value, nThreads = NULL, simParamBee = NULL) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } if (is.null(nThreads)) { - nThreads = simParamBee$nThreads + nThreads <- simParamBee$nThreads } if (isColony(x)) { slot(x, slot) <- value @@ -1929,7 +1929,7 @@ combine <- function(strong, weak, simParamBee = NULL, nThreads = NULL) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } if (is.null(nThreads)) { - nThreads = simParamBee$nThreads + nThreads <- simParamBee$nThreads } if (hasCollapsed(strong)) { stop(paste0("The colony ", getId(strong), " (strong) has collapsed, hence you can not combine it!")) @@ -2016,7 +2016,7 @@ setLocation <- function(x, location = c(0, 0), simParamBee = NULL, nThreads = NU simParamBee <- get(x = "SP", envir = .GlobalEnv) } if (is.null(nThreads)) { - nThreads = simParamBee$nThreads + nThreads <- simParamBee$nThreads } if (isColony(x)) { if (is.list(location)) { # is.list() captures also is.data.frame() From 42be86b65a103c2d06855eec981ad734293c8cc1 Mon Sep 17 00:00:00 2001 From: janaobsteter Date: Thu, 29 May 2025 12:53:23 +0200 Subject: [PATCH 21/42] Adding docs and correcting the cross --- DESCRIPTION | 2 +- NAMESPACE | 5 +++ R/Functions_L0_auxilary.R | 57 ++++++---------------------------- R/Functions_L1_Pop.R | 56 ++++++++++++++++++++++++--------- R/Functions_L2_Colony.R | 65 +++++++++++++++++++++++---------------- man/SimParamBee.Rd | 19 ++++++++++++ man/addCastePop.Rd | 6 ++-- man/buildUp.Rd | 6 ++-- man/collapse.Rd | 8 +++-- man/combine.Rd | 9 ++++-- man/createCastePop.Rd | 9 +++++- man/createColony.Rd | 2 ++ man/createCrossPlan.Rd | 57 ++++++---------------------------- man/createMultiColony.Rd | 2 ++ man/cross.Rd | 2 ++ man/downsize.Rd | 2 ++ man/pullCastePop.Rd | 2 ++ man/reQueen.Rd | 2 ++ man/removeCastePop.Rd | 8 +---- man/replaceCastePop.Rd | 17 ++-------- man/resetEvents.Rd | 4 +++ man/setEvents.Rd | 42 +++++++++++++++++++++++++ man/setLocation.Rd | 4 +++ man/split.Rd | 2 ++ man/supersede.Rd | 16 ++-------- man/swarm.Rd | 2 ++ 26 files changed, 220 insertions(+), 186 deletions(-) create mode 100644 man/setEvents.Rd diff --git a/DESCRIPTION b/DESCRIPTION index 4ef4a624..64092120 100644 --- a/DESCRIPTION +++ b/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), foreach, doParallel +Imports: methods, R6, stats, utils, extraDistr (>= 1.9.1), RANN, Rcpp (>= 0.12.7), foreach, doParallel, dplyr Depends: R (>= 3.3.0), AlphaSimR (>= 1.5.3) LinkingTo: Rcpp, RcppArmadillo (>= 0.7.500.0.0), BH RoxygenNote: 7.3.2 diff --git a/NAMESPACE b/NAMESPACE index ca22c22c..cd0e1d5b 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -208,7 +208,12 @@ exportClasses(MultiColony) import(AlphaSimR) import(Rcpp) importFrom(R6,R6Class) +importFrom(doParallel,registerDoParallel) +importFrom(dplyr,"%>%") +importFrom(dplyr,arrange) importFrom(extraDistr,rtpois) +importFrom(foreach,"%dopar%") +importFrom(foreach,foreach) importFrom(methods,"slot<-") importFrom(methods,classLabel) importFrom(methods,is) diff --git a/R/Functions_L0_auxilary.R b/R/Functions_L0_auxilary.R index 66ad56e2..3b22a242 100644 --- a/R/Functions_L0_auxilary.R +++ b/R/Functions_L0_auxilary.R @@ -6437,10 +6437,6 @@ editCsdLocus <- function(pop, alleles = NULL, simParamBee = NULL) { #' virginColonies2 <- setLocation(virginColonies2, #' location = Map(c, runif(30, 0, 2*pi), #' runif(30, 0, 2*pi))) -#' virginColonies3 <- createMultiColony(basePop[61:90]) -#' virginColonies3 <- setLocation(virginColonies3, -#' location = Map(c, runif(30, 0, 2*pi), -#' runif(30, 0, 2*pi))) #' #' # Create drone colonies #' droneColonies <- createMultiColony(basePop[121:200]) @@ -6460,58 +6456,23 @@ editCsdLocus <- function(pop, alleles = NULL, simParamBee = NULL) { #' nDrones = nFathersPoisson, #' crossPlan = randomCrossPlan) #' -#' # Plot the colonies in space -#' virginLocations <- as.data.frame(getLocation(c(virginColonies1, virginColonies2, virginColonies3), -#' collapse= TRUE)) -#' virginLocations$Type <- "Virgin" -#' droneLocations <- as.data.frame(getLocation(droneColonies, collapse= TRUE)) -#' droneLocations$Type <- "Drone" -#' locations <- rbind(virginLocations, droneLocations) -#' -#' plot(x = locations$V1, y = locations$V2, -#' col = c("red", "blue")[as.numeric(as.factor(locations$Type))]) -#' -#' # Cross according to a spatial cross plan according to the colonies' locations -#' crossPlanSpatial <- createCrossPlan(x = virginColonies1, -#' droneColonies = droneColonies, -#' nDrones = nFathersPoisson, -#' spatial = TRUE, -#' radius = 1.5) -#' -#' # Plot the crossing for the first colony in the crossPlan -#' virginLocations1 <- as.data.frame(getLocation(virginColonies1, collapse= TRUE)) -#' virginLocations1$Type <- "Virgin" -#' droneLocations <- as.data.frame(getLocation(droneColonies, collapse= TRUE)) -#' droneLocations$Type <- "Drone" -#' locations1 <- rbind(virginLocations1, droneLocations) -#' -#' # Blue marks the target virgin colony and blue marks the drone colonies in the chosen radius -#' plot(x = locations1$V1, y = locations1$V2, pch = c(1, 2)[as.numeric(as.factor(locations1$Type))], -#' col = ifelse(rownames(locations1) %in% crossPlanSpatial[[1]], -#' "red", -#' ifelse(rownames(locations1) == names(crossPlanSpatial)[[1]], -#' "blue", "black"))) -#' -#' colonies1 <- cross(x = virginColonies1, -#' crossPlan = crossPlanSpatial, -#' droneColonies = droneColonies, -#' nDrones = nFathersPoisson) -#' nFathers(colonies1) -#' #' # Cross according to a cross plan that is created internally within the cross function #' # The cross plan is created at random, regardless the location of the colonies -#' colonies2 <- cross(x = virginColonies2, +#' colonies1 <- cross(x = virginColonies1, #' droneColonies = droneColonies, #' nDrones = nFathersPoisson, #' crossPlan = "create") #' -#' # Mate spatially with cross plan created internally by the cross function -#' colonies3 <- cross(x = virginColonies3, -#' droneColonies = droneColonies, +#' +#' # Cross according to a spatial cross plan created internally according to the colonies' locations +#' colonies2 <- cross(x = virginColonies2, #' crossPlan = "create", -#' checkCross = "warning", +#' droneColonies = droneColonies, +#' nDrones = nFathersPoisson, #' spatial = TRUE, -#' radius = 1) +#' radius = 1.5) +#' nFathers(colonies2) +#' #' #' @export createCrossPlan <- function(x, diff --git a/R/Functions_L1_Pop.R b/R/Functions_L1_Pop.R index 389d47a1..cfddf3d9 100644 --- a/R/Functions_L1_Pop.R +++ b/R/Functions_L1_Pop.R @@ -1374,7 +1374,8 @@ pullVirginQueens <- function(x, nInd = NULL, use = "rand", collapse = FALSE, sim #' to their distance from the virgin colony (that is, in a radius) #' @param radius numeric, the radius around the virgin colony in which to sample mating partners, #' only needed when \code{spatial = TRUE} -#' @param checkCross character, throw a warning (when \code{checkCross = "warning"}), +#' @param checkCross character, throw a warning (when \code{checkCross = "warning"}). +#' This will also remove the unmated queens and return only the mated ones. #' @param simParamBee \code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters #' @param nThreads integer, number of cores to use for parallel computing (over colonies) #' @param ... other arguments for \code{nDrones}, when \code{nDrones} is a function @@ -1611,13 +1612,15 @@ cross <- function(x, } noMatches <- sapply(crossPlan, FUN = length) + if (all(noMatches == 0)) { + stop("All crossings failed!") + } if (0 %in% noMatches) { - msg <- "Crossing failed!" if (checkCross == "warning") { - message(msg) + message("Crossing failed, unmated virgin queens will be removed!") ret <- x } else if (checkCross == "error") { - stop(msg) + stop("Crossing failed!") } } } @@ -1656,6 +1659,10 @@ cross <- function(x, nD = nDrones } + if (length(IDs) > 0 & length(nD) == 1) { + nD = rep(nD, length(IDs)) + } + combine_list <- function(a, b) { if (isPop(a)) { @@ -1665,23 +1672,41 @@ cross <- function(x, } } + if (crossPlan_given | crossPlan_create) { if (crossPlan_colonyID) { # WHAT IF ONE ELEMENT IS EMPTY + # This is the crossPlan - for spatial, these are all DPCs found in a radius crossPlanDF <- data.frame(virginID = rep(names(crossPlan), unlist(sapply(crossPlan, length))), DPC = unlist(crossPlan)) - - crossPlanDF_sample <- do.call("rbind", lapply(IDs, FUN = function(x) { - data.frame(virginID = x, DPC = sample(crossPlan[[x]], size = nD[which(x == IDs)], replace = TRUE))})) %>% - arrange(DPC) - crossPlanDF_DPCtable <- as.data.frame(table(crossPlanDF_sample$DPC)) %>% arrange(Var1) + # If some of the crossing would fail, we only return the queens that mated successfully + IDs = IDs[IDs %in% crossPlanDF$virginID] + x = x[IDs] + if (type == "MultiColony") { + multicolony <- multicolony[getId(multicolony) %in% IDs] + } + # Here we sample from the DPC in the cross plan to get the needed number of drones (nD) + crossPlanDF_sample <- do.call("rbind", lapply(IDs, + FUN = function(x) { + data.frame(virginID = x, DPC = sample(crossPlan[[x]], size = nD[which(x == IDs)], replace = TRUE)) + } )) %>% + arrange(as.integer(DPC)) + # Here I gather how many drones each DPC needs to produce + crossPlanDF_DPCtable <- as.data.frame(table(crossPlanDF_sample$DPC)) %>% + arrange(as.integer(as.character(Var1))) colnames(crossPlanDF_DPCtable) <- c("DPC", "noDrones") - - selectedDPC = droneColonies[as.character(crossPlanDF_DPCtable$DPC)] + # Here I select only the DPCs that have been sampled to produce drones + selectedDPC = selectColonies(droneColonies, ID = as.character(crossPlanDF_DPCtable$DPC)) + # And here I create the drones + print(simParamBee$lastId) + print(sum(as.integer(crossPlanDF_DPCtable$noDrones))) dronesByDPC <- createCastePop(selectedDPC, caste = "drones", - nInd = as.integer(crossPlanDF_DPCtable$noDrones), simParamBee = simParamBee) + nInd = as.integer(crossPlanDF_DPCtable$noDrones), + simParamBee = simParamBee, + nThreads = nThreads) + # This is where I link the drone ID to the DPC ID dronesByDPC_DF <- data.frame(DPC = rep(names(dronesByDPC), as.vector(crossPlanDF_DPCtable$noDrones)), droneID = unlist(sapply(dronesByDPC, FUN = function(x) getId(x)))) %>% - arrange(as.numeric(DPC)) + arrange(as.integer(DPC)) dronePop = mergePops(dronesByDPC) if (any(!crossPlanDF_sample$DPC == dronesByDPC_DF$DPC)) { @@ -1689,8 +1714,9 @@ cross <- function(x, } dronesByVirgin_DF <- cbind(dronesByDPC_DF, crossPlanDF_sample[, c("virginID"), drop = FALSE]) %>% - arrange(virginID) - dronesByVirgin_list <- lapply(IDs, FUN = function(x) dronesByVirgin_DF$droneID[dronesByVirgin_DF$virginID == x]) + arrange(as.integer(virginID)) + dronesByVirgin_list <- lapply(IDs, + FUN = function(x) dronesByVirgin_DF$droneID[dronesByVirgin_DF$virginID == x]) names(dronesByVirgin_list) <- IDs dronesByVirgin <- foreach(virgin = IDs, .combine = combine_list) %dopar% { diff --git a/R/Functions_L2_Colony.R b/R/Functions_L2_Colony.R index 48211d41..7a7ffc65 100644 --- a/R/Functions_L2_Colony.R +++ b/R/Functions_L2_Colony.R @@ -8,6 +8,7 @@ #' #' @param x \code{\link[AlphaSimR]{Pop-class}}, one queen or virgin queen(s) #' @param simParamBee \code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters +#' @param id character, ID of the colony that is going to be created (used internally for parallel computing) #' #' @return new \code{\link[SIMplyBee]{Colony-class}} #' @@ -320,6 +321,20 @@ addCastePop <- function(x, caste = NULL, nInd = NULL, new = FALSE, if (hasCollapsed(x)) { stop(paste0("The colony ", getId(x), " collapsed, hence you can not add individuals (from the queen) to it!")) } + if (!isQueenPresent(x, simParamBee = simParamBee)) { + stop("Missing queen!") + } + if (length(nInd) > 1) { + warning("More than one value in the nInd argument, taking only the first value!") + p <- p[1] + } + if (is.function(nInd)) { + nInd <- nInd(x, ...) + } else { + if (!is.null(nInd) && nInd < 0) { + stop("nInd must be non-negative or NULL!") + } + } if (length(nInd) > 1) { warning("More than one value in the nInd argument, taking only the first value!") nInd <- nInd[1] @@ -453,6 +468,7 @@ addVirginQueens <- function(x, nInd = NULL, new = FALSE, #' @param resetEvents logical, call \code{\link[SIMplyBee]{resetEvents}} as part of the #' build up #' @param simParamBee \code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters +#' @param nThreads integer, number of cores to use for parallel computing (over colonies) #' @param ... additional arguments passed to \code{nWorkers} or \code{nDrones} #' when these arguments are a function #' @@ -672,6 +688,7 @@ buildUp <- function(x, nWorkers = NULL, nDrones = NULL, #' @param new logical, should we remove all current workers and add a targeted #' proportion anew (say, create winter workers) #' @param simParamBee \code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters +#' @param nThreads integer, number of cores to use for parallel computing (over colonies) #' @param ... additional arguments passed to \code{p} when this argument is a #' function #' @@ -958,12 +975,6 @@ replaceVirginQueens <- function(x, p = 1, use = "rand", simParamBee = NULL, nThr #' a single value is provided, the same value will be applied to all the colonies #' @param use character, all the options provided by \code{\link[AlphaSimR]{selectInd}} - #' guides selection of virgins queens that will stay when \code{p < 1} -#' @param addVirginQueens logical, whether virgin queens should be added; only -#' used when removing the queen from the colony -#' @param nVirginQueens integer, the number of virgin queens to be created in the -#' colony; only used when removing the queen from the colony. If \code{0}, no virgin -#' queens are added; If \code{NULL}, the value from \code{simParamBee$nVirginQueens} -#' is used #' @param year numeric, only relevant when adding virgin queens - year of birth for virgin queens #' @param simParamBee \code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters #' @param nThreads integer, number of cores to use for parallel computing (over colonies) @@ -1253,13 +1264,13 @@ resetEvents <- function(x, collapse = NULL, simParamBee = NULL, nThreads = NULL) #' SP <- SimParamBee$new(founderGenomes) #' \dontshow{SP$nThreads = 1L} #' basePop <- createVirginQueens(founderGenomes) -#' drones <- createDrones(basePop[1], n = 1000) +#' drones <- createDrones(basePop[1], nInd = 1000) #' droneGroups <- pullDroneGroupsFromDCA(drones, n = 10, nDrones = 10) #' #' # Create Colony and MultiColony class #' colony <- createColony(x = basePop[1]) #' colony <- cross(colony, drones = droneGroups[[1]]) -#' apiary <- createMultiColony(x = basePop[2:10], n = 9) +#' apiary <- createMultiColony(x = basePop[2:10]) #' apiary <- cross(apiary, drones = droneGroups[2:10]) #' #' # Collapse @@ -1325,6 +1336,7 @@ collapse <- function(x, simParamBee = NULL, nThreads = NULL) { #' \code{NULL} then \code{\link[SIMplyBee]{SimParamBee}$swarmRadius} is used (which uses #' \code{0}, so by default swarm does not fly far away) #' @param simParamBee \code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters +#' @param nThreads integer, number of cores to use for parallel computing (over colonies) #' @param ... additional arguments passed to \code{p} or \code{nVirginQueens} #' when these arguments are functions #' @@ -1523,10 +1535,6 @@ swarm <- function(x, p = NULL, year = NULL, #' #' @param x \code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}} #' @param year numeric, year of birth for virgin queens -#' @param nVirginQueens integer, the number of virgin queens to be created in the -#' colony; of these one is randomly selected as the new virgin queen of the -#' remnant colony. If \code{NULL}, the value from \code{simParamBee$nVirginQueens} -#' is used #' @param simParamBee \code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters #' @param nThreads integer, number of cores to use for parallel computing (over colonies) #' @param ... additional arguments passed to \code{nVirginQueens} when this @@ -1570,7 +1578,7 @@ swarm <- function(x, p = NULL, year = NULL, #' # Swarm only the pulled colonies #' (supersede(tmp$pulled)) #' @export -supersede <- function(x, addVirginQueens = TRUE, year = NULL, simParamBee = NULL, nThreads = NULL, ...) { +supersede <- function(x, year = NULL, simParamBee = NULL, nThreads = NULL, ...) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } @@ -1888,8 +1896,9 @@ setEvents <- function(x, slot, value, nThreads = NULL, simParamBee = NULL) { #' founderGenomes <- quickHaplo(nInd = 10, nChr = 1, segSites = 50) #' SP <- SimParamBee$new(founderGenomes) #' \dontshow{SP$nThreads = 1L} +#' print(SP$nThreads) #' basePop <- createVirginQueens(founderGenomes) -#' drones <- createDrones(basePop[1], n = 1000) +#' drones <- createDrones(basePop[1], nInd = 1000) #' droneGroups <- pullDroneGroupsFromDCA(drones, n = 10, nDrones = 10) #' #' # Create weak and strong Colony and MultiColony class @@ -1918,28 +1927,30 @@ setEvents <- function(x, slot, value, nThreads = NULL, simParamBee = NULL) { #' #' nWorkers(apiary1); nWorkers(apiary2) #' nDrones(apiary1); nDrones(apiary2) -#' apiary1 <- combine(strong = apiary1, weak = apiary2) +#' apiary1 <- combine(strong = apiary1, weak = apiary2, simParamBee = SP) #' nWorkers(apiary1); nWorkers(apiary2) #' nDrones(apiary1); nDrones(apiary2) #' rm(apiary2) #' @export combine <- function(strong, weak, simParamBee = NULL, nThreads = NULL) { + if (is.null(simParamBee)) { + simParamBee <- get(x = "SP", envir = .GlobalEnv) + } + if (is.null(nThreads)) { + nThreads = simParamBee$nThreads + } + if (any(hasCollapsed(strong))) { + stop(paste0("Some of the strong colonies have collapsed, hence you can not combine it!")) + } + if (any(hasCollapsed(weak))) { + stop(paste0("Some of the weak colonies have collapsed, hence you can not combine it!")) + } if (isColony(strong) & isColony(weak)) { - if (is.null(simParamBee)) { - simParamBee <- get(x = "SP", envir = .GlobalEnv) - } - if (is.null(nThreads)) { - nThreads = simParamBee$nThreads - } - if (hasCollapsed(strong)) { - stop(paste0("The colony ", getId(strong), " (strong) has collapsed, hence you can not combine it!")) - } - if (hasCollapsed(weak)) { - stop(paste0("The colony ", getId(weak), " (weak) has collapsed, hence you can not combine it!")) - } strong@workers <- c(strong@workers, weak@workers) strong@drones <- c(strong@drones, weak@drones) } else if (isMultiColony(strong) & isMultiColony(weak)) { + print("Function nThreads") + print(nThreads) registerDoParallel(cores = nThreads) if (nColonies(weak) == nColonies(strong)) { nCol <- nColonies(weak) diff --git a/man/SimParamBee.Rd b/man/SimParamBee.Rd index 3507dbf8..607b2dc0 100644 --- a/man/SimParamBee.Rd +++ b/man/SimParamBee.Rd @@ -318,6 +318,7 @@ generate this object} \item \href{#method-SimParamBee-addToCaste}{\code{SimParamBee$addToCaste()}} \item \href{#method-SimParamBee-changeCaste}{\code{SimParamBee$changeCaste()}} \item \href{#method-SimParamBee-updatePedigree}{\code{SimParamBee$updatePedigree()}} +\item \href{#method-SimParamBee-updateRecHist}{\code{SimParamBee$updateRecHist()}} \item \href{#method-SimParamBee-updateCaste}{\code{SimParamBee$updateCaste()}} \item \href{#method-SimParamBee-updateLastId}{\code{SimParamBee$updateLastId()}} \item \href{#method-SimParamBee-updateLastColonyId}{\code{SimParamBee$updateLastColonyId()}} @@ -554,6 +555,24 @@ A function to update the pedigree. } } \if{html}{\out{
    }} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-SimParamBee-updateRecHist}{}}} +\subsection{Method \code{updateRecHist()}}{ +A function to update the recHist + For internal use only. +\subsection{Usage}{ +\if{html}{\out{
    }}\preformatted{SimParamBee$updateRecHist(recHist)}\if{html}{\out{
    }} +} + +\subsection{Arguments}{ +\if{html}{\out{
    }} +\describe{ +\item{\code{recHist}}{matrix, recHist list to be added} +} +\if{html}{\out{
    }} +} +} +\if{html}{\out{
    }} \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-SimParamBee-updateCaste}{}}} \subsection{Method \code{updateCaste()}}{ diff --git a/man/addCastePop.Rd b/man/addCastePop.Rd index ae52903d..86b86e8e 100644 --- a/man/addCastePop.Rd +++ b/man/addCastePop.Rd @@ -64,11 +64,9 @@ anew or should we only top-up the existing number of individuals to \code{nInd}} \item{simParamBee}{\code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters} -\item{...}{additional arguments passed to \code{nInd} when this argument is a function} +\item{nThreads}{integer, number of cores to use for parallel computing (over colonies)} -\item{exact}{logical, only relevant when adding workers - if the csd locus is turned -on and exact is \code{TRUE}, we add the exact specified number of viable workers -(heterozygous at the csd locus)} +\item{...}{additional arguments passed to \code{nInd} when this argument is a function} } \value{ \code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}} with diff --git a/man/buildUp.Rd b/man/buildUp.Rd index 3ebe1012..c227bece 100644 --- a/man/buildUp.Rd +++ b/man/buildUp.Rd @@ -39,12 +39,10 @@ build up} \item{simParamBee}{\code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters} +\item{nThreads}{integer, number of cores to use for parallel computing (over colonies)} + \item{...}{additional arguments passed to \code{nWorkers} or \code{nDrones} when these arguments are a function} - -\item{exact}{logical, if the csd locus is turned on and exact is \code{TRUE}, -create the exact specified number of only viable workers (heterozygous on -the csd locus)} } \value{ \code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}} with workers and diff --git a/man/collapse.Rd b/man/collapse.Rd index 5d9170a0..6ddef455 100644 --- a/man/collapse.Rd +++ b/man/collapse.Rd @@ -8,6 +8,10 @@ collapse(x, simParamBee = NULL, nThreads = NULL) } \arguments{ \item{x}{\code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}}} + +\item{simParamBee}{\code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters} + +\item{nThreads}{integer, number of cores to use for parallel computing (over colonies)} } \value{ \code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}} with the collapse @@ -30,13 +34,13 @@ founderGenomes <- quickHaplo(nInd = 10, nChr = 1, segSites = 50) SP <- SimParamBee$new(founderGenomes) \dontshow{SP$nThreads = 1L} basePop <- createVirginQueens(founderGenomes) -drones <- createDrones(basePop[1], n = 1000) +drones <- createDrones(basePop[1], nInd = 1000) droneGroups <- pullDroneGroupsFromDCA(drones, n = 10, nDrones = 10) # Create Colony and MultiColony class colony <- createColony(x = basePop[1]) colony <- cross(colony, drones = droneGroups[[1]]) -apiary <- createMultiColony(x = basePop[2:10], n = 9) +apiary <- createMultiColony(x = basePop[2:10]) apiary <- cross(apiary, drones = droneGroups[2:10]) # Collapse diff --git a/man/combine.Rd b/man/combine.Rd index 44a3cebc..23cf2d86 100644 --- a/man/combine.Rd +++ b/man/combine.Rd @@ -10,6 +10,10 @@ combine(strong, weak, simParamBee = NULL, nThreads = NULL) \item{strong}{\code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}}} \item{weak}{\code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}}} + +\item{simParamBee}{\code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters} + +\item{nThreads}{integer, number of cores to use for parallel computing (over colonies)} } \value{ a combined \code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}} @@ -26,8 +30,9 @@ Level 2 function that combines two Colony or MultiColony objects founderGenomes <- quickHaplo(nInd = 10, nChr = 1, segSites = 50) SP <- SimParamBee$new(founderGenomes) \dontshow{SP$nThreads = 1L} +print(SP$nThreads) basePop <- createVirginQueens(founderGenomes) -drones <- createDrones(basePop[1], n = 1000) +drones <- createDrones(basePop[1], nInd = 1000) droneGroups <- pullDroneGroupsFromDCA(drones, n = 10, nDrones = 10) # Create weak and strong Colony and MultiColony class @@ -56,7 +61,7 @@ rm(colony2) nWorkers(apiary1); nWorkers(apiary2) nDrones(apiary1); nDrones(apiary2) -apiary1 <- combine(strong = apiary1, weak = apiary2) +apiary1 <- combine(strong = apiary1, weak = apiary2, simParamBee = SP) nWorkers(apiary1); nWorkers(apiary2) nDrones(apiary1); nDrones(apiary2) rm(apiary2) diff --git a/man/createCastePop.Rd b/man/createCastePop.Rd index f32e923a..88c138cc 100644 --- a/man/createCastePop.Rd +++ b/man/createCastePop.Rd @@ -87,6 +87,13 @@ ensure heterozygosity at the csd locus.} \item{simParamBee}{\code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters} +\item{returnSP}{logical, whether to return the pedigree, caste, and recHist information +for each created population (used internally for parallel computing)} + +\item{ids}{character, IDs of the individuals that are going to be created} + +\item{nThreads}{integer, number of cores to use for parallel computing (over colonies)} + \item{...}{additional arguments passed to \code{nInd} when this argument is a function} \item{exact}{logical, only relevant when creating workers, @@ -122,7 +129,7 @@ Level 1 function that creates the specified number of caste founderGenomes <- quickHaplo(nInd = 4, nChr = 1, segSites = 50) SP <- SimParamBee$new(founderGenomes) \dontshow{SP$nThreads = 1L} -SP$setTrackRec(TRUE) +SP$setTrackRec(isTrackRec = TRUE) SP$setTrackPed(isTrackPed = TRUE) # Create virgin queens on a MapPop diff --git a/man/createColony.Rd b/man/createColony.Rd index c4a24899..d1707f07 100644 --- a/man/createColony.Rd +++ b/man/createColony.Rd @@ -10,6 +10,8 @@ createColony(x = NULL, simParamBee = NULL, id = NULL) \item{x}{\code{\link[AlphaSimR]{Pop-class}}, one queen or virgin queen(s)} \item{simParamBee}{\code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters} + +\item{id}{character, ID of the colony that is going to be created (used internally for parallel computing)} } \value{ new \code{\link[SIMplyBee]{Colony-class}} diff --git a/man/createCrossPlan.Rd b/man/createCrossPlan.Rd index ae90395f..8db00494 100644 --- a/man/createCrossPlan.Rd +++ b/man/createCrossPlan.Rd @@ -69,10 +69,6 @@ virginColonies2 <- createMultiColony(basePop[31:60]) virginColonies2 <- setLocation(virginColonies2, location = Map(c, runif(30, 0, 2*pi), runif(30, 0, 2*pi))) -virginColonies3 <- createMultiColony(basePop[61:90]) -virginColonies3 <- setLocation(virginColonies3, - location = Map(c, runif(30, 0, 2*pi), - runif(30, 0, 2*pi))) # Create drone colonies droneColonies <- createMultiColony(basePop[121:200]) @@ -92,57 +88,22 @@ droneColonies <- cross(droneColonies, nDrones = nFathersPoisson, crossPlan = randomCrossPlan) -# Plot the colonies in space -virginLocations <- as.data.frame(getLocation(c(virginColonies1, virginColonies2, virginColonies3), - collapse= TRUE)) -virginLocations$Type <- "Virgin" -droneLocations <- as.data.frame(getLocation(droneColonies, collapse= TRUE)) -droneLocations$Type <- "Drone" -locations <- rbind(virginLocations, droneLocations) - -plot(x = locations$V1, y = locations$V2, - col = c("red", "blue")[as.numeric(as.factor(locations$Type))]) - -# Cross according to a spatial cross plan according to the colonies' locations -crossPlanSpatial <- createCrossPlan(x = virginColonies1, - droneColonies = droneColonies, - nDrones = nFathersPoisson, - spatial = TRUE, - radius = 1.5) - -# Plot the crossing for the first colony in the crossPlan -virginLocations1 <- as.data.frame(getLocation(virginColonies1, collapse= TRUE)) -virginLocations1$Type <- "Virgin" -droneLocations <- as.data.frame(getLocation(droneColonies, collapse= TRUE)) -droneLocations$Type <- "Drone" -locations1 <- rbind(virginLocations1, droneLocations) - -# Blue marks the target virgin colony and blue marks the drone colonies in the chosen radius -plot(x = locations1$V1, y = locations1$V2, pch = c(1, 2)[as.numeric(as.factor(locations1$Type))], - col = ifelse(rownames(locations1) \%in\% crossPlanSpatial[[1]], - "red", - ifelse(rownames(locations1) == names(crossPlanSpatial)[[1]], - "blue", "black"))) - -colonies1 <- cross(x = virginColonies1, - crossPlan = crossPlanSpatial, - droneColonies = droneColonies, - nDrones = nFathersPoisson) -nFathers(colonies1) - # Cross according to a cross plan that is created internally within the cross function # The cross plan is created at random, regardless the location of the colonies -colonies2 <- cross(x = virginColonies2, +colonies1 <- cross(x = virginColonies1, droneColonies = droneColonies, nDrones = nFathersPoisson, crossPlan = "create") -# Mate spatially with cross plan created internally by the cross function -colonies3 <- cross(x = virginColonies3, - droneColonies = droneColonies, + +# Cross according to a spatial cross plan created internally according to the colonies' locations +colonies2 <- cross(x = virginColonies2, crossPlan = "create", - checkCross = "warning", + droneColonies = droneColonies, + nDrones = nFathersPoisson, spatial = TRUE, - radius = 1) + radius = 1.5) +nFathers(colonies2) + } diff --git a/man/createMultiColony.Rd b/man/createMultiColony.Rd index 642242e4..21bc2775 100644 --- a/man/createMultiColony.Rd +++ b/man/createMultiColony.Rd @@ -16,6 +16,8 @@ given then \code{\link[SIMplyBee]{MultiColony-class}} is created with \code{n} \code{NULL}) individual colony - this is mostly useful for programming)} \item{simParamBee}{\code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters} + +\item{nThreads}{integer, number of cores to use for parallel computing (over colonies)} } \value{ \code{\link[SIMplyBee]{MultiColony-class}} diff --git a/man/cross.Rd b/man/cross.Rd index cca298da..72e72a97 100644 --- a/man/cross.Rd +++ b/man/cross.Rd @@ -59,6 +59,8 @@ only needed when \code{spatial = TRUE}} \item{simParamBee}{\code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters} +\item{nThreads}{integer, number of cores to use for parallel computing (over colonies)} + \item{...}{other arguments for \code{nDrones}, when \code{nDrones} is a function} } \value{ diff --git a/man/downsize.Rd b/man/downsize.Rd index e581e2f3..64dba314 100644 --- a/man/downsize.Rd +++ b/man/downsize.Rd @@ -32,6 +32,8 @@ proportion anew (say, create winter workers)} \item{simParamBee}{\code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters} +\item{nThreads}{integer, number of cores to use for parallel computing (over colonies)} + \item{...}{additional arguments passed to \code{p} when this argument is a function} } diff --git a/man/pullCastePop.Rd b/man/pullCastePop.Rd index 0d554804..756b3a5e 100644 --- a/man/pullCastePop.Rd +++ b/man/pullCastePop.Rd @@ -60,6 +60,8 @@ virgin queens, say via insemination} for the pulled individuals (does not affect the remnant colonies)} \item{simParamBee}{\code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters} + +\item{nThreads}{integer, number of cores to use for parallel computing (over colonies)} } \value{ list of \code{\link[AlphaSimR]{Pop-class}} and \code{\link[SIMplyBee]{Colony-class}} diff --git a/man/reQueen.Rd b/man/reQueen.Rd index 91ccf2cf..ea5b2b99 100644 --- a/man/reQueen.Rd +++ b/man/reQueen.Rd @@ -25,6 +25,8 @@ queen that will have to be mated later; test will be run if the individual to ensure the provided queen prevails (see details)} \item{simParamBee}{\code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters} + +\item{nThreads}{integer, number of cores to use for parallel computing (over colonies)} } \value{ \code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}} with new queen(s) (see details) diff --git a/man/removeCastePop.Rd b/man/removeCastePop.Rd index f725e16a..f6a3089d 100644 --- a/man/removeCastePop.Rd +++ b/man/removeCastePop.Rd @@ -42,13 +42,7 @@ guides selection of virgins queens that will stay when \code{p < 1}} \item{simParamBee}{\code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters} -\item{addVirginQueens}{logical, whether virgin queens should be added; only -used when removing the queen from the colony} - -\item{nVirginQueens}{integer, the number of virgin queens to be created in the -colony; only used when removing the queen from the colony. If \code{0}, no virgin -queens are added; If \code{NULL}, the value from \code{simParamBee$nVirginQueens} -is used} +\item{nThreads}{integer, number of cores to use for parallel computing (over colonies)} } \value{ \code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}} without virgin queens diff --git a/man/replaceCastePop.Rd b/man/replaceCastePop.Rd index 4120be51..be159fb8 100644 --- a/man/replaceCastePop.Rd +++ b/man/replaceCastePop.Rd @@ -12,20 +12,12 @@ replaceCastePop( caste = NULL, p = 1, use = "rand", - exact = TRUE, year = NULL, simParamBee = NULL, nThreads = NULL ) -replaceWorkers( - x, - p = 1, - use = "rand", - exact = TRUE, - simParamBee = NULL, - nThreads = NULL -) +replaceWorkers(x, p = 1, use = "rand", simParamBee = NULL, nThreads = NULL) replaceDrones(x, p = 1, use = "rand", simParamBee = NULL, nThreads = NULL) @@ -50,15 +42,12 @@ a single value is provided, the same value will be applied to all the colonies} \item{use}{character, all the options provided by \code{\link[AlphaSimR]{selectInd}} - guides selection of caste individuals that stay when \code{p < 1}} -\item{exact}{logical, only relevant when adding workers - if the csd locus is turned -on and exact is \code{TRUE}, we replace the exact specified number of viable workers -(heterozygous at the csd locus). You probably want this set to TRUE since you want to -replace with the same number of workers.} - \item{year}{numeric, only relevant when replacing virgin queens, year of birth for virgin queens} \item{simParamBee}{\code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters} + +\item{nThreads}{integer, number of cores to use for parallel computing (over colonies)} } \value{ \code{\link[SIMplyBee]{Colony-class}} or or \code{\link[SIMplyBee]{MultiColony-class}} with diff --git a/man/resetEvents.Rd b/man/resetEvents.Rd index 4aa327eb..1abb4999 100644 --- a/man/resetEvents.Rd +++ b/man/resetEvents.Rd @@ -13,6 +13,10 @@ resetEvents(x, collapse = NULL, simParamBee = NULL, nThreads = NULL) up a new colony, which the default of \code{NULL} caters for; otherwise, a collapsed colony should be left collapsed forever, unless you force resetting this event with \code{collapse = TRUE})} + +\item{simParamBee}{\code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters} + +\item{nThreads}{integer, number of cores to use for parallel computing (over colonies)} } \value{ \code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}} with diff --git a/man/setEvents.Rd b/man/setEvents.Rd new file mode 100644 index 00000000..6c8d926d --- /dev/null +++ b/man/setEvents.Rd @@ -0,0 +1,42 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/Functions_L2_Colony.R +\name{setEvents} +\alias{setEvents} +\title{Set colony events} +\usage{ +setEvents(x, slot, value, nThreads = NULL, simParamBee = NULL) +} +\arguments{ +\item{x}{\code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}}} + +\item{slot}{character, which event to set} + +\item{value}{logical, the value for the event} + +\item{nThreads}{integer, number of cores to use for parallel computing (over colonies)} + +\item{simParamBee}{\code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters} +} +\value{ +\code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}} with + events reset +} +\description{ +Helper Level 2 function that populates the events slot. Not interded + for external use, intended for internal use in parallel computing +} +\examples{ +founderGenomes <- quickHaplo(nInd = 5, nChr = 1, segSites = 50) +SP <- SimParamBee$new(founderGenomes) +\dontshow{SP$nThreads = 1L} +basePop <- createVirginQueens(founderGenomes) + +drones <- createDrones(x = basePop[1], nInd = 100) +droneGroups <- pullDroneGroupsFromDCA(drones, n = 5, nDrones = nFathersPoisson) + +# Create and cross Colony and MultiColony class +colony <- createColony(x = basePop[2]) +colony <- cross(colony, drones = droneGroups[[1]]) +apiary <- createMultiColony(basePop[4:5]) +SIMplyBee:::setEvents(apiary, slot = "swarm", value = c(TRUE, TRUE)) +} diff --git a/man/setLocation.Rd b/man/setLocation.Rd index 88efe66e..42b4ec20 100644 --- a/man/setLocation.Rd +++ b/man/setLocation.Rd @@ -14,6 +14,10 @@ locations as \code{c(x1, y1)} (the same location set to all colonies), \code{list(c(x1, y1), c(x2, y2))}, or \code{data.frame(x = c(x1, x2), y = c(y1, y2))}} + +\item{simParamBee}{\code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters} + +\item{nThreads}{integer, number of cores to use for parallel computing (over colonies)} } \value{ \code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}} with set diff --git a/man/split.Rd b/man/split.Rd index 63c92f4c..9ebf8926 100644 --- a/man/split.Rd +++ b/man/split.Rd @@ -19,6 +19,8 @@ a single value is provided, the same value will be applied to all the colonies} \item{simParamBee}{\code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters} +\item{nThreads}{integer, number of cores to use for parallel computing (over colonies)} + \item{...}{additional arguments passed to \code{p} when this argument is a function} } diff --git a/man/supersede.Rd b/man/supersede.Rd index 0f958ba8..d8108669 100644 --- a/man/supersede.Rd +++ b/man/supersede.Rd @@ -4,14 +4,7 @@ \alias{supersede} \title{Supersede} \usage{ -supersede( - x, - addVirginQueens = TRUE, - year = NULL, - simParamBee = NULL, - nThreads = NULL, - ... -) +supersede(x, year = NULL, simParamBee = NULL, nThreads = NULL, ...) } \arguments{ \item{x}{\code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}}} @@ -20,13 +13,10 @@ supersede( \item{simParamBee}{\code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters} +\item{nThreads}{integer, number of cores to use for parallel computing (over colonies)} + \item{...}{additional arguments passed to \code{nVirginQueens} when this argument is a function} - -\item{nVirginQueens}{integer, the number of virgin queens to be created in the -colony; of these one is randomly selected as the new virgin queen of the -remnant colony. If \code{NULL}, the value from \code{simParamBee$nVirginQueens} -is used} } \value{ \code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}} with the diff --git a/man/swarm.Rd b/man/swarm.Rd index b7988ef3..aefbabba 100644 --- a/man/swarm.Rd +++ b/man/swarm.Rd @@ -36,6 +36,8 @@ the current colony location and adding deviates to each coordinate using \item{simParamBee}{\code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters} +\item{nThreads}{integer, number of cores to use for parallel computing (over colonies)} + \item{...}{additional arguments passed to \code{p} or \code{nVirginQueens} when these arguments are functions} } From 59684025a7d3c952cd4c93e7d33e4a5cb2383dc1 Mon Sep 17 00:00:00 2001 From: janaobsteter Date: Thu, 29 May 2025 12:58:12 +0200 Subject: [PATCH 22/42] Amending previous push --- NAMESPACE | 1 - R/Functions_L1_Pop.R | 4 ---- 2 files changed, 5 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index cd0e1d5b..78129144 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -192,7 +192,6 @@ export(replaceVirginQueens) export(replaceWorkers) export(resetEvents) export(selectColonies) -export(setEvents) export(setLocation) export(setMisc) export(setQueensYearOfBirth) diff --git a/R/Functions_L1_Pop.R b/R/Functions_L1_Pop.R index b88bd482..5728e05b 100644 --- a/R/Functions_L1_Pop.R +++ b/R/Functions_L1_Pop.R @@ -1675,12 +1675,8 @@ cross <- function(x, if (crossPlan_given | crossPlan_create) { -<<<<<<< HEAD if (crossPlan_colonyID) { # WHAT IF ONE ELEMENT IS EMPTY # This is the crossPlan - for spatial, these are all DPCs found in a radius -======= - if (crossPlan_colonyID) { # TODO: WHAT IF ONE ELEMENT IS EMPTY ->>>>>>> 691017b062e4ee563619486d9c22752691ab8ecf crossPlanDF <- data.frame(virginID = rep(names(crossPlan), unlist(sapply(crossPlan, length))), DPC = unlist(crossPlan)) # If some of the crossing would fail, we only return the queens that mated successfully From e566f5539950adf4685e5e928009b2a26a4072cb Mon Sep 17 00:00:00 2001 From: Gregor Gorjanc Date: Thu, 29 May 2025 13:04:16 +0200 Subject: [PATCH 23/42] Rd files update --- man/createCastePop.Rd | 3 ++- man/cross.Rd | 3 ++- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/man/createCastePop.Rd b/man/createCastePop.Rd index 88c138cc..19f2da9f 100644 --- a/man/createCastePop.Rd +++ b/man/createCastePop.Rd @@ -90,7 +90,8 @@ ensure heterozygosity at the csd locus.} \item{returnSP}{logical, whether to return the pedigree, caste, and recHist information for each created population (used internally for parallel computing)} -\item{ids}{character, IDs of the individuals that are going to be created} +\item{ids}{character, IDs of the individuals that are going to be created (used internally +for parallel computing)} \item{nThreads}{integer, number of cores to use for parallel computing (over colonies)} diff --git a/man/cross.Rd b/man/cross.Rd index 72e72a97..7a16fe98 100644 --- a/man/cross.Rd +++ b/man/cross.Rd @@ -55,7 +55,8 @@ to their distance from the virgin colony (that is, in a radius)} \item{radius}{numeric, the radius around the virgin colony in which to sample mating partners, only needed when \code{spatial = TRUE}} -\item{checkCross}{character, throw a warning (when \code{checkCross = "warning"}),} +\item{checkCross}{character, throw a warning (when \code{checkCross = "warning"}). +This will also remove the unmated queens and return only the mated ones.} \item{simParamBee}{\code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters} From e3cf5d6677b353a02109bbea446930faa6341cf8 Mon Sep 17 00:00:00 2001 From: Gregor Gorjanc Date: Thu, 29 May 2025 15:45:55 +0200 Subject: [PATCH 24/42] Add imports --- R/SIMplyBee.R | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/R/SIMplyBee.R b/R/SIMplyBee.R index 20e60684..595de8e4 100644 --- a/R/SIMplyBee.R +++ b/R/SIMplyBee.R @@ -7,8 +7,9 @@ #' @importFrom stats rnorm rbeta runif rpois na.omit #' @importFrom extraDistr rtpois #' @importFrom utils packageVersion -#' @importFrom foreach foreach +#' @importFrom foreach foreach "%dopar%" #' @importFrom doParallel registerDoParallel +#' @importFrom dplyr "%>%" arrange # see https://r-pkgs.org/namespace.html on description what to import/depend/... #' @description From a069ddd29f438c9aee7cd9cf617d68100574eb6e Mon Sep 17 00:00:00 2001 From: Gregor Gorjanc Date: Thu, 29 May 2025 15:47:50 +0200 Subject: [PATCH 25/42] .gitignore change --- .gitignore | 2 ++ 1 file changed, 2 insertions(+) diff --git a/.gitignore b/.gitignore index c8dd2d6a..0428c571 100644 --- a/.gitignore +++ b/.gitignore @@ -13,6 +13,8 @@ # Output files from R CMD build /*.tar.gz +src/*.o +src/*.so # Output files from R CMD check /*.Rcheck/ From cafc142acfeffbc8053e6d907d0342f2dd7d1e78 Mon Sep 17 00:00:00 2001 From: janaobsteter Date: Fri, 30 May 2025 08:26:22 +0200 Subject: [PATCH 26/42] Removing nThreads, renaming updateLastBeeId --- R/Class-SimParamBee.R | 7 +- R/Functions_L1_Pop.R | 128 +++++++++--------- R/Functions_L2_Colony.R | 238 ++++++++++++---------------------- R/Functions_L3_Colonies.R | 2 +- R/SIMplyBee.R | 3 +- man/SimParamBee.Rd | 13 +- man/addCastePop.Rd | 22 +--- man/buildUp.Rd | 3 - man/collapse.Rd | 4 +- man/combine.Rd | 4 +- man/createCastePop.Rd | 9 +- man/createMatingStationDCA.Rd | 2 +- man/createMultiColony.Rd | 2 +- man/cross.Rd | 8 +- man/downsize.Rd | 12 +- man/pullCastePop.Rd | 5 +- man/reQueen.Rd | 10 +- man/removeCastePop.Rd | 13 +- man/replaceCastePop.Rd | 17 +-- man/resetEvents.Rd | 4 +- man/setEvents.Rd | 4 +- man/setLocation.Rd | 4 +- man/split.Rd | 4 +- man/supersede.Rd | 4 +- man/swarm.Rd | 3 - 25 files changed, 182 insertions(+), 343 deletions(-) diff --git a/R/Class-SimParamBee.R b/R/Class-SimParamBee.R index 44e72d1a..0cdd27c0 100644 --- a/R/Class-SimParamBee.R +++ b/R/Class-SimParamBee.R @@ -454,13 +454,12 @@ SimParamBee <- R6Class( #' @description A function to update the last #' ID everytime we create an individual - #' For internal use only. + #' For internal use in SIMplyBee only. #' #' @param lastId integer, last colony ID assigned #' @param n integer, how many individuals to add - updateLastId = function(n = 1) { - n = as.integer(n) - private$.lastId = private$.lastId + n + updateLastBeeId = function(n = 1L) { + private$.lastId = private$.lastId + as.integer(n) invisible(self) }, diff --git a/R/Functions_L1_Pop.R b/R/Functions_L1_Pop.R index 5728e05b..025a0951 100644 --- a/R/Functions_L1_Pop.R +++ b/R/Functions_L1_Pop.R @@ -220,16 +220,16 @@ getFathers <- function(x, nInd = NULL, use = "rand", collapse = FALSE, simParamB } if (isPop(x)) { # TODO: DO WE WANT TO PUT THIS IN getCastePop??? ret <- lapply(X = x@misc$fathers, - FUN = function(z){ - if(is.null(z)){ - ret = NULL - }else{ - if (is.null(nInd)) { - n <- nInd(z) - } - ret <- selectInd(pop = z, nInd = n, use = use, simParam = simParamBee) - } - } + FUN = function(z){ + if(is.null(z)){ + ret = NULL + }else{ + if (is.null(nInd)) { + n <- nInd(z) + } + ret <- selectInd(pop = z, nInd = n, use = use, simParam = simParamBee) + } + } ) if (nInd(x) == 1) { ret <- ret[[1]] @@ -317,7 +317,6 @@ getVirginQueens <- function(x, nInd = NULL, use = "rand", collapse = FALSE, simP #' for each created population (used internally for parallel computing) #' @param ids character, IDs of the individuals that are going to be created (used internally #' for parallel computing) -#' @param nThreads integer, number of cores to use for parallel computing (over colonies) #' @param ... additional arguments passed to \code{nInd} when this argument is a function #' #' @return when \code{x} is \code{\link[AlphaSimR]{MapPop-class}} returns @@ -408,14 +407,11 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, simParamBee = NULL, returnSP = FALSE, ids = NULL, - nThreads = NULL, ...) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } - if (is.null(nThreads)) { - nThreads <- simParamBee$nThreads - } + if (is.null(nInd)) { if (caste == "virginQueens") { nInd <- simParamBee$nVirginQueens @@ -496,7 +492,7 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, ret$workers <- combineBeeGametes( queen = getQueen(x, simParamBee = simParamBee), drones = getFathers(x, simParamBee = simParamBee), - nProgeny = nInd, simParamBee = simParamBee + nProgeny = nInd, simParam = simParamBee ) simParamBee$addToCaste(id = ret$workers@id, caste = "workers") @@ -539,7 +535,7 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, } else if (caste == "virginQueens") { ret <- createCastePop(x = x, caste = "workers", nInd = nInd, exact = TRUE, simParamBee = simParamBee, - returnSP = returnSP, ids = ids, nThreads = 1, ...) + returnSP = returnSP, ids = ids, ...) simParamBee$changeCaste(id = ret$workers@id, caste = "virginQueens") if (!returnSP) { ret <- ret$workers @@ -548,11 +544,14 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, ret <- setQueensYearOfBirth(x = ret, year = year, simParamBee = simParamBee) } } else if (caste == "drones") { - + print("Before makeDH") + print(simParamBee$lastId) drones <- makeDH( pop = getQueen(x, simParamBee = simParamBee), nDH = nInd, keepParents = FALSE, simParam = simParamBee ) + print("After makeDH") + print(simParamBee$lastId) drones@sex[] <- "M" simParamBee$addToCaste(id = drones@id, caste = "drones") @@ -597,7 +596,8 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, } simParamBee$nThreads <- originalThreads } else if (isMultiColony(x)) { - registerDoParallel(cores = nThreads) + print("SP threads") + print(simParamBee$nThreads) if (is.null(nInd)) { string = paste0("n", toupper(substr(caste, 1, 1)), substr(caste, 2, nchar(caste))) nInd <- simParamBee[[string]] @@ -620,6 +620,8 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, stop("Nothing to create.") } + registerDoParallel(cores = simParamBee$nThreads) + lastId = simParamBee$lastId ids = (lastId+1):(lastId+totalNInd) @@ -637,7 +639,6 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, } } } - ret <- foreach(colony = seq_len(nCol), .combine=combine_list) %dopar% { nIndColony <- ifelse(nNInd == 1, nInd, nInd[colony]) if (nIndColony > 0) { @@ -659,9 +660,10 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, NULL } } - simParamBee$updateLastId(n = totalNInd) + simParamBee$updateLastBeeId(n = totalNInd) names(ret) <- getId(x) + # Add to simParamBee: pedigree, caste, recHist notNull = sapply(ret, FUN = function(x) !is.null(x)) @@ -699,7 +701,8 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, }) } } - } else { + } + else { stop("Argument x must be a Map-Pop (only for virgin queens), Pop (only for drones), Colony, or MultiColony class object!") } @@ -711,13 +714,11 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, #' @export createWorkers <- function(x, nInd = NULL, exact = FALSE, simParamBee = NULL, returnSP = FALSE, - ids = NULL, - nThreads = NULL, ...) { + ids = NULL, ...) { ret <- createCastePop(x, caste = "workers", nInd = nInd, exact = exact, simParamBee = simParamBee, returnSP = returnSP, - ids = ids, - nThreads = nThreads, ...) + ids = ids, ...) return(ret) } @@ -725,13 +726,11 @@ createWorkers <- function(x, nInd = NULL, exact = FALSE, simParamBee = NULL, #' @export createDrones <- function(x, nInd = NULL, simParamBee = NULL, returnSP = FALSE, - ids = NULL, - nThreads = NULL, ...) { + ids = NULL, ...) { ret <- createCastePop(x, caste = "drones", nInd = nInd, simParamBee = simParamBee, returnSP = returnSP, - ids = ids, - nThreads = nThreads, ...) + ids = ids, ...) return(ret) } @@ -743,14 +742,12 @@ createVirginQueens <- function(x, nInd = NULL, simParamBee = NULL, returnSP = FALSE, ids = NULL, - nThreads = NULL, ...) { ret <- createCastePop(x, caste = "virginQueens", nInd = nInd, year = year, editCsd = editCsd, csdAlleles = csdAlleles, simParamBee = simParamBee, returnSP = returnSP, - ids = ids, - nThreads = nThreads, ...) + ids = ids, ...) return(ret) } @@ -991,7 +988,7 @@ createDCA <- function(x, nInd = NULL, removeFathers = TRUE, simParamBee = NULL) #' SP <- SimParamBee$new(founderGenomes) #' \dontshow{SP$nThreads = 1L} #' basePop <- createVirginQueens(founderGenomes) -#' drones <- createDrones(basePop[1], n = 1000) +#' drones <- createDrones(basePop[1], nInd = 1000) #' droneGroups <- pullDroneGroupsFromDCA(drones, n = 10, nDrones = 10) #' #' # Create a colony and cross it @@ -1163,7 +1160,6 @@ pullDroneGroupsFromDCA <- function(DCA, n, nDrones = NULL, #' @param collapse logical, whether to return a single merged population #' for the pulled individuals (does not affect the remnant colonies) #' @param simParamBee \code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters -#' @param nThreads integer, number of cores to use for parallel computing (over colonies) #' #' @seealso \code{\link[SIMplyBee]{pullQueen}}, \code{\link[SIMplyBee]{pullVirginQueens}}, #' \code{\link[SIMplyBee]{pullWorkers}}, and \code{\link[SIMplyBee]{pullDrones}} @@ -1217,14 +1213,10 @@ pullDroneGroupsFromDCA <- function(DCA, n, nDrones = NULL, #' pullCastePop(apiary, caste = "virginQueens", collapse = TRUE) #' @export pullCastePop <- function(x, caste, nInd = NULL, use = "rand", - removeFathers = TRUE, collapse = FALSE, simParamBee = NULL, - nThreads = NULL) { + removeFathers = TRUE, collapse = FALSE, simParamBee = NULL) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } - if (is.null(nThreads)) { - nThreads <- simParamBee$nThreads - } if (length(caste) > 1) { stop("Argument caste can be only of length 1!") } @@ -1257,7 +1249,7 @@ pullCastePop <- function(x, caste, nInd = NULL, use = "rand", ret <- list(pulled = tmp$pulled, remnant = x) } } else if (isMultiColony(x)) { - registerDoParallel(cores = nThreads) + registerDoParallel(cores = simParamBee$nThreads) nCol <- nColonies(x) nNInd <- length(nInd) if (nNInd > 1 && nNInd < nCol) { @@ -1378,7 +1370,6 @@ pullVirginQueens <- function(x, nInd = NULL, use = "rand", collapse = FALSE, sim #' @param checkCross character, throw a warning (when \code{checkCross = "warning"}). #' This will also remove the unmated queens and return only the mated ones. #' @param simParamBee \code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters -#' @param nThreads integer, number of cores to use for parallel computing (over colonies) #' @param ... other arguments for \code{nDrones}, when \code{nDrones} is a function #' #' @details This function changes caste for the mated drones to fathers, and @@ -1406,7 +1397,7 @@ pullVirginQueens <- function(x, nInd = NULL, use = "rand", collapse = FALSE, sim #' @examples #' founderGenomes <- quickHaplo(nInd = 30, nChr = 1, segSites = 100) #' SP <- SimParamBee$new(founderGenomes) -#' \dontshow{SP$nThreads = 1L} +#' SP$nThreads = 1L #' basePop <- createVirginQueens(founderGenomes) #' #' drones <- createDrones(x = basePop[1], nInd = 1000) @@ -1525,15 +1516,11 @@ cross <- function(x, radius = NULL, checkCross = "error", simParamBee = NULL, - nThreads = NULL, ...) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } - if (is.null(nThreads)) { - nThreads <- simParamBee$nThreads - } - registerDoParallel(cores = nThreads) + registerDoParallel(cores = simParamBee$nThreads) if (isPop(x)) { type = "Pop" @@ -1645,9 +1632,9 @@ cross <- function(x, } IDs <- as.character(getId(x)) - # Now x is always a Pop + #Now x is always a Pop ret <- list() - nVirgin <- nInd(x) + nVirgin = nInd(x) # Rename crossPlan if (crossPlan_create | crossPlan_given) { @@ -1655,9 +1642,9 @@ cross <- function(x, } if (is.function(nDrones)) { - nD <- nDrones(n = nVirgin, ...) + nD = nDrones(n = nVirgin, ...) } else { - nD <- nDrones + nD = nDrones } if (length(IDs) > 0 & length(nD) == 1) { @@ -1683,13 +1670,13 @@ cross <- function(x, IDs = IDs[IDs %in% crossPlanDF$virginID] x = x[IDs] if (type == "MultiColony") { - multicolony <- multicolony[getId(multicolony) %in% IDs] + multicolony <- multicolony[getId(multicolony) %in% IDs] } # Here we sample from the DPC in the cross plan to get the needed number of drones (nD) crossPlanDF_sample <- do.call("rbind", lapply(IDs, FUN = function(x) { - data.frame(virginID = x, DPC = sample(crossPlan[[x]], size = nD[which(x == IDs)], replace = TRUE)) - } )) %>% + data.frame(virginID = x, DPC = sample(crossPlan[[x]], size = nD[which(x == IDs)], replace = TRUE)) + } )) %>% arrange(as.integer(DPC)) # Here I gather how many drones each DPC needs to produce crossPlanDF_DPCtable <- as.data.frame(table(crossPlanDF_sample$DPC)) %>% @@ -1702,8 +1689,7 @@ cross <- function(x, print(sum(as.integer(crossPlanDF_DPCtable$noDrones))) dronesByDPC <- createCastePop(selectedDPC, caste = "drones", nInd = as.integer(crossPlanDF_DPCtable$noDrones), - simParamBee = simParamBee, - nThreads = nThreads) + simParamBee = simParamBee) # This is where I link the drone ID to the DPC ID dronesByDPC_DF <- data.frame(DPC = rep(names(dronesByDPC), as.vector(crossPlanDF_DPCtable$noDrones)), droneID = unlist(sapply(dronesByDPC, FUN = function(x) getId(x)))) %>% @@ -1763,16 +1749,17 @@ cross <- function(x, # All of the input has been transformed to a Pop crossVirginQueen <- function(virginQueen, virginQueenDrones, simParamBee = NULL) { virginQueen@misc$fathers[[1]] <- virginQueenDrones - virginQueen@misc$nWorkers <- 0 - virginQueen@misc$nDrones <- 0 - virginQueen@misc$nHomBrood <- 0 - - if (isCsdActive(simParamBee = simParamBee)) { - val <- calcQueensPHomBrood(x = virginQueen, simParamBee = simParamBee) - } else { - val <- NA - } - virginQueen@misc$pHomBrood <- val + virginQueen <- setMisc(x = virginQueen, node = "nWorkers", value = 0) + virginQueen <- setMisc(x = virginQueen, node = "nDrones", value = 0) + + virginQueen <- setMisc(x = virginQueen, node = "nHomBrood", value = 0) + # if (isCsdActive(simParamBee = simParamBee)) { #This does still not work it the CSD is turned on + # val <- calcQueensPHomBrood(x = virginQueen, simParamBee = simParamBee) + # } else { + # val <- NA + # } + # + # virginQueen <- setMisc(x = virginQueen, node = "pHomBrood", value = val) return(virginQueen) } @@ -1783,7 +1770,11 @@ cross <- function(x, if (type == "Pop") { - ret <- mergePops(x) + if (length(x) == 1) { + ret <- x + } else { + ret <- mergePops(x) + } } else if (type == "Colony") { ret <- reQueen(x = colony, queen = x[1], simParamBee = simParamBee) ret <- removeVirginQueens(ret, simParamBee = simParamBee) @@ -1796,6 +1787,7 @@ cross <- function(x, return(ret) } + #' @rdname setQueensYearOfBirth #' @title Set the queen's year of birth #' diff --git a/R/Functions_L2_Colony.R b/R/Functions_L2_Colony.R index 9d03a34d..ef860c99 100644 --- a/R/Functions_L2_Colony.R +++ b/R/Functions_L2_Colony.R @@ -95,7 +95,6 @@ createColony <- function(x = NULL, simParamBee = NULL, id = NULL) { #' \code{TRUE} since bee-keepers tend to remove any virgin queen cells #' to ensure the provided queen prevails (see details) #' @param simParamBee \code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters -#' @param nThreads integer, number of cores to use for parallel computing (over colonies) #' #' @details If the provided queen is mated, then she is saved in the queen slot #' of the colony. If she is not mated, then she is saved in the virgin queen @@ -147,13 +146,10 @@ createColony <- function(x = NULL, simParamBee = NULL, id = NULL) { #' getCasteId(apiary, caste = "virginQueens") #' #' @export -reQueen <- function(x, queen, removeVirginQueens = TRUE, simParamBee = NULL, nThreads = NULL) { +reQueen <- function(x, queen, removeVirginQueens = TRUE, simParamBee = NULL) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } - if (is.null(nThreads)) { - nThreads <- simParamBee$nThreads - } if (!isPop(queen)) { stop("Argument queen must be a Pop class object!") } @@ -174,7 +170,7 @@ reQueen <- function(x, queen, removeVirginQueens = TRUE, simParamBee = NULL, nTh x@virginQueens <- queen } } else if (isMultiColony(x)) { - registerDoParallel(cores = nThreads) + registerDoParallel(cores = simParamBee$nThreads) nCol <- nColonies(x) if (nInd(queen) < nCol) { stop("Not enough queens provided!") @@ -239,7 +235,6 @@ addCastePop_internal <- function(pop, colony, caste, new = FALSE) { #' anew or should we only top-up the existing number of individuals to \code{nInd} #' @param year numeric, only relevant when adding virgin queens - year of birth for virgin queens #' @param simParamBee \code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters -#' @param nThreads integer, number of cores to use for parallel computing (over colonies) #' @param ... additional arguments passed to \code{nInd} when this argument is a function #' #' @details This function increases queen's \code{nWorkers} and \code{nHomBrood} @@ -296,14 +291,10 @@ addCastePop_internal <- function(pop, colony, caste, new = FALSE) { #' #' @export addCastePop <- function(x, caste = NULL, nInd = NULL, new = FALSE, - year = NULL, simParamBee = NULL, - nThreads = NULL, ...) { + year = NULL, simParamBee = NULL, ...) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } - if (is.null(nThreads)) { - nThreads <- simParamBee$nThreads - } if (length(caste) != 1) { stop("Argument caste must be of length 1!") } @@ -342,8 +333,7 @@ addCastePop <- function(x, caste = NULL, nInd = NULL, new = FALSE, if (0 < nInd) { newInds <- createCastePop(x, nInd, caste = caste, - year = year, simParamBee = simParamBee, - nThreads = nThreads + year = year, simParamBee = simParamBee ) if (caste == "workers") { homInds <- newInds$nHomBrood @@ -372,7 +362,7 @@ addCastePop <- function(x, caste = NULL, nInd = NULL, new = FALSE, newInds <- createCastePop(x, nInd, caste = caste, year = year, simParamBee = simParamBee, - nThreads = nThreads, returnSP = FALSE, ...) + returnSP = FALSE, ...) if (caste == "workers") { @@ -413,10 +403,10 @@ addCastePop <- function(x, caste = NULL, nInd = NULL, new = FALSE, #' @describeIn addCastePop Add workers to a colony #' @export addWorkers <- function(x, nInd = NULL, new = FALSE, - simParamBee = NULL, nThreads = NULL, ...) { + simParamBee = NULL, ...) { ret <- addCastePop( x = x, caste = "workers", nInd = nInd, new = new, - simParamBee = simParamBee, nThreads = nThreads, ... + simParamBee = simParamBee, ... ) return(ret) } @@ -424,11 +414,10 @@ addWorkers <- function(x, nInd = NULL, new = FALSE, #' @describeIn addCastePop Add drones to a colony #' @export addDrones <- function(x, nInd = NULL, new = FALSE, - simParamBee = NULL, nThreads = NULL, ...) { + simParamBee = NULL, ...) { ret <- addCastePop( x = x, caste = "drones", nInd = nInd, new = new, - simParamBee = simParamBee, - nThreads = nThreads, ... + simParamBee = simParamBee, ... ) return(ret) } @@ -436,10 +425,10 @@ addDrones <- function(x, nInd = NULL, new = FALSE, #' @describeIn addCastePop Add virgin queens to a colony #' @export addVirginQueens <- function(x, nInd = NULL, new = FALSE, - year = NULL, simParamBee = NULL, nThreads = NULL, ...) { + year = NULL, simParamBee = NULL, ...) { ret <- addCastePop( x = x, caste = "virginQueens", nInd = nInd, new = new, - year = year, simParamBee = simParamBee, nThreads = nThreads, ... + year = year, simParamBee = simParamBee, ... ) return(ret) } @@ -468,7 +457,6 @@ addVirginQueens <- function(x, nInd = NULL, new = FALSE, #' @param resetEvents logical, call \code{\link[SIMplyBee]{resetEvents}} as part of the #' build up #' @param simParamBee \code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters -#' @param nThreads integer, number of cores to use for parallel computing (over colonies) #' @param ... additional arguments passed to \code{nWorkers} or \code{nDrones} #' when these arguments are a function #' @@ -541,13 +529,10 @@ addVirginQueens <- function(x, nInd = NULL, new = FALSE, #' @export buildUp <- function(x, nWorkers = NULL, nDrones = NULL, new = TRUE, resetEvents = FALSE, - simParamBee = NULL, nThreads = NULL, ...) { + simParamBee = NULL, ...) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } - if (is.null(nThreads)) { - nThreads <- simParamBee$nThreads - } # Workers if (is.null(nWorkers)) { nWorkers <- simParamBee$nWorkers @@ -580,8 +565,7 @@ buildUp <- function(x, nWorkers = NULL, nDrones = NULL, if (0 < n) { x <- addWorkers( x = x, nInd = n, new = new, - simParamBee = simParamBee, - nThreads = nThreads) + simParamBee = simParamBee) } else if (n < 0) { x@workers <- getWorkers(x, nInd = nWorkers, simParamBee = simParamBee) } @@ -600,8 +584,7 @@ buildUp <- function(x, nWorkers = NULL, nDrones = NULL, if (0 < n) { x <- addDrones( x = x, nInd = n, new = new, - simParamBee = simParamBee, - nThreads = nThreads + simParamBee = simParamBee ) } else if (n < 0) { x@drones <- getDrones(x, nInd = nDrones, simParamBee = simParamBee) @@ -613,7 +596,7 @@ buildUp <- function(x, nWorkers = NULL, nDrones = NULL, } x@production <- TRUE } else if (isMultiColony(x)) { - registerDoParallel(cores = nThreads) + registerDoParallel(cores = simParamBee$nThreads) if (any(hasCollapsed(x))) { stop(paste0("Some colonies are collapsed, hence you can not build it up!")) @@ -649,12 +632,12 @@ buildUp <- function(x, nWorkers = NULL, nDrones = NULL, if (sum(nWorkers) > 0) { x <- addWorkers( x = x, nInd = n, new = new, - simParamBee = simParamBee, nThreads = nThreads) + simParamBee = simParamBee) } if (sum(nDrones) > 0) { x <- addDrones( x = x, nInd = n, new = new, - simParamBee = simParamBee, nThreads = nThreads) + simParamBee = simParamBee) } x <- setEvents(x, slot = "production", value = TRUE) if (resetEvents) { @@ -688,7 +671,6 @@ buildUp <- function(x, nWorkers = NULL, nDrones = NULL, #' @param new logical, should we remove all current workers and add a targeted #' proportion anew (say, create winter workers) #' @param simParamBee \code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters -#' @param nThreads integer, number of cores to use for parallel computing (over colonies) #' @param ... additional arguments passed to \code{p} when this argument is a #' function #' @@ -724,16 +706,13 @@ buildUp <- function(x, nWorkers = NULL, nDrones = NULL, #' @export #' downsize <- function(x, p = NULL, use = "rand", new = FALSE, - simParamBee = NULL, nThreads = NULL, ...) { + simParamBee = NULL, ...) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } if (!is.logical(new)) { stop("Argument new must be logical!") } - if (is.null(nThreads)) { - nThreads <- simParamBee$nThreads - } if (any(1 < p)) { stop("p must not be higher than 1!") } else if (any(p < 0)) { @@ -763,7 +742,7 @@ downsize <- function(x, p = NULL, use = "rand", new = FALSE, x <- removeVirginQueens(x = x, p = 1, simParamBee = simParamBee) x@production <- FALSE } else if (isMultiColony(x)) { - registerDoParallel(cores = nThreads) + registerDoParallel(cores = simParamBee$nThreads) nCol <- nColonies(x) nP <- length(p) @@ -786,14 +765,13 @@ downsize <- function(x, p = NULL, use = "rand", new = FALSE, if (new == TRUE) { n <- round(nWorkers(x, simParamBee = simParamBee) * (1 - p)) x <- addWorkers(x = x, nInd = n, new = TRUE, - simParamBee = simParamBee, - nThreads = nThreads) + simParamBee = simParamBee) } else { x <- removeWorkers(x = x, p = p, use = use, - simParamBee = simParamBee, nThreads = nThreads) + simParamBee = simParamBee) } - x <- removeDrones(x = x, p = 1, simParamBee = simParamBee, nThreads = nThreads) - x <- removeVirginQueens(x = x, p = 1, simParamBee = simParamBee, nThreads = nThreads) + x <- removeDrones(x = x, p = 1, simParamBee = simParamBee) + x <- removeVirginQueens(x = x, p = 1, simParamBee = simParamBee) for (colony in 1:nCol) { x[[colony]]@production <- FALSE } @@ -827,7 +805,6 @@ downsize <- function(x, p = NULL, use = "rand", new = FALSE, #' @param year numeric, only relevant when replacing virgin queens, #' year of birth for virgin queens #' @param simParamBee \code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters -#' @param nThreads integer, number of cores to use for parallel computing (over colonies) #' #' @return \code{\link[SIMplyBee]{Colony-class}} or or \code{\link[SIMplyBee]{MultiColony-class}} with #' replaced virgin queens @@ -864,13 +841,10 @@ downsize <- function(x, p = NULL, use = "rand", new = FALSE, #' getCasteId(apiary, caste="workers") #' @export replaceCastePop <- function(x, caste = NULL, p = 1, use = "rand", - year = NULL, simParamBee = NULL, nThreads = NULL) { + year = NULL, simParamBee = NULL) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } - if (is.null(nThreads)) { - nThreads <- simParamBee$nThreads - } if (length(caste) != 1) { stop("Argument caste must be of length 1!") } @@ -929,34 +903,31 @@ replaceCastePop <- function(x, caste = NULL, p = 1, use = "rand", #' @describeIn replaceCastePop Replaces some workers in a colony #' @export -replaceWorkers <- function(x, p = 1, use = "rand", simParamBee = NULL, nThreads = NULL) { +replaceWorkers <- function(x, p = 1, use = "rand", simParamBee = NULL) { ret <- replaceCastePop( x = x, caste = "workers", p = p, use = use, - simParamBee = simParamBee, - nThreads = nThreads + simParamBee = simParamBee ) return(ret) } #' @describeIn replaceCastePop Replaces some drones in a colony #' @export -replaceDrones <- function(x, p = 1, use = "rand", simParamBee = NULL, nThreads = NULL) { +replaceDrones <- function(x, p = 1, use = "rand", simParamBee = NULL) { ret <- replaceCastePop( x = x, caste = "drones", p = p, - use = use, simParamBee = simParamBee, - nThreads = nThreads + use = use, simParamBee = simParamBee ) return(ret) } #' @describeIn replaceCastePop Replaces some virgin queens in a colony #' @export -replaceVirginQueens <- function(x, p = 1, use = "rand", simParamBee = NULL, nThreads = NULL) { +replaceVirginQueens <- function(x, p = 1, use = "rand", simParamBee = NULL) { ret <- replaceCastePop( x = x, caste = "virginQueens", p = p, - use = use, simParamBee = simParamBee, - nThreads = nThreads + use = use, simParamBee = simParamBee ) return(ret) } @@ -977,7 +948,6 @@ replaceVirginQueens <- function(x, p = 1, use = "rand", simParamBee = NULL, nThr #' guides selection of virgins queens that will stay when \code{p < 1} #' @param year numeric, only relevant when adding virgin queens - year of birth for virgin queens #' @param simParamBee \code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters -#' @param nThreads integer, number of cores to use for parallel computing (over colonies) #' #' @return \code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}} without virgin queens #' @@ -1015,13 +985,10 @@ replaceVirginQueens <- function(x, p = 1, use = "rand", simParamBee = NULL, nThr #' nWorkers(removeWorkers(apiary, p = c(0.1, 0.5))) #' @export removeCastePop <- function(x, caste = NULL, p = 1, use = "rand", - year = NULL, simParamBee = NULL, nThreads = NULL) { + year = NULL, simParamBee = NULL) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } - if (is.null(nThreads)) { - nThreads <- simParamBee$nThreads - } if (length(caste) != 1) { stop("Argument caste must be of length 1!") } @@ -1054,7 +1021,7 @@ removeCastePop <- function(x, caste = NULL, p = 1, use = "rand", } } } else if (isMultiColony(x)) { - registerDoParallel(cores = nThreads) + registerDoParallel(cores = simParamBee$nThreads) nCol <- nColonies(x) nP <- length(p) if (nP > 1 && nP < nCol) { @@ -1087,16 +1054,16 @@ removeCastePop <- function(x, caste = NULL, p = 1, use = "rand", #' @describeIn removeCastePop Remove queen from a colony #' @export #' -removeQueen <- function(x, year = NULL, simParamBee = NULL, nThreads = NULL) { - ret <- removeCastePop(x = x, caste = "queen", p = 1, year = year, simParamBee = simParamBee, nThreads = nThreads) +removeQueen <- function(x, year = NULL, simParamBee = NULL) { + ret <- removeCastePop(x = x, caste = "queen", p = 1, year = year, simParamBee = simParamBee) return(ret) } #' @describeIn removeCastePop Remove workers from a colony #' @export -removeWorkers <- function(x, p = 1, use = "rand", simParamBee = NULL, nThreads = NULL) { - ret <- removeCastePop(x = x, caste = "workers", p = p, use = use, simParamBee = simParamBee, nThreads = nThreads) +removeWorkers <- function(x, p = 1, use = "rand", simParamBee = NULL) { + ret <- removeCastePop(x = x, caste = "workers", p = p, use = use, simParamBee = simParamBee) return(ret) } @@ -1104,8 +1071,8 @@ removeWorkers <- function(x, p = 1, use = "rand", simParamBee = NULL, nThreads = #' @describeIn removeCastePop Remove workers from a colony #' @export -removeDrones <- function(x, p = 1, use = "rand", simParamBee = NULL, nThreads = NULL) { - ret <- removeCastePop(x = x, caste = "drones", p = p, use = use, simParamBee = simParamBee, nThreads = nThreads) +removeDrones <- function(x, p = 1, use = "rand", simParamBee = NULL) { + ret <- removeCastePop(x = x, caste = "drones", p = p, use = use, simParamBee = simParamBee) return(ret) } @@ -1113,8 +1080,8 @@ removeDrones <- function(x, p = 1, use = "rand", simParamBee = NULL, nThreads = #' @describeIn removeCastePop Remove virgin queens from a colony #' @export -removeVirginQueens <- function(x, p = 1, use = "rand", simParamBee = NULL, nThreads = NULL) { - ret <- removeCastePop(x = x, caste = "virginQueens", p = p, use = use, simParamBee = simParamBee, nThreads = nThreads) +removeVirginQueens <- function(x, p = 1, use = "rand", simParamBee = NULL) { + ret <- removeCastePop(x = x, caste = "virginQueens", p = p, use = use, simParamBee = simParamBee) return(ret) } @@ -1132,7 +1099,6 @@ removeVirginQueens <- function(x, p = 1, use = "rand", simParamBee = NULL, nThre #' collapsed colony should be left collapsed forever, unless you force #' resetting this event with \code{collapse = TRUE}) #' @param simParamBee \code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters -#' @param nThreads integer, number of cores to use for parallel computing (over colonies) #' #' @return \code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}} with #' events reset @@ -1199,13 +1165,10 @@ removeVirginQueens <- function(x, p = 1, use = "rand", simParamBee = NULL, nThre #' hasSplit(remnants[[1]]) #' resetEvents(remnants)[[1]] #' @export -resetEvents <- function(x, collapse = NULL, simParamBee = NULL, nThreads = NULL) { +resetEvents <- function(x, collapse = NULL, simParamBee = NULL) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } - if (is.null(nThreads)) { - nThreads <- simParamBee$nThreads - } if (isColony(x)) { x@swarm <- FALSE x@split <- FALSE @@ -1221,14 +1184,13 @@ resetEvents <- function(x, collapse = NULL, simParamBee = NULL, nThreads = NULL) x@production <- FALSE validObject(x) } else if (isMultiColony(x)) { - registerDoParallel(cores = nThreads) + registerDoParallel(cores = simParamBee$nThreads) nCol <- nColonies(x) x@colonies <- foreach(colony = seq_len(nCol)) %dopar% { resetEvents( x = x[[colony]], collapse = collapse, - simParamBee = simParamBee, - nThreads = 1 + simParamBee = simParamBee ) } validObject(x) @@ -1250,7 +1212,6 @@ resetEvents <- function(x, collapse = NULL, simParamBee = NULL, nThreads = NULL) #' @return \code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}} with the collapse #' event set to \code{TRUE} #' @param simParamBee \code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters -#' @param nThreads integer, number of cores to use for parallel computing (over colonies) #' #' #' @details You should use this function in an edge-case when you @@ -1286,23 +1247,19 @@ resetEvents <- function(x, collapse = NULL, simParamBee = NULL, nThreads = NULL) #' apiaryLeft <- tmp$remnant #' hasCollapsed(apiaryLeft) #' @export -collapse <- function(x, simParamBee = NULL, nThreads = NULL) { +collapse <- function(x, simParamBee = NULL) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } - if (is.null(nThreads)) { - nThreads <- simParamBee$nThreads - } if (isColony(x)) { x@collapse <- TRUE x@production <- FALSE } else if (isMultiColony(x)) { - registerDoParallel(cores = nThreads) + registerDoParallel(cores = simParamBee$nThreads) nCol <- nColonies(x) x@colonies <- foreach(colony = seq_len(nCol)) %dopar% { collapse(x = x[[colony]], - simParamBee = simParamBee, - nThreads = 1) + simParamBee = simParamBee) } } else { stop("Argument x must be a Colony or MultiColony class object!") @@ -1336,7 +1293,6 @@ collapse <- function(x, simParamBee = NULL, nThreads = NULL) { #' \code{NULL} then \code{\link[SIMplyBee]{SimParamBee}$swarmRadius} is used (which uses #' \code{0}, so by default swarm does not fly far away) #' @param simParamBee \code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters -#' @param nThreads integer, number of cores to use for parallel computing (over colonies) #' @param ... additional arguments passed to \code{p} or \code{nVirginQueens} #' when these arguments are functions #' @@ -1382,16 +1338,13 @@ collapse <- function(x, simParamBee = NULL, nThreads = NULL) { #' @export swarm <- function(x, p = NULL, year = NULL, sampleLocation = TRUE, radius = NULL, - simParamBee = NULL, nThreads= NULL, ...) { + simParamBee = NULL, ...) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } if (isMultiColony(x)) { parallel <- TRUE } - if (is.null(nThreads)) { - nThreads <- simParamBee$nThreads - } if (is.null(p)) { p <- simParamBee$swarmP } @@ -1445,25 +1398,21 @@ swarm <- function(x, p = NULL, year = NULL, x = x, nInd = 1, year = year, caste = "virginQueens", - simParamBee = simParamBee, - nThreads = nThreads + simParamBee = simParamBee ) tmp <- pullCastePop(x = x, caste = "workers", - nInd = nWorkersSwarm, simParamBee = simParamBee, - nThreads = nThreads) + nInd = nWorkersSwarm, simParamBee = simParamBee) remnantColony <- tmp$remnant - remnantColony <- removeQueen(remnantColony, nThreads = nThreads) + remnantColony <- removeQueen(remnantColony) if (isColony(x)) { remnantColony <- reQueen(remnantColony, queen = tmpVirginQueen, - simParamBee = simParamBee, - nThreads = nThreads) + simParamBee = simParamBee) } else { remnantColony <- reQueen(remnantColony, queen = mergePops(tmpVirginQueen), - simParamBee = simParamBee, - nThreads = nThreads) + simParamBee = simParamBee) } currentLocation <- getLocation(x) @@ -1500,7 +1449,7 @@ swarm <- function(x, p = NULL, year = NULL, } else { ret <- list( swarm <- createMultiColony(x = getQueen(x, collapse = TRUE), - simParamBee = simParamBee, nThreads = nThreads), + simParamBee = simParamBee), remnant <- remnantColony ) @@ -1509,10 +1458,10 @@ swarm <- function(x, p = NULL, year = NULL, pop = tmp$pulled[[colony]], caste = "workers") } - ret$remnant <- setEvents(ret$remnant, slot = "swarm", value = TRUE, nThreads = nThreads) - ret$swarm <- setEvents(ret$swarm, slot = "swarm", value = TRUE, nThreads = nThreads) - ret$swarm <- setEvents(ret$swarm, slot = "production", value = FALSE, nThreads = nThreads) - ret$remnant <- setEvents(ret$remnant, slot = "production", value = FALSE, nThreads = nThreads) + ret$remnant <- setEvents(ret$remnant, slot = "swarm", value = TRUE) + ret$swarm <- setEvents(ret$swarm, slot = "swarm", value = TRUE) + ret$swarm <- setEvents(ret$swarm, slot = "production", value = FALSE) + ret$remnant <- setEvents(ret$remnant, slot = "production", value = FALSE) } } } else { @@ -1536,7 +1485,6 @@ swarm <- function(x, p = NULL, year = NULL, #' @param x \code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}} #' @param year numeric, year of birth for virgin queens #' @param simParamBee \code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters -#' @param nThreads integer, number of cores to use for parallel computing (over colonies) #' @param ... additional arguments passed to \code{nVirginQueens} when this #' argument is a function #' @@ -1578,13 +1526,10 @@ swarm <- function(x, p = NULL, year = NULL, #' # Swarm only the pulled colonies #' (supersede(tmp$pulled)) #' @export -supersede <- function(x, year = NULL, simParamBee = NULL, nThreads = NULL, ...) { +supersede <- function(x, year = NULL, simParamBee = NULL, ...) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } - if (is.null(nThreads)) { - nThreads <- simParamBee$nThreads - } if (isColony(x)) { parallel <- FALSE } else if (isMultiColony(x)) { @@ -1607,19 +1552,19 @@ supersede <- function(x, year = NULL, simParamBee = NULL, nThreads = NULL, ...) if (!parallel) { x <- addVirginQueens(x, nInd = 1) } - x <- removeQueen(x, year = year, simParamBee = simParamBee, nThreads = nThreads) + x <- removeQueen(x, year = year, simParamBee = simParamBee) # TODO: We could consider that a non-random virgin queen prevails (say the most # aggressive one), by creating many virgin queens and then picking the # one with highest pheno for competition or some other criteria # https://github.com/HighlanderLab/SIMplyBee/issues/239 x@supersedure <- TRUE } else if (isMultiColony(x)) { - registerDoParallel(cores = nThreads) + registerDoParallel(cores = simParamBee$nThreads) nCol <- nColonies(x) if (nCol == 0) { - x <- createMultiColony(simParamBee = simParamBee, nThreads = nThreads) + x <- createMultiColony(simParamBee = simParamBee) } else { - virginQueens <- createCastePop(x, caste = "virginQueens", nInd = 1, nThreads = nThreads) + virginQueens <- createCastePop(x, caste = "virginQueens", nInd = 1) combine_list <- function(a, b) { if (length(a) == 1) { @@ -1631,8 +1576,7 @@ supersede <- function(x, year = NULL, simParamBee = NULL, nThreads = NULL, ...) x@colonies <- foreach(colony = seq_len(nCol), .combine = combine_list) %dopar% { supersede(x[[colony]], year = year, - simParamBee = simParamBee, - nThreads = nThreads, ... + simParamBee = simParamBee, ... ) } x@colonies <- foreach(colony = seq_len(nColonies(x))) %dopar% { @@ -1664,7 +1608,6 @@ supersede <- function(x, year = NULL, simParamBee = NULL, nThreads = NULL, ...) #' a single value is provided, the same value will be applied to all the colonies #' @param year numeric, year of birth for virgin queens #' @param simParamBee \code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters -#' @param nThreads integer, number of cores to use for parallel computing (over colonies) #' @param ... additional arguments passed to \code{p} when this argument is a #' function #' @@ -1708,13 +1651,10 @@ supersede <- function(x, year = NULL, simParamBee = NULL, nThreads = NULL, ...) #' # Split only the pulled colonies #' (split(tmp$pulled, p = 0.5)) #' @export -split <- function(x, p = NULL, year = NULL, simParamBee = NULL, nThreads = NULL, ...) { +split <- function(x, p = NULL, year = NULL, simParamBee = NULL, ...) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } - if (is.null(nThreads)) { - nThreads <- simParamBee$nThreads - } if (is.null(p)) { p <- simParamBee$splitP } @@ -1723,7 +1663,7 @@ split <- function(x, p = NULL, year = NULL, simParamBee = NULL, nThreads = NULL, } if (isColony(x) | isMultiColony(x)) { - registerDoParallel(cores = nThreads) + registerDoParallel(cores = simParamBee$nThreads) if (isColony(x)) { nCol <- 1 } else if (isMultiColony(x)) { @@ -1767,8 +1707,7 @@ split <- function(x, p = NULL, year = NULL, simParamBee = NULL, nThreads = NULL, x = x, nInd = 1, year = year, caste = "virginQueens", - simParamBee = simParamBee, - nThreads = nThreads + simParamBee = simParamBee ) if (isColony(x)) { @@ -1796,26 +1735,26 @@ split <- function(x, p = NULL, year = NULL, simParamBee = NULL, nThreads = NULL, } else if (isMultiColony(x)) { if (nCol == 0) { ret <- list( - split = createMultiColony(simParamBee = simParamBee, nThreads = nThreads), - remnant = createMultiColony(simParamBee = simParamBee, nThreads = nThreads) + split = createMultiColony(simParamBee = simParamBee), + remnant = createMultiColony(simParamBee = simParamBee) ) } else { ret <- list( split = createMultiColony(x = mergePops(tmpVirginQueens), n = nCol, - simParamBee = simParamBee, nThreads = nThreads), + simParamBee = simParamBee), remnant = tmp$remnant ) - ret$split <- setLocation(x = ret$split, location = location, nThreads = nThreads) + ret$split <- setLocation(x = ret$split, location = location) ret$split@colonies <- foreach(colony = seq_len(nCol)) %dopar% { addCastePop_internal(colony = ret$split@colonies[[colony]], pop = tmp$pulled[[colony]], caste = "workers") } - ret$split <- setEvents(ret$split, slot = "split", value = TRUE, nThreads = nThreads) - ret$remnant <- setEvents(ret$remnant, slot = "split", value = TRUE, nThreads = nThreads) - ret$split <- setEvents(ret$split, slot = "production", value = FALSE, nThreads = nThreads) - ret$remnant <- setEvents(ret$remnant, slot = "production", value = TRUE, nThreads = nThreads) + ret$split <- setEvents(ret$split, slot = "split", value = TRUE) + ret$remnant <- setEvents(ret$remnant, slot = "split", value = TRUE) + ret$split <- setEvents(ret$split, slot = "production", value = FALSE) + ret$remnant <- setEvents(ret$remnant, slot = "production", value = TRUE) } } } else { @@ -1835,7 +1774,6 @@ split <- function(x, p = NULL, year = NULL, simParamBee = NULL, nThreads = NULL, #' @param x \code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}} #' @param slot character, which event to set #' @param value logical, the value for the event -#' @param nThreads integer, number of cores to use for parallel computing (over colonies) #' @param simParamBee \code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters #' #' @return \code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}} with @@ -1855,18 +1793,15 @@ split <- function(x, p = NULL, year = NULL, simParamBee = NULL, nThreads = NULL, #' colony <- cross(colony, drones = droneGroups[[1]]) #' apiary <- createMultiColony(basePop[4:5]) #' SIMplyBee:::setEvents(apiary, slot = "swarm", value = c(TRUE, TRUE)) -setEvents <- function(x, slot, value, nThreads = NULL, simParamBee = NULL) { +setEvents <- function(x, slot, value, simParamBee = NULL) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } - if (is.null(nThreads)) { - nThreads <- simParamBee$nThreads - } if (isColony(x)) { slot(x, slot) <- value } if (isMultiColony(x)) { - registerDoParallel(cores = nThreads) + registerDoParallel(cores = simParamBee$nThreads) x@colonies <- foreach(colony = seq_len(nColonies(x))) %dopar% { setEvents(x[[colony]], slot, value) } @@ -1888,7 +1823,6 @@ setEvents <- function(x, slot, value, nThreads = NULL, simParamBee = NULL) { #' @param strong \code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}} #' @param weak \code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}} #' @param simParamBee \code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters -#' @param nThreads integer, number of cores to use for parallel computing (over colonies) #' #' @return a combined \code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}} #' @@ -1932,13 +1866,10 @@ setEvents <- function(x, slot, value, nThreads = NULL, simParamBee = NULL) { #' nDrones(apiary1); nDrones(apiary2) #' rm(apiary2) #' @export -combine <- function(strong, weak, simParamBee = NULL, nThreads = NULL) { +combine <- function(strong, weak, simParamBee = NULL) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } - if (is.null(nThreads)) { - nThreads = simParamBee$nThreads - } if (any(hasCollapsed(strong))) { stop(paste0("Some of the strong colonies have collapsed, hence you can not combine it!")) } @@ -1949,16 +1880,13 @@ combine <- function(strong, weak, simParamBee = NULL, nThreads = NULL) { strong@workers <- c(strong@workers, weak@workers) strong@drones <- c(strong@drones, weak@drones) } else if (isMultiColony(strong) & isMultiColony(weak)) { - print("Function nThreads") - print(nThreads) - registerDoParallel(cores = nThreads) + registerDoParallel(cores = simParamBee$nThreads) if (nColonies(weak) == nColonies(strong)) { nCol <- nColonies(weak) strong@colonies <- foreach(colony = seq_len(nCol)) %dopar% { combine(strong = strong[[colony]], weak = weak[[colony]], - simParamBee = simParamBee, - nThreads = 1) + simParamBee = simParamBee) } } else { stop("Weak and strong MultiColony objects must be of the same length!") @@ -1983,7 +1911,6 @@ combine <- function(strong, weak, simParamBee = NULL, nThreads = NULL) { #' \code{list(c(x1, y1), c(x2, y2))}, or #' \code{data.frame(x = c(x1, x2), y = c(y1, y2))} #' @param simParamBee \code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters -#' @param nThreads integer, number of cores to use for parallel computing (over colonies) #' #' @return \code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}} with set #' location @@ -2022,13 +1949,10 @@ combine <- function(strong, weak, simParamBee = NULL, nThreads = NULL) { #' apiary <- setLocation(apiary, location = locDF) #' getLocation(apiary) #' @export -setLocation <- function(x, location = c(0, 0), simParamBee = NULL, nThreads = NULL) { +setLocation <- function(x, location = c(0, 0), simParamBee = NULL) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } - if (is.null(nThreads)) { - nThreads <- simParamBee$nThreads - } if (isColony(x)) { if (is.list(location)) { # is.list() captures also is.data.frame() stop("Argument location must be numeric, when x is a Colony class object!") @@ -2038,7 +1962,7 @@ setLocation <- function(x, location = c(0, 0), simParamBee = NULL, nThreads = NU } x@location <- location } else if (isMultiColony(x)) { - registerDoParallel(cores = nThreads) + registerDoParallel(cores = simParamBee$nThreads) n <- nColonies(x) if (!is.null(location)) { if (is.numeric(location)) { diff --git a/R/Functions_L3_Colonies.R b/R/Functions_L3_Colonies.R index b7ef1c90..fafa2ad3 100644 --- a/R/Functions_L3_Colonies.R +++ b/R/Functions_L3_Colonies.R @@ -41,7 +41,7 @@ #' #' # Create mated colonies by crossing #' apiary <- createMultiColony(x = basePop[1:2], n = 2) -#' drones <- createDrones(x = basePop[3], n = 30) +#' drones <- createDrones(x = basePop[3], nInd = 30) #' droneGroups <- pullDroneGroupsFromDCA(drones, n = 2, nDrones = 15) #' apiary <- cross(apiary, drones = droneGroups) #' apiary diff --git a/R/SIMplyBee.R b/R/SIMplyBee.R index 20e60684..c10dda63 100644 --- a/R/SIMplyBee.R +++ b/R/SIMplyBee.R @@ -7,8 +7,9 @@ #' @importFrom stats rnorm rbeta runif rpois na.omit #' @importFrom extraDistr rtpois #' @importFrom utils packageVersion -#' @importFrom foreach foreach +#' @importFrom foreach foreach %dopar% #' @importFrom doParallel registerDoParallel +#' @importFrom dplyr arrange %>% # see https://r-pkgs.org/namespace.html on description what to import/depend/... #' @description diff --git a/man/SimParamBee.Rd b/man/SimParamBee.Rd index 607b2dc0..78356c8e 100644 --- a/man/SimParamBee.Rd +++ b/man/SimParamBee.Rd @@ -320,7 +320,7 @@ generate this object} \item \href{#method-SimParamBee-updatePedigree}{\code{SimParamBee$updatePedigree()}} \item \href{#method-SimParamBee-updateRecHist}{\code{SimParamBee$updateRecHist()}} \item \href{#method-SimParamBee-updateCaste}{\code{SimParamBee$updateCaste()}} -\item \href{#method-SimParamBee-updateLastId}{\code{SimParamBee$updateLastId()}} +\item \href{#method-SimParamBee-updateLastBeeId}{\code{SimParamBee$updateLastBeeId()}} \item \href{#method-SimParamBee-updateLastColonyId}{\code{SimParamBee$updateLastColonyId()}} \item \href{#method-SimParamBee-clone}{\code{SimParamBee$clone()}} } @@ -360,6 +360,7 @@ generate this object}
  • AlphaSimR::SimParam$switchGenMap()
  • AlphaSimR::SimParam$switchMaleMap()
  • AlphaSimR::SimParam$switchTrait()
    • +
  • AlphaSimR::SimParam$updateLastId()
    • }} @@ -591,14 +592,14 @@ A function to update the caste } } \if{html}{\out{
    }} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-SimParamBee-updateLastId}{}}} -\subsection{Method \code{updateLastId()}}{ +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-SimParamBee-updateLastBeeId}{}}} +\subsection{Method \code{updateLastBeeId()}}{ A function to update the last ID everytime we create an individual - For internal use only. + For internal use in SIMplyBee only. \subsection{Usage}{ -\if{html}{\out{
    }}\preformatted{SimParamBee$updateLastId(n = 1)}\if{html}{\out{
    }} +\if{html}{\out{
    }}\preformatted{SimParamBee$updateLastBeeId(n = 1L)}\if{html}{\out{
    }} } \subsection{Arguments}{ diff --git a/man/addCastePop.Rd b/man/addCastePop.Rd index 86b86e8e..9c58ba26 100644 --- a/man/addCastePop.Rd +++ b/man/addCastePop.Rd @@ -14,27 +14,12 @@ addCastePop( new = FALSE, year = NULL, simParamBee = NULL, - nThreads = NULL, ... ) -addWorkers( - x, - nInd = NULL, - new = FALSE, - simParamBee = NULL, - nThreads = NULL, - ... -) +addWorkers(x, nInd = NULL, new = FALSE, simParamBee = NULL, ...) -addDrones( - x, - nInd = NULL, - new = FALSE, - simParamBee = NULL, - nThreads = NULL, - ... -) +addDrones(x, nInd = NULL, new = FALSE, simParamBee = NULL, ...) addVirginQueens( x, @@ -42,7 +27,6 @@ addVirginQueens( new = FALSE, year = NULL, simParamBee = NULL, - nThreads = NULL, ... ) } @@ -64,8 +48,6 @@ anew or should we only top-up the existing number of individuals to \code{nInd}} \item{simParamBee}{\code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters} -\item{nThreads}{integer, number of cores to use for parallel computing (over colonies)} - \item{...}{additional arguments passed to \code{nInd} when this argument is a function} } \value{ diff --git a/man/buildUp.Rd b/man/buildUp.Rd index c227bece..21df8acc 100644 --- a/man/buildUp.Rd +++ b/man/buildUp.Rd @@ -11,7 +11,6 @@ buildUp( new = TRUE, resetEvents = FALSE, simParamBee = NULL, - nThreads = NULL, ... ) } @@ -39,8 +38,6 @@ build up} \item{simParamBee}{\code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters} -\item{nThreads}{integer, number of cores to use for parallel computing (over colonies)} - \item{...}{additional arguments passed to \code{nWorkers} or \code{nDrones} when these arguments are a function} } diff --git a/man/collapse.Rd b/man/collapse.Rd index 6ddef455..34326080 100644 --- a/man/collapse.Rd +++ b/man/collapse.Rd @@ -4,14 +4,12 @@ \alias{collapse} \title{Collapse} \usage{ -collapse(x, simParamBee = NULL, nThreads = NULL) +collapse(x, simParamBee = NULL) } \arguments{ \item{x}{\code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}}} \item{simParamBee}{\code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters} - -\item{nThreads}{integer, number of cores to use for parallel computing (over colonies)} } \value{ \code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}} with the collapse diff --git a/man/combine.Rd b/man/combine.Rd index 23cf2d86..9e98b85b 100644 --- a/man/combine.Rd +++ b/man/combine.Rd @@ -4,7 +4,7 @@ \alias{combine} \title{Combine two colony objects} \usage{ -combine(strong, weak, simParamBee = NULL, nThreads = NULL) +combine(strong, weak, simParamBee = NULL) } \arguments{ \item{strong}{\code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}}} @@ -12,8 +12,6 @@ combine(strong, weak, simParamBee = NULL, nThreads = NULL) \item{weak}{\code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}}} \item{simParamBee}{\code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters} - -\item{nThreads}{integer, number of cores to use for parallel computing (over colonies)} } \value{ a combined \code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}} diff --git a/man/createCastePop.Rd b/man/createCastePop.Rd index 88c138cc..226af5ee 100644 --- a/man/createCastePop.Rd +++ b/man/createCastePop.Rd @@ -17,7 +17,6 @@ createCastePop( simParamBee = NULL, returnSP = FALSE, ids = NULL, - nThreads = NULL, ... ) @@ -28,7 +27,6 @@ createWorkers( simParamBee = NULL, returnSP = FALSE, ids = NULL, - nThreads = NULL, ... ) @@ -38,7 +36,6 @@ createDrones( simParamBee = NULL, returnSP = FALSE, ids = NULL, - nThreads = NULL, ... ) @@ -51,7 +48,6 @@ createVirginQueens( simParamBee = NULL, returnSP = FALSE, ids = NULL, - nThreads = NULL, ... ) } @@ -90,9 +86,8 @@ ensure heterozygosity at the csd locus.} \item{returnSP}{logical, whether to return the pedigree, caste, and recHist information for each created population (used internally for parallel computing)} -\item{ids}{character, IDs of the individuals that are going to be created} - -\item{nThreads}{integer, number of cores to use for parallel computing (over colonies)} +\item{ids}{character, IDs of the individuals that are going to be created (used internally +for parallel computing)} \item{...}{additional arguments passed to \code{nInd} when this argument is a function} diff --git a/man/createMatingStationDCA.Rd b/man/createMatingStationDCA.Rd index 8ccf320d..58c138a7 100644 --- a/man/createMatingStationDCA.Rd +++ b/man/createMatingStationDCA.Rd @@ -35,7 +35,7 @@ founderGenomes <- quickHaplo(nInd = 10, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes) \dontshow{SP$nThreads = 1L} basePop <- createVirginQueens(founderGenomes) -drones <- createDrones(basePop[1], n = 1000) +drones <- createDrones(basePop[1], nInd = 1000) droneGroups <- pullDroneGroupsFromDCA(drones, n = 10, nDrones = 10) # Create a colony and cross it diff --git a/man/createMultiColony.Rd b/man/createMultiColony.Rd index 21bc2775..b1c48ec3 100644 --- a/man/createMultiColony.Rd +++ b/man/createMultiColony.Rd @@ -51,7 +51,7 @@ apiary[[2]] # Create mated colonies by crossing apiary <- createMultiColony(x = basePop[1:2], n = 2) -drones <- createDrones(x = basePop[3], n = 30) +drones <- createDrones(x = basePop[3], nInd = 30) droneGroups <- pullDroneGroupsFromDCA(drones, n = 2, nDrones = 15) apiary <- cross(apiary, drones = droneGroups) apiary diff --git a/man/cross.Rd b/man/cross.Rd index 72e72a97..8d34e3a6 100644 --- a/man/cross.Rd +++ b/man/cross.Rd @@ -15,7 +15,6 @@ cross( radius = NULL, checkCross = "error", simParamBee = NULL, - nThreads = NULL, ... ) } @@ -55,12 +54,11 @@ to their distance from the virgin colony (that is, in a radius)} \item{radius}{numeric, the radius around the virgin colony in which to sample mating partners, only needed when \code{spatial = TRUE}} -\item{checkCross}{character, throw a warning (when \code{checkCross = "warning"}),} +\item{checkCross}{character, throw a warning (when \code{checkCross = "warning"}). +This will also remove the unmated queens and return only the mated ones.} \item{simParamBee}{\code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters} -\item{nThreads}{integer, number of cores to use for parallel computing (over colonies)} - \item{...}{other arguments for \code{nDrones}, when \code{nDrones} is a function} } \value{ @@ -98,7 +96,7 @@ This function changes caste for the mated drones to fathers, and \examples{ founderGenomes <- quickHaplo(nInd = 30, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes) -\dontshow{SP$nThreads = 1L} +SP$nThreads = 1L basePop <- createVirginQueens(founderGenomes) drones <- createDrones(x = basePop[1], nInd = 1000) diff --git a/man/downsize.Rd b/man/downsize.Rd index 64dba314..e418ad0b 100644 --- a/man/downsize.Rd +++ b/man/downsize.Rd @@ -5,15 +5,7 @@ \title{Reduce number of workers and remove all drones and virgin queens from a Colony or MultiColony object} \usage{ -downsize( - x, - p = NULL, - use = "rand", - new = FALSE, - simParamBee = NULL, - nThreads = NULL, - ... -) +downsize(x, p = NULL, use = "rand", new = FALSE, simParamBee = NULL, ...) } \arguments{ \item{x}{\code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}}} @@ -32,8 +24,6 @@ proportion anew (say, create winter workers)} \item{simParamBee}{\code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters} -\item{nThreads}{integer, number of cores to use for parallel computing (over colonies)} - \item{...}{additional arguments passed to \code{p} when this argument is a function} } diff --git a/man/pullCastePop.Rd b/man/pullCastePop.Rd index 756b3a5e..dcf63748 100644 --- a/man/pullCastePop.Rd +++ b/man/pullCastePop.Rd @@ -15,8 +15,7 @@ pullCastePop( use = "rand", removeFathers = TRUE, collapse = FALSE, - simParamBee = NULL, - nThreads = NULL + simParamBee = NULL ) pullQueen(x, collapse = FALSE, simParamBee = NULL) @@ -60,8 +59,6 @@ virgin queens, say via insemination} for the pulled individuals (does not affect the remnant colonies)} \item{simParamBee}{\code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters} - -\item{nThreads}{integer, number of cores to use for parallel computing (over colonies)} } \value{ list of \code{\link[AlphaSimR]{Pop-class}} and \code{\link[SIMplyBee]{Colony-class}} diff --git a/man/reQueen.Rd b/man/reQueen.Rd index ea5b2b99..e90abb52 100644 --- a/man/reQueen.Rd +++ b/man/reQueen.Rd @@ -4,13 +4,7 @@ \alias{reQueen} \title{Re-queen} \usage{ -reQueen( - x, - queen, - removeVirginQueens = TRUE, - simParamBee = NULL, - nThreads = NULL -) +reQueen(x, queen, removeVirginQueens = TRUE, simParamBee = NULL) } \arguments{ \item{x}{\code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}}} @@ -25,8 +19,6 @@ queen that will have to be mated later; test will be run if the individual to ensure the provided queen prevails (see details)} \item{simParamBee}{\code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters} - -\item{nThreads}{integer, number of cores to use for parallel computing (over colonies)} } \value{ \code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}} with new queen(s) (see details) diff --git a/man/removeCastePop.Rd b/man/removeCastePop.Rd index f6a3089d..e47267ed 100644 --- a/man/removeCastePop.Rd +++ b/man/removeCastePop.Rd @@ -14,17 +14,16 @@ removeCastePop( p = 1, use = "rand", year = NULL, - simParamBee = NULL, - nThreads = NULL + simParamBee = NULL ) -removeQueen(x, year = NULL, simParamBee = NULL, nThreads = NULL) +removeQueen(x, year = NULL, simParamBee = NULL) -removeWorkers(x, p = 1, use = "rand", simParamBee = NULL, nThreads = NULL) +removeWorkers(x, p = 1, use = "rand", simParamBee = NULL) -removeDrones(x, p = 1, use = "rand", simParamBee = NULL, nThreads = NULL) +removeDrones(x, p = 1, use = "rand", simParamBee = NULL) -removeVirginQueens(x, p = 1, use = "rand", simParamBee = NULL, nThreads = NULL) +removeVirginQueens(x, p = 1, use = "rand", simParamBee = NULL) } \arguments{ \item{x}{\code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}}} @@ -41,8 +40,6 @@ guides selection of virgins queens that will stay when \code{p < 1}} \item{year}{numeric, only relevant when adding virgin queens - year of birth for virgin queens} \item{simParamBee}{\code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters} - -\item{nThreads}{integer, number of cores to use for parallel computing (over colonies)} } \value{ \code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}} without virgin queens diff --git a/man/replaceCastePop.Rd b/man/replaceCastePop.Rd index be159fb8..c23232cc 100644 --- a/man/replaceCastePop.Rd +++ b/man/replaceCastePop.Rd @@ -13,21 +13,14 @@ replaceCastePop( p = 1, use = "rand", year = NULL, - simParamBee = NULL, - nThreads = NULL + simParamBee = NULL ) -replaceWorkers(x, p = 1, use = "rand", simParamBee = NULL, nThreads = NULL) +replaceWorkers(x, p = 1, use = "rand", simParamBee = NULL) -replaceDrones(x, p = 1, use = "rand", simParamBee = NULL, nThreads = NULL) +replaceDrones(x, p = 1, use = "rand", simParamBee = NULL) -replaceVirginQueens( - x, - p = 1, - use = "rand", - simParamBee = NULL, - nThreads = NULL -) +replaceVirginQueens(x, p = 1, use = "rand", simParamBee = NULL) } \arguments{ \item{x}{\code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}}} @@ -46,8 +39,6 @@ guides selection of caste individuals that stay when \code{p < 1}} year of birth for virgin queens} \item{simParamBee}{\code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters} - -\item{nThreads}{integer, number of cores to use for parallel computing (over colonies)} } \value{ \code{\link[SIMplyBee]{Colony-class}} or or \code{\link[SIMplyBee]{MultiColony-class}} with diff --git a/man/resetEvents.Rd b/man/resetEvents.Rd index 1abb4999..cada3fd6 100644 --- a/man/resetEvents.Rd +++ b/man/resetEvents.Rd @@ -4,7 +4,7 @@ \alias{resetEvents} \title{Reset colony events} \usage{ -resetEvents(x, collapse = NULL, simParamBee = NULL, nThreads = NULL) +resetEvents(x, collapse = NULL, simParamBee = NULL) } \arguments{ \item{x}{\code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}}} @@ -15,8 +15,6 @@ collapsed colony should be left collapsed forever, unless you force resetting this event with \code{collapse = TRUE})} \item{simParamBee}{\code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters} - -\item{nThreads}{integer, number of cores to use for parallel computing (over colonies)} } \value{ \code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}} with diff --git a/man/setEvents.Rd b/man/setEvents.Rd index 6c8d926d..5035cd70 100644 --- a/man/setEvents.Rd +++ b/man/setEvents.Rd @@ -4,7 +4,7 @@ \alias{setEvents} \title{Set colony events} \usage{ -setEvents(x, slot, value, nThreads = NULL, simParamBee = NULL) +setEvents(x, slot, value, simParamBee = NULL) } \arguments{ \item{x}{\code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}}} @@ -13,8 +13,6 @@ setEvents(x, slot, value, nThreads = NULL, simParamBee = NULL) \item{value}{logical, the value for the event} -\item{nThreads}{integer, number of cores to use for parallel computing (over colonies)} - \item{simParamBee}{\code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters} } \value{ diff --git a/man/setLocation.Rd b/man/setLocation.Rd index 42b4ec20..e9596075 100644 --- a/man/setLocation.Rd +++ b/man/setLocation.Rd @@ -4,7 +4,7 @@ \alias{setLocation} \title{Set colony location} \usage{ -setLocation(x, location = c(0, 0), simParamBee = NULL, nThreads = NULL) +setLocation(x, location = c(0, 0), simParamBee = NULL) } \arguments{ \item{x}{\code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}}} @@ -16,8 +16,6 @@ locations as \code{data.frame(x = c(x1, x2), y = c(y1, y2))}} \item{simParamBee}{\code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters} - -\item{nThreads}{integer, number of cores to use for parallel computing (over colonies)} } \value{ \code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}} with set diff --git a/man/split.Rd b/man/split.Rd index 9ebf8926..7def12fb 100644 --- a/man/split.Rd +++ b/man/split.Rd @@ -4,7 +4,7 @@ \alias{split} \title{Split colony in two MultiColony} \usage{ -split(x, p = NULL, year = NULL, simParamBee = NULL, nThreads = NULL, ...) +split(x, p = NULL, year = NULL, simParamBee = NULL, ...) } \arguments{ \item{x}{\code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}}} @@ -19,8 +19,6 @@ a single value is provided, the same value will be applied to all the colonies} \item{simParamBee}{\code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters} -\item{nThreads}{integer, number of cores to use for parallel computing (over colonies)} - \item{...}{additional arguments passed to \code{p} when this argument is a function} } diff --git a/man/supersede.Rd b/man/supersede.Rd index d8108669..019a21cd 100644 --- a/man/supersede.Rd +++ b/man/supersede.Rd @@ -4,7 +4,7 @@ \alias{supersede} \title{Supersede} \usage{ -supersede(x, year = NULL, simParamBee = NULL, nThreads = NULL, ...) +supersede(x, year = NULL, simParamBee = NULL, ...) } \arguments{ \item{x}{\code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}}} @@ -13,8 +13,6 @@ supersede(x, year = NULL, simParamBee = NULL, nThreads = NULL, ...) \item{simParamBee}{\code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters} -\item{nThreads}{integer, number of cores to use for parallel computing (over colonies)} - \item{...}{additional arguments passed to \code{nVirginQueens} when this argument is a function} } diff --git a/man/swarm.Rd b/man/swarm.Rd index aefbabba..34d2c198 100644 --- a/man/swarm.Rd +++ b/man/swarm.Rd @@ -11,7 +11,6 @@ swarm( sampleLocation = TRUE, radius = NULL, simParamBee = NULL, - nThreads = NULL, ... ) } @@ -36,8 +35,6 @@ the current colony location and adding deviates to each coordinate using \item{simParamBee}{\code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters} -\item{nThreads}{integer, number of cores to use for parallel computing (over colonies)} - \item{...}{additional arguments passed to \code{p} or \code{nVirginQueens} when these arguments are functions} } From 481377ae47f0385016e17f2fcb914ea67a8062f4 Mon Sep 17 00:00:00 2001 From: janaobsteter Date: Tue, 3 Jun 2025 12:04:25 +0200 Subject: [PATCH 27/42] Fixing error to make examples and tests run --- DESCRIPTION | 2 +- NAMESPACE | 2 - R/Class-SimParamBee.R | 83 +++++- R/Functions_L0_auxilary.R | 24 +- R/Functions_L1_Pop.R | 117 +++++---- R/Functions_L2_Colony.R | 253 +++++++++++-------- R/SIMplyBee.R | 1 - man/SimParamBee.Rd | 50 ++-- man/createCastePop.Rd | 6 - man/getIbdHaplo.Rd | 21 +- man/hasSwarmed.Rd | 2 +- man/pullCastePop.Rd | 4 +- man/swarm.Rd | 2 + tests/testthat/test-L0_auxiliary_functions.R | 2 +- tests/testthat/test-L1_pop_functions.R | 3 +- tests/testthat/test-L2_colony_functions.R | 31 +-- 16 files changed, 365 insertions(+), 238 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 64092120..4ef4a624 100644 --- a/DESCRIPTION +++ b/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), foreach, doParallel, dplyr +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 diff --git a/NAMESPACE b/NAMESPACE index 78129144..c2382781 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -208,8 +208,6 @@ import(AlphaSimR) import(Rcpp) importFrom(R6,R6Class) importFrom(doParallel,registerDoParallel) -importFrom(dplyr,"%>%") -importFrom(dplyr,arrange) importFrom(extraDistr,rtpois) importFrom(foreach,"%dopar%") importFrom(foreach,foreach) diff --git a/R/Class-SimParamBee.R b/R/Class-SimParamBee.R index 0cdd27c0..2b66a241 100644 --- a/R/Class-SimParamBee.R +++ b/R/Class-SimParamBee.R @@ -425,21 +425,80 @@ SimParamBee <- R6Class( invisible(self) }, - #' @description A function to update the pedigree. - #' For internal use only. + #' @description For internal use only. #' - #' @param pedigree matrix, pedigree matrix to be added - updatePedigree = function(pedigree) { - private$.pedigree = rbind(private$.pedigree, pedigree) + #' @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 A function to update the recHist - #' For internal use only. + + #' @description For internal use only. #' - #' @param recHist matrix, recHist list to be added - updateRecHist = function(recHist) { - private$.recHist = c(private$.recHist, recHist) + #' @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) }, @@ -499,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) } @@ -509,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) } diff --git a/R/Functions_L0_auxilary.R b/R/Functions_L0_auxilary.R index 3b22a242..43efba27 100644 --- a/R/Functions_L0_auxilary.R +++ b/R/Functions_L0_auxilary.R @@ -1800,7 +1800,7 @@ getEvents <- function(x) { #' colony <- buildUp(x = colony, nWorkers = 6, nDrones = 3) #' colony <- addVirginQueens(colony, nInd = 5) #' -#' apiary <- createMultiColony(basePop[3:4], n = 2) +#' apiary <- createMultiColony(basePop[3:4]) #' apiary <- cross(apiary, drones = droneGroups[c(2, 3)]) #' apiary <- buildUp(x = apiary, nWorkers = 6, nDrones = 3) #' @@ -2912,10 +2912,10 @@ nCsdAlleles <- function(x, collapse = FALSE, simParamBee = NULL) { #' \code{\link[SIMplyBee]{MultiColony-class}} #' #' @examples -#' founderGenomes <- quickHaplo(nInd = 4, nChr = 1, segSites = 50) -#' SP <- SimParamBee$new(founderGenomes) +#' founderGenomes <- quickHaplo(nInd = 4, nChr = 1, segSites = 5) +#' SP <- SimParamBee$new(founderGenomes, nCsdAlleles = 4) #' \dontshow{SP$nThreads = 1L} -#' SP$setTrackRec(TRUE) +#' SP$setTrackRec(isTrackRec = TRUE) #' SP$setTrackPed(isTrackPed = TRUE) #' basePop <- createVirginQueens(founderGenomes) #' @@ -2925,13 +2925,13 @@ nCsdAlleles <- function(x, collapse = FALSE, simParamBee = NULL) { #' # Create a Colony and a MultiColony class #' colony <- createColony(x = basePop[2]) #' colony <- cross(colony, drones = droneGroups[[1]]) -#' colony <- buildUp(x = colony, nWorkers = 6, nDrones = 3) -#' colony <- addVirginQueens(x = colony, nInd = 5) +#' colony <- buildUp(x = colony, nWorkers = 3, nDrones = 2) +#' colony <- addVirginQueens(x = colony, nInd = 2) #' -#' apiary <- createMultiColony(basePop[3:4], n = 2) +#' apiary <- createMultiColony(basePop[3:4]) #' apiary <- cross(apiary, drones = droneGroups[c(2, 3)]) -#' apiary <- buildUp(x = apiary, nWorkers = 6, nDrones = 3) -#' apiary <- addVirginQueens(x = apiary, nInd = 5) +#' apiary <- buildUp(x = apiary, nWorkers = 3, nDrones = 2) +#' apiary <- addVirginQueens(x = apiary, nInd = 2) #' #' # Input is a population #' getIbdHaplo(x = getQueen(colony)) @@ -2943,6 +2943,8 @@ nCsdAlleles <- function(x, collapse = FALSE, simParamBee = NULL) { #' getQueenIbdHaplo(colony) #' #' getIbdHaplo(colony, caste = "workers", nInd = 3) +#' getIbdHaplo(colony, caste = "virginQueens") +#' getIbdHaplo(colony, caste = "drones") #' getWorkersIbdHaplo(colony) #' # Same aliases exist for all castes! #' @@ -2957,6 +2959,9 @@ nCsdAlleles <- function(x, collapse = FALSE, simParamBee = NULL) { #' # Or collapse all the haplotypes into a single matrix #' getQueenIbdHaplo(apiary, collapse = TRUE) #' +#' +#' getIbdHaplo(x = apiary, caste = "workers") +#' getIbdHaplo(x = apiary, caste = "drones") #' # Get the haplotypes of all individuals either by colony or in a single matrix #' getIbdHaplo(apiary, caste = "all") #' getIbdHaplo(apiary, caste = "all", collapse = TRUE) @@ -2988,6 +2993,7 @@ getIbdHaplo <- function(x, caste = NULL, nInd = NULL, chr = NULL, snpChip = NULL ret <- vector(mode = "list", length = 5) names(ret) <- c("queen", "fathers", "workers", "drones", "virginQueens") for (caste in names(ret)) { + print(caste) tmp <- getIbdHaplo(x = x, caste = caste, nInd = nInd, chr = chr, snpChip = snpChip, dronesHaploid = dronesHaploid, collapse = collapse, simParamBee = simParamBee) diff --git a/R/Functions_L1_Pop.R b/R/Functions_L1_Pop.R index 025a0951..90119261 100644 --- a/R/Functions_L1_Pop.R +++ b/R/Functions_L1_Pop.R @@ -1,4 +1,6 @@ # ---- Level 1 Pop Functions ---- +utils::globalVariables("colony") +utils::globalVariables("i") #' @rdname getCastePop #' @title Access individuals of a caste @@ -295,10 +297,6 @@ getVirginQueens <- function(x, nInd = NULL, use = "rand", collapse = FALSE, simP #' only used when \code{x} is \code{\link[SIMplyBee]{Colony-class}} or #' \code{\link[SIMplyBee]{MultiColony-class}}, when \code{x} is \code{link[AlphaSimR]{MapPop-class}} #' all individuals in \code{x} are converted into virgin queens -#' @param exact logical, only relevant when creating workers, -#' if the csd locus is active and exact is \code{TRUE}, -#' create the exactly specified number of viable workers (heterozygous on the -#' csd locus) #' @param year numeric, year of birth for virgin queens #' @param editCsd logical (only active when \code{x} is \code{link[AlphaSimR]{MapPop-class}}), #' whether the csd locus should be edited to ensure heterozygosity at the csd @@ -424,6 +422,9 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, if (is.function(nInd)) { nInd <- nInd(x, ...) } + if (any(nInd == 0)) { + stop("nInd set to 0, should be > 0!") + } # doing "if (is.function(nInd))" below if (isMapPop(x)) { if (caste != "virginQueens") { # Creating virgin queens if input is a MapPop @@ -437,6 +438,7 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, } ret@sex[] <- "F" simParamBee$changeCaste(id = ret@id, caste = "virginQueens") + if (!is.null(year)) { ret <- setQueensYearOfBirth(x = ret, year = year, simParamBee = simParamBee) } @@ -492,7 +494,8 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, ret$workers <- combineBeeGametes( queen = getQueen(x, simParamBee = simParamBee), drones = getFathers(x, simParamBee = simParamBee), - nProgeny = nInd, simParam = simParamBee + nProgeny = nInd, + simParamBee = simParamBee ) simParamBee$addToCaste(id = ret$workers@id, caste = "workers") @@ -515,10 +518,10 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, if (nInd(ret$workers) > length(ids)) { stop("Too many IDs provided!") } - ret$workers@id <- ids + ret$workers@id <- as.character(ids) ret$workers@iid <- as.integer(ids) if (returnSP) { - names(ret$caste) <- ids + names(ret$caste) <- as.character(ids) if (simParamBee$isTrackPed) { rownames(ret$pedigree) <- ids } @@ -534,8 +537,10 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, } else if (caste == "virginQueens") { ret <- createCastePop(x = x, caste = "workers", - nInd = nInd, exact = TRUE, simParamBee = simParamBee, + nInd = nInd, simParamBee = simParamBee, returnSP = returnSP, ids = ids, ...) + ret$caste = rep("virginQueens", length(ret$caste)) + names(ret$caste) = ids simParamBee$changeCaste(id = ret$workers@id, caste = "virginQueens") if (!returnSP) { ret <- ret$workers @@ -544,14 +549,10 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, ret <- setQueensYearOfBirth(x = ret, year = year, simParamBee = simParamBee) } } else if (caste == "drones") { - print("Before makeDH") - print(simParamBee$lastId) drones <- makeDH( pop = getQueen(x, simParamBee = simParamBee), nDH = nInd, keepParents = FALSE, simParam = simParamBee ) - print("After makeDH") - print(simParamBee$lastId) drones@sex[] <- "M" simParamBee$addToCaste(id = drones@id, caste = "drones") @@ -596,8 +597,6 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, } simParamBee$nThreads <- originalThreads } else if (isMultiColony(x)) { - print("SP threads") - print(simParamBee$nThreads) if (is.null(nInd)) { string = paste0("n", toupper(substr(caste, 1, 1)), substr(caste, 2, nchar(caste))) nInd <- simParamBee[[string]] @@ -660,33 +659,41 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, NULL } } - simParamBee$updateLastBeeId(n = totalNInd) + if (nCol == 1) { + ret <- list(ret) + } names(ret) <- getId(x) - - # Add to simParamBee: pedigree, caste, recHist notNull = sapply(ret, FUN = function(x) !is.null(x)) + if (!simParamBee$isTrackPed) { + simParamBee$updateLastBeeId(n = totalNInd) + } else if (simParamBee$isTrackPed) { + Pedigree <- do.call("rbind", lapply(ret[notNull], '[[', "pedigree")) + if (!simParamBee$isTrackRec) { + simParamBee$addToBeePed(nNewInd = totalNInd, id = rownames(Pedigree), + mother = Pedigree[, 'mother'], father = Pedigree[, 'father'], + isDH = Pedigree[, 'isDH']) + #simParamBee$updatePedigree(pedigree = Pedigree) + } else { + RecHist = do.call("c", lapply(ret[notNull], '[[', "recHist")) + if (caste == "drones") { + ploidy = rep(1, totalNInd) + } else { + ploidy = rep(2, totalNInd) + } + simParamBee$addToBeeRec(nNewInd = totalNInd, id = rownames(Pedigree), + mother = Pedigree[, 'mother'], father = Pedigree[, 'father'], + isDH = Pedigree[, 'isDH'], + hist = RecHist, ploidy = ploidy) + } + } # Extend caste Caste <- do.call("c", lapply(ret[notNull], '[[', "caste")) - if (caste == "virginQueens") { - Caste <- rep("virginQueens", length(Caste)) - } Names <- do.call("c", lapply(ret[notNull], function(x) names(x$caste))) names(Caste) <- Names simParamBee$updateCaste(caste = Caste) - # Extend pedigree - if (simParamBee$isTrackPed) { - Pedigree <- do.call("rbind", lapply(ret[notNull], '[[', "pedigree")) - simParamBee$updatePedigree(pedigree = Pedigree) - } - - # Extend recHist - if (simParamBee$isTrackRec) { - RecHist = do.call("c", lapply(ret[notNull], '[[', "recHist")) - simParamBee$updateRecHist(recHist = RecHist) - } if (!returnSP) { if (caste %in% c("drones", "virginQueens")) { @@ -712,11 +719,11 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, #' @describeIn createCastePop Create workers from a colony #' @export -createWorkers <- function(x, nInd = NULL, exact = FALSE, simParamBee = NULL, +createWorkers <- function(x, nInd = NULL, simParamBee = NULL, returnSP = FALSE, ids = NULL, ...) { ret <- createCastePop(x, caste = "workers", nInd = nInd, - exact = exact, simParamBee = simParamBee, + simParamBee = simParamBee, returnSP = returnSP, ids = ids, ...) return(ret) @@ -1182,12 +1189,12 @@ pullDroneGroupsFromDCA <- function(DCA, n, nDrones = NULL, #' # Create a Colony and a MultiColony class #' colony <- createColony(x = basePop[2]) #' colony <- cross(colony, drones = droneGroups[[1]]) -#' colony <- buildUp(x = colony, nWorkers = 100, nDrones = 10, exact = TRUE) +#' colony <- buildUp(x = colony, nWorkers = 100, nDrones = 10) #' colony <- addVirginQueens(x = colony, nInd = 3) #' #' apiary <- createMultiColony(basePop[3:4], n = 2) #' apiary <- cross(apiary, drones = droneGroups[c(2, 3)]) -#' apiary <- buildUp(x = apiary, nWorkers = 100, nDrones = 10, exact = TRUE) +#' apiary <- buildUp(x = apiary, nWorkers = 100, nDrones = 10) #' apiary <- addVirginQueens(x = apiary, nInd = 3) #' #' # pullCastePop on Colony class @@ -1562,6 +1569,9 @@ cross <- function(x, stop("The argument drones must be a Pop-class or a list of drone Pop-class objects!") } + if (isPop(drones) && nInd(drones) == 0) { + stop("Argument drones is a Pop-class with 0 individuals!") + } if (crossPlan_given && !is.null(drones) && !all(unlist(crossPlan) %in% drones@id)) { stop("Some drones from the crossPlan are missing in the drones population!") } @@ -1676,42 +1686,40 @@ cross <- function(x, crossPlanDF_sample <- do.call("rbind", lapply(IDs, FUN = function(x) { data.frame(virginID = x, DPC = sample(crossPlan[[x]], size = nD[which(x == IDs)], replace = TRUE)) - } )) %>% - arrange(as.integer(DPC)) + } )) + crossPlanDF_sample <- crossPlanDF_sample[order(as.integer(crossPlanDF_sample$DPC)),] # Here I gather how many drones each DPC needs to produce - crossPlanDF_DPCtable <- as.data.frame(table(crossPlanDF_sample$DPC)) %>% - arrange(as.integer(as.character(Var1))) + crossPlanDF_DPCtable <- as.data.frame(table(crossPlanDF_sample$DPC)) + crossPlanDF_DPCtable <- crossPlanDF_DPCtable[order(as.integer(as.character(crossPlanDF_DPCtable$Var1))),] colnames(crossPlanDF_DPCtable) <- c("DPC", "noDrones") # Here I select only the DPCs that have been sampled to produce drones selectedDPC = selectColonies(droneColonies, ID = as.character(crossPlanDF_DPCtable$DPC)) # And here I create the drones - print(simParamBee$lastId) - print(sum(as.integer(crossPlanDF_DPCtable$noDrones))) dronesByDPC <- createCastePop(selectedDPC, caste = "drones", nInd = as.integer(crossPlanDF_DPCtable$noDrones), simParamBee = simParamBee) # This is where I link the drone ID to the DPC ID dronesByDPC_DF <- data.frame(DPC = rep(names(dronesByDPC), as.vector(crossPlanDF_DPCtable$noDrones)), - droneID = unlist(sapply(dronesByDPC, FUN = function(x) getId(x)))) %>% - arrange(as.integer(DPC)) + droneID = unlist(sapply(dronesByDPC, FUN = function(x) getId(x)))) + dronesByDPC_DF <- dronesByDPC_DF[order(as.integer(dronesByDPC_DF$DPC)),] dronePop = mergePops(dronesByDPC) if (any(!crossPlanDF_sample$DPC == dronesByDPC_DF$DPC)) { stop("Something went wrong with cross plan - drone matching!") } - dronesByVirgin_DF <- cbind(dronesByDPC_DF, crossPlanDF_sample[, c("virginID"), drop = FALSE]) %>% - arrange(as.integer(virginID)) + dronesByVirgin_DF <- cbind(dronesByDPC_DF, crossPlanDF_sample[, c("virginID"), drop = FALSE]) + dronesByVirgin_DF <- dronesByVirgin_DF[order(as.integer(dronesByVirgin_DF$virginID)),] dronesByVirgin_list <- lapply(IDs, FUN = function(x) dronesByVirgin_DF$droneID[dronesByVirgin_DF$virginID == x]) names(dronesByVirgin_list) <- IDs - dronesByVirgin <- foreach(virgin = IDs, .combine = combine_list) %dopar% { - dronePop[as.character(dronesByVirgin_list[[virgin]])] + dronesByVirgin <- foreach(i = IDs, .combine = combine_list) %dopar% { + dronePop[as.character(dronesByVirgin_list[[i]])] } } else if (crossPlan_droneID) { - dronesByVirgin <- foreach(virgin = IDs, .combine = combine_list) %dopar% { - drones[as.character(crossPlan[[virgin]])] + dronesByVirgin <- foreach(i = IDs, .combine = combine_list) %dopar% { + drones[as.character(crossPlan[[i]])] } } } @@ -1764,8 +1772,10 @@ cross <- function(x, } # Add drones in the queens father slot - x <- foreach(ID = 1:length(IDs), .combine = combine_list) %dopar% { - crossVirginQueen(virginQueen = x[ID], virginQueenDrones = dronesByVirgin[[ID]], simParamBee = SP) + x <- foreach(i = 1:length(IDs), .combine = combine_list) %dopar% { + crossVirginQueen(virginQueen = x[i], + virginQueenDrones = dronesByVirgin[[i]], + simParamBee = simParamBee) } @@ -1779,7 +1789,10 @@ cross <- function(x, ret <- reQueen(x = colony, queen = x[1], simParamBee = simParamBee) ret <- removeVirginQueens(ret, simParamBee = simParamBee) } else if (type == "MultiColony") { - ret <- reQueen(x = multicolony, queen = mergePops(x), simParamBee = simParamBee) + if (length(IDs) > 1) { + x <- mergePops(x) + } + ret <- reQueen(x = multicolony, queen = x, simParamBee = simParamBee) ret <- removeCastePop(ret, caste = "virginQueens", simParamBee = simParamBee) } diff --git a/R/Functions_L2_Colony.R b/R/Functions_L2_Colony.R index ef860c99..f2a6b593 100644 --- a/R/Functions_L2_Colony.R +++ b/R/Functions_L2_Colony.R @@ -76,9 +76,6 @@ createColony <- function(x = NULL, simParamBee = NULL, id = NULL) { return(colony) } - - - #' @rdname reQueen #' @title Re-queen #' @@ -115,7 +112,7 @@ createColony <- function(x = NULL, simParamBee = NULL, id = NULL) { #' # Create and cross Colony and MultiColony class #' colony <- createColony(x = basePop[2]) #' colony <- cross(colony, drones = droneGroups[[1]]) -#' apiary <- createMultiColony(basePop[3:4], n = 2) +#' apiary <- createMultiColony(basePop[3:4]) #' apiary <- cross(apiary, drones = droneGroups[2:3]) #' #' # Check queen and virgin queens IDs @@ -172,6 +169,9 @@ reQueen <- function(x, queen, removeVirginQueens = TRUE, simParamBee = NULL) { } else if (isMultiColony(x)) { registerDoParallel(cores = simParamBee$nThreads) nCol <- nColonies(x) + if (nCol == 0) { + stop("The Multicolony contains 0 colonies!") + } if (nInd(queen) < nCol) { stop("Not enough queens provided!") } @@ -291,7 +291,7 @@ addCastePop_internal <- function(pop, colony, caste, new = FALSE) { #' #' @export addCastePop <- function(x, caste = NULL, nInd = NULL, new = FALSE, - year = NULL, simParamBee = NULL, ...) { + year = NULL, simParamBee = NULL, ...) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } @@ -332,14 +332,16 @@ addCastePop <- function(x, caste = NULL, nInd = NULL, new = FALSE, } if (0 < nInd) { newInds <- createCastePop(x, nInd, - caste = caste, - year = year, simParamBee = simParamBee + caste = caste, + year = year, simParamBee = simParamBee ) if (caste == "workers") { homInds <- newInds$nHomBrood newInds <- newInds$workers x@queen@misc$nWorkers[[1]] <- x@queen@misc$nWorkers[[1]] + nInd(newInds) - x@queen@misc$nHomBrood[[1]] <- x@queen@misc$nHomBrood[[1]] + homInds + if (isCsdActive(simParamBee = simParamBee)) { + x@queen@misc$nHomBrood[[1]] <- x@queen@misc$nHomBrood[[1]] + homInds + } } if (caste == "drones") { x@queen@misc$nDrones[[1]] <- x@queen@misc$nDrones[[1]] + nInd(newInds) @@ -354,15 +356,17 @@ addCastePop <- function(x, caste = NULL, nInd = NULL, new = FALSE, } } else if (isMultiColony(x)) { nCol <- nColonies(x) - + if (nCol == 0) { + stop("The Multicolony contains 0 colonies!") + } if (any(hasCollapsed(x))) { stop(paste0("The colony ", getId(x), " collapsed, hence you can not add individuals (from the queen) to it!")) } newInds <- createCastePop(x, nInd, - caste = caste, - year = year, simParamBee = simParamBee, - returnSP = FALSE, ...) + caste = caste, + year = year, simParamBee = simParamBee, + returnSP = FALSE, ...) if (caste == "workers") { @@ -403,7 +407,7 @@ addCastePop <- function(x, caste = NULL, nInd = NULL, new = FALSE, #' @describeIn addCastePop Add workers to a colony #' @export addWorkers <- function(x, nInd = NULL, new = FALSE, - simParamBee = NULL, ...) { + simParamBee = NULL, ...) { ret <- addCastePop( x = x, caste = "workers", nInd = nInd, new = new, simParamBee = simParamBee, ... @@ -414,7 +418,7 @@ addWorkers <- function(x, nInd = NULL, new = FALSE, #' @describeIn addCastePop Add drones to a colony #' @export addDrones <- function(x, nInd = NULL, new = FALSE, - simParamBee = NULL, ...) { + simParamBee = NULL, ...) { ret <- addCastePop( x = x, caste = "drones", nInd = nInd, new = new, simParamBee = simParamBee, ... @@ -425,7 +429,7 @@ addDrones <- function(x, nInd = NULL, new = FALSE, #' @describeIn addCastePop Add virgin queens to a colony #' @export addVirginQueens <- function(x, nInd = NULL, new = FALSE, - year = NULL, simParamBee = NULL, ...) { + year = NULL, simParamBee = NULL, ...) { ret <- addCastePop( x = x, caste = "virginQueens", nInd = nInd, new = new, year = year, simParamBee = simParamBee, ... @@ -528,8 +532,8 @@ addVirginQueens <- function(x, nInd = NULL, new = FALSE, #' getMisc(getQueen(buildUp(colony))) #' @export buildUp <- function(x, nWorkers = NULL, nDrones = NULL, - new = TRUE, resetEvents = FALSE, - simParamBee = NULL, ...) { + new = TRUE, resetEvents = FALSE, + simParamBee = NULL, ...) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } @@ -602,6 +606,9 @@ buildUp <- function(x, nWorkers = NULL, nDrones = NULL, stop(paste0("Some colonies are collapsed, hence you can not build it up!")) } nCol <- nColonies(x) + if (nCol == 0) { + stop("The Multicolony contains 0 colonies!") + } nNWorkers <- length(nWorkers) nNDrones <- length(nDrones) if (nNWorkers > 1 && nNWorkers < nCol) { @@ -706,7 +713,7 @@ buildUp <- function(x, nWorkers = NULL, nDrones = NULL, #' @export #' downsize <- function(x, p = NULL, use = "rand", new = FALSE, - simParamBee = NULL, ...) { + simParamBee = NULL, ...) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } @@ -745,6 +752,9 @@ downsize <- function(x, p = NULL, use = "rand", new = FALSE, registerDoParallel(cores = simParamBee$nThreads) nCol <- nColonies(x) nP <- length(p) + if (nCol == 0) { + stop("The Multicolony contains 0 colonies!") + } if (any(hasCollapsed(x))) { stop("Some of hte colonies have collapsed, hence you can not downsize them!") @@ -765,10 +775,10 @@ downsize <- function(x, p = NULL, use = "rand", new = FALSE, if (new == TRUE) { n <- round(nWorkers(x, simParamBee = simParamBee) * (1 - p)) x <- addWorkers(x = x, nInd = n, new = TRUE, - simParamBee = simParamBee) + simParamBee = simParamBee) } else { x <- removeWorkers(x = x, p = p, use = use, - simParamBee = simParamBee) + simParamBee = simParamBee) } x <- removeDrones(x = x, p = 1, simParamBee = simParamBee) x <- removeVirginQueens(x = x, p = 1, simParamBee = simParamBee) @@ -860,6 +870,9 @@ replaceCastePop <- function(x, caste = NULL, p = 1, use = "rand", } else if (isMultiColony(x)) { nCol <- nColonies(x) } + if (nCol == 0) { + stop("The Multicolony contains 0 colonies!") + } if (any(hasCollapsed(x))) { stop(paste0("The colony or some of the colonies have collapsed, hence you can not replace individuals in it!")) } @@ -879,20 +892,20 @@ replaceCastePop <- function(x, caste = NULL, p = 1, use = "rand", if (any(nIndReplaced < nInd)) { x <- removeCastePop(x, - caste = caste, - p = p) + caste = caste, + p = p) nIndAdd <- nInd - nCaste(x, caste, simParamBee = simParamBee) x <- addCastePop(x, - caste = caste, - nInd = nIndAdd, - year = year, simParamBee = simParamBee + caste = caste, + nInd = nIndAdd, + year = year, simParamBee = simParamBee + ) + } else { + x <- addCastePop( + x = x, caste = caste, nInd = nIndReplaced, new = TRUE, + year = year, simParamBee = simParamBee ) } - } else { - x <- addCastePop( - x = x, caste = caste, nInd = nIndReplaced, new = TRUE, - year = year, simParamBee = simParamBee - ) } } else { stop("Argument x must be a Colony or MultiColony class object!") @@ -985,7 +998,7 @@ replaceVirginQueens <- function(x, p = 1, use = "rand", simParamBee = NULL) { #' nWorkers(removeWorkers(apiary, p = c(0.1, 0.5))) #' @export removeCastePop <- function(x, caste = NULL, p = 1, use = "rand", - year = NULL, simParamBee = NULL) { + year = NULL, simParamBee = NULL) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } @@ -1024,6 +1037,9 @@ removeCastePop <- function(x, caste = NULL, p = 1, use = "rand", registerDoParallel(cores = simParamBee$nThreads) nCol <- nColonies(x) nP <- length(p) + if (nCol == 0) { + stop("The Multicolony contains 0 colonies!") + } if (nP > 1 && nP < nCol) { stop("Too few values in the p argument!") } @@ -1186,6 +1202,9 @@ resetEvents <- function(x, collapse = NULL, simParamBee = NULL) { } else if (isMultiColony(x)) { registerDoParallel(cores = simParamBee$nThreads) nCol <- nColonies(x) + if (nCol == 0) { + stop("The Multicolony contains 0 colonies!") + } x@colonies <- foreach(colony = seq_len(nCol)) %dopar% { resetEvents( x = x[[colony]], @@ -1257,6 +1276,9 @@ collapse <- function(x, simParamBee = NULL) { } else if (isMultiColony(x)) { registerDoParallel(cores = simParamBee$nThreads) nCol <- nColonies(x) + if (nCol == 0) { + stop("The Multicolony contains 0 colonies!") + } x@colonies <- foreach(colony = seq_len(nCol)) %dopar% { collapse(x = x[[colony]], simParamBee = simParamBee) @@ -1303,6 +1325,8 @@ collapse <- function(x, simParamBee = NULL) { #' @examples #' founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 50) #' SP <- SimParamBee$new(founderGenomes) +#' SP$setTrackPed(TRUE) +#' SP$setTrackRec(TRUE) #' \dontshow{SP$nThreads = 1L} #' basePop <- createVirginQueens(founderGenomes) #' drones <- createDrones(basePop[1], n = 1000) @@ -1312,7 +1336,7 @@ collapse <- function(x, simParamBee = NULL) { #' colony <- createColony(x = basePop[2]) #' colony <- cross(colony, drones = droneGroups[[1]]) #' (colony <- buildUp(colony, nWorkers = 100)) -#' apiary <- createMultiColony(basePop[3:8], n = 6) +#' apiary <- createMultiColony(basePop[3:8]) #' apiary <- cross(apiary, drones = droneGroups[2:7]) #' apiary <- buildUp(apiary, nWorkers = 100) #' @@ -1337,8 +1361,8 @@ collapse <- function(x, simParamBee = NULL) { #' (swarm(tmp$pulled, p = 0.6)) #' @export swarm <- function(x, p = NULL, year = NULL, - sampleLocation = TRUE, radius = NULL, - simParamBee = NULL, ...) { + sampleLocation = TRUE, radius = NULL, + simParamBee = NULL, ...) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } @@ -1361,6 +1385,9 @@ swarm <- function(x, p = NULL, year = NULL, nCol <- nColonies(x) } nP <- length(p) + if (nCol == 0) { + stop("The Multicolony contains 0 colonies!") + } if (any(hasCollapsed(x))) { stop(paste0("One of the collonies is collapsed, hence you can not split it!")) @@ -1374,7 +1401,7 @@ swarm <- function(x, p = NULL, year = NULL, if (is.function(p)) { p <- p(x, ...) } else { - if (p < 0 | 1 < p) { + if (any(p < 0) | any(1 < p)) { stop("p must be between 0 and 1 (inclusive)!") } if (length(p) > nCol) { @@ -1385,9 +1412,6 @@ swarm <- function(x, p = NULL, year = NULL, stop("Too few values in the p argument!") } } - if (is.function(nVirginQueens)) { - nVirginQueens <- nVirginQueens(x, ...) - } nWorkers <- nWorkers(x, simParamBee = simParamBee) nWorkersSwarm <- round(nWorkers * p) @@ -1402,17 +1426,17 @@ swarm <- function(x, p = NULL, year = NULL, ) tmp <- pullCastePop(x = x, caste = "workers", - nInd = nWorkersSwarm, simParamBee = simParamBee) + nInd = nWorkersSwarm, simParamBee = simParamBee) remnantColony <- tmp$remnant remnantColony <- removeQueen(remnantColony) if (isColony(x)) { remnantColony <- reQueen(remnantColony, - queen = tmpVirginQueen, - simParamBee = simParamBee) + queen = tmpVirginQueen, + simParamBee = simParamBee) } else { remnantColony <- reQueen(remnantColony, - queen = mergePops(tmpVirginQueen), - simParamBee = simParamBee) + queen = mergePops(tmpVirginQueen), + simParamBee = simParamBee) } currentLocation <- getLocation(x) @@ -1442,29 +1466,27 @@ swarm <- function(x, p = NULL, year = NULL, ret <- list(swarm = swarmColony, remnant = remnantColony) } else if (isMultiColony(x)) { if (nCol == 0) { - ret <- list( - swarm <- createMultiColony(simParamBee = simParamBee), - remnant <- createMultiColony(simParamBee = simParamBee) - ) - } else { - ret <- list( - swarm <- createMultiColony(x = getQueen(x, collapse = TRUE), - simParamBee = simParamBee), - remnant <- remnantColony - ) + stop("The Multicolony contains 0 colonies!") + } - ret$swarm@colonies <- foreach(colony = seq_len(nCol)) %dopar% { - addCastePop_internal(colony = ret$swarm@colonies[[colony]], - pop = tmp$pulled[[colony]], caste = "workers") - } + ret <- list( + swarm = createMultiColony(x = getQueen(x, collapse = TRUE), + simParamBee = simParamBee), + remnant = remnantColony + ) - ret$remnant <- setEvents(ret$remnant, slot = "swarm", value = TRUE) - ret$swarm <- setEvents(ret$swarm, slot = "swarm", value = TRUE) - ret$swarm <- setEvents(ret$swarm, slot = "production", value = FALSE) - ret$remnant <- setEvents(ret$remnant, slot = "production", value = FALSE) + ret$swarm@colonies <- foreach(colony = seq_len(nCol)) %dopar% { + addCastePop_internal(colony = ret$swarm@colonies[[colony]], + pop = tmp$pulled[[colony]], caste = "workers") } + + ret$remnant <- setEvents(ret$remnant, slot = "swarm", value = TRUE) + ret$swarm <- setEvents(ret$swarm, slot = "swarm", value = TRUE) + ret$swarm <- setEvents(ret$swarm, slot = "production", value = FALSE) + ret$remnant <- setEvents(ret$remnant, slot = "production", value = FALSE) } - } else { + } + else { stop("Argument x must be a Colony or MultiColony class object!") } validObject(ret$swarmColony) @@ -1562,28 +1584,33 @@ supersede <- function(x, year = NULL, simParamBee = NULL, ...) { registerDoParallel(cores = simParamBee$nThreads) nCol <- nColonies(x) if (nCol == 0) { - x <- createMultiColony(simParamBee = simParamBee) - } else { - virginQueens <- createCastePop(x, caste = "virginQueens", nInd = 1) + stop("The Multicolony contains 0 colonies!") + } + virginQueens <- createCastePop(x, caste = "virginQueens", nInd = 1) - combine_list <- function(a, b) { - if (length(a) == 1) { - c(list(a), list(b)) - } else { - c(a, list(b)) - } - } - x@colonies <- foreach(colony = seq_len(nCol), .combine = combine_list) %dopar% { - supersede(x[[colony]], - year = year, - simParamBee = simParamBee, ... - ) - } - x@colonies <- foreach(colony = seq_len(nColonies(x))) %dopar% { - addCastePop_internal(colony = x[[colony]], pop = virginQueens[[colony]], caste = "virginQueens") + combine_list <- function(a, b) { + if (length(a) == 1) { + c(list(a), list(b)) + } else { + c(a, list(b)) } } - } else { + tmp <- foreach(colony = seq_len(nCol), .combine = combine_list) %dopar% { + supersede(x[[colony]], + year = year, + simParamBee = simParamBee, ... + ) + } + if (nCol == 1) { + x@colonies = list(tmp) + } else { + x@colonies = tmp + } + x@colonies <- foreach(colony = seq_len(nColonies(x))) %dopar% { + addCastePop_internal(colony = x[[colony]], pop = virginQueens[[colony]], caste = "virginQueens") + } + } + else { stop("Argument x must be a Colony or MultiColony class object!") } validObject(x) @@ -1669,6 +1696,9 @@ split <- function(x, p = NULL, year = NULL, simParamBee = NULL, ...) { } else if (isMultiColony(x)) { nCol <- nColonies(x) } + if (nCol == 0) { + stop("The Multicolony contains 0 colonies!") + } nP <- length(p) location <- getLocation(x) @@ -1684,7 +1714,7 @@ split <- function(x, p = NULL, year = NULL, simParamBee = NULL, ...) { if (is.function(p)) { p <- p(x, ...) } else { - if (p < 0 | 1 < p) { + if (any(p < 0) | any(1 < p)) { stop("p must be between 0 and 1 (inclusive)!") } if (length(p) > nCol) { @@ -1734,34 +1764,31 @@ split <- function(x, p = NULL, year = NULL, simParamBee = NULL, ...) { ret <- list(split = splitColony, remnant = remnantColony) } else if (isMultiColony(x)) { if (nCol == 0) { - ret <- list( - split = createMultiColony(simParamBee = simParamBee), - remnant = createMultiColony(simParamBee = simParamBee) - ) - } else { - ret <- list( - split = createMultiColony(x = mergePops(tmpVirginQueens), n = nCol, - simParamBee = simParamBee), - remnant = tmp$remnant - - ) - ret$split <- setLocation(x = ret$split, location = location) + stop("The Multicolony contains 0 colonies!") + } + ret <- list( + split = createMultiColony(x = mergePops(tmpVirginQueens), n = nCol, + simParamBee = simParamBee), + remnant = tmp$remnant - ret$split@colonies <- foreach(colony = seq_len(nCol)) %dopar% { - addCastePop_internal(colony = ret$split@colonies[[colony]], - pop = tmp$pulled[[colony]], caste = "workers") - } - ret$split <- setEvents(ret$split, slot = "split", value = TRUE) - ret$remnant <- setEvents(ret$remnant, slot = "split", value = TRUE) - ret$split <- setEvents(ret$split, slot = "production", value = FALSE) - ret$remnant <- setEvents(ret$remnant, slot = "production", value = TRUE) + ) + ret$split <- setLocation(x = ret$split, location = location) + tmp <- foreach(colony = seq_len(nCol)) %dopar% { + addCastePop_internal(colony = ret$split@colonies[[colony]], + pop = tmp$pulled[[colony]], caste = "workers") } + + ret$split <- setEvents(ret$split, slot = "split", value = TRUE) + ret$remnant <- setEvents(ret$remnant, slot = "split", value = TRUE) + ret$split <- setEvents(ret$split, slot = "production", value = FALSE) + ret$remnant <- setEvents(ret$remnant, slot = "production", value = TRUE) } - } else { + } + else { stop("Argument x must be a Colony or MultiColony class object!") } - validObject(ret$splitColony) - validObject(ret$remnantColony) + validObject(ret$split) + validObject(ret$remnant) return(ret) } @@ -1963,21 +1990,24 @@ setLocation <- function(x, location = c(0, 0), simParamBee = NULL) { x@location <- location } else if (isMultiColony(x)) { registerDoParallel(cores = simParamBee$nThreads) - n <- nColonies(x) + nCol <- nColonies(x) + if (nCol == 0) { + stop("The Multicolony contains 0 colonies!") + } if (!is.null(location)) { if (is.numeric(location)) { if (length(location) != 2) { stop("When argument location is a numeric, it must be of length 2!") } } else if (is.data.frame(location)) { - if (nrow(location) != n) { + if (nrow(location) != nCol) { stop("When argument location is a data.frame, it must have as many rows as the number of colonies!") } if (ncol(location) != 2) { stop("When argument location is a data.frame, it must have 2 columns!") } } else if (is.list(location)) { - if (length(location) != n) { + if (length(location) != nCol) { stop("When argument location is a list, it must be of length equal to the number of colonies!") } tmp <- sapply(X = location, FUN = length) @@ -1999,7 +2029,7 @@ setLocation <- function(x, location = c(0, 0), simParamBee = NULL) { c(a, list(b)) } } - x@colonies <- foreach(colony = seq_len(n), .combine = combine_list) %dopar% { + tmp <- foreach(colony = seq_len(nCol), .combine = combine_list) %dopar% { if (is.data.frame(location)) { loc <- location[colony, ] loc <- c(loc$x, loc$y) @@ -2015,6 +2045,11 @@ setLocation <- function(x, location = c(0, 0), simParamBee = NULL) { x[[colony]] } + if (nCol == 1) { + x@colonies = list(tmp) + } else { + x@colonies = tmp + } } else { stop("Argument x must be a Colony or MultiColony class object!") } diff --git a/R/SIMplyBee.R b/R/SIMplyBee.R index c10dda63..a6d480e7 100644 --- a/R/SIMplyBee.R +++ b/R/SIMplyBee.R @@ -9,7 +9,6 @@ #' @importFrom utils packageVersion #' @importFrom foreach foreach %dopar% #' @importFrom doParallel registerDoParallel -#' @importFrom dplyr arrange %>% # see https://r-pkgs.org/namespace.html on description what to import/depend/... #' @description diff --git a/man/SimParamBee.Rd b/man/SimParamBee.Rd index 78356c8e..00f6e5f5 100644 --- a/man/SimParamBee.Rd +++ b/man/SimParamBee.Rd @@ -317,8 +317,8 @@ generate this object} \item \href{#method-SimParamBee-new}{\code{SimParamBee$new()}} \item \href{#method-SimParamBee-addToCaste}{\code{SimParamBee$addToCaste()}} \item \href{#method-SimParamBee-changeCaste}{\code{SimParamBee$changeCaste()}} -\item \href{#method-SimParamBee-updatePedigree}{\code{SimParamBee$updatePedigree()}} -\item \href{#method-SimParamBee-updateRecHist}{\code{SimParamBee$updateRecHist()}} +\item \href{#method-SimParamBee-addToBeePed}{\code{SimParamBee$addToBeePed()}} +\item \href{#method-SimParamBee-addToBeeRec}{\code{SimParamBee$addToBeeRec()}} \item \href{#method-SimParamBee-updateCaste}{\code{SimParamBee$updateCaste()}} \item \href{#method-SimParamBee-updateLastBeeId}{\code{SimParamBee$updateLastBeeId()}} \item \href{#method-SimParamBee-updateLastColonyId}{\code{SimParamBee$updateLastColonyId()}} @@ -538,37 +538,55 @@ SP$caste } \if{html}{\out{
    }} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-SimParamBee-updatePedigree}{}}} -\subsection{Method \code{updatePedigree()}}{ -A function to update the pedigree. - For internal use only. +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-SimParamBee-addToBeePed}{}}} +\subsection{Method \code{addToBeePed()}}{ +For internal use only. \subsection{Usage}{ -\if{html}{\out{
    }}\preformatted{SimParamBee$updatePedigree(pedigree)}\if{html}{\out{
    }} +\if{html}{\out{
    }}\preformatted{SimParamBee$addToBeePed(nNewInd, id, mother, father, isDH)}\if{html}{\out{
    }} } \subsection{Arguments}{ \if{html}{\out{
    }} \describe{ -\item{\code{pedigree}}{matrix, pedigree matrix to be added} +\item{\code{nNewInd}}{Number of newly created individuals} + +\item{\code{id}}{the name of each individual} + +\item{\code{mother}}{vector of mother iids} + +\item{\code{father}}{vector of father iids} + +\item{\code{isDH}}{indicator for DH lines} } \if{html}{\out{
    }} } } \if{html}{\out{
    }} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-SimParamBee-updateRecHist}{}}} -\subsection{Method \code{updateRecHist()}}{ -A function to update the recHist - For internal use only. +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-SimParamBee-addToBeeRec}{}}} +\subsection{Method \code{addToBeeRec()}}{ +For internal use only. \subsection{Usage}{ -\if{html}{\out{
    }}\preformatted{SimParamBee$updateRecHist(recHist)}\if{html}{\out{
    }} +\if{html}{\out{
    }}\preformatted{SimParamBee$addToBeeRec(nNewInd, id, mother, father, isDH, hist, ploidy)}\if{html}{\out{
    }} } \subsection{Arguments}{ \if{html}{\out{
    }} \describe{ -\item{\code{recHist}}{matrix, recHist list to be added} +\item{\code{nNewInd}}{Number of newly created individuals} + +\item{\code{id}}{the name of each individual} + +\item{\code{mother}}{vector of mother iids} + +\item{\code{father}}{vector of father iids} + +\item{\code{isDH}}{indicator for DH lines} + +\item{\code{hist}}{new recombination history} + +\item{\code{ploidy}}{ploidy level} } \if{html}{\out{
    }} } diff --git a/man/createCastePop.Rd b/man/createCastePop.Rd index 226af5ee..b12572cb 100644 --- a/man/createCastePop.Rd +++ b/man/createCastePop.Rd @@ -23,7 +23,6 @@ createCastePop( createWorkers( x, nInd = NULL, - exact = FALSE, simParamBee = NULL, returnSP = FALSE, ids = NULL, @@ -90,11 +89,6 @@ for each created population (used internally for parallel computing)} for parallel computing)} \item{...}{additional arguments passed to \code{nInd} when this argument is a function} - -\item{exact}{logical, only relevant when creating workers, -if the csd locus is active and exact is \code{TRUE}, -create the exactly specified number of viable workers (heterozygous on the -csd locus)} } \value{ when \code{x} is \code{\link[AlphaSimR]{MapPop-class}} returns diff --git a/man/getIbdHaplo.Rd b/man/getIbdHaplo.Rd index fd6dfe79..08895a7a 100644 --- a/man/getIbdHaplo.Rd +++ b/man/getIbdHaplo.Rd @@ -115,10 +115,10 @@ Level 0 function that returns IBD (identity by descent) }} \examples{ -founderGenomes <- quickHaplo(nInd = 4, nChr = 1, segSites = 50) -SP <- SimParamBee$new(founderGenomes) +founderGenomes <- quickHaplo(nInd = 4, nChr = 1, segSites = 5) +SP <- SimParamBee$new(founderGenomes, nCsdAlleles = 4) \dontshow{SP$nThreads = 1L} -SP$setTrackRec(TRUE) +SP$setTrackRec(isTrackRec = TRUE) SP$setTrackPed(isTrackPed = TRUE) basePop <- createVirginQueens(founderGenomes) @@ -128,13 +128,13 @@ droneGroups <- pullDroneGroupsFromDCA(drones, n = 10, nDrones = nFathersPoisson) # Create a Colony and a MultiColony class colony <- createColony(x = basePop[2]) colony <- cross(colony, drones = droneGroups[[1]]) -colony <- buildUp(x = colony, nWorkers = 6, nDrones = 3) -colony <- addVirginQueens(x = colony, nInd = 5) +colony <- buildUp(x = colony, nWorkers = 3, nDrones = 2) +colony <- addVirginQueens(x = colony, nInd = 2) -apiary <- createMultiColony(basePop[3:4], n = 2) +apiary <- createMultiColony(basePop[3:4]) apiary <- cross(apiary, drones = droneGroups[c(2, 3)]) -apiary <- buildUp(x = apiary, nWorkers = 6, nDrones = 3) -apiary <- addVirginQueens(x = apiary, nInd = 5) +apiary <- buildUp(x = apiary, nWorkers = 3, nDrones = 2) +apiary <- addVirginQueens(x = apiary, nInd = 2) # Input is a population getIbdHaplo(x = getQueen(colony)) @@ -146,6 +146,8 @@ getIbdHaplo(x = colony, caste = "queen") getQueenIbdHaplo(colony) getIbdHaplo(colony, caste = "workers", nInd = 3) +getIbdHaplo(colony, caste = "virginQueens") +getIbdHaplo(colony, caste = "drones") getWorkersIbdHaplo(colony) # Same aliases exist for all castes! @@ -160,6 +162,9 @@ getQueenIbdHaplo(apiary) # Or collapse all the haplotypes into a single matrix getQueenIbdHaplo(apiary, collapse = TRUE) + +getIbdHaplo(x = apiary, caste = "workers") +getIbdHaplo(x = apiary, caste = "drones") # Get the haplotypes of all individuals either by colony or in a single matrix getIbdHaplo(apiary, caste = "all") getIbdHaplo(apiary, caste = "all", collapse = TRUE) diff --git a/man/hasSwarmed.Rd b/man/hasSwarmed.Rd index 870d2d14..427d41d3 100644 --- a/man/hasSwarmed.Rd +++ b/man/hasSwarmed.Rd @@ -31,7 +31,7 @@ colony <- cross(colony, drones = droneGroups[[1]]) colony <- buildUp(x = colony, nWorkers = 6, nDrones = 3) colony <- addVirginQueens(colony, nInd = 5) -apiary <- createMultiColony(basePop[3:4], n = 2) +apiary <- createMultiColony(basePop[3:4]) apiary <- cross(apiary, drones = droneGroups[c(2, 3)]) apiary <- buildUp(x = apiary, nWorkers = 6, nDrones = 3) diff --git a/man/pullCastePop.Rd b/man/pullCastePop.Rd index dcf63748..42a890b2 100644 --- a/man/pullCastePop.Rd +++ b/man/pullCastePop.Rd @@ -95,12 +95,12 @@ droneGroups <- pullDroneGroupsFromDCA(drones, n = 10, nDrones = nFathersPoisson) # Create a Colony and a MultiColony class colony <- createColony(x = basePop[2]) colony <- cross(colony, drones = droneGroups[[1]]) -colony <- buildUp(x = colony, nWorkers = 100, nDrones = 10, exact = TRUE) +colony <- buildUp(x = colony, nWorkers = 100, nDrones = 10) colony <- addVirginQueens(x = colony, nInd = 3) apiary <- createMultiColony(basePop[3:4], n = 2) apiary <- cross(apiary, drones = droneGroups[c(2, 3)]) -apiary <- buildUp(x = apiary, nWorkers = 100, nDrones = 10, exact = TRUE) +apiary <- buildUp(x = apiary, nWorkers = 100, nDrones = 10) apiary <- addVirginQueens(x = apiary, nInd = 3) # pullCastePop on Colony class diff --git a/man/swarm.Rd b/man/swarm.Rd index 34d2c198..72c7e88f 100644 --- a/man/swarm.Rd +++ b/man/swarm.Rd @@ -55,6 +55,8 @@ Level 2 function that swarms a Colony or MultiColony object - \examples{ founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 50) SP <- SimParamBee$new(founderGenomes) +SP$setTrackPed(TRUE) +SP$setTrackRec(TRUE) \dontshow{SP$nThreads = 1L} basePop <- createVirginQueens(founderGenomes) drones <- createDrones(basePop[1], n = 1000) diff --git a/tests/testthat/test-L0_auxiliary_functions.R b/tests/testthat/test-L0_auxiliary_functions.R index b9883b0a..6a8bf4d6 100644 --- a/tests/testthat/test-L0_auxiliary_functions.R +++ b/tests/testthat/test-L0_auxiliary_functions.R @@ -181,7 +181,7 @@ test_that("pHomBrood", { expect_error(pHomBrood(colony@workers, simParamBee = SP)) expect_error(pHomBrood(colony@virginQueens, simParamBee = SP)) expect_error(pHomBrood(colony@drones, simParamBee = SP)) - expect_true(is.numeric(pHomBrood(colony@queen, simParamBee = SP))) + #expect_true(is.numeric(pHomBrood(colony@queen, simParamBee = SP))) colony@queen <- NULL expect_error(pHomBrood(colony@queen, simParamBee = SP)) diff --git a/tests/testthat/test-L1_pop_functions.R b/tests/testthat/test-L1_pop_functions.R index 7cabd2b8..5d39e6a3 100644 --- a/tests/testthat/test-L1_pop_functions.R +++ b/tests/testthat/test-L1_pop_functions.R @@ -282,7 +282,7 @@ test_that("cross", { expect_error(cross(colony2, drones = dronesGroups[7], simParamBee = SP)) # Message if fathers == 0 "Mating failed" - expect_error(cross(virginQueen2, drones= selectInd(colony@drones,nInd = 0, use = "rand", simParam = SP), simParamBee = SP)) + expect_error(cross(virginQueen2, drones= selectInd(colony@drones, nInd = 0, use = "rand", simParam = SP), simParamBee = SP)) #expect_message(cross(virginQueen2, drones= selectInd(colony@drones,nInd = 0, use = "rand", simParam = SP), checkCross = "warning", simParamBee = SP)) }) @@ -414,3 +414,4 @@ test_that("combineBeeGametesHaploidDiploid", { expect_equal(nInd(drones), 5) expect_equal(drones@ploidy, 1) }) + diff --git a/tests/testthat/test-L2_colony_functions.R b/tests/testthat/test-L2_colony_functions.R index bb1a729e..2daeb877 100644 --- a/tests/testthat/test-L2_colony_functions.R +++ b/tests/testthat/test-L2_colony_functions.R @@ -109,9 +109,7 @@ test_that("Add functions", { expect_equal(nDrones(addDrones(colony, nInd = 5, new = TRUE, simParamBee = SP), simParamBee = SP), 5) # If input is an apiary # Empty apiary - you can add, but nothing happens - returns an empty apiary - expect_s4_class(addVirginQueens(emptyApiary, nInd = 5, simParamBee = SP), "MultiColony") - expect_s4_class(addWorkers(emptyApiary, nInd = 5, simParamBee = SP), "MultiColony") - expect_s4_class(addDrones(emptyApiary, nInd = 5, simParamBee = SP), "MultiColony") + expect_error(addVirginQueens(emptyApiary, nInd = 5, simParamBee = SP)) # Non-empty apiary expect_s4_class(addVirginQueens(apiary, nInd = 5, simParamBee = SP), "MultiColony") expect_s4_class(addWorkers(apiary, nInd = 5, simParamBee = SP), "MultiColony") @@ -154,7 +152,7 @@ test_that("BuildUpDownsize", { # Build Up an apiary # Empty apiary - expect_s4_class(buildUp(emptyApiary, simParamBee = SP), "MultiColony") + expect_error(buildUp(emptyApiary, simParamBee = SP)) # Non-empty apiary expect_equal(nColonies(buildUp(apiary, simParamBee = SP)), 2) @@ -169,7 +167,7 @@ test_that("BuildUpDownsize", { expect_length(intersect(getId(getWorkers(downsize(colony, p = 0.1, new = TRUE, simParamBee = SP), simParamBee = SP)), workersIDs), 0) # Empty apiary - expect_s4_class(downsize(emptyApiary, simParamBee = SP), "MultiColony") + expect_error(downsize(emptyApiary, simParamBee = SP)) # Non-empty apiary downsize(apiary, simParamBee = SP) }) @@ -201,9 +199,9 @@ test_that("replaceFunctions", { expect_error(replaceVirginQueens(emptyColony, p = 0.5, simParamBee = SP)) expect_error(replaceWorkers(emptyColony, p = 0, simParamBee = SP)) expect_error(replaceDrones(emptyColony, p = 1, simParamBee = SP)) - expect_s4_class(replaceVirginQueens(emptyApiary, p = 0.5, simParamBee = SP), "MultiColony") - expect_s4_class(replaceWorkers(emptyApiary, p = 0, simParamBee = SP), "MultiColony") - expect_s4_class(replaceDrones(emptyApiary, p = 1, simParamBee = SP), "MultiColony") + expect_error(replaceVirginQueens(emptyApiary, p = 0.5, simParamBee = SP)) + expect_error(replaceWorkers(emptyApiary, p = 0, simParamBee = SP)) + expect_error(replaceDrones(emptyApiary, p = 1, simParamBee = SP)) # Replace individuals in the non-empty colony/apiary expect_s4_class(replaceVirginQueens(colony, simParamBee = SP), "Colony") @@ -211,7 +209,7 @@ test_that("replaceFunctions", { expect_s4_class(replaceDrones(colony, simParamBee = SP), "Colony") expect_equal(nVirginQueens(replaceVirginQueens(colony, p = 1, simParamBee = SP), simParamBee = SP), nVirginQueens(colony, simParam = SP)) expect_equal(nWorkers(replaceWorkers(colony, p = 0.5, simParamBee = SP), simParamBee = SP), nWorkers(colony, simParamBee = SP)) - expect_equal(nDrones(replaceDrones(colony, p = 0, simParamBee = SP), simParamBee = SP), nDrones(colony, simParamBee = SP)) + expect_warning(nDrones(replaceDrones(colony, p = 0, simParamBee = SP), simParamBee = SP)) virginQueensIDs <- getId(colony@virginQueens) workerIDs <- getId(colony@workers) droneIDs <- getId(colony@drones) @@ -219,14 +217,14 @@ test_that("replaceFunctions", { virginQueensIDs), 0) expect_length(intersect(getId(replaceWorkers(colony, p = 0.5, simParamBee = SP)@workers), workerIDs), nWorkers(colony, simParamBee = SP)/2) - expect_length(intersect(getId(replaceDrones(colony, p = 0, simParamBee = SP)@drones), - droneIDs), nDrones(colony, simParamBee = SP)) + expect_warning(intersect(getId(replaceDrones(colony, p = 0, simParamBee = SP)@drones), + droneIDs)) expect_s4_class(replaceVirginQueens(apiary, simParamBee = SP), "MultiColony") expect_s4_class(replaceWorkers(apiary, simParamBee = SP), "MultiColony") expect_s4_class(replaceDrones(apiary, simParamBee = SP), "MultiColony") expect_equal(nColonies(replaceVirginQueens(apiary, p = 1, simParamBee = SP)), nColonies(apiary)) expect_equal(nColonies(replaceWorkers(apiary, p = 0.5, simParamBee = SP)), nColonies(apiary)) - expect_equal(nColonies(replaceDrones(apiary, p = 0, simParamBee = SP)), nColonies(apiary)) + expect_error(nColonies(replaceDrones(apiary, p = 0, simParamBee = SP))) }) # ---- Remove functions ---- @@ -256,9 +254,9 @@ test_that("removeFunctions", { expect_s4_class(removeVirginQueens(emptyColony, p = 0.5, simParamBee = SP), "Colony") expect_s4_class(removeWorkers(emptyColony, p = 0, simParamBee = SP), "Colony") expect_s4_class(removeDrones(emptyColony, p = 1, simParamBee = SP), "Colony") - expect_s4_class(removeVirginQueens(emptyApiary, p = 0.5, simParamBee = SP), "MultiColony") - expect_s4_class(removeWorkers(emptyApiary, p = 0, simParamBee = SP), "MultiColony") - expect_s4_class(removeDrones(emptyApiary, p = 1, simParamBee = SP), "MultiColony") + expect_error(removeVirginQueens(emptyApiary, p = 0.5, simParamBee = SP)) + expect_error(removeWorkers(emptyApiary, p = 0, simParamBee = SP)) + expect_error(removeDrones(emptyApiary, p = 1, simParamBee = SP)) # Remove individuals in the non-empty colony/apiary expect_s4_class(removeVirginQueens(colony, simParamBee = SP), "Colony") @@ -308,9 +306,8 @@ test_that("setLocation", { emptyApiary <- createMultiColony(n = 3, simParamBee = SP) apiary <- createMultiColony(basePop[1:3], simParamBee = SP) - expect_s4_class(setLocation(emptyApiary, location = c(1,2)), "MultiColony") + expect_error(setLocation(emptyApiary, location = c(1,2))) expect_error(setLocation(emptyApiary, location = list(1,2))) # Lengths do not match - expect_s4_class(setLocation(emptyApiary, location = list(1:2, 3:4, 4:5)), "MultiColony") #Not setting anything, if all are NULL!!!! expect_s4_class(setLocation(apiary, location = c(1,2)), "MultiColony") expect_s4_class(setLocation(apiary, location = list(1:2, 3:4, 4:5)), "MultiColony") }) From b51c879eb923f95084ad2cb133562fe83262c3fa Mon Sep 17 00:00:00 2001 From: janaobsteter Date: Sun, 8 Jun 2025 21:27:47 +0200 Subject: [PATCH 28/42] Fixing errors in the cross function --- R/Functions_L1_Pop.R | 14 +++++++++----- 1 file changed, 9 insertions(+), 5 deletions(-) diff --git a/R/Functions_L1_Pop.R b/R/Functions_L1_Pop.R index 90119261..2f1583e4 100644 --- a/R/Functions_L1_Pop.R +++ b/R/Functions_L1_Pop.R @@ -1553,6 +1553,10 @@ cross <- function(x, # Do all the tests here to simplify the function + if (is.null(crossPlan) & (length(IDs) > 1) & isPop(drones)) { + stop("When supplying drones as a single population for mating multiple virgin queens, + crossPlan argument must be set to 'create' to internally create a mating plan!") + } if (crossPlan_droneID && !isPop(drones)) { stop("When using a cross plan, drones must be supplied as a single Pop-class!") } @@ -1638,7 +1642,10 @@ cross <- function(x, virginId = unlist(sapply(x, FUN = function(y) getId(y)))) x <- mergePops(x) } - + # Rename crossPlan + if (crossPlan_create | crossPlan_given) { + names(crossPlan) <- ID_by_input$virginId[match(ID_by_input$inputId, names(crossPlan))] + } } IDs <- as.character(getId(x)) @@ -1646,10 +1653,7 @@ cross <- function(x, ret <- list() nVirgin = nInd(x) - # Rename crossPlan - if (crossPlan_create | crossPlan_given) { - names(crossPlan) <- ID_by_input$virginId[match(ID_by_input$inputId, names(crossPlan))] - } + if (is.function(nDrones)) { nD = nDrones(n = nVirgin, ...) From 6fc7d0d35f90202a0431e5eb0a8746ca67bd5275 Mon Sep 17 00:00:00 2001 From: janaobsteter Date: Mon, 23 Jun 2025 11:16:20 +0200 Subject: [PATCH 29/42] Fixing errors in cross() --- R/Functions_L1_Pop.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/Functions_L1_Pop.R b/R/Functions_L1_Pop.R index 2f1583e4..cbc1d5ba 100644 --- a/R/Functions_L1_Pop.R +++ b/R/Functions_L1_Pop.R @@ -1684,7 +1684,7 @@ cross <- function(x, IDs = IDs[IDs %in% crossPlanDF$virginID] x = x[IDs] if (type == "MultiColony") { - multicolony <- multicolony[getId(multicolony) %in% IDs] + multicolony <- multicolony[getId(getVirginQueens(multicolony, collapse=TRUE)) %in% IDs] } # Here we sample from the DPC in the cross plan to get the needed number of drones (nD) crossPlanDF_sample <- do.call("rbind", lapply(IDs, From 03b17c9ef0b34061f5282162c72316d435739c5f Mon Sep 17 00:00:00 2001 From: janaobsteter Date: Thu, 26 Jun 2025 12:19:01 +0200 Subject: [PATCH 30/42] Adding print message into cross --- R/Functions_L1_Pop.R | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/R/Functions_L1_Pop.R b/R/Functions_L1_Pop.R index cbc1d5ba..3da51dd8 100644 --- a/R/Functions_L1_Pop.R +++ b/R/Functions_L1_Pop.R @@ -671,10 +671,11 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, } else if (simParamBee$isTrackPed) { Pedigree <- do.call("rbind", lapply(ret[notNull], '[[', "pedigree")) if (!simParamBee$isTrackRec) { - simParamBee$addToBeePed(nNewInd = totalNInd, id = rownames(Pedigree), - mother = Pedigree[, 'mother'], father = Pedigree[, 'father'], - isDH = Pedigree[, 'isDH']) - #simParamBee$updatePedigree(pedigree = Pedigree) + print(paste0("totalnInd is ", totalNInd, "; nrow Pedigree is ", nrow(Pedigree), "; length mother is ", length(Pedigree[, 'mother']))) + simParamBee$addToBeePed(nNewInd = totalNInd, id = rownames(Pedigree), + mother = Pedigree[, 'mother'], father = Pedigree[, 'father'], + isDH = Pedigree[, 'isDH']) + #simParamBee$updatePedigree(pedigree = Pedigree) } else { RecHist = do.call("c", lapply(ret[notNull], '[[', "recHist")) if (caste == "drones") { From 12353f73bcf4bf1392b49bfc400ba3d8ac2c5696 Mon Sep 17 00:00:00 2001 From: janaobsteter Date: Mon, 20 Oct 2025 13:56:36 +0200 Subject: [PATCH 31/42] Removed adding a virgin queen to splits, edited to handle inbreeding - colonies that don't produce a virgin queens due to homozygosity are now removed in split, swarm, and supersedure --- R/Functions_L0_auxilary.R | 1 - R/Functions_L1_Pop.R | 27 +++++---- R/Functions_L2_Colony.R | 116 ++++++++++++++++++++++++-------------- R/Functions_L3_Colonies.R | 5 ++ 4 files changed, 95 insertions(+), 54 deletions(-) diff --git a/R/Functions_L0_auxilary.R b/R/Functions_L0_auxilary.R index 43efba27..7d90ccbd 100644 --- a/R/Functions_L0_auxilary.R +++ b/R/Functions_L0_auxilary.R @@ -2993,7 +2993,6 @@ getIbdHaplo <- function(x, caste = NULL, nInd = NULL, chr = NULL, snpChip = NULL ret <- vector(mode = "list", length = 5) names(ret) <- c("queen", "fathers", "workers", "drones", "virginQueens") for (caste in names(ret)) { - print(caste) tmp <- getIbdHaplo(x = x, caste = caste, nInd = nInd, chr = chr, snpChip = snpChip, dronesHaploid = dronesHaploid, collapse = collapse, simParamBee = simParamBee) diff --git a/R/Functions_L1_Pop.R b/R/Functions_L1_Pop.R index 3da51dd8..bf086960 100644 --- a/R/Functions_L1_Pop.R +++ b/R/Functions_L1_Pop.R @@ -439,9 +439,9 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, ret@sex[] <- "F" simParamBee$changeCaste(id = ret@id, caste = "virginQueens") - if (!is.null(year)) { - ret <- setQueensYearOfBirth(x = ret, year = year, simParamBee = simParamBee) - } + # if (!is.null(year)) { + # ret <- setQueensYearOfBirth(x = ret, year = year, simParamBee = simParamBee) + # } } else if (isPop(x)) { if (caste != "drones") { # Creating drones if input is a Pop stop("Pop-class can only be used to create drones!") @@ -498,6 +498,8 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, simParamBee = simParamBee ) + + simParamBee$addToCaste(id = ret$workers@id, caste = "workers") ret$workers@sex[] <- "F" @@ -512,10 +514,10 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, } if (!is.null(ids)) { - if (nInd(ret$workers) < length(ids)) { + if (nInd(ret$workers) > length(ids)) { stop("Not enough IDs provided") } - if (nInd(ret$workers) > length(ids)) { + if (nInd(ret$workers) < length(ids)) { stop("Too many IDs provided!") } ret$workers@id <- as.character(ids) @@ -532,7 +534,11 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, } if (isCsdActive(simParamBee = simParamBee)) { - ret$nHomBrood <- sum(!isCsdHeterozygous(ret$workers, simParamBee = simParamBee)) / nInd(ret$workers) + sel <- isCsdHeterozygous(pop = ret$workers, simParamBee = simParamBee) + ret$workers <- ret$workers[sel] + ret$nHomBrood <- nInd(ret$workers) - sum(sel) + } else { + ret$nHomBrood <- NA } } else if (caste == "virginQueens") { @@ -545,9 +551,11 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, if (!returnSP) { ret <- ret$workers } - if (!is.null(year)) { - ret <- setQueensYearOfBirth(x = ret, year = year, simParamBee = simParamBee) - } + # print(ret) + # if ((nInd(ret) > 0) & (!is.null(year))) { + # print("Setting by") + # ret <- setQueensYearOfBirth(x = ret, year = year, simParamBee = simParamBee) + # } } else if (caste == "drones") { drones <- makeDH( pop = getQueen(x, simParamBee = simParamBee), nDH = nInd, keepParents = FALSE, @@ -671,7 +679,6 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, } else if (simParamBee$isTrackPed) { Pedigree <- do.call("rbind", lapply(ret[notNull], '[[', "pedigree")) if (!simParamBee$isTrackRec) { - print(paste0("totalnInd is ", totalNInd, "; nrow Pedigree is ", nrow(Pedigree), "; length mother is ", length(Pedigree[, 'mother']))) simParamBee$addToBeePed(nNewInd = totalNInd, id = rownames(Pedigree), mother = Pedigree[, 'mother'], father = Pedigree[, 'father'], isDH = Pedigree[, 'isDH']) diff --git a/R/Functions_L2_Colony.R b/R/Functions_L2_Colony.R index f2a6b593..5f2dbf04 100644 --- a/R/Functions_L2_Colony.R +++ b/R/Functions_L2_Colony.R @@ -1375,9 +1375,6 @@ swarm <- function(x, p = NULL, year = NULL, if (is.null(radius)) { radius <- simParamBee$swarmRadius } - if (is.null(nVirginQueens)) { - nVirginQueens <- simParamBee$nVirginQueens - } if (isColony(x) | isMultiColony(x)) { if (isColony(x)) { nCol <- 1 @@ -1418,24 +1415,44 @@ swarm <- function(x, p = NULL, year = NULL, # TODO: Add use="something" to select pWorkers that swarm # https://github.com/HighlanderLab/SIMplyBee/issues/160 - tmpVirginQueen <- createCastePop( - x = x, nInd = 1, + tmpVirginQueens <- createCastePop( + x = x, nInd = max(10, simParamBee$nVirginQueens), year = year, caste = "virginQueens", simParamBee = simParamBee ) + if (isColony(x)) { + homCol = nInd(tmpVirginQueens) == 0 + } else if (isMultiColony(x)) { + homCol = lapply(tmpVirginQueens, nInd) == 0 + } + + if (sum(homCol) > 0) { + if (isColony(x)) { + stop("Colony to inbred to produce any virgin queens!") + } else if (isMultiColony(x)) { + warning(paste0(sum(homCol), " colonies produced 0 virgin queens due to high colony homozygosity, removing these colonies!")) + tmpVirginQueens <- tmpVirginQueens[!homCol] + x = x[!homCol] + location = location[!homCol] + nWorkersSwarm = nWorkersSwarm[!homCol] + nCol = nColonies(x) + } + } + tmp <- pullCastePop(x = x, caste = "workers", nInd = nWorkersSwarm, simParamBee = simParamBee) remnantColony <- tmp$remnant remnantColony <- removeQueen(remnantColony) if (isColony(x)) { remnantColony <- reQueen(remnantColony, - queen = tmpVirginQueen, + queen = selectInd(tmpVirginQueens, nInd = 1, use = "rand"), simParamBee = simParamBee) } else { + tmpVirginQueens <- lapply(tmpVirginQueens, FUN = function(x) selectInd(x, n= 1, use = "rand")) remnantColony <- reQueen(remnantColony, - queen = mergePops(tmpVirginQueen), + queen = mergePops(tmpVirginQueens), simParamBee = simParamBee) } currentLocation <- getLocation(x) @@ -1505,7 +1522,6 @@ swarm <- function(x, p = NULL, year = NULL, #' queens, of which only one prevails. #' #' @param x \code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}} -#' @param year numeric, year of birth for virgin queens #' @param simParamBee \code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters #' @param ... additional arguments passed to \code{nVirginQueens} when this #' argument is a function @@ -1548,7 +1564,7 @@ swarm <- function(x, p = NULL, year = NULL, #' # Swarm only the pulled colonies #' (supersede(tmp$pulled)) #' @export -supersede <- function(x, year = NULL, simParamBee = NULL, ...) { +supersede <- function(x, simParamBee = NULL, ...) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } @@ -1560,21 +1576,48 @@ supersede <- function(x, year = NULL, simParamBee = NULL, ...) { if (is.null(nVirginQueens)) { nVirginQueens <- simParamBee$nVirginQueens } + + if (any(hasCollapsed(x))) { + stop(paste0("One of the collonies is collapsed, hence you can not split it!")) + } + if (any(!isQueenPresent(x, simParamBee = simParamBee))) { + stop("No queen present in one of the colonies!") + } + if (is.function(nVirginQueens)) { + nVirginQueens <- nVirginQueens(x, ...) + } + + # Do this because some colonies might not produce a viable virgin queen + tmpVirginQueens <- createCastePop( + x = x, nInd = max(10, SP$nVirginQueens), + caste = "virginQueens", + simParamBee = simParamBee + ) + if (isColony(x)) { - if (hasCollapsed(x)) { - stop(paste0("The colony ", getId(x), " collapsed, hence it can not supresede!")) - } - if (!isQueenPresent(x, simParamBee = simParamBee)) { - stop("No queen present in the colony!") - } - if (is.function(nVirginQueens)) { - nVirginQueens <- nVirginQueens(x, ...) + homCol = nInd(tmpVirginQueens) == 0 + } else if (isMultiColony(x)) { + homCol = sapply(tmpVirginQueens, nInd) == 0 + } + + if (sum(homCol) > 0) { + if (isColony(x)) { + print("X is colony") + print(class(x)) + stop("Colony to inbred to produce any virgin queens!") + } else if (isMultiColony(x)) { + warning(paste0(sum(homCol), " colonies produced 0 virgin queens due to high colony homozygosity, removing these colonies!")) + tmpVirginQueens <- tmpVirginQueens[!homCol] + x = x[!homCol] + nCol = nColonies(x) } + } + if (isColony(x)) { if (!parallel) { - x <- addVirginQueens(x, nInd = 1) + x <- addCastePop_internal(selectInd(tmpVirginQueens, n= 1, use = "rand"), colony = x, caste = "virginQueens") } - x <- removeQueen(x, year = year, simParamBee = simParamBee) + x <- removeQueen(x, simParamBee = simParamBee) # TODO: We could consider that a non-random virgin queen prevails (say the most # aggressive one), by creating many virgin queens and then picking the # one with highest pheno for competition or some other criteria @@ -1586,7 +1629,7 @@ supersede <- function(x, year = NULL, simParamBee = NULL, ...) { if (nCol == 0) { stop("The Multicolony contains 0 colonies!") } - virginQueens <- createCastePop(x, caste = "virginQueens", nInd = 1) + tmpVirginQueens <- lapply(tmpVirginQueens, FUN = function(x) selectInd(x, n= 1, use = "rand")) combine_list <- function(a, b) { if (length(a) == 1) { @@ -1595,20 +1638,11 @@ supersede <- function(x, year = NULL, simParamBee = NULL, ...) { c(a, list(b)) } } - tmp <- foreach(colony = seq_len(nCol), .combine = combine_list) %dopar% { - supersede(x[[colony]], - year = year, - simParamBee = simParamBee, ... - ) - } - if (nCol == 1) { - x@colonies = list(tmp) - } else { - x@colonies = tmp - } x@colonies <- foreach(colony = seq_len(nColonies(x))) %dopar% { - addCastePop_internal(colony = x[[colony]], pop = virginQueens[[colony]], caste = "virginQueens") + addCastePop_internal(colony = removeQueen(x[[colony]], simParamBee = simParamBee), + pop = tmpVirginQueens[[colony]], caste = "virginQueens") } + x = setEvents(x, slot = "supersedure", value = TRUE) } else { stop("Argument x must be a Colony or MultiColony class object!") @@ -1633,7 +1667,6 @@ supersede <- function(x, year = NULL, simParamBee = NULL, ...) { #' If input is \code{\link[SIMplyBee]{MultiColony-class}}, #' the input could also be a vector of the same length as the number of colonies. If #' a single value is provided, the same value will be applied to all the colonies -#' @param year numeric, year of birth for virgin queens #' @param simParamBee \code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters #' @param ... additional arguments passed to \code{p} when this argument is a #' function @@ -1678,7 +1711,7 @@ supersede <- function(x, year = NULL, simParamBee = NULL, ...) { #' # Split only the pulled colonies #' (split(tmp$pulled, p = 0.5)) #' @export -split <- function(x, p = NULL, year = NULL, simParamBee = NULL, ...) { +split <- function(x, p = NULL, simParamBee = NULL, ...) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } @@ -1725,6 +1758,7 @@ split <- function(x, p = NULL, year = NULL, simParamBee = NULL, ...) { stop("Too few values in the p argument!") } } + nWorkers <- nWorkers(x, simParamBee = simParamBee) nWorkersSplit <- round(nWorkers * p) # TODO: Split colony at random by default, but we could make it as a @@ -1733,13 +1767,6 @@ split <- function(x, p = NULL, year = NULL, simParamBee = NULL, ...) { tmp <- pullCastePop(x = x, caste = "workers", nInd = nWorkersSplit, simParamBee = simParamBee) remnantColony <- tmp$remnant - tmpVirginQueens <- createCastePop( - x = x, nInd = 1, - year = year, - caste = "virginQueens", - simParamBee = simParamBee - ) - if (isColony(x)) { # Workers raise virgin queens from eggs laid by the queen (assuming) that @@ -1750,7 +1777,7 @@ split <- function(x, p = NULL, year = NULL, simParamBee = NULL, ...) { # highest pheno for competition or some other criteria # https://github.com/HighlanderLab/SIMplyBee/issues/239 - splitColony <- createColony(x = tmpVirginQueens, simParamBee = simParamBee) + splitColony <- createColony(simParamBee = simParamBee) splitColony <- setLocation(x = splitColony, location = location) splitColony@workers <- tmp$pulled @@ -1766,8 +1793,9 @@ split <- function(x, p = NULL, year = NULL, simParamBee = NULL, ...) { if (nCol == 0) { stop("The Multicolony contains 0 colonies!") } + ret <- list( - split = createMultiColony(x = mergePops(tmpVirginQueens), n = nCol, + split = createMultiColony(n = nCol, simParamBee = simParamBee), remnant = tmp$remnant @@ -1787,6 +1815,8 @@ split <- function(x, p = NULL, year = NULL, simParamBee = NULL, ...) { else { stop("Argument x must be a Colony or MultiColony class object!") } + + warning("Split colonies do not have a queen! You need to re-queen them manually.") validObject(ret$split) validObject(ret$remnant) return(ret) diff --git a/R/Functions_L3_Colonies.R b/R/Functions_L3_Colonies.R index fafa2ad3..403c30c0 100644 --- a/R/Functions_L3_Colonies.R +++ b/R/Functions_L3_Colonies.R @@ -62,6 +62,11 @@ createMultiColony <- function(x = NULL, n = NULL, simParamBee = NULL, nThreads = ret <- new(Class = "MultiColony") } else { ret <- new(Class = "MultiColony", colonies = vector(mode = "list", length = n)) + ids <- (simParamBee$lastColonyId+1):(simParamBee$lastColonyId + n) + ret@colonies <- foreach(colony = seq_len(n)) %dopar% { + createColony(simParamBee = simParamBee, id = ids[colony]) + } + simParamBee$updateLastColonyId(n = n) } } else { if (!isPop(x)) { From e2e528278a5a24ae28a0c174ffb891631b0d3b1f Mon Sep 17 00:00:00 2001 From: janaobsteter Date: Mon, 20 Oct 2025 13:58:10 +0200 Subject: [PATCH 32/42] Changing split warning to message --- R/Functions_L2_Colony.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/Functions_L2_Colony.R b/R/Functions_L2_Colony.R index 5f2dbf04..98243ae5 100644 --- a/R/Functions_L2_Colony.R +++ b/R/Functions_L2_Colony.R @@ -1816,7 +1816,7 @@ split <- function(x, p = NULL, simParamBee = NULL, ...) { stop("Argument x must be a Colony or MultiColony class object!") } - warning("Split colonies do not have a queen! You need to re-queen them manually.") + message("Split colonies do not have a queen! You need to re-queen them manually.") validObject(ret$split) validObject(ret$remnant) return(ret) From a2ea0c5adc4ff217f1ad12c4b1fd4c88140d8944 Mon Sep 17 00:00:00 2001 From: janaobsteter Date: Mon, 20 Oct 2025 14:46:56 +0200 Subject: [PATCH 33/42] Running tests and checks --- NEWS.md | 14 ++++++++++++++ R/Functions_L2_Colony.R | 9 +++++---- R/Functions_L3_Colonies.R | 22 ++++++++++++---------- 3 files changed, 31 insertions(+), 14 deletions(-) diff --git a/NEWS.md b/NEWS.md index d72a41ac..bb8b0965 100644 --- a/NEWS.md +++ b/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) + +- swarm/split/supersede do no longer store the name 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 diff --git a/R/Functions_L2_Colony.R b/R/Functions_L2_Colony.R index 98243ae5..0a64bb2e 100644 --- a/R/Functions_L2_Colony.R +++ b/R/Functions_L2_Colony.R @@ -1450,7 +1450,7 @@ swarm <- function(x, p = NULL, year = NULL, queen = selectInd(tmpVirginQueens, nInd = 1, use = "rand"), simParamBee = simParamBee) } else { - tmpVirginQueens <- lapply(tmpVirginQueens, FUN = function(x) selectInd(x, n= 1, use = "rand")) + tmpVirginQueens <- lapply(tmpVirginQueens, FUN = function(x) selectInd(x, nInd = 1, use = "rand")) remnantColony <- reQueen(remnantColony, queen = mergePops(tmpVirginQueens), simParamBee = simParamBee) @@ -1615,7 +1615,7 @@ supersede <- function(x, simParamBee = NULL, ...) { if (isColony(x)) { if (!parallel) { - x <- addCastePop_internal(selectInd(tmpVirginQueens, n= 1, use = "rand"), colony = x, caste = "virginQueens") + x <- addCastePop_internal(selectInd(tmpVirginQueens, nInd = 1, use = "rand"), colony = x, caste = "virginQueens") } x <- removeQueen(x, simParamBee = simParamBee) # TODO: We could consider that a non-random virgin queen prevails (say the most @@ -1629,7 +1629,7 @@ supersede <- function(x, simParamBee = NULL, ...) { if (nCol == 0) { stop("The Multicolony contains 0 colonies!") } - tmpVirginQueens <- lapply(tmpVirginQueens, FUN = function(x) selectInd(x, n= 1, use = "rand")) + tmpVirginQueens <- lapply(tmpVirginQueens, FUN = function(x) selectInd(x, nInd = 1, use = "rand")) combine_list <- function(a, b) { if (length(a) == 1) { @@ -1796,7 +1796,8 @@ split <- function(x, p = NULL, simParamBee = NULL, ...) { ret <- list( split = createMultiColony(n = nCol, - simParamBee = simParamBee), + simParamBee = simParamBee, + populateColonies = TRUE), remnant = tmp$remnant ) diff --git a/R/Functions_L3_Colonies.R b/R/Functions_L3_Colonies.R index 403c30c0..b6535b9e 100644 --- a/R/Functions_L3_Colonies.R +++ b/R/Functions_L3_Colonies.R @@ -13,7 +13,7 @@ #' given then \code{\link[SIMplyBee]{MultiColony-class}} is created with \code{n} #' \code{NULL}) individual colony - this is mostly useful for programming) #' @param simParamBee \code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters -#' @param nThreads integer, number of cores to use for parallel computing (over colonies) +#' @param populateColonies boolean, whether to create n empty Colony objects within with assigned ID #' #' @details When both \code{x} and \code{n} are \code{NULL}, then a #' \code{\link[SIMplyBee]{MultiColony-class}} with 0 colonies is created. @@ -49,24 +49,26 @@ #' apiary[[2]] #' #' @export -createMultiColony <- function(x = NULL, n = NULL, simParamBee = NULL, nThreads = NULL) { +createMultiColony <- function(x = NULL, n = NULL, simParamBee = NULL, populateColonies = FALSE) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } - if (is.null(nThreads)) { - nThreads <- simParamBee$nThreads - } - registerDoParallel(cores = nThreads) + + registerDoParallel(cores = simParamBee$nThreads) if (is.null(x)) { if (is.null(n)) { ret <- new(Class = "MultiColony") } else { ret <- new(Class = "MultiColony", colonies = vector(mode = "list", length = n)) - ids <- (simParamBee$lastColonyId+1):(simParamBee$lastColonyId + n) - ret@colonies <- foreach(colony = seq_len(n)) %dopar% { - createColony(simParamBee = simParamBee, id = ids[colony]) + if (populateColonies) { + ids <- (simParamBee$lastColonyId+1):(simParamBee$lastColonyId + n) + ret@colonies <- foreach(colony = seq_len(n)) %dopar% { + createColony(simParamBee = simParamBee, id = ids[colony]) + } + simParamBee$updateLastColonyId(n = n) + } else { + } - simParamBee$updateLastColonyId(n = n) } } else { if (!isPop(x)) { From 4a4764f2906b06418b2d74e3ea6d7a4414de2134 Mon Sep 17 00:00:00 2001 From: Gregor Gorjanc Date: Tue, 21 Oct 2025 14:30:14 +0100 Subject: [PATCH 34/42] Update NEWS.md --- NEWS.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/NEWS.md b/NEWS.md index bb8b0965..338299e6 100644 --- a/NEWS.md +++ b/NEWS.md @@ -52,7 +52,7 @@ 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) +- parallelised all the major functions (so they run on simParamBee$nThreads cores) - swarm/split/supersede do no longer store the name of the queen From bf1384ff1355e62414d19fd7110886f62a31d3b3 Mon Sep 17 00:00:00 2001 From: janaobsteter Date: Wed, 19 Nov 2025 15:41:07 +0100 Subject: [PATCH 35/42] Removed "year" argument from functions (that is year of queen birth), resolved issues in the split function --- NAMESPACE | 1 - NEWS.md | 2 +- R/Functions_L0_auxilary.R | 144 -------------------------------------- R/Functions_L1_Pop.R | 90 +----------------------- R/Functions_L2_Colony.R | 41 +++++------ 5 files changed, 22 insertions(+), 256 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index c2382781..60d468aa 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -76,7 +76,6 @@ export(getPooledGeno) export(getQtlGeno) export(getQtlHaplo) export(getQueen) -export(getQueenAge) export(getQueenCsdAlleles) export(getQueenCsdGeno) export(getQueenGv) diff --git a/NEWS.md b/NEWS.md index bb8b0965..3743a64b 100644 --- a/NEWS.md +++ b/NEWS.md @@ -54,7 +54,7 @@ which caused an error. We now read in the locations from a csv file. - parallelised all the major functions (so they run on simParamBee$nThreads) -- swarm/split/supersede do no longer store the name of the queen +- 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 diff --git a/R/Functions_L0_auxilary.R b/R/Functions_L0_auxilary.R index 7d90ccbd..65160d15 100644 --- a/R/Functions_L0_auxilary.R +++ b/R/Functions_L0_auxilary.R @@ -983,150 +983,6 @@ isNULLColonies <- function(multicolony) { # get (general) ---- -#' @rdname getQueenYearOfBirth -#' @title Access the queen's year of birth -#' -#' @description Level 0 function that returns the queen's year of birth. -#' -#' @param x \code{\link[AlphaSimR]{Pop-class}} (one or more than one queen), -#' \code{\link[SIMplyBee]{Colony-class}} (one colony), or -#' \code{\link[SIMplyBee]{MultiColony-class}} (more colonies) -#' @param simParamBee \code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters -#' -#' @return numeric, the year of birth of the queen(s); named when theres is more -#' than one queen; \code{NA} if queen not present -#' -#' @examples -#' founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) -#' SP <- SimParamBee$new(founderGenomes) -#' \dontshow{SP$nThreads = 1L} -#' basePop <- createVirginQueens(founderGenomes) -#' -#' drones <- createDrones(x = basePop[1], nInd = 1000) -#' droneGroups <- pullDroneGroupsFromDCA(drones, n = 10, nDrones = nFathersPoisson) -#' -#' # Create a Colony and a MultiColony class -#' colony <- createColony(x = basePop[2]) -#' colony <- cross(colony, drones = droneGroups[[1]]) -#' -#' apiary <- createMultiColony(basePop[3:4], n = 2) -#' apiary <- cross(apiary, drones = droneGroups[c(2, 3)]) -#' -#' queen <- getQueen(colony) -#' queen <- setQueensYearOfBirth(queen, year = 2022) -#' getQueenYearOfBirth(queen) -#' -#' getQueenYearOfBirth(getQueen(colony)) -#' colony <- setQueensYearOfBirth(colony, year = 2030) -#' getQueenYearOfBirth(colony) -#' -#' apiary <- setQueensYearOfBirth(apiary, year = 2022) -#' getQueenYearOfBirth(apiary) -#' @export -getQueenYearOfBirth <- function(x, simParamBee = NULL) { - if (is.null(simParamBee)) { - simParamBee <- get(x = "SP", envir = .GlobalEnv) - } - if (isPop(x)) { - if (any(!(isVirginQueen(x, simParamBee = simParamBee) | isQueen(x, simParamBee = simParamBee)))) { - stop("Individuals in x must be virgin queens or queens!") - } - nInd <- nInd(x) - ret <- rep(x = NA, times = nInd) - for (ind in seq_len(nInd)) { - if (!is.null(x@misc$yearOfBirth[[ind]])) { - ret[ind] <- x@misc$yearOfBirth[[ind]] - } - } - if (nInd > 1) { - names(ret) <- getId(x) - } - } else if (isColony(x)) { - ret <- ifelse(is.null(x@queen@misc$yearOfBirth[[1]]), NA, x@queen@misc$yearOfBirth[[1]]) - } else if (isMultiColony(x)) { - ret <- sapply(X = x@colonies, FUN = getQueenYearOfBirth, simParamBee = simParamBee) - names(ret) <- getId(x) - } else { - stop("Argument x must be a Pop, Colony, or MultiColony class object!") - } - return(ret) -} - -#' @rdname getQueenAge -#' @title Get (calculate) the queen's age -#' -#' @description Level 0 function that returns the queen's age. -#' -#' @param x \code{\link[AlphaSimR]{Pop-class}}, \code{\link[SIMplyBee]{Colony-class}}, or -#' \code{\link[SIMplyBee]{MultiColony-class}} -#' @param currentYear integer, current year -#' @param simParamBee \code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters -#' -#' @return numeric, the age of the queen(s); named when theres is more -#' than one queen; \code{NA} if queen not present -#' -#' @examples -#' founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) -#' SP <- SimParamBee$new(founderGenomes) -#' \dontshow{SP$nThreads = 1L} -#' basePop <- createVirginQueens(founderGenomes) -#' -#' drones <- createDrones(x = basePop[1], nInd = 1000) -#' droneGroups <- pullDroneGroupsFromDCA(drones, n = 10, nDrones = nFathersPoisson) -#' -#' # Create a Colony and a MultiColony class -#' colony <- createColony(x = basePop[2]) -#' colony <- cross(colony, drones = droneGroups[[1]]) -#' apiary <- createMultiColony(basePop[3:4], n = 2) -#' apiary <- cross(apiary, drones = droneGroups[c(2, 3)]) -#' -#' queen <- getQueen(colony) -#' queen <- setQueensYearOfBirth(queen, year = 2020) -#' getQueenAge(queen, currentYear = 2022) -#' -#' colony <- setQueensYearOfBirth(colony, year = 2021) -#' getQueenAge(colony, currentYear = 2022) -#' -#' apiary <- setQueensYearOfBirth(apiary, year = 2018) -#' getQueenAge(apiary, currentYear = 2022) -#' @export -getQueenAge <- function(x, currentYear, simParamBee = NULL) { - if (is.null(simParamBee)) { - simParamBee <- get(x = "SP", envir = .GlobalEnv) - } - if (isPop(x)) { - if (any(!(isVirginQueen(x, simParamBee = simParamBee) | isQueen(x, simParamBee = simParamBee)))) { - stop("Individuals in x must be virgin queens or queens!") - } - nInd <- nInd(x) - ret <- rep(x = NA, times = nInd) - for (ind in seq_len(nInd)) { - if (!is.null(x@misc$yearOfBirth[[ind]])) { - ret[ind] <- currentYear - x@misc$yearOfBirth[[ind]] - } - } - if (nInd > 1) { - names(ret) <- getId(x) - } - } else if (isColony(x)) { - if (isQueenPresent(x, simParamBee = simParamBee)) { - if(packageVersion("AlphaSimR") > package_version("1.5.3")){ - ret <- currentYear - x@queen@misc$yearOfBirth[[1]] - }else{ - ret <- currentYear - x@queen@misc[[1]]$yearOfBirth - } - } else { - ret <- NA - } - } else if (isMultiColony(x)) { - ret <- sapply(X = x@colonies, FUN = getQueenAge, currentYear = currentYear) - names(ret) <- getId(x) - } else { - stop("Argument x must be a Pop, Colony, or MultiColony class object!") - } - return(ret) -} - #' @rdname getId #' @title Get the colony ID #' diff --git a/R/Functions_L1_Pop.R b/R/Functions_L1_Pop.R index bf086960..53c3e047 100644 --- a/R/Functions_L1_Pop.R +++ b/R/Functions_L1_Pop.R @@ -297,7 +297,6 @@ getVirginQueens <- function(x, nInd = NULL, use = "rand", collapse = FALSE, simP #' only used when \code{x} is \code{\link[SIMplyBee]{Colony-class}} or #' \code{\link[SIMplyBee]{MultiColony-class}}, when \code{x} is \code{link[AlphaSimR]{MapPop-class}} #' all individuals in \code{x} are converted into virgin queens -#' @param year numeric, year of birth for virgin queens #' @param editCsd logical (only active when \code{x} is \code{link[AlphaSimR]{MapPop-class}}), #' whether the csd locus should be edited to ensure heterozygosity at the csd #' locus (to get viable virgin queens); see \code{csdAlleles} @@ -400,7 +399,6 @@ getVirginQueens <- function(x, nInd = NULL, use = "rand", collapse = FALSE, simP # patrilines # https://github.com/HighlanderLab/SIMplyBee/issues/78 createCastePop <- function(x, caste = NULL, nInd = NULL, - year = NULL, editCsd = TRUE, csdAlleles = NULL, simParamBee = NULL, returnSP = FALSE, @@ -439,9 +437,6 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, ret@sex[] <- "F" simParamBee$changeCaste(id = ret@id, caste = "virginQueens") - # if (!is.null(year)) { - # ret <- setQueensYearOfBirth(x = ret, year = year, simParamBee = simParamBee) - # } } else if (isPop(x)) { if (caste != "drones") { # Creating drones if input is a Pop stop("Pop-class can only be used to create drones!") @@ -535,8 +530,8 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, if (isCsdActive(simParamBee = simParamBee)) { sel <- isCsdHeterozygous(pop = ret$workers, simParamBee = simParamBee) - ret$workers <- ret$workers[sel] ret$nHomBrood <- nInd(ret$workers) - sum(sel) + ret$workers <- ret$workers[sel] } else { ret$nHomBrood <- NA } @@ -551,11 +546,7 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, if (!returnSP) { ret <- ret$workers } - # print(ret) - # if ((nInd(ret) > 0) & (!is.null(year))) { - # print("Setting by") - # ret <- setQueensYearOfBirth(x = ret, year = year, simParamBee = simParamBee) - # } + } else if (caste == "drones") { drones <- makeDH( pop = getQueen(x, simParamBee = simParamBee), nDH = nInd, keepParents = FALSE, @@ -657,7 +648,6 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, createCastePop( x = x[[colony]], caste = caste, nInd = nIndColony, - year = year, editCsd = TRUE, csdAlleles = NULL, simParamBee = simParamBee, returnSP = TRUE, @@ -752,14 +742,13 @@ createDrones <- function(x, nInd = NULL, simParamBee = NULL, #' @describeIn createCastePop Create virgin queens from a colony #' @export createVirginQueens <- function(x, nInd = NULL, - year = NULL, editCsd = TRUE, csdAlleles = NULL, simParamBee = NULL, returnSP = FALSE, ids = NULL, ...) { ret <- createCastePop(x, caste = "virginQueens", nInd = nInd, - year = year, editCsd = editCsd, + editCsd = editCsd, csdAlleles = csdAlleles, simParamBee = simParamBee, returnSP = returnSP, ids = ids, ...) @@ -1812,76 +1801,3 @@ cross <- function(x, return(ret) } - -#' @rdname setQueensYearOfBirth -#' @title Set the queen's year of birth -#' -#' @description Level 1 function that sets the queen's year of birth. -#' -#' @param x \code{\link[AlphaSimR]{Pop-class}} (one or more than one queen), -#' \code{\link[SIMplyBee]{Colony-class}} (one colony), or -#' \code{\link[SIMplyBee]{MultiColony-class}} (more colonies) -#' @param year integer, the year of the birth of the queen -#' @param simParamBee \code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters -#' -#' @return \code{\link[AlphaSimR]{Pop-class}}, \code{\link[SIMplyBee]{Colony-class}}, or -#' \code{\link[SIMplyBee]{MultiColony-class}} with queens having the year of birth set -#' -#' @examples -#' founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) -#' SP <- SimParamBee$new(founderGenomes) -#' \dontshow{SP$nThreads = 1L} -#' basePop <- createVirginQueens(founderGenomes) -#' -#' drones <- createDrones(x = basePop[1], nInd = 1000) -#' droneGroups <- pullDroneGroupsFromDCA(drones, n = 10, nDrones = nFathersPoisson) -#' -#' # Create a Colony and a MultiColony class -#' colony <- createColony(x = basePop[2]) -#' colony <- cross(x = colony, drones = droneGroups[[1]]) -#' apiary <- createMultiColony(basePop[3:4], n = 2) -#' apiary <- cross(apiary, drones = droneGroups[c(2, 3)]) -#' -#' # Example on Colony class -#' getQueenYearOfBirth(colony) -#' getQueenYearOfBirth(apiary) -#' -#' queen1 <- getQueen(colony) -#' queen1 <- setQueensYearOfBirth(queen1, year = 2022) -#' getQueenYearOfBirth(queen1) -#' -#' colony <- setQueensYearOfBirth(colony, year = 2022) -#' getQueenYearOfBirth(colony) -#' -#' apiary <- setQueensYearOfBirth(apiary, year = 2022) -#' getQueenYearOfBirth(apiary) -#' @export -setQueensYearOfBirth <- function(x, year, simParamBee = NULL) { - if (is.null(simParamBee)) { - simParamBee <- get(x = "SP", envir = .GlobalEnv) - } - if (isPop(x)) { - if (any(!(isVirginQueen(x, simParamBee = simParamBee) | isQueen(x, simParamBee = simParamBee)))) { - stop("Individuals in x must be virgin queens or queens!") - } - nInd <- nInd(x) - x <- setMisc(x = x, node = "yearOfBirth", value = year) - } else if (isColony(x)) { - if (isQueenPresent(x, simParamBee = simParamBee)) { - x@queen <- setMisc(x = x@queen, node = "yearOfBirth", value = year) - } else { - stop("Missing queen!") - } - } else if (isMultiColony(x)) { - nCol <- nColonies(x) - for (colony in seq_len(nCol)) { - x[[colony]]@queen <- setMisc( - x = x[[colony]]@queen, node = "yearOfBirth", - value = year - ) - } - } else { - stop("Argument x must be a Pop, Colony or MultiColony class object!") - } - return(x) -} diff --git a/R/Functions_L2_Colony.R b/R/Functions_L2_Colony.R index 0a64bb2e..d3739322 100644 --- a/R/Functions_L2_Colony.R +++ b/R/Functions_L2_Colony.R @@ -233,7 +233,6 @@ addCastePop_internal <- function(pop, colony, caste, new = FALSE) { #' a single value is provided, the same value will be used for all the colonies. #' @param new logical, should the number of individuals be added to the caste population #' anew or should we only top-up the existing number of individuals to \code{nInd} -#' @param year numeric, only relevant when adding virgin queens - year of birth for virgin queens #' @param simParamBee \code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters #' @param ... additional arguments passed to \code{nInd} when this argument is a function #' @@ -291,7 +290,7 @@ addCastePop_internal <- function(pop, colony, caste, new = FALSE) { #' #' @export addCastePop <- function(x, caste = NULL, nInd = NULL, new = FALSE, - year = NULL, simParamBee = NULL, ...) { + simParamBee = NULL, ...) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } @@ -333,7 +332,7 @@ addCastePop <- function(x, caste = NULL, nInd = NULL, new = FALSE, if (0 < nInd) { newInds <- createCastePop(x, nInd, caste = caste, - year = year, simParamBee = simParamBee + simParamBee = simParamBee ) if (caste == "workers") { homInds <- newInds$nHomBrood @@ -365,7 +364,7 @@ addCastePop <- function(x, caste = NULL, nInd = NULL, new = FALSE, newInds <- createCastePop(x, nInd, caste = caste, - year = year, simParamBee = simParamBee, + simParamBee = simParamBee, returnSP = FALSE, ...) @@ -429,10 +428,10 @@ addDrones <- function(x, nInd = NULL, new = FALSE, #' @describeIn addCastePop Add virgin queens to a colony #' @export addVirginQueens <- function(x, nInd = NULL, new = FALSE, - year = NULL, simParamBee = NULL, ...) { + simParamBee = NULL, ...) { ret <- addCastePop( x = x, caste = "virginQueens", nInd = nInd, new = new, - year = year, simParamBee = simParamBee, ... + simParamBee = simParamBee, ... ) return(ret) } @@ -812,8 +811,6 @@ downsize <- function(x, p = NULL, use = "rand", new = FALSE, #' a single value is provided, the same value will be applied to all the colonies #' @param use character, all the options provided by \code{\link[AlphaSimR]{selectInd}} - #' guides selection of caste individuals that stay when \code{p < 1} -#' @param year numeric, only relevant when replacing virgin queens, -#' year of birth for virgin queens #' @param simParamBee \code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters #' #' @return \code{\link[SIMplyBee]{Colony-class}} or or \code{\link[SIMplyBee]{MultiColony-class}} with @@ -851,7 +848,7 @@ downsize <- function(x, p = NULL, use = "rand", new = FALSE, #' getCasteId(apiary, caste="workers") #' @export replaceCastePop <- function(x, caste = NULL, p = 1, use = "rand", - year = NULL, simParamBee = NULL) { + simParamBee = NULL) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } @@ -898,12 +895,12 @@ replaceCastePop <- function(x, caste = NULL, p = 1, use = "rand", x <- addCastePop(x, caste = caste, nInd = nIndAdd, - year = year, simParamBee = simParamBee + simParamBee = simParamBee ) } else { x <- addCastePop( x = x, caste = caste, nInd = nIndReplaced, new = TRUE, - year = year, simParamBee = simParamBee + simParamBee = simParamBee ) } } @@ -959,7 +956,7 @@ replaceVirginQueens <- function(x, p = 1, use = "rand", simParamBee = NULL) { #' a single value is provided, the same value will be applied to all the colonies #' @param use character, all the options provided by \code{\link[AlphaSimR]{selectInd}} - #' guides selection of virgins queens that will stay when \code{p < 1} -#' @param year numeric, only relevant when adding virgin queens - year of birth for virgin queens + #' @param simParamBee \code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters #' #' @return \code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}} without virgin queens @@ -998,7 +995,7 @@ replaceVirginQueens <- function(x, p = 1, use = "rand", simParamBee = NULL) { #' nWorkers(removeWorkers(apiary, p = c(0.1, 0.5))) #' @export removeCastePop <- function(x, caste = NULL, p = 1, use = "rand", - year = NULL, simParamBee = NULL) { + simParamBee = NULL) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } @@ -1070,8 +1067,8 @@ removeCastePop <- function(x, caste = NULL, p = 1, use = "rand", #' @describeIn removeCastePop Remove queen from a colony #' @export #' -removeQueen <- function(x, year = NULL, simParamBee = NULL) { - ret <- removeCastePop(x = x, caste = "queen", p = 1, year = year, simParamBee = simParamBee) +removeQueen <- function(x, simParamBee = NULL) { + ret <- removeCastePop(x = x, caste = "queen", p = 1, simParamBee = simParamBee) return(ret) } @@ -1307,7 +1304,6 @@ collapse <- function(x, simParamBee = NULL) { #' If input is \code{\link[SIMplyBee]{MultiColony-class}}, #' the input could also be a vector of the same length as the number of colonies. If #' a single value is provided, the same value will be applied to all the colonies -#' @param year numeric, year of birth for virgin queens #' @param sampleLocation logical, sample location of the swarm by taking #' the current colony location and adding deviates to each coordinate using #' \code{\link[SIMplyBee]{rcircle}} @@ -1360,7 +1356,7 @@ collapse <- function(x, simParamBee = NULL) { #' # Swarm only the pulled colonies #' (swarm(tmp$pulled, p = 0.6)) #' @export -swarm <- function(x, p = NULL, year = NULL, +swarm <- function(x, p = NULL, sampleLocation = TRUE, radius = NULL, simParamBee = NULL, ...) { if (is.null(simParamBee)) { @@ -1417,7 +1413,6 @@ swarm <- function(x, p = NULL, year = NULL, tmpVirginQueens <- createCastePop( x = x, nInd = max(10, simParamBee$nVirginQueens), - year = year, caste = "virginQueens", simParamBee = simParamBee ) @@ -1658,8 +1653,9 @@ supersede <- function(x, simParamBee = NULL, ...) { #' into two new colonies to #' prevent swarming (in managed situation). The remnant colony retains the #' queen and a proportion of the workers and all drones. The split colony gets -#' the other part of the workers, which raise virgin queens, of which only one -#' prevails. Location of the split is the same as for the remnant. +#' the other part of the workers, but note that it is queenless, since the beekeepers +#' would normally requeen with a different queen. +#' Location of the split is the same as for the remnant. #' #' @param x \code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}} #' @param p numeric, proportion of workers that will go to the split colony; if @@ -1798,11 +1794,11 @@ split <- function(x, p = NULL, simParamBee = NULL, ...) { split = createMultiColony(n = nCol, simParamBee = simParamBee, populateColonies = TRUE), - remnant = tmp$remnant + remnant = remnantColony ) ret$split <- setLocation(x = ret$split, location = location) - tmp <- foreach(colony = seq_len(nCol)) %dopar% { + ret$split@colonies <- foreach(colony = seq_len(nCol)) %dopar% { addCastePop_internal(colony = ret$split@colonies[[colony]], pop = tmp$pulled[[colony]], caste = "workers") } @@ -1817,7 +1813,6 @@ split <- function(x, p = NULL, simParamBee = NULL, ...) { stop("Argument x must be a Colony or MultiColony class object!") } - message("Split colonies do not have a queen! You need to re-queen them manually.") validObject(ret$split) validObject(ret$remnant) return(ret) From 48609f6c58060c396d58b756b340a885eac7c80b Mon Sep 17 00:00:00 2001 From: Gregor Gorjanc Date: Thu, 20 Nov 2025 07:35:08 +0000 Subject: [PATCH 36/42] Apply suggestion from @gregorgorjanc --- R/Functions_L2_Colony.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/Functions_L2_Colony.R b/R/Functions_L2_Colony.R index d3739322..78ace6a9 100644 --- a/R/Functions_L2_Colony.R +++ b/R/Functions_L2_Colony.R @@ -1425,7 +1425,7 @@ swarm <- function(x, p = NULL, if (sum(homCol) > 0) { if (isColony(x)) { - stop("Colony to inbred to produce any virgin queens!") + stop("Colony too inbred to produce any virgin queens!") } else if (isMultiColony(x)) { warning(paste0(sum(homCol), " colonies produced 0 virgin queens due to high colony homozygosity, removing these colonies!")) tmpVirginQueens <- tmpVirginQueens[!homCol] From e307261c85fed8c5d2d6f37de3176658c8f89c44 Mon Sep 17 00:00:00 2001 From: janaobsteter Date: Thu, 20 Nov 2025 09:58:31 +0100 Subject: [PATCH 37/42] Updating documentation --- NAMESPACE | 2 -- man/addCastePop.Rd | 21 ++------------- man/createCastePop.Rd | 5 ---- man/createMultiColony.Rd | 9 +++++-- man/getQueenAge.Rd | 48 --------------------------------- man/getQueenYearOfBirth.Rd | 49 ---------------------------------- man/reQueen.Rd | 2 +- man/removeCastePop.Rd | 13 ++------- man/replaceCastePop.Rd | 12 +-------- man/setQueensYearOfBirth.Rd | 53 ------------------------------------- man/split.Rd | 9 +++---- man/supersede.Rd | 4 +-- man/swarm.Rd | 5 +--- 13 files changed, 19 insertions(+), 213 deletions(-) delete mode 100644 man/getQueenAge.Rd delete mode 100644 man/getQueenYearOfBirth.Rd delete mode 100644 man/setQueensYearOfBirth.Rd diff --git a/NAMESPACE b/NAMESPACE index 60d468aa..d912dc8c 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -87,7 +87,6 @@ export(getQueenSegSiteGeno) export(getQueenSegSiteHaplo) export(getQueenSnpGeno) export(getQueenSnpHaplo) -export(getQueenYearOfBirth) export(getSegSiteGeno) export(getSegSiteHaplo) export(getSnpGeno) @@ -193,7 +192,6 @@ export(resetEvents) export(selectColonies) export(setLocation) export(setMisc) -export(setQueensYearOfBirth) export(simulateHoneyBeeGenomes) export(split) export(splitPColonyStrength) diff --git a/man/addCastePop.Rd b/man/addCastePop.Rd index 9c58ba26..b18d7704 100644 --- a/man/addCastePop.Rd +++ b/man/addCastePop.Rd @@ -7,28 +7,13 @@ \alias{addVirginQueens} \title{Add caste individuals to the colony} \usage{ -addCastePop( - x, - caste = NULL, - nInd = NULL, - new = FALSE, - year = NULL, - simParamBee = NULL, - ... -) +addCastePop(x, caste = NULL, nInd = NULL, new = FALSE, simParamBee = NULL, ...) addWorkers(x, nInd = NULL, new = FALSE, simParamBee = NULL, ...) addDrones(x, nInd = NULL, new = FALSE, simParamBee = NULL, ...) -addVirginQueens( - x, - nInd = NULL, - new = FALSE, - year = NULL, - simParamBee = NULL, - ... -) +addVirginQueens(x, nInd = NULL, new = FALSE, simParamBee = NULL, ...) } \arguments{ \item{x}{\code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}}} @@ -44,8 +29,6 @@ a single value is provided, the same value will be used for all the colonies.} \item{new}{logical, should the number of individuals be added to the caste population anew or should we only top-up the existing number of individuals to \code{nInd}} -\item{year}{numeric, only relevant when adding virgin queens - year of birth for virgin queens} - \item{simParamBee}{\code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters} \item{...}{additional arguments passed to \code{nInd} when this argument is a function} diff --git a/man/createCastePop.Rd b/man/createCastePop.Rd index 6cc9be6c..63c3576b 100644 --- a/man/createCastePop.Rd +++ b/man/createCastePop.Rd @@ -11,7 +11,6 @@ createCastePop( x, caste = NULL, nInd = NULL, - year = NULL, editCsd = TRUE, csdAlleles = NULL, simParamBee = NULL, @@ -41,7 +40,6 @@ createDrones( createVirginQueens( x, nInd = NULL, - year = NULL, editCsd = TRUE, csdAlleles = NULL, simParamBee = NULL, @@ -64,8 +62,6 @@ only used when \code{x} is \code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}}, when \code{x} is \code{link[AlphaSimR]{MapPop-class}} all individuals in \code{x} are converted into virgin queens} -\item{year}{numeric, year of birth for virgin queens} - \item{editCsd}{logical (only active when \code{x} is \code{link[AlphaSimR]{MapPop-class}}), whether the csd locus should be edited to ensure heterozygosity at the csd locus (to get viable virgin queens); see \code{csdAlleles}} @@ -87,7 +83,6 @@ for each created population (used internally for parallel computing)} \item{ids}{character, IDs of the individuals that are going to be created (used internally for parallel computing)} -\item{nThreads}{integer, number of cores to use for parallel computing (over colonies)} \item{...}{additional arguments passed to \code{nInd} when this argument is a function} } diff --git a/man/createMultiColony.Rd b/man/createMultiColony.Rd index b1c48ec3..7951d430 100644 --- a/man/createMultiColony.Rd +++ b/man/createMultiColony.Rd @@ -4,7 +4,12 @@ \alias{createMultiColony} \title{Create MultiColony object} \usage{ -createMultiColony(x = NULL, n = NULL, simParamBee = NULL, nThreads = NULL) +createMultiColony( + x = NULL, + n = NULL, + simParamBee = NULL, + populateColonies = FALSE +) } \arguments{ \item{x}{\code{\link[AlphaSimR]{Pop-class}}, virgin queens or queens for the colonies @@ -17,7 +22,7 @@ given then \code{\link[SIMplyBee]{MultiColony-class}} is created with \code{n} \item{simParamBee}{\code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters} -\item{nThreads}{integer, number of cores to use for parallel computing (over colonies)} +\item{populateColonies}{boolean, whether to create n empty Colony objects within with assigned ID} } \value{ \code{\link[SIMplyBee]{MultiColony-class}} diff --git a/man/getQueenAge.Rd b/man/getQueenAge.Rd deleted file mode 100644 index dba30d22..00000000 --- a/man/getQueenAge.Rd +++ /dev/null @@ -1,48 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/Functions_L0_auxilary.R -\name{getQueenAge} -\alias{getQueenAge} -\title{Get (calculate) the queen's age} -\usage{ -getQueenAge(x, currentYear, simParamBee = NULL) -} -\arguments{ -\item{x}{\code{\link[AlphaSimR]{Pop-class}}, \code{\link[SIMplyBee]{Colony-class}}, or -\code{\link[SIMplyBee]{MultiColony-class}}} - -\item{currentYear}{integer, current year} - -\item{simParamBee}{\code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters} -} -\value{ -numeric, the age of the queen(s); named when theres is more - than one queen; \code{NA} if queen not present -} -\description{ -Level 0 function that returns the queen's age. -} -\examples{ -founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) -SP <- SimParamBee$new(founderGenomes) -\dontshow{SP$nThreads = 1L} -basePop <- createVirginQueens(founderGenomes) - -drones <- createDrones(x = basePop[1], nInd = 1000) -droneGroups <- pullDroneGroupsFromDCA(drones, n = 10, nDrones = nFathersPoisson) - -# Create a Colony and a MultiColony class -colony <- createColony(x = basePop[2]) -colony <- cross(colony, drones = droneGroups[[1]]) -apiary <- createMultiColony(basePop[3:4], n = 2) -apiary <- cross(apiary, drones = droneGroups[c(2, 3)]) - -queen <- getQueen(colony) -queen <- setQueensYearOfBirth(queen, year = 2020) -getQueenAge(queen, currentYear = 2022) - -colony <- setQueensYearOfBirth(colony, year = 2021) -getQueenAge(colony, currentYear = 2022) - -apiary <- setQueensYearOfBirth(apiary, year = 2018) -getQueenAge(apiary, currentYear = 2022) -} diff --git a/man/getQueenYearOfBirth.Rd b/man/getQueenYearOfBirth.Rd deleted file mode 100644 index 0db401d3..00000000 --- a/man/getQueenYearOfBirth.Rd +++ /dev/null @@ -1,49 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/Functions_L0_auxilary.R -\name{getQueenYearOfBirth} -\alias{getQueenYearOfBirth} -\title{Access the queen's year of birth} -\usage{ -getQueenYearOfBirth(x, simParamBee = NULL) -} -\arguments{ -\item{x}{\code{\link[AlphaSimR]{Pop-class}} (one or more than one queen), -\code{\link[SIMplyBee]{Colony-class}} (one colony), or -\code{\link[SIMplyBee]{MultiColony-class}} (more colonies)} - -\item{simParamBee}{\code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters} -} -\value{ -numeric, the year of birth of the queen(s); named when theres is more - than one queen; \code{NA} if queen not present -} -\description{ -Level 0 function that returns the queen's year of birth. -} -\examples{ -founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) -SP <- SimParamBee$new(founderGenomes) -\dontshow{SP$nThreads = 1L} -basePop <- createVirginQueens(founderGenomes) - -drones <- createDrones(x = basePop[1], nInd = 1000) -droneGroups <- pullDroneGroupsFromDCA(drones, n = 10, nDrones = nFathersPoisson) - -# Create a Colony and a MultiColony class -colony <- createColony(x = basePop[2]) -colony <- cross(colony, drones = droneGroups[[1]]) - -apiary <- createMultiColony(basePop[3:4], n = 2) -apiary <- cross(apiary, drones = droneGroups[c(2, 3)]) - -queen <- getQueen(colony) -queen <- setQueensYearOfBirth(queen, year = 2022) -getQueenYearOfBirth(queen) - -getQueenYearOfBirth(getQueen(colony)) -colony <- setQueensYearOfBirth(colony, year = 2030) -getQueenYearOfBirth(colony) - -apiary <- setQueensYearOfBirth(apiary, year = 2022) -getQueenYearOfBirth(apiary) -} diff --git a/man/reQueen.Rd b/man/reQueen.Rd index e90abb52..61e22665 100644 --- a/man/reQueen.Rd +++ b/man/reQueen.Rd @@ -46,7 +46,7 @@ droneGroups <- pullDroneGroupsFromDCA(drones, n = 7, nDrones = nFathersPoisson) # Create and cross Colony and MultiColony class colony <- createColony(x = basePop[2]) colony <- cross(colony, drones = droneGroups[[1]]) -apiary <- createMultiColony(basePop[3:4], n = 2) +apiary <- createMultiColony(basePop[3:4]) apiary <- cross(apiary, drones = droneGroups[2:3]) # Check queen and virgin queens IDs diff --git a/man/removeCastePop.Rd b/man/removeCastePop.Rd index e47267ed..e705e435 100644 --- a/man/removeCastePop.Rd +++ b/man/removeCastePop.Rd @@ -8,16 +8,9 @@ \alias{removeVirginQueens} \title{Remove a proportion of caste individuals from a colony} \usage{ -removeCastePop( - x, - caste = NULL, - p = 1, - use = "rand", - year = NULL, - simParamBee = NULL -) +removeCastePop(x, caste = NULL, p = 1, use = "rand", simParamBee = NULL) -removeQueen(x, year = NULL, simParamBee = NULL) +removeQueen(x, simParamBee = NULL) removeWorkers(x, p = 1, use = "rand", simParamBee = NULL) @@ -37,8 +30,6 @@ a single value is provided, the same value will be applied to all the colonies} \item{use}{character, all the options provided by \code{\link[AlphaSimR]{selectInd}} - guides selection of virgins queens that will stay when \code{p < 1}} -\item{year}{numeric, only relevant when adding virgin queens - year of birth for virgin queens} - \item{simParamBee}{\code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters} } \value{ diff --git a/man/replaceCastePop.Rd b/man/replaceCastePop.Rd index c23232cc..513b5abd 100644 --- a/man/replaceCastePop.Rd +++ b/man/replaceCastePop.Rd @@ -7,14 +7,7 @@ \alias{replaceVirginQueens} \title{Replace a proportion of caste individuals with new ones} \usage{ -replaceCastePop( - x, - caste = NULL, - p = 1, - use = "rand", - year = NULL, - simParamBee = NULL -) +replaceCastePop(x, caste = NULL, p = 1, use = "rand", simParamBee = NULL) replaceWorkers(x, p = 1, use = "rand", simParamBee = NULL) @@ -35,9 +28,6 @@ a single value is provided, the same value will be applied to all the colonies} \item{use}{character, all the options provided by \code{\link[AlphaSimR]{selectInd}} - guides selection of caste individuals that stay when \code{p < 1}} -\item{year}{numeric, only relevant when replacing virgin queens, -year of birth for virgin queens} - \item{simParamBee}{\code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters} } \value{ diff --git a/man/setQueensYearOfBirth.Rd b/man/setQueensYearOfBirth.Rd deleted file mode 100644 index 094eea2f..00000000 --- a/man/setQueensYearOfBirth.Rd +++ /dev/null @@ -1,53 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/Functions_L1_Pop.R -\name{setQueensYearOfBirth} -\alias{setQueensYearOfBirth} -\title{Set the queen's year of birth} -\usage{ -setQueensYearOfBirth(x, year, simParamBee = NULL) -} -\arguments{ -\item{x}{\code{\link[AlphaSimR]{Pop-class}} (one or more than one queen), -\code{\link[SIMplyBee]{Colony-class}} (one colony), or -\code{\link[SIMplyBee]{MultiColony-class}} (more colonies)} - -\item{year}{integer, the year of the birth of the queen} - -\item{simParamBee}{\code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters} -} -\value{ -\code{\link[AlphaSimR]{Pop-class}}, \code{\link[SIMplyBee]{Colony-class}}, or - \code{\link[SIMplyBee]{MultiColony-class}} with queens having the year of birth set -} -\description{ -Level 1 function that sets the queen's year of birth. -} -\examples{ -founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) -SP <- SimParamBee$new(founderGenomes) -\dontshow{SP$nThreads = 1L} -basePop <- createVirginQueens(founderGenomes) - -drones <- createDrones(x = basePop[1], nInd = 1000) -droneGroups <- pullDroneGroupsFromDCA(drones, n = 10, nDrones = nFathersPoisson) - -# Create a Colony and a MultiColony class -colony <- createColony(x = basePop[2]) -colony <- cross(x = colony, drones = droneGroups[[1]]) -apiary <- createMultiColony(basePop[3:4], n = 2) -apiary <- cross(apiary, drones = droneGroups[c(2, 3)]) - -# Example on Colony class -getQueenYearOfBirth(colony) -getQueenYearOfBirth(apiary) - -queen1 <- getQueen(colony) -queen1 <- setQueensYearOfBirth(queen1, year = 2022) -getQueenYearOfBirth(queen1) - -colony <- setQueensYearOfBirth(colony, year = 2022) -getQueenYearOfBirth(colony) - -apiary <- setQueensYearOfBirth(apiary, year = 2022) -getQueenYearOfBirth(apiary) -} diff --git a/man/split.Rd b/man/split.Rd index 7def12fb..0fab0d75 100644 --- a/man/split.Rd +++ b/man/split.Rd @@ -4,7 +4,7 @@ \alias{split} \title{Split colony in two MultiColony} \usage{ -split(x, p = NULL, year = NULL, simParamBee = NULL, ...) +split(x, p = NULL, simParamBee = NULL, ...) } \arguments{ \item{x}{\code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}}} @@ -15,8 +15,6 @@ If input is \code{\link[SIMplyBee]{MultiColony-class}}, the input could also be a vector of the same length as the number of colonies. If a single value is provided, the same value will be applied to all the colonies} -\item{year}{numeric, year of birth for virgin queens} - \item{simParamBee}{\code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters} \item{...}{additional arguments passed to \code{p} when this argument is a @@ -32,8 +30,9 @@ Level 2 function that splits a Colony or MultiColony object into two new colonies to prevent swarming (in managed situation). The remnant colony retains the queen and a proportion of the workers and all drones. The split colony gets - the other part of the workers, which raise virgin queens, of which only one - prevails. Location of the split is the same as for the remnant. + the other part of the workers, but note that it is queenless, since the beekeepers + would normally requeen with a different queen. + Location of the split is the same as for the remnant. } \examples{ founderGenomes <- quickHaplo(nInd = 10, nChr = 1, segSites = 50) diff --git a/man/supersede.Rd b/man/supersede.Rd index 019a21cd..051c8401 100644 --- a/man/supersede.Rd +++ b/man/supersede.Rd @@ -4,13 +4,11 @@ \alias{supersede} \title{Supersede} \usage{ -supersede(x, year = NULL, simParamBee = NULL, ...) +supersede(x, simParamBee = NULL, ...) } \arguments{ \item{x}{\code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}}} -\item{year}{numeric, year of birth for virgin queens} - \item{simParamBee}{\code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters} \item{...}{additional arguments passed to \code{nVirginQueens} when this diff --git a/man/swarm.Rd b/man/swarm.Rd index 72c7e88f..3895f184 100644 --- a/man/swarm.Rd +++ b/man/swarm.Rd @@ -7,7 +7,6 @@ swarm( x, p = NULL, - year = NULL, sampleLocation = TRUE, radius = NULL, simParamBee = NULL, @@ -23,8 +22,6 @@ If input is \code{\link[SIMplyBee]{MultiColony-class}}, the input could also be a vector of the same length as the number of colonies. If a single value is provided, the same value will be applied to all the colonies} -\item{year}{numeric, year of birth for virgin queens} - \item{sampleLocation}{logical, sample location of the swarm by taking the current colony location and adding deviates to each coordinate using \code{\link[SIMplyBee]{rcircle}}} @@ -66,7 +63,7 @@ droneGroups <- pullDroneGroupsFromDCA(drones, n = 10, nDrones = 10) colony <- createColony(x = basePop[2]) colony <- cross(colony, drones = droneGroups[[1]]) (colony <- buildUp(colony, nWorkers = 100)) -apiary <- createMultiColony(basePop[3:8], n = 6) +apiary <- createMultiColony(basePop[3:8]) apiary <- cross(apiary, drones = droneGroups[2:7]) apiary <- buildUp(apiary, nWorkers = 100) From 6ba1ec6cbca0e70d18ac1ff1b61a1c961eebb429 Mon Sep 17 00:00:00 2001 From: janaobsteter Date: Wed, 26 Nov 2025 13:52:21 +0100 Subject: [PATCH 38/42] Implementing PSOCK parallelisation, instead of forking (mcapply). Since it's slower, we keep the older version for then nThread = 1 --- DESCRIPTION | 2 +- NAMESPACE | 5 ++ R/Functions_L1_Pop.R | 80 +++++++++++++---- R/Functions_L2_Colony.R | 175 +++++++++++++++++++++++++++++++++----- R/Functions_L3_Colonies.R | 32 ++++++- R/SIMplyBee.R | 3 +- 6 files changed, 255 insertions(+), 42 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 4ef4a624..bdc0e699 100644 --- a/DESCRIPTION +++ b/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), foreach, doParallel +Imports: methods, R6, stats, utils, extraDistr (>= 1.9.1), RANN, Rcpp (>= 0.12.7), foreach, doParallel, parallel Depends: R (>= 3.3.0), AlphaSimR (>= 1.5.3) LinkingTo: Rcpp, RcppArmadillo (>= 0.7.500.0.0), BH RoxygenNote: 7.3.2 diff --git a/NAMESPACE b/NAMESPACE index d912dc8c..f6f27d9a 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -206,6 +206,7 @@ import(Rcpp) importFrom(R6,R6Class) importFrom(doParallel,registerDoParallel) importFrom(extraDistr,rtpois) +importFrom(foreach,"%do%") importFrom(foreach,"%dopar%") importFrom(foreach,foreach) importFrom(methods,"slot<-") @@ -219,6 +220,10 @@ importFrom(methods,setValidity) importFrom(methods,show) importFrom(methods,slot) importFrom(methods,validObject) +importFrom(parallel,clusterApply) +importFrom(parallel,clusterExport) +importFrom(parallel,makeCluster) +importFrom(parallel,stopCluster) importFrom(stats,na.omit) importFrom(stats,rbeta) importFrom(stats,rnorm) diff --git a/R/Functions_L1_Pop.R b/R/Functions_L1_Pop.R index 53c3e047..e4a3d46d 100644 --- a/R/Functions_L1_Pop.R +++ b/R/Functions_L1_Pop.R @@ -1,6 +1,12 @@ # ---- Level 1 Pop Functions ---- utils::globalVariables("colony") utils::globalVariables("i") +utils::globalVariables("cl") + +# Protect from accidental multicore use +options(mc.cores = 1) +Sys.setenv(OMP_NUM_THREADS = 1) +Sys.setenv(MKL_NUM_THREADS = 1) #' @rdname getCastePop #' @title Access individuals of a caste @@ -618,8 +624,6 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, stop("Nothing to create.") } - registerDoParallel(cores = simParamBee$nThreads) - lastId = simParamBee$lastId ids = (lastId+1):(lastId+totalNInd) @@ -637,7 +641,18 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, } } } - ret <- foreach(colony = seq_len(nCol), .combine=combine_list) %dopar% { + + if (simParamBee$nThreads > 1) { + N <- as.numeric(simParamBee$nThreads) + cl <- makeCluster(N, type="PSOCK") + registerDoParallel(cl) + + clusterExport(cl, c("SP")) + } else { + registerDoParallel(cores = 1) + } + + ret <- foreach(colony = seq_len(nCol), .combine=combine_list, .packages = c("SIMplyBee")) %dopar% { nIndColony <- ifelse(nNInd == 1, nInd, nInd[colony]) if (nIndColony > 0) { if (nNInd == 1) { @@ -657,6 +672,11 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, NULL } } + + if (simParamBee$nThreads > 1) { + stopCluster(cl) + } + if (nCol == 1) { ret <- list(ret) } @@ -1253,7 +1273,6 @@ pullCastePop <- function(x, caste, nInd = NULL, use = "rand", ret <- list(pulled = tmp$pulled, remnant = x) } } else if (isMultiColony(x)) { - registerDoParallel(cores = simParamBee$nThreads) nCol <- nColonies(x) nNInd <- length(nInd) if (nNInd > 1 && nNInd < nCol) { @@ -1269,7 +1288,16 @@ pullCastePop <- function(x, caste, nInd = NULL, use = "rand", names(ret$pulled) <- getId(x) ret$remnant <- x - tmp = foreach(colony = seq_len(nCol)) %dopar% { + if (simParamBee$nThreads > 1) { + N <- as.numeric(simParamBee$nThreads) + cl <- makeCluster(N, type="PSOCK") + registerDoParallel(cl) + + clusterExport(cl, c("SP")) + } else { + registerDoParallel(cores = 1) + } + tmp = foreach(colony = seq_len(nCol), .packages = c("SIMplyBee")) %dopar% { if (is.null(nInd)) { nIndColony <- NULL } else { @@ -1283,6 +1311,10 @@ pullCastePop <- function(x, caste, nInd = NULL, use = "rand", collapse = collapse, simParamBee = simParamBee) } + if (simParamBee$nThreads > 1) { + stopCluster(cl) + } + ret$pulled <- lapply(tmp, '[[', "pulled") ret$remnant@colonies <- lapply(tmp, '[[', "remnant") @@ -1524,7 +1556,6 @@ cross <- function(x, if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } - registerDoParallel(cores = simParamBee$nThreads) if (isPop(x)) { type = "Pop" @@ -1671,7 +1702,6 @@ cross <- function(x, } } - if (crossPlan_given | crossPlan_create) { if (crossPlan_colonyID) { # WHAT IF ONE ELEMENT IS EMPTY # This is the crossPlan - for spatial, these are all DPCs found in a radius @@ -1715,16 +1745,17 @@ cross <- function(x, FUN = function(x) dronesByVirgin_DF$droneID[dronesByVirgin_DF$virginID == x]) names(dronesByVirgin_list) <- IDs - dronesByVirgin <- foreach(i = IDs, .combine = combine_list) %dopar% { + dronesByVirgin <- foreach(i = IDs, .combine = combine_list, + .packages = c("SIMplyBee")) %do% { dronePop[as.character(dronesByVirgin_list[[i]])] } } else if (crossPlan_droneID) { - dronesByVirgin <- foreach(i = IDs, .combine = combine_list) %dopar% { + dronesByVirgin <- foreach(i = IDs, .combine = combine_list, + .packages = c("SIMplyBee")) %do% { drones[as.character(crossPlan[[i]])] } } } - # At this point, x is a Pop and dronesByVirgin are a list (so are they if they come if via drone packages) if (oneColony) { dronesByVirgin <- list(drones) @@ -1773,12 +1804,31 @@ cross <- function(x, } # Add drones in the queens father slot - x <- foreach(i = 1:length(IDs), .combine = combine_list) %dopar% { - crossVirginQueen(virginQueen = x[i], - virginQueenDrones = dronesByVirgin[[i]], - simParamBee = simParamBee) - } + if (simParamBee$nThreads > 1) { + foreach_op <- `%dopar%` + N <- as.numeric(simParamBee$nThreads) + cl <- makeCluster(N, type="PSOCK") + registerDoParallel(cl) + + clusterExport(cl, c("SP")) + } else { + foreach_op <- `%do%` + } + x <- do.call(foreach_op, list( + foreach(i = 1:length(IDs), .combine = combine_list, .packages = "SIMplyBee"), + quote({ + crossVirginQueen( + virginQueen = x[i], + virginQueenDrones = dronesByVirgin[[i]], + simParamBee = simParamBee + ) + }) + )) + + if (simParamBee$nThreads > 1) { + stopCluster(cl) + } if (type == "Pop") { if (length(x) == 1) { diff --git a/R/Functions_L2_Colony.R b/R/Functions_L2_Colony.R index 78ace6a9..264caf63 100644 --- a/R/Functions_L2_Colony.R +++ b/R/Functions_L2_Colony.R @@ -167,7 +167,6 @@ reQueen <- function(x, queen, removeVirginQueens = TRUE, simParamBee = NULL) { x@virginQueens <- queen } } else if (isMultiColony(x)) { - registerDoParallel(cores = simParamBee$nThreads) nCol <- nColonies(x) if (nCol == 0) { stop("The Multicolony contains 0 colonies!") @@ -175,13 +174,26 @@ reQueen <- function(x, queen, removeVirginQueens = TRUE, simParamBee = NULL) { if (nInd(queen) < nCol) { stop("Not enough queens provided!") } - x@colonies = foreach(colony = seq_len(nCol)) %dopar% { + + if (simParamBee$nThreads > 1) { + N <- as.numeric(simParamBee$nThreads) + cl <- makeCluster(N, type="PSOCK") + registerDoParallel(cl) + + clusterExport(cl, c("SP")) + } else { + registerDoParallel(cores = 1) + } + x@colonies = foreach(colony = seq_len(nCol), .packages = c("SIMplyBee")) %dopar% { reQueen( x = x[[colony]], queen = queen[colony], simParamBee = simParamBee ) } + if (simParamBee$nThreads > 1) { + stopCluster(cl) + } } else { stop("Argument x must be a Colony or MultiColony class object!") } @@ -383,7 +395,16 @@ addCastePop <- function(x, caste = NULL, nInd = NULL, new = FALSE, nInd(x) }) - x@colonies <- foreach(colony = seq_len(nCol)) %dopar% { + if (simParamBee$nThreads > 1) { + N <- as.numeric(simParamBee$nThreads) + cl <- makeCluster(N, type="PSOCK") + registerDoParallel(cl) + + clusterExport(cl, c("SP")) + } else { + registerDoParallel(cores = 1) + } + x@colonies <- foreach(colony = seq_len(nCol), .packages = c("SIMplyBee")) %dopar% { if (!is.null(nInds[[colony]])) { if (caste == "workers") { x[[colony]]@queen@misc$nWorkers[[1]] <- x[[colony]]@queen@misc$nWorkers[[1]] + nInds[[colony]] @@ -396,6 +417,9 @@ addCastePop <- function(x, caste = NULL, nInd = NULL, new = FALSE, x[[colony]] } } + if (simParamBee$nThreads > 1) { + stopCluster(cl) + } } else { stop("Argument x must be a Colony or MultiColony class object!") } @@ -599,7 +623,6 @@ buildUp <- function(x, nWorkers = NULL, nDrones = NULL, } x@production <- TRUE } else if (isMultiColony(x)) { - registerDoParallel(cores = simParamBee$nThreads) if (any(hasCollapsed(x))) { stop(paste0("Some colonies are collapsed, hence you can not build it up!")) @@ -748,7 +771,6 @@ downsize <- function(x, p = NULL, use = "rand", new = FALSE, x <- removeVirginQueens(x = x, p = 1, simParamBee = simParamBee) x@production <- FALSE } else if (isMultiColony(x)) { - registerDoParallel(cores = simParamBee$nThreads) nCol <- nColonies(x) nP <- length(p) if (nCol == 0) { @@ -1031,7 +1053,6 @@ removeCastePop <- function(x, caste = NULL, p = 1, use = "rand", } } } else if (isMultiColony(x)) { - registerDoParallel(cores = simParamBee$nThreads) nCol <- nColonies(x) nP <- length(p) if (nCol == 0) { @@ -1044,7 +1065,17 @@ removeCastePop <- function(x, caste = NULL, p = 1, use = "rand", warning(paste0("Too many values in the p argument, taking only the first ", nCol, "values!")) p <- p[1:nCol] } - x@colonies <- foreach(colony = seq_len(nCol)) %dopar% { + + if (simParamBee$nThreads > 1) { + N <- as.numeric(simParamBee$nThreads) + cl <- makeCluster(N, type="PSOCK") + registerDoParallel(cl) + + clusterExport(cl, c("SP")) + } else { + registerDoParallel(cores = 1) + } + x@colonies <- foreach(colony = seq_len(nCol), .packages = c("SIMplyBee")) %dopar% { if (is.null(p)) { pColony <- NULL } else { @@ -1057,6 +1088,9 @@ removeCastePop <- function(x, caste = NULL, p = 1, use = "rand", simParamBee = simParamBee ) } + if (simParamBee$nThreads > 1) { + stopCluster(cl) + } } else { stop("Argument x must be a Colony or MultiColony class object!") } @@ -1197,18 +1231,30 @@ resetEvents <- function(x, collapse = NULL, simParamBee = NULL) { x@production <- FALSE validObject(x) } else if (isMultiColony(x)) { - registerDoParallel(cores = simParamBee$nThreads) nCol <- nColonies(x) if (nCol == 0) { stop("The Multicolony contains 0 colonies!") } - x@colonies <- foreach(colony = seq_len(nCol)) %dopar% { + + if (simParamBee$nThreads > 1) { + N <- as.numeric(simParamBee$nThreads) + cl <- makeCluster(N, type="PSOCK") + registerDoParallel(cl) + + clusterExport(cl, c("SP")) + } else { + registerDoParallel(cores = 1) + } + x@colonies <- foreach(colony = seq_len(nCol), .packages = c("SIMplyBee")) %dopar% { resetEvents( x = x[[colony]], collapse = collapse, simParamBee = simParamBee ) } + if (simParamBee$nThreads > 1) { + stopCluster(cl) + } validObject(x) } else { stop("Argument x must be a Colony or MultiColony class object!") @@ -1271,15 +1317,27 @@ collapse <- function(x, simParamBee = NULL) { x@collapse <- TRUE x@production <- FALSE } else if (isMultiColony(x)) { - registerDoParallel(cores = simParamBee$nThreads) nCol <- nColonies(x) if (nCol == 0) { stop("The Multicolony contains 0 colonies!") } - x@colonies <- foreach(colony = seq_len(nCol)) %dopar% { + + if (simParamBee$nThreads > 1) { + N <- as.numeric(simParamBee$nThreads) + cl <- makeCluster(N, type="PSOCK") + registerDoParallel(cl) + + clusterExport(cl, c("SP")) + } else { + registerDoParallel(cores = 1) + } + x@colonies <- foreach(colony = seq_len(nCol), .packages = c("SIMplyBee")) %dopar% { collapse(x = x[[colony]], simParamBee = simParamBee) } + if (simParamBee$nThreads > 1) { + stopCluster(cl) + } } else { stop("Argument x must be a Colony or MultiColony class object!") } @@ -1487,10 +1545,22 @@ swarm <- function(x, p = NULL, remnant = remnantColony ) - ret$swarm@colonies <- foreach(colony = seq_len(nCol)) %dopar% { + if (simParamBee$nThreads > 1) { + N <- as.numeric(simParamBee$nThreads) + cl <- makeCluster(N, type="PSOCK") + registerDoParallel(cl) + + clusterExport(cl, c("SP")) + } else { + registerDoParallel(cores = 1) + } + ret$swarm@colonies <- foreach(colony = seq_len(nCol), .packages = c("SIMplyBee")) %dopar% { addCastePop_internal(colony = ret$swarm@colonies[[colony]], pop = tmp$pulled[[colony]], caste = "workers") } + if (simParamBee$nThreads > 1) { + stopCluster(cl) + } ret$remnant <- setEvents(ret$remnant, slot = "swarm", value = TRUE) ret$swarm <- setEvents(ret$swarm, slot = "swarm", value = TRUE) @@ -1619,7 +1689,6 @@ supersede <- function(x, simParamBee = NULL, ...) { # https://github.com/HighlanderLab/SIMplyBee/issues/239 x@supersedure <- TRUE } else if (isMultiColony(x)) { - registerDoParallel(cores = simParamBee$nThreads) nCol <- nColonies(x) if (nCol == 0) { stop("The Multicolony contains 0 colonies!") @@ -1633,10 +1702,23 @@ supersede <- function(x, simParamBee = NULL, ...) { c(a, list(b)) } } - x@colonies <- foreach(colony = seq_len(nColonies(x))) %dopar% { + + if (simParamBee$nThreads > 1) { + N <- as.numeric(simParamBee$nThreads) + cl <- makeCluster(N, type="PSOCK") + registerDoParallel(cl) + + clusterExport(cl, c("SP")) + } else { + registerDoParallel(cores = 1) + } + x@colonies <- foreach(colony = seq_len(nColonies(x)), .packages = c("SIMplyBee")) %dopar% { addCastePop_internal(colony = removeQueen(x[[colony]], simParamBee = simParamBee), pop = tmpVirginQueens[[colony]], caste = "virginQueens") } + if (simParamBee$nThreads > 1) { + stopCluster(cl) + } x = setEvents(x, slot = "supersedure", value = TRUE) } else { @@ -1719,7 +1801,6 @@ split <- function(x, p = NULL, simParamBee = NULL, ...) { } if (isColony(x) | isMultiColony(x)) { - registerDoParallel(cores = simParamBee$nThreads) if (isColony(x)) { nCol <- 1 } else if (isMultiColony(x)) { @@ -1798,10 +1879,23 @@ split <- function(x, p = NULL, simParamBee = NULL, ...) { ) ret$split <- setLocation(x = ret$split, location = location) - ret$split@colonies <- foreach(colony = seq_len(nCol)) %dopar% { + + if (simParamBee$nThreads > 1) { + N <- as.numeric(simParamBee$nThreads) + cl <- makeCluster(N, type="PSOCK") + registerDoParallel(cl) + + clusterExport(cl, c("SP")) + } else { + registerDoParallel(cores = 1) + } + ret$split@colonies <- foreach(colony = seq_len(nCol), .packages = c("SIMplyBee")) %dopar% { addCastePop_internal(colony = ret$split@colonies[[colony]], pop = tmp$pulled[[colony]], caste = "workers") } + if (simParamBee$nThreads > 1) { + stopCluster(cl) + } ret$split <- setEvents(ret$split, slot = "split", value = TRUE) ret$remnant <- setEvents(ret$remnant, slot = "split", value = TRUE) @@ -1854,10 +1948,21 @@ setEvents <- function(x, slot, value, simParamBee = NULL) { slot(x, slot) <- value } if (isMultiColony(x)) { - registerDoParallel(cores = simParamBee$nThreads) - x@colonies <- foreach(colony = seq_len(nColonies(x))) %dopar% { + if (simParamBee$nThreads > 1) { + N <- as.numeric(simParamBee$nThreads) + cl <- makeCluster(N, type="PSOCK") + registerDoParallel(cl) + + clusterExport(cl, c("SP")) + } else { + registerDoParallel(cores = 1) + } + x@colonies <- foreach(colony = seq_len(nColonies(x)), .packages = c("SIMplyBee")) %dopar% { setEvents(x[[colony]], slot, value) } + if (simParamBee$nThreads > 1) { + stopCluster(cl) + } } return(x) } @@ -1933,14 +2038,27 @@ combine <- function(strong, weak, simParamBee = NULL) { strong@workers <- c(strong@workers, weak@workers) strong@drones <- c(strong@drones, weak@drones) } else if (isMultiColony(strong) & isMultiColony(weak)) { - registerDoParallel(cores = simParamBee$nThreads) + if (nColonies(weak) == nColonies(strong)) { nCol <- nColonies(weak) - strong@colonies <- foreach(colony = seq_len(nCol)) %dopar% { + + if (simParamBee$nThreads > 1) { + N <- as.numeric(simParamBee$nThreads) + cl <- makeCluster(N, type="PSOCK") + registerDoParallel(cl) + + clusterExport(cl, c("SP")) + } else { + registerDoParallel(cores = 1) + } + strong@colonies <- foreach(colony = seq_len(nCol), .packages = c("SIMplyBee")) %dopar% { combine(strong = strong[[colony]], weak = weak[[colony]], simParamBee = simParamBee) } + if (simParamBee$nThreads > 1) { + stopCluster(cl) + } } else { stop("Weak and strong MultiColony objects must be of the same length!") } @@ -2015,7 +2133,6 @@ setLocation <- function(x, location = c(0, 0), simParamBee = NULL) { } x@location <- location } else if (isMultiColony(x)) { - registerDoParallel(cores = simParamBee$nThreads) nCol <- nColonies(x) if (nCol == 0) { stop("The Multicolony contains 0 colonies!") @@ -2055,7 +2172,17 @@ setLocation <- function(x, location = c(0, 0), simParamBee = NULL) { c(a, list(b)) } } - tmp <- foreach(colony = seq_len(nCol), .combine = combine_list) %dopar% { + + if (simParamBee$nThreads > 1) { + N <- as.numeric(simParamBee$nThreads) + cl <- makeCluster(N, type="PSOCK") + registerDoParallel(cl) + + clusterExport(cl, c("SP")) + } else { + registerDoParallel(cores = 1) + } + tmp <- foreach(colony = seq_len(nCol), .combine = combine_list, .packages = c("SIMplyBee")) %dopar% { if (is.data.frame(location)) { loc <- location[colony, ] loc <- c(loc$x, loc$y) @@ -2071,6 +2198,10 @@ setLocation <- function(x, location = c(0, 0), simParamBee = NULL) { x[[colony]] } + if (simParamBee$nThreads > 1) { + stopCluster(cl) + } + if (nCol == 1) { x@colonies = list(tmp) } else { diff --git a/R/Functions_L3_Colonies.R b/R/Functions_L3_Colonies.R index b6535b9e..16d4b87d 100644 --- a/R/Functions_L3_Colonies.R +++ b/R/Functions_L3_Colonies.R @@ -54,7 +54,6 @@ createMultiColony <- function(x = NULL, n = NULL, simParamBee = NULL, populateCo simParamBee <- get(x = "SP", envir = .GlobalEnv) } - registerDoParallel(cores = simParamBee$nThreads) if (is.null(x)) { if (is.null(n)) { ret <- new(Class = "MultiColony") @@ -62,9 +61,22 @@ createMultiColony <- function(x = NULL, n = NULL, simParamBee = NULL, populateCo ret <- new(Class = "MultiColony", colonies = vector(mode = "list", length = n)) if (populateColonies) { ids <- (simParamBee$lastColonyId+1):(simParamBee$lastColonyId + n) - ret@colonies <- foreach(colony = seq_len(n)) %dopar% { + + if (simParamBee$nThreads > 1) { + N <- as.numeric(simParamBee$nThreads) + cl <- makeCluster(N, type="PSOCK") + registerDoParallel(cl) + + clusterExport(cl, c("SP")) + } else { + registerDoParallel(cores = 1) + } + ret@colonies <- foreach(colony = seq_len(n), .packages = c("SIMplyBee")) %dopar% { createColony(simParamBee = simParamBee, id = ids[colony]) } + if (simParamBee$nThreads > 1) { + stopCluster(cl) + } simParamBee$updateLastColonyId(n = n) } else { @@ -85,11 +97,25 @@ createMultiColony <- function(x = NULL, n = NULL, simParamBee = NULL, populateCo } ret <- new(Class = "MultiColony", colonies = vector(mode = "list", length = n)) ids <- (simParamBee$lastColonyId+1):(simParamBee$lastColonyId + n) - ret@colonies <- foreach(colony = seq_len(n)) %dopar% { + + if (simParamBee$nThreads > 1) { + N <- as.numeric(simParamBee$nThreads) + cl <- makeCluster(N, type="PSOCK") + registerDoParallel(cl) + + clusterExport(cl, c("SP")) + } else { + registerDoParallel(cores = 1) + } + ret@colonies <- foreach(colony = seq_len(n), .packages = c("SIMplyBee")) %dopar% { createColony(x = x[colony], simParamBee = simParamBee, id = ids[colony]) } + if (simParamBee$nThreads > 1) { + stopCluster(cl) + } simParamBee$updateLastColonyId(n = n) } + validObject(ret) return(ret) } diff --git a/R/SIMplyBee.R b/R/SIMplyBee.R index 774af783..3c431da4 100644 --- a/R/SIMplyBee.R +++ b/R/SIMplyBee.R @@ -7,8 +7,9 @@ #' @importFrom stats rnorm rbeta runif rpois na.omit #' @importFrom extraDistr rtpois #' @importFrom utils packageVersion -#' @importFrom foreach foreach "%dopar%" +#' @importFrom foreach foreach "%dopar%" "%do%" #' @importFrom doParallel registerDoParallel +#' @importFrom parallel makeCluster stopCluster clusterExport clusterApply # see https://r-pkgs.org/namespace.html on description what to import/depend/... #' @description From 1bb0363622c2bc3bd5b00d7beb2a702736cd19b1 Mon Sep 17 00:00:00 2001 From: janaobsteter Date: Wed, 26 Nov 2025 13:52:21 +0100 Subject: [PATCH 39/42] Reversing back to the original foreach loop in cross --- DESCRIPTION | 2 +- NAMESPACE | 5 ++ R/Functions_L1_Pop.R | 75 ++++++++++++---- R/Functions_L2_Colony.R | 175 +++++++++++++++++++++++++++++++++----- R/Functions_L3_Colonies.R | 32 ++++++- R/SIMplyBee.R | 3 +- man/MultiColony-class.Rd | 4 +- 7 files changed, 252 insertions(+), 44 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 4ef4a624..bdc0e699 100644 --- a/DESCRIPTION +++ b/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), foreach, doParallel +Imports: methods, R6, stats, utils, extraDistr (>= 1.9.1), RANN, Rcpp (>= 0.12.7), foreach, doParallel, parallel Depends: R (>= 3.3.0), AlphaSimR (>= 1.5.3) LinkingTo: Rcpp, RcppArmadillo (>= 0.7.500.0.0), BH RoxygenNote: 7.3.2 diff --git a/NAMESPACE b/NAMESPACE index d912dc8c..f6f27d9a 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -206,6 +206,7 @@ import(Rcpp) importFrom(R6,R6Class) importFrom(doParallel,registerDoParallel) importFrom(extraDistr,rtpois) +importFrom(foreach,"%do%") importFrom(foreach,"%dopar%") importFrom(foreach,foreach) importFrom(methods,"slot<-") @@ -219,6 +220,10 @@ importFrom(methods,setValidity) importFrom(methods,show) importFrom(methods,slot) importFrom(methods,validObject) +importFrom(parallel,clusterApply) +importFrom(parallel,clusterExport) +importFrom(parallel,makeCluster) +importFrom(parallel,stopCluster) importFrom(stats,na.omit) importFrom(stats,rbeta) importFrom(stats,rnorm) diff --git a/R/Functions_L1_Pop.R b/R/Functions_L1_Pop.R index 53c3e047..6fd7f389 100644 --- a/R/Functions_L1_Pop.R +++ b/R/Functions_L1_Pop.R @@ -1,6 +1,12 @@ # ---- Level 1 Pop Functions ---- utils::globalVariables("colony") utils::globalVariables("i") +utils::globalVariables("cl") + +# Protect from accidental multicore use +options(mc.cores = 1) +Sys.setenv(OMP_NUM_THREADS = 1) +Sys.setenv(MKL_NUM_THREADS = 1) #' @rdname getCastePop #' @title Access individuals of a caste @@ -618,8 +624,6 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, stop("Nothing to create.") } - registerDoParallel(cores = simParamBee$nThreads) - lastId = simParamBee$lastId ids = (lastId+1):(lastId+totalNInd) @@ -637,7 +641,18 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, } } } - ret <- foreach(colony = seq_len(nCol), .combine=combine_list) %dopar% { + + if (simParamBee$nThreads > 1) { + N <- as.numeric(simParamBee$nThreads) + cl <- makeCluster(N, type="PSOCK") + registerDoParallel(cl) + + clusterExport(cl, c("SP")) + } else { + registerDoParallel(cores = 1) + } + + ret <- foreach(colony = seq_len(nCol), .combine=combine_list, .packages = c("SIMplyBee")) %dopar% { nIndColony <- ifelse(nNInd == 1, nInd, nInd[colony]) if (nIndColony > 0) { if (nNInd == 1) { @@ -657,6 +672,11 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, NULL } } + + if (simParamBee$nThreads > 1) { + stopCluster(cl) + } + if (nCol == 1) { ret <- list(ret) } @@ -1253,7 +1273,6 @@ pullCastePop <- function(x, caste, nInd = NULL, use = "rand", ret <- list(pulled = tmp$pulled, remnant = x) } } else if (isMultiColony(x)) { - registerDoParallel(cores = simParamBee$nThreads) nCol <- nColonies(x) nNInd <- length(nInd) if (nNInd > 1 && nNInd < nCol) { @@ -1269,7 +1288,16 @@ pullCastePop <- function(x, caste, nInd = NULL, use = "rand", names(ret$pulled) <- getId(x) ret$remnant <- x - tmp = foreach(colony = seq_len(nCol)) %dopar% { + if (simParamBee$nThreads > 1) { + N <- as.numeric(simParamBee$nThreads) + cl <- makeCluster(N, type="PSOCK") + registerDoParallel(cl) + + clusterExport(cl, c("SP")) + } else { + registerDoParallel(cores = 1) + } + tmp = foreach(colony = seq_len(nCol), .packages = c("SIMplyBee")) %dopar% { if (is.null(nInd)) { nIndColony <- NULL } else { @@ -1283,6 +1311,10 @@ pullCastePop <- function(x, caste, nInd = NULL, use = "rand", collapse = collapse, simParamBee = simParamBee) } + if (simParamBee$nThreads > 1) { + stopCluster(cl) + } + ret$pulled <- lapply(tmp, '[[', "pulled") ret$remnant@colonies <- lapply(tmp, '[[', "remnant") @@ -1524,7 +1556,6 @@ cross <- function(x, if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } - registerDoParallel(cores = simParamBee$nThreads) if (isPop(x)) { type = "Pop" @@ -1671,7 +1702,6 @@ cross <- function(x, } } - if (crossPlan_given | crossPlan_create) { if (crossPlan_colonyID) { # WHAT IF ONE ELEMENT IS EMPTY # This is the crossPlan - for spatial, these are all DPCs found in a radius @@ -1715,16 +1745,17 @@ cross <- function(x, FUN = function(x) dronesByVirgin_DF$droneID[dronesByVirgin_DF$virginID == x]) names(dronesByVirgin_list) <- IDs - dronesByVirgin <- foreach(i = IDs, .combine = combine_list) %dopar% { - dronePop[as.character(dronesByVirgin_list[[i]])] - } + dronesByVirgin <- foreach(i = IDs, .combine = combine_list, + .packages = c("SIMplyBee")) %do% { + dronePop[as.character(dronesByVirgin_list[[i]])] + } } else if (crossPlan_droneID) { - dronesByVirgin <- foreach(i = IDs, .combine = combine_list) %dopar% { - drones[as.character(crossPlan[[i]])] - } + dronesByVirgin <- foreach(i = IDs, .combine = combine_list, + .packages = c("SIMplyBee")) %do% { + drones[as.character(crossPlan[[i]])] + } } } - # At this point, x is a Pop and dronesByVirgin are a list (so are they if they come if via drone packages) if (oneColony) { dronesByVirgin <- list(drones) @@ -1773,12 +1804,26 @@ cross <- function(x, } # Add drones in the queens father slot - x <- foreach(i = 1:length(IDs), .combine = combine_list) %dopar% { + if (simParamBee$nThreads > 1) { + N <- as.numeric(simParamBee$nThreads) + cl <- makeCluster(N, type="PSOCK") + registerDoParallel(cl) + + clusterExport(cl, c("SP")) + } else { + registerDoParallel(cores = 1) + } + + sink("Cross_VQ.txt", append = T) + x <- foreach(i = 1:length(IDs), .combine = combine_list, .packages = "SIMplyBee") %dopar% { crossVirginQueen(virginQueen = x[i], virginQueenDrones = dronesByVirgin[[i]], simParamBee = simParamBee) } + if (simParamBee$nThreads > 1) { + stopCluster(cl) + } if (type == "Pop") { if (length(x) == 1) { diff --git a/R/Functions_L2_Colony.R b/R/Functions_L2_Colony.R index 78ace6a9..264caf63 100644 --- a/R/Functions_L2_Colony.R +++ b/R/Functions_L2_Colony.R @@ -167,7 +167,6 @@ reQueen <- function(x, queen, removeVirginQueens = TRUE, simParamBee = NULL) { x@virginQueens <- queen } } else if (isMultiColony(x)) { - registerDoParallel(cores = simParamBee$nThreads) nCol <- nColonies(x) if (nCol == 0) { stop("The Multicolony contains 0 colonies!") @@ -175,13 +174,26 @@ reQueen <- function(x, queen, removeVirginQueens = TRUE, simParamBee = NULL) { if (nInd(queen) < nCol) { stop("Not enough queens provided!") } - x@colonies = foreach(colony = seq_len(nCol)) %dopar% { + + if (simParamBee$nThreads > 1) { + N <- as.numeric(simParamBee$nThreads) + cl <- makeCluster(N, type="PSOCK") + registerDoParallel(cl) + + clusterExport(cl, c("SP")) + } else { + registerDoParallel(cores = 1) + } + x@colonies = foreach(colony = seq_len(nCol), .packages = c("SIMplyBee")) %dopar% { reQueen( x = x[[colony]], queen = queen[colony], simParamBee = simParamBee ) } + if (simParamBee$nThreads > 1) { + stopCluster(cl) + } } else { stop("Argument x must be a Colony or MultiColony class object!") } @@ -383,7 +395,16 @@ addCastePop <- function(x, caste = NULL, nInd = NULL, new = FALSE, nInd(x) }) - x@colonies <- foreach(colony = seq_len(nCol)) %dopar% { + if (simParamBee$nThreads > 1) { + N <- as.numeric(simParamBee$nThreads) + cl <- makeCluster(N, type="PSOCK") + registerDoParallel(cl) + + clusterExport(cl, c("SP")) + } else { + registerDoParallel(cores = 1) + } + x@colonies <- foreach(colony = seq_len(nCol), .packages = c("SIMplyBee")) %dopar% { if (!is.null(nInds[[colony]])) { if (caste == "workers") { x[[colony]]@queen@misc$nWorkers[[1]] <- x[[colony]]@queen@misc$nWorkers[[1]] + nInds[[colony]] @@ -396,6 +417,9 @@ addCastePop <- function(x, caste = NULL, nInd = NULL, new = FALSE, x[[colony]] } } + if (simParamBee$nThreads > 1) { + stopCluster(cl) + } } else { stop("Argument x must be a Colony or MultiColony class object!") } @@ -599,7 +623,6 @@ buildUp <- function(x, nWorkers = NULL, nDrones = NULL, } x@production <- TRUE } else if (isMultiColony(x)) { - registerDoParallel(cores = simParamBee$nThreads) if (any(hasCollapsed(x))) { stop(paste0("Some colonies are collapsed, hence you can not build it up!")) @@ -748,7 +771,6 @@ downsize <- function(x, p = NULL, use = "rand", new = FALSE, x <- removeVirginQueens(x = x, p = 1, simParamBee = simParamBee) x@production <- FALSE } else if (isMultiColony(x)) { - registerDoParallel(cores = simParamBee$nThreads) nCol <- nColonies(x) nP <- length(p) if (nCol == 0) { @@ -1031,7 +1053,6 @@ removeCastePop <- function(x, caste = NULL, p = 1, use = "rand", } } } else if (isMultiColony(x)) { - registerDoParallel(cores = simParamBee$nThreads) nCol <- nColonies(x) nP <- length(p) if (nCol == 0) { @@ -1044,7 +1065,17 @@ removeCastePop <- function(x, caste = NULL, p = 1, use = "rand", warning(paste0("Too many values in the p argument, taking only the first ", nCol, "values!")) p <- p[1:nCol] } - x@colonies <- foreach(colony = seq_len(nCol)) %dopar% { + + if (simParamBee$nThreads > 1) { + N <- as.numeric(simParamBee$nThreads) + cl <- makeCluster(N, type="PSOCK") + registerDoParallel(cl) + + clusterExport(cl, c("SP")) + } else { + registerDoParallel(cores = 1) + } + x@colonies <- foreach(colony = seq_len(nCol), .packages = c("SIMplyBee")) %dopar% { if (is.null(p)) { pColony <- NULL } else { @@ -1057,6 +1088,9 @@ removeCastePop <- function(x, caste = NULL, p = 1, use = "rand", simParamBee = simParamBee ) } + if (simParamBee$nThreads > 1) { + stopCluster(cl) + } } else { stop("Argument x must be a Colony or MultiColony class object!") } @@ -1197,18 +1231,30 @@ resetEvents <- function(x, collapse = NULL, simParamBee = NULL) { x@production <- FALSE validObject(x) } else if (isMultiColony(x)) { - registerDoParallel(cores = simParamBee$nThreads) nCol <- nColonies(x) if (nCol == 0) { stop("The Multicolony contains 0 colonies!") } - x@colonies <- foreach(colony = seq_len(nCol)) %dopar% { + + if (simParamBee$nThreads > 1) { + N <- as.numeric(simParamBee$nThreads) + cl <- makeCluster(N, type="PSOCK") + registerDoParallel(cl) + + clusterExport(cl, c("SP")) + } else { + registerDoParallel(cores = 1) + } + x@colonies <- foreach(colony = seq_len(nCol), .packages = c("SIMplyBee")) %dopar% { resetEvents( x = x[[colony]], collapse = collapse, simParamBee = simParamBee ) } + if (simParamBee$nThreads > 1) { + stopCluster(cl) + } validObject(x) } else { stop("Argument x must be a Colony or MultiColony class object!") @@ -1271,15 +1317,27 @@ collapse <- function(x, simParamBee = NULL) { x@collapse <- TRUE x@production <- FALSE } else if (isMultiColony(x)) { - registerDoParallel(cores = simParamBee$nThreads) nCol <- nColonies(x) if (nCol == 0) { stop("The Multicolony contains 0 colonies!") } - x@colonies <- foreach(colony = seq_len(nCol)) %dopar% { + + if (simParamBee$nThreads > 1) { + N <- as.numeric(simParamBee$nThreads) + cl <- makeCluster(N, type="PSOCK") + registerDoParallel(cl) + + clusterExport(cl, c("SP")) + } else { + registerDoParallel(cores = 1) + } + x@colonies <- foreach(colony = seq_len(nCol), .packages = c("SIMplyBee")) %dopar% { collapse(x = x[[colony]], simParamBee = simParamBee) } + if (simParamBee$nThreads > 1) { + stopCluster(cl) + } } else { stop("Argument x must be a Colony or MultiColony class object!") } @@ -1487,10 +1545,22 @@ swarm <- function(x, p = NULL, remnant = remnantColony ) - ret$swarm@colonies <- foreach(colony = seq_len(nCol)) %dopar% { + if (simParamBee$nThreads > 1) { + N <- as.numeric(simParamBee$nThreads) + cl <- makeCluster(N, type="PSOCK") + registerDoParallel(cl) + + clusterExport(cl, c("SP")) + } else { + registerDoParallel(cores = 1) + } + ret$swarm@colonies <- foreach(colony = seq_len(nCol), .packages = c("SIMplyBee")) %dopar% { addCastePop_internal(colony = ret$swarm@colonies[[colony]], pop = tmp$pulled[[colony]], caste = "workers") } + if (simParamBee$nThreads > 1) { + stopCluster(cl) + } ret$remnant <- setEvents(ret$remnant, slot = "swarm", value = TRUE) ret$swarm <- setEvents(ret$swarm, slot = "swarm", value = TRUE) @@ -1619,7 +1689,6 @@ supersede <- function(x, simParamBee = NULL, ...) { # https://github.com/HighlanderLab/SIMplyBee/issues/239 x@supersedure <- TRUE } else if (isMultiColony(x)) { - registerDoParallel(cores = simParamBee$nThreads) nCol <- nColonies(x) if (nCol == 0) { stop("The Multicolony contains 0 colonies!") @@ -1633,10 +1702,23 @@ supersede <- function(x, simParamBee = NULL, ...) { c(a, list(b)) } } - x@colonies <- foreach(colony = seq_len(nColonies(x))) %dopar% { + + if (simParamBee$nThreads > 1) { + N <- as.numeric(simParamBee$nThreads) + cl <- makeCluster(N, type="PSOCK") + registerDoParallel(cl) + + clusterExport(cl, c("SP")) + } else { + registerDoParallel(cores = 1) + } + x@colonies <- foreach(colony = seq_len(nColonies(x)), .packages = c("SIMplyBee")) %dopar% { addCastePop_internal(colony = removeQueen(x[[colony]], simParamBee = simParamBee), pop = tmpVirginQueens[[colony]], caste = "virginQueens") } + if (simParamBee$nThreads > 1) { + stopCluster(cl) + } x = setEvents(x, slot = "supersedure", value = TRUE) } else { @@ -1719,7 +1801,6 @@ split <- function(x, p = NULL, simParamBee = NULL, ...) { } if (isColony(x) | isMultiColony(x)) { - registerDoParallel(cores = simParamBee$nThreads) if (isColony(x)) { nCol <- 1 } else if (isMultiColony(x)) { @@ -1798,10 +1879,23 @@ split <- function(x, p = NULL, simParamBee = NULL, ...) { ) ret$split <- setLocation(x = ret$split, location = location) - ret$split@colonies <- foreach(colony = seq_len(nCol)) %dopar% { + + if (simParamBee$nThreads > 1) { + N <- as.numeric(simParamBee$nThreads) + cl <- makeCluster(N, type="PSOCK") + registerDoParallel(cl) + + clusterExport(cl, c("SP")) + } else { + registerDoParallel(cores = 1) + } + ret$split@colonies <- foreach(colony = seq_len(nCol), .packages = c("SIMplyBee")) %dopar% { addCastePop_internal(colony = ret$split@colonies[[colony]], pop = tmp$pulled[[colony]], caste = "workers") } + if (simParamBee$nThreads > 1) { + stopCluster(cl) + } ret$split <- setEvents(ret$split, slot = "split", value = TRUE) ret$remnant <- setEvents(ret$remnant, slot = "split", value = TRUE) @@ -1854,10 +1948,21 @@ setEvents <- function(x, slot, value, simParamBee = NULL) { slot(x, slot) <- value } if (isMultiColony(x)) { - registerDoParallel(cores = simParamBee$nThreads) - x@colonies <- foreach(colony = seq_len(nColonies(x))) %dopar% { + if (simParamBee$nThreads > 1) { + N <- as.numeric(simParamBee$nThreads) + cl <- makeCluster(N, type="PSOCK") + registerDoParallel(cl) + + clusterExport(cl, c("SP")) + } else { + registerDoParallel(cores = 1) + } + x@colonies <- foreach(colony = seq_len(nColonies(x)), .packages = c("SIMplyBee")) %dopar% { setEvents(x[[colony]], slot, value) } + if (simParamBee$nThreads > 1) { + stopCluster(cl) + } } return(x) } @@ -1933,14 +2038,27 @@ combine <- function(strong, weak, simParamBee = NULL) { strong@workers <- c(strong@workers, weak@workers) strong@drones <- c(strong@drones, weak@drones) } else if (isMultiColony(strong) & isMultiColony(weak)) { - registerDoParallel(cores = simParamBee$nThreads) + if (nColonies(weak) == nColonies(strong)) { nCol <- nColonies(weak) - strong@colonies <- foreach(colony = seq_len(nCol)) %dopar% { + + if (simParamBee$nThreads > 1) { + N <- as.numeric(simParamBee$nThreads) + cl <- makeCluster(N, type="PSOCK") + registerDoParallel(cl) + + clusterExport(cl, c("SP")) + } else { + registerDoParallel(cores = 1) + } + strong@colonies <- foreach(colony = seq_len(nCol), .packages = c("SIMplyBee")) %dopar% { combine(strong = strong[[colony]], weak = weak[[colony]], simParamBee = simParamBee) } + if (simParamBee$nThreads > 1) { + stopCluster(cl) + } } else { stop("Weak and strong MultiColony objects must be of the same length!") } @@ -2015,7 +2133,6 @@ setLocation <- function(x, location = c(0, 0), simParamBee = NULL) { } x@location <- location } else if (isMultiColony(x)) { - registerDoParallel(cores = simParamBee$nThreads) nCol <- nColonies(x) if (nCol == 0) { stop("The Multicolony contains 0 colonies!") @@ -2055,7 +2172,17 @@ setLocation <- function(x, location = c(0, 0), simParamBee = NULL) { c(a, list(b)) } } - tmp <- foreach(colony = seq_len(nCol), .combine = combine_list) %dopar% { + + if (simParamBee$nThreads > 1) { + N <- as.numeric(simParamBee$nThreads) + cl <- makeCluster(N, type="PSOCK") + registerDoParallel(cl) + + clusterExport(cl, c("SP")) + } else { + registerDoParallel(cores = 1) + } + tmp <- foreach(colony = seq_len(nCol), .combine = combine_list, .packages = c("SIMplyBee")) %dopar% { if (is.data.frame(location)) { loc <- location[colony, ] loc <- c(loc$x, loc$y) @@ -2071,6 +2198,10 @@ setLocation <- function(x, location = c(0, 0), simParamBee = NULL) { x[[colony]] } + if (simParamBee$nThreads > 1) { + stopCluster(cl) + } + if (nCol == 1) { x@colonies = list(tmp) } else { diff --git a/R/Functions_L3_Colonies.R b/R/Functions_L3_Colonies.R index b6535b9e..16d4b87d 100644 --- a/R/Functions_L3_Colonies.R +++ b/R/Functions_L3_Colonies.R @@ -54,7 +54,6 @@ createMultiColony <- function(x = NULL, n = NULL, simParamBee = NULL, populateCo simParamBee <- get(x = "SP", envir = .GlobalEnv) } - registerDoParallel(cores = simParamBee$nThreads) if (is.null(x)) { if (is.null(n)) { ret <- new(Class = "MultiColony") @@ -62,9 +61,22 @@ createMultiColony <- function(x = NULL, n = NULL, simParamBee = NULL, populateCo ret <- new(Class = "MultiColony", colonies = vector(mode = "list", length = n)) if (populateColonies) { ids <- (simParamBee$lastColonyId+1):(simParamBee$lastColonyId + n) - ret@colonies <- foreach(colony = seq_len(n)) %dopar% { + + if (simParamBee$nThreads > 1) { + N <- as.numeric(simParamBee$nThreads) + cl <- makeCluster(N, type="PSOCK") + registerDoParallel(cl) + + clusterExport(cl, c("SP")) + } else { + registerDoParallel(cores = 1) + } + ret@colonies <- foreach(colony = seq_len(n), .packages = c("SIMplyBee")) %dopar% { createColony(simParamBee = simParamBee, id = ids[colony]) } + if (simParamBee$nThreads > 1) { + stopCluster(cl) + } simParamBee$updateLastColonyId(n = n) } else { @@ -85,11 +97,25 @@ createMultiColony <- function(x = NULL, n = NULL, simParamBee = NULL, populateCo } ret <- new(Class = "MultiColony", colonies = vector(mode = "list", length = n)) ids <- (simParamBee$lastColonyId+1):(simParamBee$lastColonyId + n) - ret@colonies <- foreach(colony = seq_len(n)) %dopar% { + + if (simParamBee$nThreads > 1) { + N <- as.numeric(simParamBee$nThreads) + cl <- makeCluster(N, type="PSOCK") + registerDoParallel(cl) + + clusterExport(cl, c("SP")) + } else { + registerDoParallel(cores = 1) + } + ret@colonies <- foreach(colony = seq_len(n), .packages = c("SIMplyBee")) %dopar% { createColony(x = x[colony], simParamBee = simParamBee, id = ids[colony]) } + if (simParamBee$nThreads > 1) { + stopCluster(cl) + } simParamBee$updateLastColonyId(n = n) } + validObject(ret) return(ret) } diff --git a/R/SIMplyBee.R b/R/SIMplyBee.R index 774af783..3c431da4 100644 --- a/R/SIMplyBee.R +++ b/R/SIMplyBee.R @@ -7,8 +7,9 @@ #' @importFrom stats rnorm rbeta runif rpois na.omit #' @importFrom extraDistr rtpois #' @importFrom utils packageVersion -#' @importFrom foreach foreach "%dopar%" +#' @importFrom foreach foreach "%dopar%" "%do%" #' @importFrom doParallel registerDoParallel +#' @importFrom parallel makeCluster stopCluster clusterExport clusterApply # see https://r-pkgs.org/namespace.html on description what to import/depend/... #' @description diff --git a/man/MultiColony-class.Rd b/man/MultiColony-class.Rd index d81e7d6f..9979cf15 100644 --- a/man/MultiColony-class.Rd +++ b/man/MultiColony-class.Rd @@ -7,8 +7,8 @@ \alias{show,MultiColony-method} \alias{c,MultiColony-method} \alias{c,MultiColonyOrNULL-method} -\alias{[,MultiColony,integerOrNumericOrLogical-method} -\alias{[,MultiColony,character-method} +\alias{[,MultiColony,integerOrNumericOrLogical,ANY,ANY-method} +\alias{[,MultiColony,character,ANY,ANY-method} \alias{[[,MultiColony,integerOrNumericOrLogical-method} \alias{[[,MultiColony,character-method} \alias{[<-,MultiColony,integerOrNumericOrLogicalOrCharacter,ANY,MultiColony-method} From 224dfb49ae31db867cbfa66d016eb87562b3ef9a Mon Sep 17 00:00:00 2001 From: janaobsteter Date: Fri, 28 Nov 2025 09:48:54 +0100 Subject: [PATCH 40/42] Removing the creation of the clusters from within the functions --- DESCRIPTION | 4 +- NAMESPACE | 5 - NEWS.md | 43 +++-- R/Functions_L1_Pop.R | 44 +---- R/Functions_L2_Colony.R | 188 +++---------------- R/Functions_L3_Colonies.R | 24 --- R/SIMplyBee.R | 2 - man/MultiColony-class.Rd | 8 +- tests/testthat/test-L0_auxiliary_functions.R | 69 +++++-- tests/testthat/test-L1_pop_functions.R | 41 +--- tests/testthat/test-L2_colony_functions.R | 47 +++-- tests/testthat/test-L3_Colonies_functions.R | 7 +- 12 files changed, 166 insertions(+), 316 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index bdc0e699..394a7d28 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: SIMplyBee Type: Package Title: 'AlphaSimR' Extension for Simulating Honeybee Populations and Breeding Programmes -Version: 0.4.1 +Version: 0.5.0 Authors@R: c( person("Jana", "Obšteter", email = "obsteter.jana@gmail.com", role = c("aut", "cre"), comment = c(ORCID = "0000-0003-1511-3916")), @@ -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), foreach, doParallel, parallel +Imports: methods, R6, stats, utils, extraDistr (>= 1.9.1), RANN, Rcpp (>= 0.12.7), foreach Depends: R (>= 3.3.0), AlphaSimR (>= 1.5.3) LinkingTo: Rcpp, RcppArmadillo (>= 0.7.500.0.0), BH RoxygenNote: 7.3.2 diff --git a/NAMESPACE b/NAMESPACE index f6f27d9a..2d0cae7e 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -204,7 +204,6 @@ exportClasses(MultiColony) import(AlphaSimR) import(Rcpp) importFrom(R6,R6Class) -importFrom(doParallel,registerDoParallel) importFrom(extraDistr,rtpois) importFrom(foreach,"%do%") importFrom(foreach,"%dopar%") @@ -220,10 +219,6 @@ importFrom(methods,setValidity) importFrom(methods,show) importFrom(methods,slot) importFrom(methods,validObject) -importFrom(parallel,clusterApply) -importFrom(parallel,clusterExport) -importFrom(parallel,makeCluster) -importFrom(parallel,stopCluster) importFrom(stats,na.omit) importFrom(stats,rbeta) importFrom(stats,rnorm) diff --git a/NEWS.md b/NEWS.md index c0766ff7..838297ad 100644 --- a/NEWS.md +++ b/NEWS.md @@ -4,6 +4,33 @@ editor_options: wrap: 72 --- +# SIMplyBee version 0.5.0 + +- 2025-11-27 + +## Major changes + +- 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 + +## New features + +- parallelised all the major functions (so they run on + simParamBee\$nThreads cores) with PSOCK system. Since the parallelisation setup within functions + takes additional time, we recommend using a single threads for a small number of colonies + +## Bug fixes + + # SIMplyBee version 0.4.1 - 2024-09-19 @@ -52,27 +79,11 @@ 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 input was a Pop-class -- - # SIMplyBee version 0.3.0 - 2022-12-05 First public/CRAN version of the package diff --git a/R/Functions_L1_Pop.R b/R/Functions_L1_Pop.R index 6e8d48d2..1684d1ed 100644 --- a/R/Functions_L1_Pop.R +++ b/R/Functions_L1_Pop.R @@ -642,16 +642,6 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, } } - if (simParamBee$nThreads > 1) { - N <- as.numeric(simParamBee$nThreads) - cl <- makeCluster(N, type="PSOCK") - registerDoParallel(cl) - - clusterExport(cl, c("SP")) - } else { - registerDoParallel(cores = 1) - } - ret <- foreach(colony = seq_len(nCol), .combine=combine_list, .packages = c("SIMplyBee")) %dopar% { nIndColony <- ifelse(nNInd == 1, nInd, nInd[colony]) if (nIndColony > 0) { @@ -673,10 +663,6 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, } } - if (simParamBee$nThreads > 1) { - stopCluster(cl) - } - if (nCol == 1) { ret <- list(ret) } @@ -1288,15 +1274,6 @@ pullCastePop <- function(x, caste, nInd = NULL, use = "rand", names(ret$pulled) <- getId(x) ret$remnant <- x - if (simParamBee$nThreads > 1) { - N <- as.numeric(simParamBee$nThreads) - cl <- makeCluster(N, type="PSOCK") - registerDoParallel(cl) - - clusterExport(cl, c("SP")) - } else { - registerDoParallel(cores = 1) - } tmp = foreach(colony = seq_len(nCol), .packages = c("SIMplyBee")) %dopar% { if (is.null(nInd)) { nIndColony <- NULL @@ -1311,9 +1288,6 @@ pullCastePop <- function(x, caste, nInd = NULL, use = "rand", collapse = collapse, simParamBee = simParamBee) } - if (simParamBee$nThreads > 1) { - stopCluster(cl) - } ret$pulled <- lapply(tmp, '[[', "pulled") ret$remnant@colonies <- lapply(tmp, '[[', "remnant") @@ -1660,12 +1634,12 @@ cross <- function(x, inputId <- getId(x) if (isColony(x)) { colony <- x - x <- pullCastePop(x, caste = "virginQueens", nInd = 1)$pulled + x <- pullCastePop(x, caste = "virginQueens", nInd = 1, simParamBee = simParamBee)$pulled ID_by_input <- data.frame(inputId = inputId, virginId = getId(x)) } else if (isMultiColony(x)) { multicolony <- x - x <- pullCastePop(x, caste = "virginQueens", nInd = 1)$pulled + x <- pullCastePop(x, caste = "virginQueens", nInd = 1, simParamBee = simParamBee)$pulled ID_by_input <- data.frame(inputId = inputId, virginId = unlist(sapply(x, FUN = function(y) getId(y)))) x <- mergePops(x) @@ -1804,15 +1778,6 @@ cross <- function(x, } # Add drones in the queens father slot - if (simParamBee$nThreads > 1) { - N <- as.numeric(simParamBee$nThreads) - cl <- makeCluster(N, type="PSOCK") - registerDoParallel(cl) - - clusterExport(cl, c("SP")) - } else { - registerDoParallel(cores = 1) - } x <- foreach(i = 1:length(IDs), .combine = combine_list, .packages = "SIMplyBee") %dopar% { crossVirginQueen(virginQueen = x[i], @@ -1820,11 +1785,6 @@ cross <- function(x, simParamBee = simParamBee) } - - if (simParamBee$nThreads > 1) { - stopCluster(cl) - } - if (type == "Pop") { if (length(x) == 1) { ret <- x diff --git a/R/Functions_L2_Colony.R b/R/Functions_L2_Colony.R index 264caf63..f3440b8b 100644 --- a/R/Functions_L2_Colony.R +++ b/R/Functions_L2_Colony.R @@ -71,7 +71,7 @@ createColony <- function(x = NULL, simParamBee = NULL, id = NULL) { virginQueens = virginQueens ) } - colony <- resetEvents(colony) + colony <- resetEvents(colony, simParamBee = simParamBee) validObject(colony) return(colony) } @@ -175,15 +175,7 @@ reQueen <- function(x, queen, removeVirginQueens = TRUE, simParamBee = NULL) { stop("Not enough queens provided!") } - if (simParamBee$nThreads > 1) { - N <- as.numeric(simParamBee$nThreads) - cl <- makeCluster(N, type="PSOCK") - registerDoParallel(cl) - clusterExport(cl, c("SP")) - } else { - registerDoParallel(cores = 1) - } x@colonies = foreach(colony = seq_len(nCol), .packages = c("SIMplyBee")) %dopar% { reQueen( x = x[[colony]], @@ -191,9 +183,6 @@ reQueen <- function(x, queen, removeVirginQueens = TRUE, simParamBee = NULL) { simParamBee = simParamBee ) } - if (simParamBee$nThreads > 1) { - stopCluster(cl) - } } else { stop("Argument x must be a Colony or MultiColony class object!") } @@ -395,15 +384,6 @@ addCastePop <- function(x, caste = NULL, nInd = NULL, new = FALSE, nInd(x) }) - if (simParamBee$nThreads > 1) { - N <- as.numeric(simParamBee$nThreads) - cl <- makeCluster(N, type="PSOCK") - registerDoParallel(cl) - - clusterExport(cl, c("SP")) - } else { - registerDoParallel(cores = 1) - } x@colonies <- foreach(colony = seq_len(nCol), .packages = c("SIMplyBee")) %dopar% { if (!is.null(nInds[[colony]])) { if (caste == "workers") { @@ -417,9 +397,7 @@ addCastePop <- function(x, caste = NULL, nInd = NULL, new = FALSE, x[[colony]] } } - if (simParamBee$nThreads > 1) { - stopCluster(cl) - } + } else { stop("Argument x must be a Colony or MultiColony class object!") } @@ -668,9 +646,9 @@ buildUp <- function(x, nWorkers = NULL, nDrones = NULL, x = x, nInd = n, new = new, simParamBee = simParamBee) } - x <- setEvents(x, slot = "production", value = TRUE) + x <- setEvents(x, slot = "production", value = TRUE, simParamBee = simParamBee) if (resetEvents) { - x <- resetEvents(x) + x <- resetEvents(x, simParamBee = simParamBee) } } else { @@ -912,7 +890,7 @@ replaceCastePop <- function(x, caste = NULL, p = 1, use = "rand", x <- removeCastePop(x, caste = caste, - p = p) + p = p, simParamBee = simParamBee) nIndAdd <- nInd - nCaste(x, caste, simParamBee = simParamBee) x <- addCastePop(x, caste = caste, @@ -1066,15 +1044,6 @@ removeCastePop <- function(x, caste = NULL, p = 1, use = "rand", p <- p[1:nCol] } - if (simParamBee$nThreads > 1) { - N <- as.numeric(simParamBee$nThreads) - cl <- makeCluster(N, type="PSOCK") - registerDoParallel(cl) - - clusterExport(cl, c("SP")) - } else { - registerDoParallel(cores = 1) - } x@colonies <- foreach(colony = seq_len(nCol), .packages = c("SIMplyBee")) %dopar% { if (is.null(p)) { pColony <- NULL @@ -1088,9 +1057,7 @@ removeCastePop <- function(x, caste = NULL, p = 1, use = "rand", simParamBee = simParamBee ) } - if (simParamBee$nThreads > 1) { - stopCluster(cl) - } + } else { stop("Argument x must be a Colony or MultiColony class object!") } @@ -1236,15 +1203,6 @@ resetEvents <- function(x, collapse = NULL, simParamBee = NULL) { stop("The Multicolony contains 0 colonies!") } - if (simParamBee$nThreads > 1) { - N <- as.numeric(simParamBee$nThreads) - cl <- makeCluster(N, type="PSOCK") - registerDoParallel(cl) - - clusterExport(cl, c("SP")) - } else { - registerDoParallel(cores = 1) - } x@colonies <- foreach(colony = seq_len(nCol), .packages = c("SIMplyBee")) %dopar% { resetEvents( x = x[[colony]], @@ -1252,9 +1210,6 @@ resetEvents <- function(x, collapse = NULL, simParamBee = NULL) { simParamBee = simParamBee ) } - if (simParamBee$nThreads > 1) { - stopCluster(cl) - } validObject(x) } else { stop("Argument x must be a Colony or MultiColony class object!") @@ -1322,22 +1277,10 @@ collapse <- function(x, simParamBee = NULL) { stop("The Multicolony contains 0 colonies!") } - if (simParamBee$nThreads > 1) { - N <- as.numeric(simParamBee$nThreads) - cl <- makeCluster(N, type="PSOCK") - registerDoParallel(cl) - - clusterExport(cl, c("SP")) - } else { - registerDoParallel(cores = 1) - } x@colonies <- foreach(colony = seq_len(nCol), .packages = c("SIMplyBee")) %dopar% { collapse(x = x[[colony]], simParamBee = simParamBee) } - if (simParamBee$nThreads > 1) { - stopCluster(cl) - } } else { stop("Argument x must be a Colony or MultiColony class object!") } @@ -1497,13 +1440,13 @@ swarm <- function(x, p = NULL, tmp <- pullCastePop(x = x, caste = "workers", nInd = nWorkersSwarm, simParamBee = simParamBee) remnantColony <- tmp$remnant - remnantColony <- removeQueen(remnantColony) + remnantColony <- removeQueen(remnantColony, simParamBee = simParamBee) if (isColony(x)) { remnantColony <- reQueen(remnantColony, - queen = selectInd(tmpVirginQueens, nInd = 1, use = "rand"), + queen = selectInd(tmpVirginQueens, nInd = 1, use = "rand", simParam = simParamBee), simParamBee = simParamBee) } else { - tmpVirginQueens <- lapply(tmpVirginQueens, FUN = function(x) selectInd(x, nInd = 1, use = "rand")) + tmpVirginQueens <- lapply(tmpVirginQueens, FUN = function(x) selectInd(x, nInd = 1, use = "rand", simParam = simParamBee)) remnantColony <- reQueen(remnantColony, queen = mergePops(tmpVirginQueens), simParamBee = simParamBee) @@ -1523,9 +1466,9 @@ swarm <- function(x, p = NULL, # It's not re-queening, but the function also sets the colony id swarmColony@workers <- tmp$pulled - swarmColony <- setLocation(x = swarmColony, location = newLocation[[1]]) + swarmColony <- setLocation(x = swarmColony, location = newLocation[[1]], simParamBee = simParamBee) - remnantColony <- setLocation(x = remnantColony, location = currentLocation) + remnantColony <- setLocation(x = remnantColony, location = currentLocation, simParamBee = simParamBee) remnantColony@swarm <- TRUE swarmColony@swarm <- TRUE @@ -1540,32 +1483,21 @@ swarm <- function(x, p = NULL, } ret <- list( - swarm = createMultiColony(x = getQueen(x, collapse = TRUE), + swarm = createMultiColony(x = getQueen(x, collapse = TRUE, simParamBee = simParamBee), simParamBee = simParamBee), remnant = remnantColony ) - if (simParamBee$nThreads > 1) { - N <- as.numeric(simParamBee$nThreads) - cl <- makeCluster(N, type="PSOCK") - registerDoParallel(cl) - - clusterExport(cl, c("SP")) - } else { - registerDoParallel(cores = 1) - } ret$swarm@colonies <- foreach(colony = seq_len(nCol), .packages = c("SIMplyBee")) %dopar% { addCastePop_internal(colony = ret$swarm@colonies[[colony]], pop = tmp$pulled[[colony]], caste = "workers") } - if (simParamBee$nThreads > 1) { - stopCluster(cl) - } - ret$remnant <- setEvents(ret$remnant, slot = "swarm", value = TRUE) - ret$swarm <- setEvents(ret$swarm, slot = "swarm", value = TRUE) - ret$swarm <- setEvents(ret$swarm, slot = "production", value = FALSE) - ret$remnant <- setEvents(ret$remnant, slot = "production", value = FALSE) + + ret$remnant <- setEvents(ret$remnant, slot = "swarm", value = TRUE, simParamBee = simParamBee) + ret$swarm <- setEvents(ret$swarm, slot = "swarm", value = TRUE, simParamBee = simParamBee) + ret$swarm <- setEvents(ret$swarm, slot = "production", value = FALSE, simParamBee = simParamBee) + ret$remnant <- setEvents(ret$remnant, slot = "production", value = FALSE, simParamBee = simParamBee) } } else { @@ -1649,12 +1581,12 @@ supersede <- function(x, simParamBee = NULL, ...) { stop("No queen present in one of the colonies!") } if (is.function(nVirginQueens)) { - nVirginQueens <- nVirginQueens(x, ...) + nVirginQueens <- nVirginQueens(x, simParamBee = simParamBee, ...) } # Do this because some colonies might not produce a viable virgin queen tmpVirginQueens <- createCastePop( - x = x, nInd = max(10, SP$nVirginQueens), + x = x, nInd = max(10, simParamBee$nVirginQueens), caste = "virginQueens", simParamBee = simParamBee ) @@ -1680,7 +1612,8 @@ supersede <- function(x, simParamBee = NULL, ...) { if (isColony(x)) { if (!parallel) { - x <- addCastePop_internal(selectInd(tmpVirginQueens, nInd = 1, use = "rand"), colony = x, caste = "virginQueens") + x <- addCastePop_internal(selectInd(tmpVirginQueens, nInd = 1, use = "rand", simParam = simParamBee), + colony = x, caste = "virginQueens") } x <- removeQueen(x, simParamBee = simParamBee) # TODO: We could consider that a non-random virgin queen prevails (say the most @@ -1693,7 +1626,7 @@ supersede <- function(x, simParamBee = NULL, ...) { if (nCol == 0) { stop("The Multicolony contains 0 colonies!") } - tmpVirginQueens <- lapply(tmpVirginQueens, FUN = function(x) selectInd(x, nInd = 1, use = "rand")) + tmpVirginQueens <- lapply(tmpVirginQueens, FUN = function(x) selectInd(x, nInd = 1, use = "rand", simParam = simParamBee)) combine_list <- function(a, b) { if (length(a) == 1) { @@ -1703,23 +1636,11 @@ supersede <- function(x, simParamBee = NULL, ...) { } } - if (simParamBee$nThreads > 1) { - N <- as.numeric(simParamBee$nThreads) - cl <- makeCluster(N, type="PSOCK") - registerDoParallel(cl) - - clusterExport(cl, c("SP")) - } else { - registerDoParallel(cores = 1) - } x@colonies <- foreach(colony = seq_len(nColonies(x)), .packages = c("SIMplyBee")) %dopar% { addCastePop_internal(colony = removeQueen(x[[colony]], simParamBee = simParamBee), pop = tmpVirginQueens[[colony]], caste = "virginQueens") } - if (simParamBee$nThreads > 1) { - stopCluster(cl) - } - x = setEvents(x, slot = "supersedure", value = TRUE) + x = setEvents(x, slot = "supersedure", value = TRUE, simParamBee = simParamBee) } else { stop("Argument x must be a Colony or MultiColony class object!") @@ -1855,7 +1776,7 @@ split <- function(x, p = NULL, simParamBee = NULL, ...) { # https://github.com/HighlanderLab/SIMplyBee/issues/239 splitColony <- createColony(simParamBee = simParamBee) - splitColony <- setLocation(x = splitColony, location = location) + splitColony <- setLocation(x = splitColony, location = location, simParamBee = simParamBee) splitColony@workers <- tmp$pulled @@ -1878,29 +1799,16 @@ split <- function(x, p = NULL, simParamBee = NULL, ...) { remnant = remnantColony ) - ret$split <- setLocation(x = ret$split, location = location) - - if (simParamBee$nThreads > 1) { - N <- as.numeric(simParamBee$nThreads) - cl <- makeCluster(N, type="PSOCK") - registerDoParallel(cl) + ret$split <- setLocation(x = ret$split, location = location, simParamBee = simParamBee) - clusterExport(cl, c("SP")) - } else { - registerDoParallel(cores = 1) - } ret$split@colonies <- foreach(colony = seq_len(nCol), .packages = c("SIMplyBee")) %dopar% { addCastePop_internal(colony = ret$split@colonies[[colony]], pop = tmp$pulled[[colony]], caste = "workers") } - if (simParamBee$nThreads > 1) { - stopCluster(cl) - } - - ret$split <- setEvents(ret$split, slot = "split", value = TRUE) - ret$remnant <- setEvents(ret$remnant, slot = "split", value = TRUE) - ret$split <- setEvents(ret$split, slot = "production", value = FALSE) - ret$remnant <- setEvents(ret$remnant, slot = "production", value = TRUE) + ret$split <- setEvents(ret$split, slot = "split", value = TRUE, simParamBee = simParamBee) + ret$remnant <- setEvents(ret$remnant, slot = "split", value = TRUE, simParamBee = simParamBee) + ret$split <- setEvents(ret$split, slot = "production", value = FALSE, simParamBee = simParamBee) + ret$remnant <- setEvents(ret$remnant, slot = "production", value = TRUE, simParamBee = simParamBee) } } else { @@ -1948,20 +1856,8 @@ setEvents <- function(x, slot, value, simParamBee = NULL) { slot(x, slot) <- value } if (isMultiColony(x)) { - if (simParamBee$nThreads > 1) { - N <- as.numeric(simParamBee$nThreads) - cl <- makeCluster(N, type="PSOCK") - registerDoParallel(cl) - - clusterExport(cl, c("SP")) - } else { - registerDoParallel(cores = 1) - } x@colonies <- foreach(colony = seq_len(nColonies(x)), .packages = c("SIMplyBee")) %dopar% { - setEvents(x[[colony]], slot, value) - } - if (simParamBee$nThreads > 1) { - stopCluster(cl) + setEvents(x[[colony]], slot, value, simParamBee = simParamBee) } } return(x) @@ -2042,23 +1938,11 @@ combine <- function(strong, weak, simParamBee = NULL) { if (nColonies(weak) == nColonies(strong)) { nCol <- nColonies(weak) - if (simParamBee$nThreads > 1) { - N <- as.numeric(simParamBee$nThreads) - cl <- makeCluster(N, type="PSOCK") - registerDoParallel(cl) - - clusterExport(cl, c("SP")) - } else { - registerDoParallel(cores = 1) - } strong@colonies <- foreach(colony = seq_len(nCol), .packages = c("SIMplyBee")) %dopar% { combine(strong = strong[[colony]], weak = weak[[colony]], simParamBee = simParamBee) } - if (simParamBee$nThreads > 1) { - stopCluster(cl) - } } else { stop("Weak and strong MultiColony objects must be of the same length!") } @@ -2173,15 +2057,6 @@ setLocation <- function(x, location = c(0, 0), simParamBee = NULL) { } } - if (simParamBee$nThreads > 1) { - N <- as.numeric(simParamBee$nThreads) - cl <- makeCluster(N, type="PSOCK") - registerDoParallel(cl) - - clusterExport(cl, c("SP")) - } else { - registerDoParallel(cores = 1) - } tmp <- foreach(colony = seq_len(nCol), .combine = combine_list, .packages = c("SIMplyBee")) %dopar% { if (is.data.frame(location)) { loc <- location[colony, ] @@ -2198,9 +2073,6 @@ setLocation <- function(x, location = c(0, 0), simParamBee = NULL) { x[[colony]] } - if (simParamBee$nThreads > 1) { - stopCluster(cl) - } if (nCol == 1) { x@colonies = list(tmp) diff --git a/R/Functions_L3_Colonies.R b/R/Functions_L3_Colonies.R index 16d4b87d..1c8d7ff3 100644 --- a/R/Functions_L3_Colonies.R +++ b/R/Functions_L3_Colonies.R @@ -62,21 +62,9 @@ createMultiColony <- function(x = NULL, n = NULL, simParamBee = NULL, populateCo if (populateColonies) { ids <- (simParamBee$lastColonyId+1):(simParamBee$lastColonyId + n) - if (simParamBee$nThreads > 1) { - N <- as.numeric(simParamBee$nThreads) - cl <- makeCluster(N, type="PSOCK") - registerDoParallel(cl) - - clusterExport(cl, c("SP")) - } else { - registerDoParallel(cores = 1) - } ret@colonies <- foreach(colony = seq_len(n), .packages = c("SIMplyBee")) %dopar% { createColony(simParamBee = simParamBee, id = ids[colony]) } - if (simParamBee$nThreads > 1) { - stopCluster(cl) - } simParamBee$updateLastColonyId(n = n) } else { @@ -98,21 +86,9 @@ createMultiColony <- function(x = NULL, n = NULL, simParamBee = NULL, populateCo ret <- new(Class = "MultiColony", colonies = vector(mode = "list", length = n)) ids <- (simParamBee$lastColonyId+1):(simParamBee$lastColonyId + n) - if (simParamBee$nThreads > 1) { - N <- as.numeric(simParamBee$nThreads) - cl <- makeCluster(N, type="PSOCK") - registerDoParallel(cl) - - clusterExport(cl, c("SP")) - } else { - registerDoParallel(cores = 1) - } ret@colonies <- foreach(colony = seq_len(n), .packages = c("SIMplyBee")) %dopar% { createColony(x = x[colony], simParamBee = simParamBee, id = ids[colony]) } - if (simParamBee$nThreads > 1) { - stopCluster(cl) - } simParamBee$updateLastColonyId(n = n) } diff --git a/R/SIMplyBee.R b/R/SIMplyBee.R index 3c431da4..04ad88bb 100644 --- a/R/SIMplyBee.R +++ b/R/SIMplyBee.R @@ -8,8 +8,6 @@ #' @importFrom extraDistr rtpois #' @importFrom utils packageVersion #' @importFrom foreach foreach "%dopar%" "%do%" -#' @importFrom doParallel registerDoParallel -#' @importFrom parallel makeCluster stopCluster clusterExport clusterApply # see https://r-pkgs.org/namespace.html on description what to import/depend/... #' @description diff --git a/man/MultiColony-class.Rd b/man/MultiColony-class.Rd index c898062b..d81e7d6f 100644 --- a/man/MultiColony-class.Rd +++ b/man/MultiColony-class.Rd @@ -7,8 +7,8 @@ \alias{show,MultiColony-method} \alias{c,MultiColony-method} \alias{c,MultiColonyOrNULL-method} -\alias{[,MultiColony,integerOrNumericOrLogical,ANY,ANY-method} -\alias{[,MultiColony,character,ANY,ANY-method} +\alias{[,MultiColony,integerOrNumericOrLogical-method} +\alias{[,MultiColony,character-method} \alias{[[,MultiColony,integerOrNumericOrLogical-method} \alias{[[,MultiColony,character-method} \alias{[<-,MultiColony,integerOrNumericOrLogicalOrCharacter,ANY,MultiColony-method} @@ -23,9 +23,9 @@ isMultiColony(x) \S4method{c}{MultiColonyOrNULL}(x, ...) -\S4method{[}{MultiColony,integerOrNumericOrLogical,ANY,ANY}(x, i, j, drop) +\S4method{[}{MultiColony,integerOrNumericOrLogical}(x, i, j, drop) -\S4method{[}{MultiColony,character,ANY,ANY}(x, i, j, drop) +\S4method{[}{MultiColony,character}(x, i, j, drop) \S4method{[[}{MultiColony,integerOrNumericOrLogical}(x, i) diff --git a/tests/testthat/test-L0_auxiliary_functions.R b/tests/testthat/test-L0_auxiliary_functions.R index 6a8bf4d6..a373007a 100644 --- a/tests/testthat/test-L0_auxiliary_functions.R +++ b/tests/testthat/test-L0_auxiliary_functions.R @@ -1,8 +1,9 @@ # ---- nColonies ---- + test_that("nColonies", { founderGenomes <- quickHaplo(nInd = 3, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) - SP$nThreads = 1L + SP$nThreads <- 1L basePop <- createVirginQueens(founderGenomes, simParamBee = SP) expect_equal(nColonies(createMultiColony(n = 2, simParamBee = SP)), 2) expect_equal(nColonies(createMultiColony(simParamBee = SP)), 0) @@ -14,6 +15,7 @@ test_that("nColonies", { test_that("nCaste", { founderGenomes <- quickHaplo(nInd = 5, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) + SP$nThreads <- 1L basePop <- createVirginQueens(founderGenomes, simParamBee = SP) drones <- createDrones(x = basePop[1], nInd = 45, simParamBee = SP) @@ -26,12 +28,12 @@ test_that("nCaste", { expect_equal(nCaste(colony, caste = "virginQueens", simParamBee = SP), 0) expect_equal(nCaste(colony, caste = "fathers", simParamBee = SP), 10) - apiary <- createMultiColony(basePop[3:4], n = 2, simParamBee = SP) - apiary <- cross(apiary, drones = droneGroups[c(2, 3)], simParamBee = SP) - apiary <- buildUp(apiary, nWorkers = 20, nDrones = 10, simParamBee = SP) - expect_equal(sum(nCaste(apiary, caste = "queen", simParamBee = SP)), 2) - expect_equal(sum(nCaste(apiary, caste = "virginQueens", simParamBee = SP)), 0) - expect_equal(sum(nCaste(apiary, caste = "fathers", simParamBee = SP)), 20) + #apiary <- createMultiColony(basePop[3:4], n = 2, simParamBee = SP) + #apiary <- cross(apiary, drones = droneGroups[c(2, 3)], simParamBee = SP) + #apiary <- buildUp(apiary, nWorkers = 20, nDrones = 10, simParamBee = SP) + #expect_equal(sum(nCaste(apiary, caste = "queen", simParamBee = SP)), 2) + #expect_equal(sum(nCaste(apiary, caste = "virginQueens", simParamBee = SP)), 0) + #expect_equal(sum(nCaste(apiary, caste = "fathers", simParamBee = SP)), 20) }) # ---- nQueens ---- @@ -40,6 +42,7 @@ test_that("nQueens", { founderGenomes <- quickHaplo(nInd = 10, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) SP$nThreads = 1L + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) drones <- createDrones(basePop[1], n = 1000, simParamBee = SP) fatherGroups <- pullDroneGroupsFromDCA(drones, n = 10, nDrones = 10, simParamBee = SP) @@ -60,6 +63,7 @@ test_that("nDrones", { founderGenomes <- quickHaplo(nInd = 10, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) SP$nThreads = 1L + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) drones <- createDrones(basePop[1], n = 1000, simParamBee = SP) fatherGroups <- pullDroneGroupsFromDCA(drones, n = 10, nDrones = 10, simParamBee = SP) @@ -103,6 +107,7 @@ test_that("isCaste", { founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) SP$nThreads = 1L + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) drones <- createDrones(x = basePop[1], nInd = 1000, simParamBee = SP) @@ -136,6 +141,7 @@ test_that("calcQueensPHomBrood", { founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes) SP$nThreads = 1L + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) drones <- createDrones(x = basePop[1], nInd = 1000, simParamBee = SP) @@ -167,6 +173,7 @@ test_that("pHomBrood", { founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes) SP$nThreads = 1L + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) drones <- createDrones(x = basePop[1], nInd = 1000, simParamBee = SP) @@ -199,6 +206,7 @@ test_that("nHomBrood", { founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes) SP$nThreads = 1L + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) drones <- createDrones(x = basePop[1], nInd = 1000, simParamBee = SP) @@ -231,6 +239,7 @@ test_that("isQueenPresent", { founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) SP$nThreads = 1L + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) drones <- createDrones(x = basePop[1], nInd = 1000, simParamBee = SP) @@ -259,6 +268,7 @@ test_that("isVirginQueensPresent", { founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) SP$nThreads = 1L + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) drones <- createDrones(x = basePop[1], nInd = 1000, simParamBee = SP) @@ -289,6 +299,7 @@ test_that("isProductive", { founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) SP$nThreads = 1L + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) drones <- createDrones(x = basePop[1], nInd = 1000, simParamBee = SP) @@ -323,6 +334,7 @@ test_that("reduceDroneHaplo", { founderGenomes <- quickHaplo(nInd = 3, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) SP$nThreads = 1L + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) drones <- createDrones(x = basePop[1], nInd = 2, simParamBee = SP) virginQueens <- c(basePop[2:3]) @@ -347,6 +359,7 @@ test_that("reduceDroneGeno", { founderGenomes <- quickHaplo(nInd = 10, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) SP$nThreads = 1L + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) drones <- createDrones(x = basePop[1], nInd = 2, simParamBee = SP) virginQueens <- c(basePop[2:3]) @@ -370,6 +383,7 @@ test_that("getCsdAlleles", { founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes) SP$nThreads = 1L + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) drones <- createDrones(x = basePop[1], nInd = 1000, simParamBee = SP) @@ -387,6 +401,7 @@ test_that("getCsdAlleles", { rm(SP) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) SP$nThreads = 1L + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) drones <- createDrones(x = basePop[1], nInd = 1000, simParamBee = SP) @@ -402,6 +417,8 @@ test_that("getCsdAlleles", { # test unique and colapse rm(SP) SP <- SimParamBee$new(founderGenomes, nCsdAlleles = 5) + SP$nThreads = 1L + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) drones <- createDrones(x = basePop[1], nInd = 1000, simParamBee = SP) @@ -428,6 +445,7 @@ test_that("getCsdGeno", { founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, nCsdAlleles = 5) SP$nThreads = 1L + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) drones <- createDrones(x = basePop[1], nInd = 1000, simParamBee = SP) @@ -447,6 +465,7 @@ test_that("getCsdGeno", { SP <- SimParamBee$new(founderGenomes, csdChr = NULL) SP$nThreads = 1L + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) drones <- createDrones(x = basePop[1], nInd = 1000, simParamBee = SP) @@ -467,6 +486,7 @@ test_that("isCsdHeterozygous", { founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, nCsdAlleles = 5) SP$nThreads = 1L + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) drones <- createDrones(x = basePop[1], nInd = 1000, simParamBee = SP) @@ -486,6 +506,7 @@ test_that("isCsdHeterozygous", { # set CSD to NULL SP <- SimParamBee$new(founderGenomes, csdChr = NULL) SP$nThreads = 1L + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) drones <- createDrones(x = basePop[1], nInd = 1000, simParamBee = SP) @@ -505,6 +526,7 @@ test_that("nCsdAlleles", { founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes) SP$nThreads = 1L + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) drones <- createDrones(x = basePop[1], nInd = 1000, simParamBee = SP) @@ -523,6 +545,7 @@ test_that("nCsdAlleles", { # set CSD to NULL SP <- SimParamBee$new(founderGenomes, csdChr = NULL) SP$nThreads = 1L + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) drones <- createDrones(x = basePop[1], nInd = 1000, simParamBee = SP) @@ -538,6 +561,8 @@ test_that("nCsdAlleles", { #collapse argument nCsdAlleles <- 5 SP <- SimParamBee$new(founderGenomes, nCsdAlleles = nCsdAlleles) + SP$nThreads = 1L + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) drones <- createDrones(x = basePop[1], nInd = 1000, simParamBee = SP) @@ -562,6 +587,7 @@ test_that("calcBeeGRMIbs", { SP$addTraitA(10) SP$addSnpChip(5) + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) drones <- createDrones(x = basePop[1], nInd = 1000, simParamBee = SP) fatherGroups <- pullDroneGroupsFromDCA(drones, n = 10, nDrones = 10, simParamBee = SP) @@ -615,6 +641,7 @@ test_that("editCsdLocus", { founderGenomes <- quickHaplo(nInd = 100, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = 1, nCsdAlleles = 8) SP$nThreads = 1L + basePop <- createVirginQueens(founderGenomes, editCsd = FALSE, simParamBee = SP) nrow(getCsdAlleles(basePop, unique = TRUE, simParamBee = SP)) expect_false(all(isCsdHeterozygous(basePop, simParamBee = SP))) @@ -629,6 +656,8 @@ test_that("editCsdLocus", { test_that("emptyNULL", { founderGenomes <- quickHaplo(nInd = 5, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = 1, nCsdAlleles = 8) + SP$nThreads <- 1L + basePop <- createVirginQueens(founderGenomes, editCsd = FALSE, simParamBee = SP) expect_true(isEmpty(new(Class = "Pop"))) @@ -665,6 +694,7 @@ test_that("isDronesPresent", { founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) SP$nThreads = 1L + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) drones <- createDrones(x = basePop[1], nInd = 1000, simParamBee = SP) @@ -690,6 +720,7 @@ test_that("isFathersPresent", { founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) SP$nThreads = 1L + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) drones <- createDrones(x = basePop[1], nInd = 1000, simParamBee = SP) @@ -718,6 +749,7 @@ test_that("isWorkersPresent", { founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) SP$nThreads = 1L + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) drones <- createDrones(x = basePop[1], nInd = 1000, simParamBee = SP) @@ -743,6 +775,7 @@ test_that("isGenoHeterozygous", { founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes) SP$nThreads = 1L + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) drones <- createDrones(x = basePop[1], nInd = 1000, simParamBee = SP) @@ -776,6 +809,7 @@ test_that("getBV", { SP$nThreads = 1L SP$addTraitA(nQtlPerChr = 10, var = 1) SP$addSnpChip(5) + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) drones <- createDrones(x = basePop[1], nInd = 1000, simParamBee = SP) @@ -804,6 +838,7 @@ test_that("getDd", { founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) SP$nThreads = 1L + SP$addTraitAD(nQtlPerChr = 10, meanDD = 0.2, varDD = 0.1) basePop <- createVirginQueens(founderGenomes, simParamBee = SP) @@ -833,6 +868,7 @@ test_that("getAa", { founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) SP$nThreads = 1L + SP$addTraitADE(nQtlPerChr = 10, meanDD = 0.2, varDD = 0.1, relAA = 0.5) basePop <- createVirginQueens(founderGenomes, simParamBee = SP) @@ -862,6 +898,7 @@ test_that("editCsdLocus", { founderGenomes <- quickHaplo(nInd = 100, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = 1, nCsdAlleles = 8) SP$nThreads = 1L + basePop <- createVirginQueens(founderGenomes, editCsd = FALSE, simParamBee = SP) nrow(getCsdAlleles(basePop, unique = TRUE, simParamBee = SP)) all(isCsdHeterozygous(basePop, simParamBee = SP)) @@ -891,9 +928,9 @@ test_that("getLocation", { expect_equal(getLocation(apiary, collapse = TRUE), tmp) loc <- c(123, 456) - expect_equal(getLocation(setLocation(colony, location = loc)), loc) + expect_equal(getLocation(setLocation(colony, location = loc, simParamBee = SP)), loc) - expect_equal(getLocation(setLocation(apiary, location = loc)), + expect_equal(getLocation(setLocation(apiary, location = loc, simParamBee = SP)), list("2" = loc, "3" = loc)) }) @@ -902,27 +939,32 @@ test_that("createCrossPlan", { founderGenomes <- quickHaplo(nInd = 1000, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes) SP$nThreads = 1L + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) # Create three virgin MultiColony objects with locations virginColonies1 <- createMultiColony(basePop[1:2], simParamBee = SP) virginColonies1 <- setLocation(virginColonies1, location = Map(c, runif(2, 0, 2*pi), - runif(2, 0, 2*pi))) + runif(2, 0, 2*pi)), + simParamBee = SP) virginColonies2 <- createMultiColony(basePop[3:4], simParamBee = SP) virginColonies2 <- setLocation(virginColonies2, location = Map(c, runif(2, 0, 2*pi), - runif(2, 0, 2*pi))) + runif(2, 0, 2*pi)), + simParamBee = SP) virginColonies3 <- createMultiColony(basePop[5:6], simParamBee = SP) virginColonies3 <- setLocation(virginColonies3, location = Map(c, runif(2, 0, 2*pi), - runif(2, 0, 2*pi))) + runif(2, 0, 2*pi)), + simParamBee = SP) # Create drone colonies droneColonies <- createMultiColony(basePop[7:9], simParamBee = SP) droneColonies <- setLocation(droneColonies, location = Map(c, runif(3, 0, 2*pi), - runif(3, 0, 2*pi))) + runif(3, 0, 2*pi)), + simParamBee = SP) # Create some drones to mate initial drone colonies with DCA <- createDrones(basePop[10:12], nInd = 20, simParamBee = SP) @@ -959,6 +1001,7 @@ test_that("getCaste", { founderGenomes <- quickHaplo(nInd = 1000, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes) SP$nThreads = 1L + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) expect_vector(getCaste(basePop, simParamBee = SP), "virginQueens") diff --git a/tests/testthat/test-L1_pop_functions.R b/tests/testthat/test-L1_pop_functions.R index 5d39e6a3..d73e5420 100644 --- a/tests/testthat/test-L1_pop_functions.R +++ b/tests/testthat/test-L1_pop_functions.R @@ -4,6 +4,7 @@ test_that("getCastePop", { founderGenomes <- quickHaplo(nInd = 4, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) SP$nThreads = 1L + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) drones <- createDrones(basePop[1], n = 15, simParamBee = SP) @@ -39,6 +40,7 @@ test_that("createVirginQueens", { founderGenomes <- quickHaplo(nInd = 5, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) SP$nThreads = 1L + #check that output is virginqueens ? expect_true(all(isVirginQueen(createVirginQueens(founderGenomes, simParamBee = SP), simParamBee = SP))) @@ -90,6 +92,7 @@ test_that("createDrones", { founderGenomes <- quickHaplo(nInd = 6, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) SP$nThreads = 1L + # Error: x can't be a MapPop expect_error(createDrones(founderGenomes, simParamBee = SP)) @@ -140,6 +143,7 @@ test_that("combineBeeGametes", { founderGenomes <- quickHaplo(nInd = 6, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) SP$nThreads = 1L + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) drones <- createDrones(basePop[1], n = 15, simParamBee = SP) @@ -171,6 +175,7 @@ test_that("pullCastePop", { founderGenomes <- quickHaplo(nInd = 4, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) SP$nThreads = 1L + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) drones <- createDrones(basePop[1], n = 15, simParamBee = SP) @@ -227,6 +232,7 @@ test_that("cross", { founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) SP$nThreads = 1L + basePop <- createVirginQueens(founderGenomes, nInd = 100, simParamBee = SP) drones <- createDrones(basePop[1], n = 1000, simParamBee = SP) dronesGroups <- pullDroneGroupsFromDCA(drones, n = 7, nDrones = 15, simParamBee = SP) @@ -286,43 +292,13 @@ test_that("cross", { #expect_message(cross(virginQueen2, drones= selectInd(colony@drones,nInd = 0, use = "rand", simParam = SP), checkCross = "warning", simParamBee = SP)) }) -# ---- setQueensYearOfBirth ---- -test_that("setQueensYearOfBirth", { - founderGenomes <- quickHaplo(nInd = 7, nChr = 1, segSites = 100) - SP <- SimParamBee$new(founderGenomes, csdChr = NULL) - SP$nThreads = 1L - basePop <- createVirginQueens(founderGenomes, nInd = 100, simParamBee = SP) - drones <- createDrones(x = basePop[1], nInd = 1000, simParamBee = SP) - dronesGroups <- pullDroneGroupsFromDCA(drones, n = 10, nDrones = nFathersPoisson, simParamBee = SP) - - colony <- createColony(x = basePop[2], simParamBee = SP) - colony <- cross(x = colony, drones = dronesGroups[[1]], simParamBee = SP) - colony <- buildUp(colony, simParamBee = SP) - # Error if x = pop, and not a vq or q - expect_error(setQueensYearOfBirth(colony@workers, simParamBee = SP)) - expect_error(setQueensYearOfBirth(colony@drones, simParamBee = SP)) - - colony <- removeQueen(colony, simParamBee = SP) - # Error if x = colony and no queen is present - expect_error(setQueensYearOfBirth(colony, simParamBee = SP)) - - apiary <- createMultiColony(basePop[3:4], n = 2, simParamBee = SP) - apiary <- cross(apiary, drones = dronesGroups[c(2, 3)], simParamBee = SP) - - colony1 <- createColony(x = basePop[5], simParamBee = SP) - colony1 <- cross(colony1, drones = dronesGroups[[4]], simParamBee = SP) - queen1 <- getQueen(colony1, simParamBee = SP) - - expect_s4_class(setQueensYearOfBirth(queen1, year = 2022, simParamBee = SP), "Pop") - expect_s4_class(setQueensYearOfBirth(colony1, year = 2022, simParamBee = SP), "Colony") - expect_s4_class(setQueensYearOfBirth(apiary, year = 2022, simParamBee = SP), "MultiColony") -}) # ---- createDCA ---- test_that("createDCA", { founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) SP$nThreads = 1L + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) drones <- createDrones(x = basePop[1], nInd = 1000, simParamBee = SP) @@ -358,6 +334,7 @@ test_that("pullDroneGroupsFromDCA", { founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) SP$nThreads = 1L + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) drones <- createDrones(x = basePop[1], nInd = 1000, simParamBee = SP) @@ -388,6 +365,7 @@ test_that("combineBeeGametes", { founderGenomes <- quickHaplo(nInd = 3, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) SP$nThreads = 1L + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) queen <- basePop[1] @@ -404,6 +382,7 @@ test_that("combineBeeGametesHaploidDiploid", { founderGenomes <- quickHaplo(nInd = 3, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) SP$nThreads = 1L + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) queen <- basePop[1] diff --git a/tests/testthat/test-L2_colony_functions.R b/tests/testthat/test-L2_colony_functions.R index 2daeb877..7154f39e 100644 --- a/tests/testthat/test-L2_colony_functions.R +++ b/tests/testthat/test-L2_colony_functions.R @@ -4,6 +4,7 @@ test_that("createColony", { founderGenomes <- quickHaplo(nInd = 5, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) SP$nThreads = 1L + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) drones <- createDrones(x = basePop[1], nInd = 15, simParamBee = SP) matedQueen <- cross(basePop[2], drones = drones, simParamBee = SP) @@ -24,6 +25,7 @@ test_that("reQueen", { founderGenomes <- quickHaplo(nInd = 5, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) SP$nThreads = 1L + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) drones <- createDrones(x = basePop[1], nInd = 30, simParamBee = SP) virginQueen <- basePop[2] @@ -67,6 +69,7 @@ test_that("Add functions", { founderGenomes <- quickHaplo(nInd = 5, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) SP$nThreads = 1L + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) drones <- createDrones(x = basePop[1], nInd = 100, simParamBee = SP) @@ -122,6 +125,7 @@ test_that("BuildUpDownsize", { founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) SP$nThreads = 1L + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) drones <- createDrones(x = basePop[1], nInd = 1000, simParamBee = SP) @@ -178,6 +182,7 @@ test_that("replaceFunctions", { founderGenomes <- quickHaplo(nInd = 5, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) SP$nThreads = 1L + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) drones <- createDrones(x = basePop[1], nInd = 100, simParamBee = SP) @@ -233,6 +238,7 @@ test_that("removeFunctions", { founderGenomes <- quickHaplo(nInd = 5, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) SP$nThreads = 1L + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) drones <- createDrones(x = basePop[1], nInd = 100, simParamBee = SP) @@ -279,6 +285,7 @@ test_that("setLocation", { founderGenomes <- quickHaplo(nInd = 5, nChr = 1, segSites = 50) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) SP$nThreads = 1L + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) drones <- createDrones(basePop[1], n = 1000, simParamBee = SP) droneGroups <- pullDroneGroupsFromDCA(drones, n = 4, nDrones = 10, simParamBee = SP) @@ -288,28 +295,28 @@ test_that("setLocation", { apiary <- cross(apiary, drones = droneGroups[2:4], simParamBee = SP) loc <- c(1, 1) - expect_equal(getLocation(setLocation(colony, location = loc)), loc) + expect_equal(getLocation(setLocation(colony, location = loc, simParamBee = SP)), loc) - expect_equal(getLocation(setLocation(apiary, location = loc)), + expect_equal(getLocation(setLocation(apiary, location = loc, simParamBee = SP)), list("2" = loc, "3" = loc, "4" = loc)) locList <- list("2" = c(0, 0), "3" = c(1, 1), "4" = c(2, 2)) - expect_equal(getLocation(setLocation(apiary, location = locList)), locList) + expect_equal(getLocation(setLocation(apiary, location = locList, simParamBee = SP)), locList) locDF <- data.frame(x = c(0, 1, 2), y = c(0, 1, 2)) - expect_equal(getLocation(setLocation(apiary, location = locDF)), locList) + expect_equal(getLocation(setLocation(apiary, location = locDF, simParamBee = SP)), locList) emptyColony <- createColony(simParamBee = SP) - expect_s4_class(setLocation(emptyColony, location = c(1,1)), "Colony") - expect_equal(setLocation(emptyColony, location = c(1,1))@location, c(1,1)) + expect_s4_class(setLocation(emptyColony, location = c(1,1), simParamBee = SP), "Colony") + expect_equal(setLocation(emptyColony, location = c(1,1), simParamBee = SP)@location, c(1,1)) emptyApiary <- createMultiColony(n = 3, simParamBee = SP) apiary <- createMultiColony(basePop[1:3], simParamBee = SP) - expect_error(setLocation(emptyApiary, location = c(1,2))) - expect_error(setLocation(emptyApiary, location = list(1,2))) # Lengths do not match - expect_s4_class(setLocation(apiary, location = c(1,2)), "MultiColony") - expect_s4_class(setLocation(apiary, location = list(1:2, 3:4, 4:5)), "MultiColony") + expect_error(setLocation(emptyApiary, location = c(1,2), simParamBee = SP)) + expect_error(setLocation(emptyApiary, location = list(1,2), simParamBee = SP)) # Lengths do not match + expect_s4_class(setLocation(apiary, location = c(1,2), simParamBee = SP), "MultiColony") + expect_s4_class(setLocation(apiary, location = list(1:2, 3:4, 4:5), simParamBee = SP), "MultiColony") }) # ---- Supersede ---- @@ -318,6 +325,7 @@ test_that("supersede", { founderGenomes <- quickHaplo(nInd = 10, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) SP$nThreads = 1L + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) drones <- createDrones(basePop[1], n = 1000, simParamBee = SP) fatherGroups <- pullDroneGroupsFromDCA(drones, n = 10, nDrones = 10, simParamBee = SP) @@ -354,6 +362,7 @@ test_that("split", { founderGenomes <- quickHaplo(nInd = 10, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) SP$nThreads = 1L + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) drones <- createDrones(basePop[1], n = 1000, simParamBee = SP) fatherGroups <- pullDroneGroupsFromDCA(drones, n = 10, nDrones = 10, simParamBee = SP) @@ -395,6 +404,7 @@ test_that("resetEvents", { founderGenomes <- quickHaplo(nInd = 5, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) SP$nThreads = 1L + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) drones <- createDrones(x = basePop[1], nInd = 100, simParamBee = SP) @@ -418,8 +428,8 @@ test_that("resetEvents", { expect_true(hasSuperseded(colony)) expect_true(all(hasSuperseded(apiary))) - colony <- resetEvents(colony) - apiary <- resetEvents(apiary) + colony <- resetEvents(colony, simParamBee = SP) + apiary <- resetEvents(apiary, simParamBee = SP) expect_false(isProductive(colony)) expect_false(all(isProductive(apiary))) @@ -433,6 +443,7 @@ test_that("Combine", { founderGenomes <- quickHaplo(nInd = 10, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) SP$nThreads = 1L + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) drones <- createDrones(basePop[1], n = 1000, simParamBee = SP) fatherGroups <- pullDroneGroupsFromDCA(drones, n = 10, nDrones = 10, simParamBee = SP) @@ -453,14 +464,14 @@ test_that("Combine", { apiary1 <- buildUp(x = apiary1, nWorkers = 100, nDrones = 20, simParamBee = SP) apiary2 <- buildUp(x = apiary2, nWorkers = 20, nDrones = 5, simParamBee = SP) - colony3 <- combine(strong = colony1, weak = colony2) - apiary3 <- combine(strong = apiary1, weak = apiary2) + colony3 <- combine(strong = colony1, weak = colony2, simParamBee = SP) + apiary3 <- combine(strong = apiary1, weak = apiary2, simParamBee = SP) expect_equal(nWorkers(colony3, simParamBee = SP),sum(nWorkers(colony1, simParamBee = SP), nWorkers(colony2, simParamBee = SP))) expect_equal(colony1@queen@id, colony3@queen@id) expect_equal(nWorkers(apiary3[[2]], simParamBee = SP),sum(nWorkers(apiary1[[2]], simParamBee = SP), nWorkers(apiary2[[2]], simParamBee = SP))) colony1 <- NULL colony2 <- NULL - expect_error(combine(strong = colony1, weak = colony2)) # discus the output + expect_error(combine(strong = colony1, weak = colony2, simParamBee = SP)) # discus the output }) # ---- Swarm ---- @@ -469,6 +480,7 @@ test_that("swarm", { founderGenomes <- quickHaplo(nInd = 10, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) SP$nThreads = 1L + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) drones <- createDrones(basePop[1], n = 1000, simParamBee = SP) fatherGroups <- pullDroneGroupsFromDCA(drones, n = 10, nDrones = 10, simParamBee = SP) @@ -511,6 +523,7 @@ test_that("collapse", { founderGenomes <- quickHaplo(nInd = 10, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) SP$nThreads = 1L + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) drones <- createDrones(basePop[1], n = 1000, simParamBee = SP) fatherGroups <- pullDroneGroupsFromDCA(drones, n = 10, nDrones = 10, simParamBee = SP) @@ -523,12 +536,12 @@ test_that("collapse", { # Collapse expect_false(hasCollapsed(colony)) - colony <- collapse(colony) + colony <- collapse(colony, simParamBee = SP) expect_true(hasCollapsed(colony)) expect_false(all(hasCollapsed(apiary))) tmp <- pullColonies(apiary, n = 2, simParamBee = SP) - apiaryLost <- collapse(tmp$pulled) + apiaryLost <- collapse(tmp$pulled, simParamBee = SP) expect_true(all(hasCollapsed(apiaryLost))) apiaryLeft <- tmp$remnant expect_false(all(hasCollapsed(apiaryLeft))) diff --git a/tests/testthat/test-L3_Colonies_functions.R b/tests/testthat/test-L3_Colonies_functions.R index e73a4b8f..2598dc2b 100644 --- a/tests/testthat/test-L3_Colonies_functions.R +++ b/tests/testthat/test-L3_Colonies_functions.R @@ -1,11 +1,11 @@ # Level 3 MultiColony Functions - # ---- createMultiColony ---- test_that("createMultiColony", { founderGenomes <- quickHaplo(nInd = 6, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) SP$nThreads = 1L + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) drones <- createDrones(basePop[1], n = 100, simParamBee = SP) # Error if individuals x are not vq or q @@ -37,12 +37,13 @@ test_that("createMultiColony", { expect_s4_class(createMultiColony(x = basePop[4:5], n = 2, simParamBee = SP), "MultiColony") }) -# ---- selectColonies ---- +# ---- selectColonies --- test_that("selectColonies", { founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) SP$nThreads = 1L + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) drones <- createDrones(x = basePop[1:4], nInd = 100, simParamBee = SP) @@ -87,6 +88,7 @@ test_that("pullColonies", { founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) SP$nThreads = 1L + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) # Error if argument multicolony isn't a multicolony class expect_error(pullColonies(basePop, simParamBee = SP)) @@ -128,6 +130,7 @@ test_that("removeColonies", { founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) SP$nThreads = 1L + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) # Error if argument multicolony isn't a multicolony class expect_error(removeColonies(basePop, simParamBee = SP)) From efbf77a85d9fccfcde2057930aac564cd6d82db4 Mon Sep 17 00:00:00 2001 From: janaobsteter Date: Mon, 8 Dec 2025 16:50:05 +0000 Subject: [PATCH 41/42] Resolving high-priority issues, adding a parallelisation vignette, and preparing the package for a new stable version --- DESCRIPTION | 2 +- NAMESPACE | 2 - R/Class-SimParamBee.R | 53 ++++--- R/Functions_L0_auxilary.R | 120 +++++----------- R/Functions_L1_Pop.R | 26 ++-- R/Functions_L2_Colony.R | 29 ++-- man/addCastePop.Rd | 4 +- man/buildUp.Rd | 5 +- man/createCastePop.Rd | 2 +- man/downsize.Rd | 2 +- man/getMisc.Rd | 20 --- man/isCsdHeterozygous.Rd | 3 +- man/mapCasteToColonyValue.Rd | 11 +- man/removeCastePop.Rd | 2 +- man/replaceCastePop.Rd | 2 +- man/resetEvents.Rd | 2 +- man/setMisc.Rd | 26 ---- man/supersede.Rd | 6 +- man/swarm.Rd | 6 +- tests/testthat/test-L0_auxiliary_functions.R | 67 ++++++--- vignettes/Colony_locations.csv | 68 ++++----- vignettes/H_Parallelisation.Rmd | 140 +++++++++++++++++++ vignettes/PCPU_mean.png | Bin 0 -> 21000 bytes vignettes/RSS_mean.png | Bin 0 -> 20251 bytes vignettes/Time_mean.png | Bin 0 -> 20757 bytes 25 files changed, 351 insertions(+), 247 deletions(-) delete mode 100644 man/getMisc.Rd delete mode 100644 man/setMisc.Rd create mode 100644 vignettes/H_Parallelisation.Rmd create mode 100644 vignettes/PCPU_mean.png create mode 100644 vignettes/RSS_mean.png create mode 100644 vignettes/Time_mean.png diff --git a/DESCRIPTION b/DESCRIPTION index 394a7d28..b2842785 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -27,7 +27,7 @@ License: MIT + file LICENSE Encoding: UTF-8 LazyData: true Imports: methods, R6, stats, utils, extraDistr (>= 1.9.1), RANN, Rcpp (>= 0.12.7), foreach -Depends: R (>= 3.3.0), AlphaSimR (>= 1.5.3) +Depends: R (>= 3.3.0), AlphaSimR (>= 2.0.0) LinkingTo: Rcpp, RcppArmadillo (>= 0.7.500.0.0), BH RoxygenNote: 7.3.2 Suggests: diff --git a/NAMESPACE b/NAMESPACE index 2d0cae7e..a61e2857 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -70,7 +70,6 @@ export(getGv) export(getIbdHaplo) export(getId) export(getLocation) -export(getMisc) export(getPheno) export(getPooledGeno) export(getQtlGeno) @@ -191,7 +190,6 @@ export(replaceWorkers) export(resetEvents) export(selectColonies) export(setLocation) -export(setMisc) export(simulateHoneyBeeGenomes) export(split) export(splitPColonyStrength) diff --git a/R/Class-SimParamBee.R b/R/Class-SimParamBee.R index 2b66a241..3e99a4fc 100644 --- a/R/Class-SimParamBee.R +++ b/R/Class-SimParamBee.R @@ -1249,17 +1249,20 @@ downsizePUnif <- function(colony, n = 1, min = 0.8, max = 0.9) { #' @param value character, one of \code{pheno} or \code{gv} #' @param queenTrait numeric (column position) or character (column name), #' trait(s) that represents queen's contribution to colony value(s); if -#' \code{NULL} then this contribution is 0; you can pass more than one trait +#' \code{NULL} or there is no queen present, then this contribution is 0; +#' you can pass more than one trait #' here, but make sure that \code{combineFUN} works with these trait dimensions -#' @param queenFUN function, function that will be applied to queen's value +#' @param queenFUN function, function that will be applied to queen's value. #' @param workersTrait numeric (column position) or character (column name), #' trait(s) that represents workers' contribution to colony value(s); if -#' \code{NULL} then this contribution is 0; you can pass more than one trait +#' \code{NULL} or there are no workers present, then this contribution is 0; +#' you can pass more than one trait #' here, but make sure that \code{combineFUN} works with these trait dimensions #' @param workersFUN function, function that will be applied to workers values #' @param dronesTrait numeric (column position) or character (column name), #' trait(s) that represents drones' contribution to colony value(s); if -#' \code{NULL} then this contribution is 0; you can pass more than one trait +#' \code{NULL} or there are no drones present then this contribution is 0; +#' you can pass more than one trait #' here, but make sure that \code{combineFUN} works with these trait dimensions #' @param dronesFUN function, function that will be applied to drone values #' @param traitName, the name of the colony trait(s), say, honeyYield; you can pass @@ -1369,32 +1372,44 @@ mapCasteToColonyValue <- function(colony, if (is.null(queenTrait)) { queenEff <- 0 } else { - if (value %in% c("pheno", "gv")) { - tmp <- valueFUN(colony@queen)[, queenTrait, drop = FALSE] - } else { # bv, dd, and aa: leaving this in for future use! - tmp <- valueFUN(colony@queen, simParam = simParamBee)[, queenTrait, drop = FALSE] + if (isQueenPresent(colony)) { + if (value %in% c("pheno", "gv")) { + tmp <- valueFUN(colony@queen)[, queenTrait, drop = FALSE] + } else { # bv, dd, and aa: leaving this in for future use! + tmp <- valueFUN(colony@queen, simParam = simParamBee)[, queenTrait, drop = FALSE] + } + queenEff <- queenFUN(tmp) + } else { + queenEff <- 0 } - queenEff <- queenFUN(tmp) } if (is.null(workersTrait)) { workersEff <- 0 } else { - if (value %in% c("pheno", "gv")) { - tmp <- valueFUN(colony@workers)[, workersTrait, drop = FALSE] - } else { # bv, dd, and aa - tmp <- valueFUN(colony@workers, simParam = simParamBee)[, workersTrait, drop = FALSE] + if (nWorkers(colony) != 0) { + if (value %in% c("pheno", "gv")) { + tmp <- valueFUN(colony@workers)[, workersTrait, drop = FALSE] + } else { # bv, dd, and aa + tmp <- valueFUN(colony@workers, simParam = simParamBee)[, workersTrait, drop = FALSE] + } + workersEff <- workersFUN(tmp) + } else { + workersEff <- 0 } - workersEff <- workersFUN(tmp) } if (is.null(dronesTrait)) { dronesEff <- 0 } else { - if (value %in% c("pheno", "gv")) { - tmp <- valueFUN(colony@drones)[, dronesTrait, drop = FALSE] - } else { # bv, dd, and aa - tmp <- valueFUN(colony@drones, simParam = simParamBee)[, dronesTrait, drop = FALSE] + if (nDrones(colony) != 0) { + if (value %in% c("pheno", "gv")) { + tmp <- valueFUN(colony@drones)[, dronesTrait, drop = FALSE] + } else { # bv, dd, and aa + tmp <- valueFUN(colony@drones, simParam = simParamBee)[, dronesTrait, drop = FALSE] + } + dronesEff <- dronesFUN(tmp) + } else { + dronesEff <- 0 } - dronesEff <- dronesFUN(tmp) } colonyValue <- combineFUN(q = queenEff, w = workersEff, d = dronesEff) nColTrt <- length(colonyValue) diff --git a/R/Functions_L0_auxilary.R b/R/Functions_L0_auxilary.R index 65160d15..e1198751 100644 --- a/R/Functions_L0_auxilary.R +++ b/R/Functions_L0_auxilary.R @@ -2229,6 +2229,9 @@ getQueenCsdAlleles <- function(x, allele = "all", unique = FALSE, collapse = FAL if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } + if (!(isColony(x) | isMultiColony(x))) { + stop("Argument x must be a Colony or MultiColony class object!") + } ret <- getCsdAlleles(x, caste = "queen", allele = allele, @@ -2246,6 +2249,9 @@ getFathersCsdAlleles <- function(x, nInd = NULL, allele = "all", dronesHaploid = if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } + if (!(isColony(x) | isMultiColony(x))) { + stop("Argument x must be a Colony or MultiColony class object!") + } ret <- getCsdAlleles(x, caste = "fathers", nInd = nInd, @@ -2265,6 +2271,9 @@ getVirginQueensCsdAlleles <- function(x, nInd = NULL, allele = "all", if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } + if (!(isColony(x) | isMultiColony(x))) { + stop("Argument x must be a Colony or MultiColony class object!") + } ret <- getCsdAlleles(x, caste = "virginQueens", nInd = nInd, @@ -2283,6 +2292,9 @@ getWorkersCsdAlleles <- function(x, nInd = NULL, allele = "all", if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } + if (!(isColony(x) | isMultiColony(x))) { + stop("Argument x must be a Colony or MultiColony class object!") + } ret <- getCsdAlleles(x, caste = "workers", nInd = nInd, @@ -2301,6 +2313,9 @@ getDronesCsdAlleles <- function(x, nInd = NULL, allele = "all", dronesHaploid = if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } + if (!(isColony(x) | isMultiColony(x))) { + stop("Argument x must be a Colony or MultiColony class object!") + } ret <- getCsdAlleles(x, caste = "drones", nInd = nInd, @@ -2468,6 +2483,9 @@ getQueenCsdGeno <- function(x, collapse = FALSE, simParamBee = NULL) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } + if (!(isColony(x) | isMultiColony(x))) { + stop("Argument x must be a Colony or MultiColony class object!") + } ret <- getCsdAlleles(x, caste = "queen", collapse = collapse, @@ -2483,6 +2501,9 @@ getFathersCsdGeno <- function(x, nInd = NULL, dronesHaploid = TRUE, collapse = F if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } + if (!(isColony(x) | isMultiColony(x))) { + stop("Argument x must be a Colony or MultiColony class object!") + } ret <- getCsdAlleles(x, nInd = nInd, caste = "fathers", @@ -2500,6 +2521,9 @@ getVirginQueensCsdGeno <- function(x, nInd = NULL, collapse = FALSE, if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } + if (!(isColony(x) | isMultiColony(x))) { + stop("Argument x must be a Colony or MultiColony class object!") + } ret <- getCsdAlleles(x, nInd = nInd, caste = "virginQueens", @@ -2516,6 +2540,9 @@ getWorkersCsdGeno <- function(x, nInd = NULL, collapse = FALSE, if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } + if (!(isColony(x) | isMultiColony(x))) { + stop("Argument x must be a Colony or MultiColony class object!") + } ret <- getCsdAlleles(x, nInd = nInd, caste = "workers", @@ -2533,6 +2560,9 @@ getDronesCsdGeno <- function(x, nInd = NULL, dronesHaploid = TRUE, if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } + if (!(isColony(x) | isMultiColony(x))) { + stop("Argument x must be a Colony or MultiColony class object!") + } ret <- getCsdAlleles(x, nInd = nInd, caste = "drones", @@ -2566,7 +2596,8 @@ isGenoHeterozygous <- function(x) { #' #' @description Level 0 function that returns if individuals of a population are #' heterozygous at the csd locus. See \code{\link[SIMplyBee]{SimParamBee}} for more -#' information about the csd locus. +#' information about the csd locus. The function also return \code{TRUE} for drones to +#' mark their viability, although they are haploid. #' #' @param pop \code{\link[AlphaSimR]{Pop-class}} #' @param simParamBee \code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters @@ -6401,93 +6432,6 @@ createCrossPlan <- function(x, return(crossPlan) } -# Misc helpers -# These functions replace the defunct functions of the same name in AlphaSimR - -#' @rdname setMisc -#' @title Set miscellaneous information in a population -#' -#' @description Set miscellaneous information in a population -#' -#' @param x \code{\link[AlphaSimR]{Pop-class}} -#' @param node character, name of the node to set within the \code{x@misc} slot -#' @param value, value to be saved into \code{x@misc[[*]][[node]]}; length of -#' \code{value} should be equal to \code{nInd(x)}; if its length is 1, then -#' it is repeated using \code{rep} (see examples) -#' -#' @details A \code{NULL} in \code{value} is ignored -#' -#' @return \code{\link[AlphaSimR]{Pop-class}} -#' -#' @export -setMisc <- function(x, node = NULL, value = NULL) { - if (isPop(x)) { - if (is.null(node)) { - stop("Argument node must be provided!") - } - if (is.null(value)) { - stop("Argument value must be provided!") - } - n <- nInd(x) - if (length(value) == 1 && n > 1) { - value <- rep(x = value, times = n) - } - if (length(value) != n) { - stop("Argument value must be of length 1 or nInd(x)!") - } - - # Check current AlphaSimR version for new or legacy misc slot - if(packageVersion("AlphaSimR") > package_version("1.5.3")){ - # New misc slot - x@misc[[node]] = value - }else{ - # Legacy misc slot - names(value) = rep(x = node, times = n) - inode = match(names(x@misc[[1]]),node) - inode = inode[!is.na(inode)] - if(length(inode) == 0){ - x@misc = sapply(seq_len(n),function(ind){ - c(x@misc[[ind]],value[ind]) - },simplify = FALSE) - }else{ - x@misc = sapply(seq_len(n),function(ind){ - c(x@misc[[ind]],value[ind])[-inode] - },simplify = FALSE) - } - } - - } - - return(x) -} - -#' @rdname getMisc -#' @title Get miscellaneous information in a population -#' -#' @description Get miscellaneous information in a population -#' -#' @param x \code{\link[AlphaSimR]{Pop-class}} -#' @param node character, name of the node to get from the \code{x@misc} slot; -#' if \code{NULL} the whole \code{x@misc} slot is returned -#' -#' @return The \code{x@misc} slot or its nodes \code{x@misc[[*]][[node]]} -#' -#' @export -getMisc <- function(x, node = NULL) { - if (isPop(x)) { - if (is.null(node)) { - ret <- x@misc - } else { - # Check current AlphaSimR version for new or legacy misc slot - ret = x@misc[[node]] - } - } else { - stop("Argument x must be a Pop class object!") - } - return(ret) -} - - #' @rdname mapLoci #' @title Finds loci on a genetic map and return a list of positions #' diff --git a/R/Functions_L1_Pop.R b/R/Functions_L1_Pop.R index 1684d1ed..114c7b26 100644 --- a/R/Functions_L1_Pop.R +++ b/R/Functions_L1_Pop.R @@ -352,7 +352,7 @@ getVirginQueens <- function(x, nInd = NULL, use = "rand", collapse = FALSE, simP #' # Create a Colony and a MultiColony class #' colony <- createColony(x = basePop[2]) #' colony <- cross(colony, drones = droneGroups[[1]]) -#' apiary <- createMultiColony(basePop[3:4], n = 2) +#' apiary <- createMultiColony(basePop[3:4]) #' apiary <- cross(apiary, drones = droneGroups[c(2, 3)]) #' #' # Using default nInd in SP @@ -499,8 +499,6 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, simParamBee = simParamBee ) - - simParamBee$addToCaste(id = ret$workers@id, caste = "workers") ret$workers@sex[] <- "F" @@ -1763,17 +1761,17 @@ cross <- function(x, # All of the input has been transformed to a Pop crossVirginQueen <- function(virginQueen, virginQueenDrones, simParamBee = NULL) { virginQueen@misc$fathers[[1]] <- virginQueenDrones - virginQueen <- setMisc(x = virginQueen, node = "nWorkers", value = 0) - virginQueen <- setMisc(x = virginQueen, node = "nDrones", value = 0) - - virginQueen <- setMisc(x = virginQueen, node = "nHomBrood", value = 0) - # if (isCsdActive(simParamBee = simParamBee)) { #This does still not work it the CSD is turned on - # val <- calcQueensPHomBrood(x = virginQueen, simParamBee = simParamBee) - # } else { - # val <- NA - # } - # - # virginQueen <- setMisc(x = virginQueen, node = "pHomBrood", value = val) + virginQueen@misc[["nWorkers"]] <- 0 + virginQueen@misc[["nDrones"]] <- 0 + virginQueen@misc[["nHomBrood"]] <- 0 + + if (isCsdActive(simParamBee = simParamBee)) { #This does still not work it the CSD is turned on + val <- calcQueensPHomBrood(x = virginQueen, simParamBee = simParamBee) + } else { + val <- NA + } + + virginQueen@misc[["pHomBrood"]] <- val return(virginQueen) } diff --git a/R/Functions_L2_Colony.R b/R/Functions_L2_Colony.R index f3440b8b..867cbd4c 100644 --- a/R/Functions_L2_Colony.R +++ b/R/Functions_L2_Colony.R @@ -255,7 +255,7 @@ addCastePop_internal <- function(pop, colony, caste, new = FALSE) { #' # Create and cross Colony and MultiColony class #' colony <- createColony(x = basePop[2]) #' colony <- cross(colony, drones = droneGroups[[1]]) -#' apiary <- createMultiColony(basePop[4:5], n = 2) +#' apiary <- createMultiColony(basePop[4:5]) #' apiary <- cross(apiary, drones = droneGroups[3:4]) #' #' #Here we show an example for workers, but same holds for drones and virgin queens! @@ -282,7 +282,7 @@ addCastePop_internal <- function(pop, colony, caste, new = FALSE) { #' # nVirginQueens/nWorkers/nDrones will vary between function calls when a function is used #' #' # Queen's counters -#' getMisc(getQueen(addWorkers(colony))) +#' getQueen(addWorkers(colony))@misc #' #' # Add individuals to a MultiColony object #' apiary <- addWorkers(apiary) @@ -498,7 +498,7 @@ addVirginQueens <- function(x, nInd = NULL, new = FALSE, #' colony <- createColony(x = basePop[2]) #' colony <- cross(colony, drones = droneGroups[[1]]) #' isProductive(colony) -#' apiary <- createMultiColony(basePop[3:4], n = 2) +#' apiary <- createMultiColony(basePop[3:4]) #' apiary <- cross(apiary, drones = droneGroups[c(2, 3)]) #' isProductive(apiary) #' @@ -530,7 +530,8 @@ addVirginQueens <- function(x, nInd = NULL, new = FALSE, #' nDrones(apiary) #' #' # Queen's counters -#' getMisc(getQueen(buildUp(colony))) +#' getQueen(buildUp(colony))@misc +#' #' @export buildUp <- function(x, nWorkers = NULL, nDrones = NULL, new = TRUE, resetEvents = FALSE, @@ -696,7 +697,7 @@ buildUp <- function(x, nWorkers = NULL, nDrones = NULL, #' colony <- createColony(x = basePop[2]) #' colony <- cross(colony, drones = droneGroups[[1]]) #' colony <- buildUp(colony) -#' apiary <- createMultiColony(basePop[3:4], n = 2) +#' apiary <- createMultiColony(basePop[3:4]) #' apiary <- cross(apiary, drones = droneGroups[c(2, 3)]) #' apiary <- buildUp(apiary) #' @@ -828,7 +829,7 @@ downsize <- function(x, p = NULL, use = "rand", new = FALSE, #' # Create and cross Colony and MultiColony class #' colony <- createColony(x = basePop[2]) #' colony <- cross(colony, drones = droneGroups[[1]]) -#' apiary <- createMultiColony(basePop[4:5], n = 2) +#' apiary <- createMultiColony(basePop[4:5]) #' apiary <- cross(apiary, drones = droneGroups[3:4]) #' #' # Add individuals @@ -974,7 +975,7 @@ replaceVirginQueens <- function(x, p = 1, use = "rand", simParamBee = NULL) { #' colony <- createColony(x = basePop[2]) #' colony <- cross(colony, drones = droneGroups[[1]]) #' colony <- buildUp(colony) -#' apiary <- createMultiColony(basePop[4:5], n = 2) +#' apiary <- createMultiColony(basePop[4:5]) #' apiary <- cross(apiary, drones = droneGroups[3:4]) #' apiary <- buildUp(apiary) #' @@ -1129,7 +1130,7 @@ removeVirginQueens <- function(x, p = 1, use = "rand", simParamBee = NULL) { #' # Create and cross Colony and MultiColony class #' colony <- createColony(x = basePop[2]) #' colony <- cross(colony, drones = droneGroups[[1]]) -#' apiary <- createMultiColony(basePop[4:5], n = 2) +#' apiary <- createMultiColony(basePop[4:5]) #' apiary <- cross(apiary, drones = droneGroups[3:4]) #' #' # Build-up - this sets Productive to TRUE @@ -1295,7 +1296,11 @@ collapse <- function(x, simParamBee = NULL) { #' an event where the queen #' leaves with a proportion of workers to create a new colony (the swarm). The #' remnant colony retains the other proportion of workers and all drones, and -#' the workers raise virgin queens, of which only one prevails. Location of +#' the workers raise virgin queens, of which only one prevails. The function +#' will create either 10 or \code{SimParamBee$nVirginQueens} virgin queens, +#' whichever is higher, and select one at random. In case of high inbreeding, +#' it could be that none of the virgin queens are viable. In that case, you might +#' want to increase \code{SimParamBee$nVirginQueens} or discard the colony. Location of #' the swarm is the same as for the remnant or sampled as deviation from the #' remnant. #' @@ -1516,7 +1521,11 @@ swarm <- function(x, p = NULL, #' @description Level 2 function that supersedes a Colony or MultiColony object - #' an event where the #' queen dies. The workers and drones stay unchanged, but workers raise virgin -#' queens, of which only one prevails. +#' queens, of which only one prevails. The function +#' will create either 10 or \code{SimParamBee$nVirginQueens} virgin queens, +#' whichever is higher, and select one at random In case of high inbreeding, +#' it could be that none of the virgin queens are viable.In that case, you might +#' want to increase \code{SimParamBee$nVirginQueens} or discard the colony. #' #' @param x \code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}} #' @param simParamBee \code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters diff --git a/man/addCastePop.Rd b/man/addCastePop.Rd index b18d7704..87e1f727 100644 --- a/man/addCastePop.Rd +++ b/man/addCastePop.Rd @@ -68,7 +68,7 @@ droneGroups <- pullDroneGroupsFromDCA(drones, n = 5, nDrones = nFathersPoisson) # Create and cross Colony and MultiColony class colony <- createColony(x = basePop[2]) colony <- cross(colony, drones = droneGroups[[1]]) -apiary <- createMultiColony(basePop[4:5], n = 2) +apiary <- createMultiColony(basePop[4:5]) apiary <- cross(apiary, drones = droneGroups[3:4]) #Here we show an example for workers, but same holds for drones and virgin queens! @@ -95,7 +95,7 @@ SP$nWorkers <- nWorkersPoisson # nVirginQueens/nWorkers/nDrones will vary between function calls when a function is used # Queen's counters -getMisc(getQueen(addWorkers(colony))) +getQueen(addWorkers(colony))@misc # Add individuals to a MultiColony object apiary <- addWorkers(apiary) diff --git a/man/buildUp.Rd b/man/buildUp.Rd index 21df8acc..650d8169 100644 --- a/man/buildUp.Rd +++ b/man/buildUp.Rd @@ -81,7 +81,7 @@ droneGroups <- pullDroneGroupsFromDCA(drones, n = 10, nDrones = nFathersPoisson) colony <- createColony(x = basePop[2]) colony <- cross(colony, drones = droneGroups[[1]]) isProductive(colony) -apiary <- createMultiColony(basePop[3:4], n = 2) +apiary <- createMultiColony(basePop[3:4]) apiary <- cross(apiary, drones = droneGroups[c(2, 3)]) isProductive(apiary) @@ -113,5 +113,6 @@ nWorkers(apiary) nDrones(apiary) # Queen's counters -getMisc(getQueen(buildUp(colony))) +getQueen(buildUp(colony))@misc + } diff --git a/man/createCastePop.Rd b/man/createCastePop.Rd index 63c3576b..5913ca00 100644 --- a/man/createCastePop.Rd +++ b/man/createCastePop.Rd @@ -132,7 +132,7 @@ droneGroups <- pullDroneGroupsFromDCA(drones, n = 3, nDrones = nFathersPoisson) # Create a Colony and a MultiColony class colony <- createColony(x = basePop[2]) colony <- cross(colony, drones = droneGroups[[1]]) -apiary <- createMultiColony(basePop[3:4], n = 2) +apiary <- createMultiColony(basePop[3:4]) apiary <- cross(apiary, drones = droneGroups[c(2, 3)]) # Using default nInd in SP diff --git a/man/downsize.Rd b/man/downsize.Rd index e418ad0b..d2acf269 100644 --- a/man/downsize.Rd +++ b/man/downsize.Rd @@ -48,7 +48,7 @@ droneGroups <- pullDroneGroupsFromDCA(drones, n = 3, nDrones = 12) colony <- createColony(x = basePop[2]) colony <- cross(colony, drones = droneGroups[[1]]) colony <- buildUp(colony) -apiary <- createMultiColony(basePop[3:4], n = 2) +apiary <- createMultiColony(basePop[3:4]) apiary <- cross(apiary, drones = droneGroups[c(2, 3)]) apiary <- buildUp(apiary) diff --git a/man/getMisc.Rd b/man/getMisc.Rd deleted file mode 100644 index 60b342d8..00000000 --- a/man/getMisc.Rd +++ /dev/null @@ -1,20 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/Functions_L0_auxilary.R -\name{getMisc} -\alias{getMisc} -\title{Get miscellaneous information in a population} -\usage{ -getMisc(x, node = NULL) -} -\arguments{ -\item{x}{\code{\link[AlphaSimR]{Pop-class}}} - -\item{node}{character, name of the node to get from the \code{x@misc} slot; -if \code{NULL} the whole \code{x@misc} slot is returned} -} -\value{ -The \code{x@misc} slot or its nodes \code{x@misc[[*]][[node]]} -} -\description{ -Get miscellaneous information in a population -} diff --git a/man/isCsdHeterozygous.Rd b/man/isCsdHeterozygous.Rd index 7a5d9d26..1bd9f5ed 100644 --- a/man/isCsdHeterozygous.Rd +++ b/man/isCsdHeterozygous.Rd @@ -17,7 +17,8 @@ logical \description{ Level 0 function that returns if individuals of a population are heterozygous at the csd locus. See \code{\link[SIMplyBee]{SimParamBee}} for more - information about the csd locus. + information about the csd locus. The function also return \code{TRUE} for drones to + mark their viability, although they are haploid. } \details{ We could expand \code{isCsdHeterozygous} to work also with diff --git a/man/mapCasteToColonyValue.Rd b/man/mapCasteToColonyValue.Rd index 290d5e5d..3742a6cb 100644 --- a/man/mapCasteToColonyValue.Rd +++ b/man/mapCasteToColonyValue.Rd @@ -42,21 +42,24 @@ mapCasteToColonyAa(colony, simParamBee = NULL, ...) \item{queenTrait}{numeric (column position) or character (column name), trait(s) that represents queen's contribution to colony value(s); if -\code{NULL} then this contribution is 0; you can pass more than one trait +\code{NULL} or there is no queen present, then this contribution is 0; +you can pass more than one trait here, but make sure that \code{combineFUN} works with these trait dimensions} -\item{queenFUN}{function, function that will be applied to queen's value} +\item{queenFUN}{function, function that will be applied to queen's value.} \item{workersTrait}{numeric (column position) or character (column name), trait(s) that represents workers' contribution to colony value(s); if -\code{NULL} then this contribution is 0; you can pass more than one trait +\code{NULL} or there are no workers present, then this contribution is 0; +you can pass more than one trait here, but make sure that \code{combineFUN} works with these trait dimensions} \item{workersFUN}{function, function that will be applied to workers values} \item{dronesTrait}{numeric (column position) or character (column name), trait(s) that represents drones' contribution to colony value(s); if -\code{NULL} then this contribution is 0; you can pass more than one trait +\code{NULL} or there are no drones present then this contribution is 0; +you can pass more than one trait here, but make sure that \code{combineFUN} works with these trait dimensions} \item{dronesFUN}{function, function that will be applied to drone values} diff --git a/man/removeCastePop.Rd b/man/removeCastePop.Rd index e705e435..cbe9c2ec 100644 --- a/man/removeCastePop.Rd +++ b/man/removeCastePop.Rd @@ -63,7 +63,7 @@ droneGroups <- pullDroneGroupsFromDCA(drones, n = 5, nDrones = nFathersPoisson) colony <- createColony(x = basePop[2]) colony <- cross(colony, drones = droneGroups[[1]]) colony <- buildUp(colony) -apiary <- createMultiColony(basePop[4:5], n = 2) +apiary <- createMultiColony(basePop[4:5]) apiary <- cross(apiary, drones = droneGroups[3:4]) apiary <- buildUp(apiary) diff --git a/man/replaceCastePop.Rd b/man/replaceCastePop.Rd index 513b5abd..44fd8728 100644 --- a/man/replaceCastePop.Rd +++ b/man/replaceCastePop.Rd @@ -61,7 +61,7 @@ droneGroups <- pullDroneGroupsFromDCA(drones, n = 5, nDrones = nFathersPoisson) # Create and cross Colony and MultiColony class colony <- createColony(x = basePop[2]) colony <- cross(colony, drones = droneGroups[[1]]) -apiary <- createMultiColony(basePop[4:5], n = 2) +apiary <- createMultiColony(basePop[4:5]) apiary <- cross(apiary, drones = droneGroups[3:4]) # Add individuals diff --git a/man/resetEvents.Rd b/man/resetEvents.Rd index cada3fd6..27836670 100644 --- a/man/resetEvents.Rd +++ b/man/resetEvents.Rd @@ -38,7 +38,7 @@ droneGroups <- pullDroneGroupsFromDCA(drones, n = 5, nDrones = nFathersPoisson) # Create and cross Colony and MultiColony class colony <- createColony(x = basePop[2]) colony <- cross(colony, drones = droneGroups[[1]]) -apiary <- createMultiColony(basePop[4:5], n = 2) +apiary <- createMultiColony(basePop[4:5]) apiary <- cross(apiary, drones = droneGroups[3:4]) # Build-up - this sets Productive to TRUE diff --git a/man/setMisc.Rd b/man/setMisc.Rd deleted file mode 100644 index 0b2c0291..00000000 --- a/man/setMisc.Rd +++ /dev/null @@ -1,26 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/Functions_L0_auxilary.R -\name{setMisc} -\alias{setMisc} -\title{Set miscellaneous information in a population} -\usage{ -setMisc(x, node = NULL, value = NULL) -} -\arguments{ -\item{x}{\code{\link[AlphaSimR]{Pop-class}}} - -\item{node}{character, name of the node to set within the \code{x@misc} slot} - -\item{value, }{value to be saved into \code{x@misc[[*]][[node]]}; length of -\code{value} should be equal to \code{nInd(x)}; if its length is 1, then -it is repeated using \code{rep} (see examples)} -} -\value{ -\code{\link[AlphaSimR]{Pop-class}} -} -\description{ -Set miscellaneous information in a population -} -\details{ -A \code{NULL} in \code{value} is ignored -} diff --git a/man/supersede.Rd b/man/supersede.Rd index 051c8401..bc1de781 100644 --- a/man/supersede.Rd +++ b/man/supersede.Rd @@ -22,7 +22,11 @@ supersede event set to \code{TRUE} Level 2 function that supersedes a Colony or MultiColony object - an event where the queen dies. The workers and drones stay unchanged, but workers raise virgin - queens, of which only one prevails. + queens, of which only one prevails. The function + will create either 10 or \code{SimParamBee$nVirginQueens} virgin queens, + whichever is higher, and select one at random In case of high inbreeding, + it could be that none of the virgin queens are viable.In that case, you might + want to increase \code{SimParamBee$nVirginQueens} or discard the colony. } \examples{ founderGenomes <- quickHaplo(nInd = 10, nChr = 1, segSites = 50) diff --git a/man/swarm.Rd b/man/swarm.Rd index 3895f184..6c6293f1 100644 --- a/man/swarm.Rd +++ b/man/swarm.Rd @@ -45,7 +45,11 @@ Level 2 function that swarms a Colony or MultiColony object - an event where the queen leaves with a proportion of workers to create a new colony (the swarm). The remnant colony retains the other proportion of workers and all drones, and - the workers raise virgin queens, of which only one prevails. Location of + the workers raise virgin queens, of which only one prevails. The function + will create either 10 or \code{SimParamBee$nVirginQueens} virgin queens, + whichever is higher, and select one at random. In case of high inbreeding, + it could be that none of the virgin queens are viable. In that case, you might + want to increase \code{SimParamBee$nVirginQueens} or discard the colony. Location of the swarm is the same as for the remnant or sampled as deviation from the remnant. } diff --git a/tests/testthat/test-L0_auxiliary_functions.R b/tests/testthat/test-L0_auxiliary_functions.R index a373007a..1c5ffcb0 100644 --- a/tests/testthat/test-L0_auxiliary_functions.R +++ b/tests/testthat/test-L0_auxiliary_functions.R @@ -148,7 +148,7 @@ test_that("calcQueensPHomBrood", { fatherGroups <- pullDroneGroupsFromDCA(drones, n = 10, nDrones = 10, simParamBee = SP) # Create a Colony class object - colony <- createColony(x = basePop[2], simParamBee = SP) + colony <- createColony(x = basePop[1], simParamBee = SP) colony <- cross(colony, drones = fatherGroups[[1]], simParamBee = SP) colony <- buildUp(x = colony, nWorkers = 120, nDrones = 20, simParamBee = SP) colony <- addVirginQueens(x = colony, nInd = 1, simParamBee = SP) @@ -156,6 +156,7 @@ test_that("calcQueensPHomBrood", { expect_error(calcQueensPHomBrood(colony@drones, simParamBee = SP)) expect_error(calcQueensPHomBrood(colony@workers, simParamBee = SP)) expect_true(is.numeric(calcQueensPHomBrood(colony@queen, simParamBee = SP))) + expect_true(calcQueensPHomBrood(colony@queen, simParamBee = SP) > 0) colony@queen <- NULL expect_error(calcQueensPHomBrood(colony@queen, simParamBee = SP)) @@ -165,6 +166,8 @@ test_that("calcQueensPHomBrood", { colony@virginQueens <- NULL expect_error(calcQueensPHomBrood(colony, simParamBee = SP)) expect_equal((length(calcQueensPHomBrood(apiary, simParamBee = SP))), 0) + + }) # ---- pHomBrood ---- @@ -188,7 +191,7 @@ test_that("pHomBrood", { expect_error(pHomBrood(colony@workers, simParamBee = SP)) expect_error(pHomBrood(colony@virginQueens, simParamBee = SP)) expect_error(pHomBrood(colony@drones, simParamBee = SP)) - #expect_true(is.numeric(pHomBrood(colony@queen, simParamBee = SP))) + expect_true(is.numeric(pHomBrood(colony@queen, simParamBee = SP))) colony@queen <- NULL expect_error(pHomBrood(colony@queen, simParamBee = SP)) @@ -223,13 +226,12 @@ test_that("nHomBrood", { expect_error(nHomBrood(colony@drones, simParamBee = SP)) expect_true(is.numeric(nHomBrood(colony@queen, simParamBee = SP))) - colony@queen <- NULL - expect_error(nHomBrood(colony@queen, simParamBee = SP)) + apiary <- createMultiColony(simParamBee = SP) colony@workers <- NULL colony@drones <- NULL colony@virginQueens <- NULL - expect_error(nHomBrood(colony, simParamBee = SP)) + expect_error(nHomBrood(removeQueen(colony), simParamBee = SP)) expect_equal(length(nHomBrood(apiary, simParamBee = SP)), 0) }) @@ -385,8 +387,12 @@ test_that("getCsdAlleles", { SP$nThreads = 1L basePop <- createVirginQueens(founderGenomes, simParamBee = SP) + baseAlleles <- getCsdAlleles(basePop, simParamBee = SP) + expect_equal(nrow(baseAlleles), 8 * 2) drones <- createDrones(x = basePop[1], nInd = 1000, simParamBee = SP) + dronesAlleles <- getCsdAlleles(drones, simParamBee = SP) + expect_equal(nrow(dronesAlleles), 1000) fatherGroups <- pullDroneGroupsFromDCA(drones, n = 10, nDrones = 10, simParamBee = SP) # Create a Colony class @@ -483,13 +489,15 @@ test_that("getCsdGeno", { # ---- isCsdHeterozygous ---- test_that("isCsdHeterozygous", { - founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) + founderGenomes <- quickHaplo(nInd = 50, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, nCsdAlleles = 5) SP$nThreads = 1L basePop <- createVirginQueens(founderGenomes, simParamBee = SP) + expect_true(all(isCsdHeterozygous(basePop, simParamBee = SP))) drones <- createDrones(x = basePop[1], nInd = 1000, simParamBee = SP) + expect_true(all(isCsdHeterozygous(drones, simParamBee = SP))) fatherGroups <- pullDroneGroupsFromDCA(drones, n = 10, nDrones = 10, simParamBee = SP) # Create a Colony class @@ -507,17 +515,8 @@ test_that("isCsdHeterozygous", { SP <- SimParamBee$new(founderGenomes, csdChr = NULL) SP$nThreads = 1L - basePop <- createVirginQueens(founderGenomes, simParamBee = SP) - - drones <- createDrones(x = basePop[1], nInd = 1000, simParamBee = SP) - fatherGroups <- pullDroneGroupsFromDCA(drones, n = 10, nDrones = 10, simParamBee = SP) - - # Create a Colony class - colony <- createColony(x = basePop[2], simParamBee = SP) - colony <- cross(colony, drones = fatherGroups[[1]], simParamBee = SP) - colony <- buildUp(x = colony, simParamBee = SP) - - expect_error(isCsdHeterozygous(colony@queen, simParamBee = SP)) + basePop <- createVirginQueens(founderGenomes[10:15], simParamBee = SP) + expect_error(isCsdHeterozygous(basePop, simParamBee = SP)) }) # ---- nCsdAlleles ---- @@ -778,7 +777,15 @@ test_that("isGenoHeterozygous", { basePop <- createVirginQueens(founderGenomes, simParamBee = SP) + #Test on a Pop + (tmp <- getCsdGeno(basePop, simParamBee = SP)) + expect_true(all(SIMplyBee:::isGenoHeterozygous(tmp))) + drones <- createDrones(x = basePop[1], nInd = 1000, simParamBee = SP) + # Test on drones + (tmp <- getCsdGeno(drones, simParamBee = SP)) + expect_true(all(SIMplyBee:::isGenoHeterozygous(tmp))) + droneGroups <- pullDroneGroupsFromDCA(drones, n = 10, nDrones = nFathersPoisson, simParamBee = SP) # Create a Colony and a MultiColony class @@ -1066,5 +1073,31 @@ test_that("getCaste", { +test_that("getIbdHaplo", { + founderGenomes <- quickHaplo(nInd = 4, nChr = 1, segSites = 5) + SP <- SimParamBee$new(founderGenomes, nCsdAlleles = 4) + SP$nThreads = 1L + SP$setTrackRec(isTrackRec = TRUE) + SP$setTrackPed(isTrackPed = TRUE) + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) + baseHaplo = getIbdHaplo(basePop, simParamBee = SP) + expect_equal(nrow(baseHaplo), 2*4) + expect_equal(ncol(baseHaplo), 5) + + drones <- createDrones(x = basePop[1], nInd = 200, simParamBee = SP) + expect_equal(nrow(getIbdHaplo(drones, simParamBee = SP)), 200*1) + droneGroups <- pullDroneGroupsFromDCA(drones, n = 10, nDrones = nFathersPoisson, simParamBee = SP) + # Create a Colony and a MultiColony class + colony <- createColony(x = basePop[2], simParamBee = SP) + colony <- cross(colony, drones = droneGroups[[1]], simParamBee = SP) + colony <- buildUp(x = colony, nWorkers = 3, nDrones = 2, simParamBee = SP) + colony <- addVirginQueens(x = colony, nInd = 2, simParamBee = SP) + expect_length(getIbdHaplo(colony, simParamBee = SP), 5) + apiary <- createMultiColony(basePop[3:4], simParamBee = SP) + apiary <- cross(apiary, drones = droneGroups[c(2, 3)], simParamBee = SP) + apiary <- buildUp(x = apiary, nWorkers = 3, nDrones = 2, simParamBee = SP) + apiary <- addVirginQueens(x = apiary, nInd = 2, simParamBee = SP) + expect_length(getIbdHaplo(apiary, simParamBee = SP), 2) + }) diff --git a/vignettes/Colony_locations.csv b/vignettes/Colony_locations.csv index 0ac2a90d..6678dcde 100644 --- a/vignettes/Colony_locations.csv +++ b/vignettes/Colony_locations.csv @@ -1,36 +1,36 @@ ColonyID,X,Y -1,0.662431162288274,5.97033145745812 -2,0.889869211813095,0.882040306233467 -3,3.20406617225118,4.2012594475023 -4,3.37467634975274,1.85276144978548 -5,6.26877271726022,4.12336288238627 -6,1.49762073729787,0.854711175179748 -7,6.27428327657999,5.28537368571472 -8,0.377119552748809,1.26003243402567 -9,0.884600259265786,2.55843304434275 -10,4.85341262281402,4.34423864421118 -11,0.439273950460384,5.78768883580839 -12,4.85267013629791,5.24037990077726 -13,6.27814888107222,1.67684867115787 -14,5.91398658831959,2.21947012261649 +1,0.211675140867833,1.58970616827141 +2,0.377119552748809,1.26003243402567 +3,0.439273950460384,5.78768883580839 +4,0.662431162288274,5.97033145745812 +5,0.884600259265786,2.55843304434275 +6,0.889869211813095,0.882040306233467 +7,1.49762073729787,0.854711175179748 +8,1.54126706057672,0.265964466739025 +9,1.59318554922445,3.95724726174676 +10,1.69897541097397,2.4435374157815 +11,1.76640287495849,1.81689439235 +12,1.94181870616625,1.04070091389605 +13,1.96273450676472,2.98552319129881 +14,2.15001173188715,5.30559199476844 15,2.2845571049277,2.76273156562477 -16,2.15001173188715,5.30559199476844 -17,3.30277055998226,3.88408253149063 -18,1.59318554922445,3.95724726174676 -19,5.14489315015939,3.48380219722517 -20,4.89542592867685,4.87175443368121 -21,4.98504294579104,4.63186113766538 -22,1.96273450676472,2.98552319129881 -23,1.94181870616625,1.04070091389605 -24,3.71355474699821,3.98892629339701 -25,1.76640287495849,1.81689439235 -26,3.49162610986539,2.007127614613 -27,4.70110619836582,1.98065883153337 -28,2.93773502070683,2.79053982429322 -29,1.69897541097397,2.4435374157815 -30,1.54126706057672,0.265964466739025 -31,0.211675140867833,1.58970616827141 -32,4.38863010920245,4.35616019770602 -33,4.3632705003701,0.955920230806015 -34,5.94574863325625,5.50420647366442 -35,2.86914251070775,0.176914088999066 +16,2.86914251070775,0.176914088999066 +17,2.93773502070683,2.79053982429322 +18,3.20406617225118,4.2012594475023 +19,3.30277055998226,3.88408253149063 +20,3.37467634975274,1.85276144978548 +21,3.49162610986539,2.007127614613 +22,3.71355474699821,3.98892629339701 +23,4.3632705003701,0.955920230806015 +24,4.38863010920245,4.35616019770602 +25,4.70110619836582,1.98065883153337 +26,4.85267013629791,5.24037990077726 +27,4.85341262281402,4.34423864421118 +28,4.89542592867685,4.87175443368121 +29,4.98504294579104,4.63186113766538 +30,5.14489315015939,3.48380219722517 +31,5.91398658831959,2.21947012261649 +32,5.94574863325625,5.50420647366442 +33,6.26877271726022,4.12336288238627 +34,6.27428327657999,5.28537368571472 +35,6.27814888107222,1.67684867115787 diff --git a/vignettes/H_Parallelisation.Rmd b/vignettes/H_Parallelisation.Rmd new file mode 100644 index 00000000..f6e4f504 --- /dev/null +++ b/vignettes/H_Parallelisation.Rmd @@ -0,0 +1,140 @@ +--- +title: "Parallelisation and high-performing cluster setup" +date: "`r Sys.Date()`" +output: rmarkdown::html_vignette +vignette: > + %\VignetteIndexEntry{Multiple colonies} + %\VignetteEngine{knitr::rmarkdown} + %\VignetteEncoding{UTF-8} +editor_options: + markdown: + wrap: 80 + canonical: true +--- + +```{r setup, include = FALSE} +knitr::opts_chunk$set( + collapse = TRUE, + comment = "#>", + include = TRUE +) +``` + +# Quick set-up instructions + +Here, we show how you should set-up the parallel back-end on different +environments. We do recommend reading the remaining of this vignette. We +recommend running these lines straight after setting the `SimParamBee`. + +```{r quick_setup, eval=F, echo=T} +library(SIMplyBee) +library(parallel) +library(doParallel) + +founderGenomes <- quickHaplo(nInd = 30, nChr = 1, segSites = 100) +SP <- SimParamBee$new(founderGenomes) +SP$nThreads <- NCORES #Where NCORES is a specified number or all available cores (detectCores(), see below) + +# If using Linux/MACOS +registerDoParallel(cores = SP$nThreads) + +# If using Windows machine / running the simulation on HPC +cl <- makeCluster(SP$nThreads, type="PSOCK") +registerDoParallel(cl) +#Do the simulation +# At the end of everything you run +stopImplicitCluster() +``` + +# Introduction + +Honeybee simulations consist of simulating individuals as `Pop` classes, and +then on top of this also `Colony` and `MultiColony` classes, all of them with +their meta-data. This makes the simulation computationally demanding and slow. +With the aim to speed up the simulation, we parallelised the major functions +with `foreach` and `doParallel` R packages. Nothing changed in terms of running +the functions, but do functions now have the ability to run on multiple cores at +the same time. They would all search for the number of available cores in the +`SimParamBee` object, under `nThreads`. You can set that to a desired number or +make the simulation use all available cores. + +```{r nThread_setup} +library(package = "SIMplyBee") +library(package = "parallel") + +founderGenomes <- quickHaplo(nInd = 30, nChr = 1, segSites = 100) +SP <- SimParamBee$new(founderGenomes) + +# Set the number of cores to use +SP$nThreads <- 8 +# Or use all available cores +SP$nThreads <- detectCores() +``` + +In R, there are two possible options for parallelisation, `FORK` and `PSOCK`. +The forking (`FORK`) creates subprocesses that share memory and objects with the +parent process, which means it's very efficient! However, such parallelisation +is not supported on Windows machines and is not allowed on most high-performing +clusters! + +The alternative, PSOCK, can be used on all system, but it works by creating a +separate R process for each subprocess (that communicate through sockets), +meaning that the whole environment needs to be copied to each subprocess, +creating a larger memory overhead. (adapted from +). + +We profiled the following piece of code using different parallelisation options. + +```{r defining_testing_function} +create_bee_colonies <- function() { + founderGenomes <- quickHaplo(nInd = 200, nChr = 1, segSites = 50) + SP <- SimParamBee$new(founderGenomes) + + basePop <- createVirginQueens(founderGenomes) + drones = createDrones(basePop, nInd = 100) + baseColonies <- createMultiColony(cross(basePop, drones = drones, crossPlan = "create")) + baseColonies <- buildUp(baseColonies, nWorkers = 1000, nDrones = 1000) + baseColonies <- supersede(baseColonies) + baseColonies <- cross(baseColonies, drones = drones, crossPlan = "create") + tmp = split(baseColonies) +} +``` + +We set up different parallelisation back-ends with the following code, where +`ncores` was either 1 or 8. + +```{r parallelisation_options, eval=F, echo=T} + +# First one - ??? +SP$nThreads = ncores +registerDoParallel(cores = SP$nThreads) +create_bee_colonies() + +# Second one - create a FORK cluster +SP$nThreads = ncores +cl <- makeCluster(SP$nThreads, type="FORK") +registerDoParallel(cl) +create_bee_colonies() +stopImplicitCluster() + +# Third one - create a PSOCK cluster +SP$nThreads = ncores +cl <- makeCluster(SP$nThreads, type="PSOCK") +registerDoParallel(cl) +create_bee_colonies() +stopImplicitCluster() +``` + +Here are the results of running these different options. + +```{r meanRSS_figure, echo=FALSE, out.width='100%'} +knitr::include_graphics("RSS_mean.png") +``` + +```{r meanPCPU_figure, echo=FALSE, out.width='100%'} +knitr::include_graphics("PCPU_mean.png") +``` + +```{r meanTime_figure, echo=FALSE, out.width='100%'} +knitr::include_graphics("Time_mean.png") +``` diff --git a/vignettes/PCPU_mean.png b/vignettes/PCPU_mean.png new file mode 100644 index 0000000000000000000000000000000000000000..5b3949aad1ee3cd588d4bb8c8c04b38e5f34745b GIT binary patch literal 21000 zcmc$GWl)@5lxBnwAOV6W5Fi96NO1Sy!QF#vYhrW@cw+ zYif3DsFJ8R-i}VWqrbCCU z^TmrVFC=~lD!HT{EE;JksT03Fv8OZ(5ar56cp0ZsB?8s4fT~$Qk2JL3l>!@~?LVp- zxht#QyorlF(!1qj_^zs6!NdIi^bT@DngBjA8D0RlaBeTyQzz#m!&hj9RZeQd+ZRe` zNT|=Bk%V5uo9}-{pI?T3VR>#y|3g>1yz|SSjz`w|(KO2s?tw}ky)6-J|Hp|MYDtTv;IN3Z` zqn-Wz3iTS%=h@__uu=R)MMYhDloCoyX^A2WN=izOgo>%F)U@Q}zI;F`zLzLz?;jY* zG1K_+p|J786bdS;vNLiVP5>o*tG_Y)5aG=)gshkF=A)n~{P{xk13vuu8)GT}QAB5L zp0-HR`wjd>EP9*{l+2^vewc4Rsb)SYUQ3WlqN&zMcq6>tgYNG4@M~{ts{sZ8DSWIF z3(cO{U-HGUg?gL4Xy)Az*?Aoi`h|-*!06iLK!AImA46DBRD3lCd@K!-GODbcRvJF= zkEbPnSt+Hr>x~^m7do8Y-5`2I*!TvyLd%2XZc7v=4go&=2^|Mj)`r$oLlbi>POMQD zvMhv0LB6GaJ9mae;%5UmpnX?PzJYxLSxS_GveADU{>Wq~E-5M5_sGS?#mUK8TvV5x zX_ovUIwj?qPz=fW;6IPeynd>U@o=D;+TiD~nUBYF=3)d&_(-Y}1&0Hqdmk9%1&6JZOw761v z3UqX3G~VOIm6Aui@|)-{=@SO@^}2kjsX!*-<5jhjveM%8N!wIXlHyZ!)oh~=-J&no zh+n)Ac%$ScAA0y%OZVH}$}Z?Dm}>PPD`nv}e1T(mLCuQ%nJ?@&T>`cm9EhO?i^Y{* z+##&A4-K+Ao5Q4j9`^s-HU|wVDt=oG48i*m=-Io|Me^h|3Sxtcq=1NT(iiv){}*!d zUx?8Et1g>K?N;=^1DkvFFClW|ntu7aG&j!5C@B8f8@en$4WlgDglI35^QW|hjFioU ze6{HDQ2h7GUp5#8|tI3ew7+coVl5qEnLdWibDFHWwfE6_>~rYLRb5ahx&^8 zGqn7hF#Z>E`v0wKHFn-Q+NdR1f;yKUkg0Y%Z8hB>(#L3RZ+Hw+oWmWy3RtlF_6*gD zG@wxdJe~!R`S!crz=}No+3MDob}{hcEE50_1|iD$AcO?X>sdIJMlC!m{-59Y#PX@7 zuJ4Xv=a0LE@#mUjjX+ZGlxV#L^Zw$;@`JPDXE^B3z7L?}%X&v_xtu=cG5+Bl8%9B% zaZ>&MHd#~ucCuR1{yE>Vp}3S(OrPPgbG8{+t31Fw%R#wXL-);OEy}Bv*1a@~kOi zA%nvWx+smpQI?MkH|RVc0PTt(-^Qr(_b$)@&ehpL3k=P+ab>h{j*b}V#T#>5^iEdV z{QdpO?+CdZ#Kpu4ezqu-#W;Bo=l4o^t{A3?57KuL@A|6cJxUrqt!+O zk=#VwPCtc(bAGm9nb0chEqpb7rA)mqC@&b?r5`2Uxqiy=*)c5j6^VXTB3xXq8gB7Z zhVrQf>ls4rA~d24w#%vZ*qzqnJS0q(=jtq*2eg?GGlug(VNgFSi(EHq;GpSs1wfZUXc1D+W^;6Y(>X00>gPmpD-fMn*bsJ?Z0{CJ|U-JAAC3_aCjHUaa z%b8v3wotY(4x5$Ri2eCS_3RutE@n1Rk+aym?mh~m1!Sz@5qJTZJk}Oo9;&cUDJkp0 z=a8$4%_|X@06vwH932m*yHP2-@jky6j01T1C{7FoKhWQ#3H43E-wF6D*NtZO4)-dV z?wcw~mOm?Wno=fzM0JmirFlzhU34veI1S_gu}l~WQ4Z^^mp^Vm5XDp{2L03i{rrar zCq^+@IMfILrNagNmE@x9ohi1M^VW%}G7x;(Be3HnhP1D~pns4t2&OcMv z1+0V!VZ(TV&->m9--?2cb}VwZgN_x^{LuVE2Mc0)iZflh`1Q~LHJmz`TvV4dNXc@a(e5VJIkdFC!*An+ z0i#2M1#rH78phD=uv1F9u34AtnpeD-jV$r}l>^LUZHSBAX|I`y9e*ThbnMPI)eIvg zpeD;hPiq$K)phZv#4+&~_j@6lm<%-_&&@i~=K?lg@8UjsfHR!nd%xF^FPQ7XlBUjw z*8=AD=tY5&=%}?DZSkk*kcB#<`yE+bQwQKZ;j`ga%$>$IK|wy0$Y?GYNuYNL;SH_j zc$^GS=4RjOqikT^K#^hiTB?nAxTgYoQ4g@Ue^4&qVotX&4}POiT9abV0< z_5CHC<@YiJnDL@oLgLxJ!m0HF%VUJ`o7k}#i}MA4nk=g0eKuCQ%rduQw^2tMWsV9P zb0!kgCtuY#Y(DB@ z^P*>spnx8^`4-K>QjSR`bDjADc6(OHta{Gxjh*Jcdd;f7&W|`v|B2-n_l3GUi@w&2 zWB0}y+WGsr9|9Ocx#(zw(zVB&O=)I*;I!>Y>mAwT5qfQ@9BN@K;j^Q)h-OfXKZ{-? zD*yG$-XO8``wf0LhCjLV_&EW~=B>m%Gw=-=3B1ZoER6AZT-G0WXg|X7>Ll1|{gaft zS;qDL$m`vVE<_O-Npr@Y;jt|P*z1ALF+tt<=+ws>6C08Kc`|U7??VrPxZ*2NK7gQc zXT!_Hxh@YV(g!26)-C9b2EmFH?_NLInuK7h?$V*yXgM(-#DvxsFJ%lmfcuhPV4Yo zHfYtap|0Dnu*a)ozCWN;)L^@!723Uvn0c^S2{B=(*Q&R<8Z9pZd@c9qpP8Rn>rv66 z0*LgM`qn%`%)bA6TD0FsyxsA*9%_&o@=B@QI!JqHNm;meACA(xV1w_=<42OS_IJwM zFCK$~-~5kdqheb-CS))?Z@PPkZr9+qdKSK5;ceS)Jn!O$gkq)Zey>N7cQ99QG6d6a2O7Y?zNKpG%3yl-{$hcbu_cwIo@Jf~zto5ClR5B0_aZ(jv6 zGZpA$EPKBDO8I`-gS}ZT_QrI32O~vc0r9=*wUJ4)aSZ?Mln2mwWoU|T>9)B9IsbXnqsFX{${AQR#yXQjBpU^;>vKi*||Z*bdGRe_QYGC8&!v|4_3qa zVa6)Q2|!@#;1rYru8S{n&hShnA|QP_yMamQlKv9im_ut1*Iszf%1Vbn9Put0WFYz% zaRRWD)DmmT(b4MnXrbsjZZ>8XFGX0Af2#9NK0Z!%JGpt3M*u>}cj*!= z@efZsr0C+Jnbat@C@wBLu{mvTrz2xq!re*P-!pZ7orJ6CX6YbI*=s0;&S9UtNDTjc zEAYYfW+)@U`&i6udJl9d-%_RvU~qJ{%E7S?vDP@*o{z zKe;(8Pd1{bZ9Mn)&+1W0F|Qm6?7jAv&f3zQe$M-JuIsgw8#ft%fXQu}oAxC+51t_XW%4;pyw7I9k}$htT}#L3UN^#FQBtZM13LWh%EE5u+fir>~)6GfHEB9 zUBRxF?A9>!iH|N;OF);edg@le&%qC6p&|>ealbVizB0tVHJhq?xZf+_sFIFFfI}@G zSl)!&axA5vbW>}wmMensRmR&1=A{Lx(e^q4g1^e#^{j`NLk58Oq!e?rNWat6LwTk1^`#ZL^RVH$pPf+9 zPS5syid+NeUD+du`&W~})8~$CYaeV6);XA$U&dPsA$*$YeBU$4ds8g-%R0aE|Lr6$=3-B zz&-aB7c!4Zw}Y8Lg9er2(M%88j?Bj_A1C19g}R@3vR`Bxt}S>IDVYNM(u)PoeWNJw z=pXfLwauzf@DGKvA=mRQWQ0FV4_jZ!mC%>l>qSNpiWR1Pv;Rbklff5KRZSQ&<~u>| zSK8G#oke>|6xpM%-1_a+Zf(c9`_Dz!bu;|k!Xphyd9N&=@tVuC+mkmVOJx+4G<0I~ z60O4neL2BI%GDeQQok~vs>lfm3HgtPjcYhR)9PziWr|Fehp_r+(Nl8FOzo`)*7s*y zGT?+{(`@KUeq#FwVam2Xi||S_nADb{?x!;!ODZryPxYi}&J`Aqzdl2)s%D;WxUvy% ze){4IKbQI#EE>SOP}^TZ2Dcee{45N02NoA+o7U3b4$uuNiV6ZAA{dg{m?02S{`IlT z?SK{;)NvDAf~WDb$$QRs_WLOXiySFX2ak6(D2b17Cj2dLn(1F8o0E};-3v*z=x2jj z?HP5~m;4#OeDqu$4;YKoR}`6U2|z10$Pva6s^z&IPSL!ZYi1WQZr(z>teO`6$JO`? zA;8BD#%N(Z0)5lDn3|%-*Cw@xIo)JQ(Oy%~KMrX<0;9&OuguI2&q?{;!q@FzgbDf5 zx;>Qku5E?VSL`T4F9yidy&ck?ouR@(2p)d!DFYUrw>tmV8KQ(axJy!qpQoo>kQHdw z)pT&}4!?-$DSB}Uy4>KG6wf|f;YXus*PGMfz4C1A<&>U6cxa)C!kO|CiTi>>SV<2$ z@+@+3cRHqjwbYs~^lZD6lG1pFYFU8}{03+9B(~s5B=`WFR#*V#4EznO0iNnY6OkeIpYQ@)zw&Er4ULoR!nVN^A=e4h%76xyuGX zp+SR*>#30F>6 zf_pzEp_y&(cB5NsaGqiAU+aL!YFV=~`FrT_qRQ>rms1GB8ZOty^rDtA+?cZ3nOVAg z|4k$C5w@2l()BgHjxFIsyRA)~gv+DCPoz~2kZHE()eOLlQwdHGIn+@wWdQqLl`6)9 zwGBHo!Ctdg`{E)6N?$wy6MEg#)xmjupN>^z*Ir$^DY?i)Ku+d|U65}W(ittu^BNlt zqF8Z2u_1-+8 z9}gdi#FF$F?V%ZH8{pp={M2k<$9s>Hu0w%=Voy#L+4&st}$4=>(dI?0Xd*ZK%9 zjyXM9PAJ80`%KL0yzG)^oQ9Ig;1ypgbL5*gY3++|lf-aNlM9xx256j?-ZZR}3SImC z4LG`iYN;HcA9A$ke@(M&(GBI%lU?T0IqWXucBS0AKW!|kE`3)s=XQ57_lN?OfuEV` z?fm$#&-U;i)kcp})9Hrb&fsa~tNuH+Ty$^G*ulS{cc<)Sj=}A&Gywf2Z zeFvR|!S2j9mvE*0o2l~i+cKRUw-d?&4WCQTRP#uWMaT7Jz~!X&REvkTi;&yXf{}V7 zj<>VJXs+V2wZSI@nZy~dDPp{13HQ48H}LCwA(^>(({uHfcd4t3BKZAht%LVBd-OXN z%V`r|;>4-xVauSJ+!;$r`h=WkK@f1AncEt69EAJ)MG$tLwlZk0&)QCQmpo@i*>{qN z*`~e1UdrB-lJPnC)S0htbYx!}&3Qg%zaBz-+js!LEW8tntpQjrdk+)xWUO-DSuzZu zunEF>IJ4=pP_+4Ixn(1If0F+U0zI0tfTcGUn2>toTy~djUgYEi);Uem2Hx^1P+`Mk zZ<{v+tBwB}nxId>67mxw3H6sH+mjzhh!clHeA3T+Ii=b+$=}|J?z2>e?_VZYRYBh? z!qi!U_`uxbwUp?mg*ZG8tNoeZXUWq7^4NhLRBHlY!O%i&9E(5Ekzh-<#*hc? zIPpC0xcI|7A$g^|JE?C$3h7oN3X?vbcb)jgM0~&@$v#`2Rqw#(@M@tXJec!&q@1*& z;D8(B^8S>dqb{w{VRwPLvqu4|4UQj~b2LVE81vx$KS36@yTS7F-3V33rTB8o(~}S{ zP?glxl8a){EZhouF*WKfBcIP=K54=4V0C?iS42H_m+z0H;}>bVXKK6-HS4@5Owid> zu2!#uk3RAK<)V!>GDB+EdVxwwl%L!6Ib&JE#$A3nANa&Ur2?>p50bOJ?`={PSxrgl zfgR6-te^TC!EQ3ro-~sWT+e)w_t6hgq-~#|2PP&eO2pyFF5SUd@0mdDKJ93JWTf%Z zIuAbTMX`dL>EG=hUH&?2UBeBZ2^e#&7J=gqljm}G#E^N)3MBq{_wsNm+gat>-zg*4 z7O9@g2u~01k51;0eWS7)ALru<82^yCmji;&mzfNY*^Ppa$3x7Lb47?X@jNXTC#`u! zb1V#xmgvQw(}7d)EAt^>VLX!?d4l9d19n3-4dCpiL;yFd;{9dk(fBqspUJOeSZ|66 zZ~wQ1+kYz_`L7wg+*ksYq5z)l-6Y?FV{+V6=~Ul2AbRz5ZqUK(5}2DfWSRdDVA*Nm zw}59cPsy|PqUdL25!ZJP91gGEo8;`2yjr{Fk0IKmO`Mwk%6-%(wRWb-Ou$CsSBWr< zFaG|;RKn>eEXRZsQn%5)@)wy}ak{2|n>oC*3RidJwRv3qt{bVA-t*ZrZx+aKQhzdb z3}CY`5BI@*p^OX~QFKQBd6|@Rgz_TOVG|FZY9dp|7eQtrx*``7IWMb75Jge(9rfU3m2kuDi5A!&uvOj?layr%0nlw^J9(kPmD7xh~B27gHNs+NF}+GF-j3kYr?_2^N^-=kWT0(mCbH5S=}a9XPsQT;voo4msXR;RRyY(`*8Ot~MwZbV zbT(PttI?wbq#732aVJWV*n1^vu1c<0U%Um#y{Y9aGt| z)LVSew+D%tngTc(D1oE-9f^WE_h&S4H|m9#0N5X~zp`yby*zp(fQX9D{$mtz!R&wpF@u-{2%<98 z!Elf6nVBFG%^g?{dJ6jKc@=b#&q=@T;p!C)A$slk#IJrInBWPu*x1Udcf z{zu3fPYh=aY?RB3ixYE||D+-#GbcweSVlwnr;ZMh^n~)`P<+pN+@T^>Axu5TftK!4 z5i44Xg1z%SxxsF;f2}JtfmVGDUQltQQC!6Tbg!5tN2^sYx9DG(8WDk}5>4+b ziACw?;4rEEr@u01O6EkJ@=>FO9|xYJPkfV4|K`n`&uDM$B_~B_;&Acs3@X*b;f5Xw z0%@)s{=dS8EfIW%|3z&}QY~q#L4J*dehq^MK4V{Hz05=y=@mOj2%iUZv;xewdWKFlD2yjSf#| zQ}q<**SGH?{b0hkMESwC*sZEImp??ldOJH_9!x=*a1`{XyvD;IOSknG)e90aBXmg^ z=@XXywYpls)B6PWhLx)ZfA-wZ#Ydg;s4SD((vD=_?kmTDB7BdWjGl+J-zk-?Em;Lw zuP_#ufS1}QgG1b)GNLUPYulap9Uigh6vzo$|b2d-M|kuKPvt=rmD zSmZj3K;xlqUP|lc_{l=N@j8gt#a3K_KkyZAn5)aT+gQk&3%x*|mvp(RGc-^L3;NxVKX0J-&>wRi^t>=sccq`URl;F)$pC;Pbjt zk5bMNjhMsEVxilAqt-mzd>{~D9|S6D7${lW348Z0{|IO5=`sP=s&praHL!+<%gJiH zB5*-YW~X$XAV1(JL`Eu@uj;NBEBrT+XR?{LZsQdflmMKi6|@#{&+9r1X5Y0{y%N>x zud|+SDbcjsIP3i}|GS|V_2d(L7r*1BHnGJTou<9ismO+pqrH-~M| z*q`U(tk;!1|H>K`&5|k31>UO6)K#<2z`qYmF-iaEc(AGb_lqNn*)4=_}$if z%Vj3Hllv1eOJk&GWeE*OW z>`P+2Ui3;E`-!7`!!rQ8B}BrpnAottzq!S1NiW^cN_nER2v&umMyI#sNOPaf$$VOzN$pHuJR2<37UtGw=6*-$QRgRnVot^H&^Dx; zlP?Ontwiv>KfElt@!@T7O)=X|c6UtXxP#%dPmAzGrLg0(+B*=)+P^2GA*LIat*>>v zJ^N;MHc}D&fzyF#T8Eoeb0jPw;R68!nfvlNE<$p>=;-P|qt>f^tFM zVd-<{kx>HIe=SpSp#z5e_Ssg zKExTl@eR5>1GQT#X%sK~Jvt%hMFsKCDGM%2n+gop?yAC*rBDZ2{^}_}B8ja7E;Z&9 z*f(pq;qPk9B#|%|zUX4VeDBcDS*JhGY{1VSDEok#4rqM(Y?)G(#WwJ6p{-c;Gbpr=y`DlK5 z+kJvA~?(6zblzbBbJuWZVOie z7RU@8iBUi9lg9Fkme> z6UA$W*xue+L`c=BKt#<7@cfT(K`DIToY$1chcRNO{#XQQH|F?Tc|aI*{#u@NuP+B%!fKDxX-LbAQFhq{d!5;{RlxadGtGWPfJB?a6}(VUX^sIi8zuk1-q<=9(Qr13m? zM4`no08h>;S;}^GRnM;il<_*J13p!C0fqOVETgTJMJQwK1>6PxhwcS^475xaC)JEq zm#563i&gjH4dA$IX`LZsRKiOR4wOu6B-CQ^VE)>#YiZhq+}hG58Y=c1d}DQ zux{fK5FLN|_ISNWX#C|NwgiK|0`^teTlAa0m#V78f2mg6^KafwA2i0Ob`-dl7!T`i zAZlr=6B&*;4f4qwEUZ-#rXX-qr>Amy+*-wpoa?3#@GXHK)fzn4^MTSB^GcFYE;fQ3 zizcVBM??5-rk%Pxc4uzUUcN_w!zCiMMp&MN?-nHfBfkGQ2}>bv=t#du9KDS_)5eG0 z6iwKV?uEq0A{C$TKlnE(@f!iRFVl$}?|ol+nyc@x&hgJ+=bYL{`i` zO;cPKWblok!nK6>dm2hNFE{HZc~aSMleY;YciVN7YUe|Jyo~YMZch8x_IJj>p}!xM zq=}pv*GNW|p;W6Ib2lX;+xR;sI&+><`vpra4ttYTM!etXYG2&r`5{ha*Nf8Y$RLW0 z-NAa2K?l=WwjBaJwY~#RJ?dWls5j+;L=-L+O00byfOl5Vbj&$m9Vh$gt*>8h3Er{> zeE(SUIpG9%8Y{0`hTo=Ykwr{0H37ApNUS@H(Tu z;QRs509QJB&3JXvc8-Zbn{7@2$dTOOkB1k48-{+!ZLR72Cd*KPI-%da*8SL^2bWj+ z^r8g63%c2?#br>%W2rU2o8qPLAzq7S)yAIz{h%p-(X@frIQ5YHd; z;NjA_&t=E!$G-boDSV({a%5 z-!W-vRzvHf0_e#lsukw1fS{?y%#X zpoLPm&%)3zvbXKUm(IZb8|Wm~k`|*~e}J&qaDh8o(qv5?z3A3&3@y7N$?Dn^P237j z4ASy3)0K_Yp)eh>;dJ-mOxc;ld{&Mh(dTS&b(O50H6 zWcay^ge)6@1`mGhsw3bnUVEWRdKuMzk#`wK8n%7;%PRrKmO^C6+gD2!V_ClLedndU zVH(T^%1tAFqkOEP`s?QxglQJ0s}6ZuAFiD9}{mvem|8Yxe7w;^){bk4S!D2$}5#5g)2GK1}Y$jNLAZ zIyg^sAWO|sMNnMcj-CNV!XEA|9Shg|>E`T0sRF?c}AOuiO!Zo@fKfU@k6|H zj*L-1Zm9SwPPX!42_Ni@)W_UaEj`IjPC-y3jCMwc%W2Pg*P%8S;U@}+%+{^P=T|4B zAMj%X>6@C32glV4@|P$+i*ye)_gF#1Z4Wr}!)uDdRXt_xj4p2rqZht}N5peNf!(x5 zanX3jxp=mNTD~6AF|vnTx;rW@b;yy~7peGc=gxL#Phi!zvJ1!(tZs11nR!wLk;qI8(ia z;I0^x@_GB6_HT3*#&p83!ZZ9Uc+_`rck~8x)bL+1+ZzyibSh_AZwIWKQLxhWoj-67 zM^j++0D;}Tse2yG?3Un>YUjz3rds>sca4yVTWH7V=X(x6#JmsuGbhl9gNC7di{!mg zTZ|YJZ8pnAPzpLu^Kq+zXU2=Sylm8csHyd;mUxl)iC1|-4oBfQ6X+*i$SJJZQ9IYs z(x4khjan3B7LRJjuE2%NBg_&GGvmR-!X3lIOc_)%O8!m6oSEj5=_4+joO!o}M5ikb zM5RD_$*_n9EK&!{iQ%o;_(*UY@OrH~E(NyOd%nXD&d7M_=9)L-K6ti<43PQ zwe0$LTxh$2@y8xU6ZzKc#A8Xyn%S40_k<3!em3t@_oqbl<(L}2Ja!kwsAd>fN|#9k z)f}$6yzBb80xqv62iy`fajwm-UOHZtxEZ3+uy z*U@yi&S^9`g1axURuzB-@DVKajlur&>ta$@Ps^i?P1U8%uH^>G)BTAS|2Ft25SR4) zJ@z=nq6abJR{Xu3C=#k<8}=6esa+-3w{|Z6>Z}- z7TZ-2liOvRa776IW`9-zNGA4VT*|HD-yi%#cu^4(;NT!W2i9MQV1YOQkN2dlFMH=BhTrb=wP*BzJYU z6P&TKo!?dDYBW`Zhol`FK=ur77hiPBv)T&mC&okkIg^qq7#?dV^He-5l2z22Mai-4 zs?^R%Smd}OWJG1@wFW%A(Q@8@CIl`wNsg62?Dy&{xp5#U31t11>WW6s@-aHJ%&Ve7^ zC7w$>tZsRC<@q|AeMHBZPDCi^E9^AS{VSfcMbk*(`!48;1X*;X?jGXh4h2WcuScJ4 zR}`VnV7!V>&4$JmI;7Y)--I5$cbeP@^2L*@m06R(i-)d{`S@6;Zq4TNz;6bXnK}a2I(L9W4K<#2YB~iYBeVc1 zs^|DKF9=@aEC}R>44bX)Gw&x@f|E*e#6p1&x3V7>5UhV>((aVswoqZp9M$jhc+A=m z19mkRp(EuVkvBLwX?r3R^JBW^%bTngI^Mi3>8}ib9XL#8k*xU*=0T8Ot*sq2wbnZ@o?jBT2jxOcAR*SpSe;AyZ--pO}9`R9%5=K$%$M3C#k%kff34p`GBX0Dq< zLpdzZ=y2US&cX1!%CKU!=FZK09U;#xHs2GFQoFuiw+t=CQd7LTp79Y5ME}f7e0kEf zzY)e0^{1q)prCJa7YU&OKe4C+#nJ$(aep@tO%n&9ms-TSZML>`+@Ys6xgGBg_)Q*s z{gjtgQqi$)zDKZQv8sE*LJIV?me?NW!5)sB%-yMHL&FIWPvU4ZE>Z3SdJwIw4crkV%cBy*_48{*b{%|YCpXi>|32}o4`XW&Pj4* z_gG5KjX%#1Ok7)3@c&`klRy{Z(#L9OLLrsb5J9*ItkbzNIVbo|mh0hg)IoTTM<~5< zLe8l_VN6)K>D|DCm; z-*lzAbYa`t+7)e~@_;nfudfSVxZy+gJ@rTL=q%S{ zugD3JEa~hcSH7HIds;+pA)*n@^GxJ^y9ZdN3GT<;6Q6V3F17h-rGDDhA|TcS1EZ;z(r(=Qhugbz+Vdk0rWU#u=BB2U zd@WWmSITbAx)%}piy#%7cSq78Lr~U9XlFe_A%akcbKk@fA*Wlx3`F7`f5`|RcU3K5 zzX3brZaX$t4|+vX#$9JNm%GTYs4>YV0$14@G=qKO194_M=9S1KA);~v)BH}=MM=;$QCPf9QN=ewt3EHMO{8KuU z9Dn)hkVytGW2;*ulUefut3)~XdbrzFm9S@Icb#sfl7q`Q{uuAKlDJD9>cd5jb2*&3 zh}A}3b!2Cni{~tNRiPw(oP*vUt?gP^8&UH;p)D5)yTf8rKnmD?mB9Dmj*PNevt&i= z9R;WdQ`Vy=BoDV}$crAV>g|}5-$@yWyMmYb{Q#@`7U}mC5;90xEH}lGula}f^YSp0)~4EKnQ@PrE@g~YxJ|dNTL%xb1}cmVN)=f*f=BeJ(REeBy#W#P z%tjZMINSx`vGsY(%MG>8)Kr~3J% zRqNT}TeJh6I}^>0z!J(w;BJv;feaU3d>K~;6@}jiGxLiMT5d{$3x+}jqj5uljD~is zZ*0p$S@85Ay-O2d6~a?tT$bWel@l+M?7pL1)#^MtI2y$dWfd@2L6y{$)l7{!KX%5i zE3?)PFBHa`xV}217)oAfNqU`s{<~Pu3O8w1lEBj7{)HvL7)%X}!Zn%kA$W#o13BVUlTy8 zjLI@)!EMn^b5F1}O*G$bhuRK-?CLR2=rkQi;{H?5=!bdP8hq+AYSSv_*;5zX}JSAm#zChE-G1p;oSpMYYu7Ci@f9a(5^$ zJ(tU4md6*CdrFb5G&<%EHf`6_YyHlnP_qD?HacMsI9)W{FI>mVghAnV{^6#-{y0>4 z#O4Fwg0`5ZNskRibW8SfVnyhg>HEIh3PISe6J)iRnRcjUo#^`ExtaY=CtZVi|M+Bp zk-Cq8{%9W8^)fA8GmQ&^y1(10<0)sT+|sv=b)=Sjdz*M)qBUMS&%GU3#&f>{*xPsS zaX#XB{9&wFp&pcR<(pPQno$YRIv8@`h~>C6zFq@ZKOmx-n+6!X=zlkDc8%^Z><>1O zos~sY>z{%JOHp8cuc;$7eDUwMJhY z;nOC};5yKW37<$_r{|&h;_hxbHyQKiXg#3Tb~*=%P7+dOKRd_Vb=fmQbWjrKVAmFQ z!txaTCTvREeCo&cqB^gw$e*Xms^(XNu716C85wFIhn{o%=8pVYRu@N`p?+Ra&2_h% zk|5tacp^xCaqr`*Hc~$ZYF_k$`kcl6qv6dR1I`U70ez>1LgVK|trA)M6SVx~Nddbn zm6Mp1#*K)vsE1*_op}2jpGVG0_Zq|()Y&_!p`)DF+rrfX9i?OF)V0KE;pNIvt(e_r z#$ln8;b1J$g<%ln@Yf+x#n5^|dv%ycjJ!?{XzY&52<9AJTqGLB&tuY;n(tUhG{Y!< z+Xa?iKDDyde3$S%yXbH*Uq0SV#uJz^_QtY1c%5z8?j0Rp06e~mBtkH=>R3UP-WN&bCE-YNtI<+Cu zWKVnCw74QwrxB>;0VR}tqzr@Zo_gnIF;P-Ij%GLtky`4_e3AvH6};Y7D)T>uCz`D8 z_?q$O^|R}%`*e>qKT?~`bV0+UcS;*E2Jp)G&Xfub4u6^KTb?+fFmRqlT? ztbIRtTaY2UhxyGsc#ycWfwqPuE*hkX6!V3EPsH{T)$uf-NGap!8{%^2-#c7~jUyXm7Q zZOfyBUs)q2V{a;CDzraFO*m|{3K+2bj+R&=O5!!h$Xz|oL444X)y>*mIXY13k??Sx zxLvmf9;8}I*K)*?9m;gBDYMhvhTqO&z|h`Ywv#7hWQC@S4W@b~-t$XHhB=L5>Iz}!z+O16kUZ6)tUtVsyR?rhKfVVGd zw2B6+=cD}>Eg8?{`yi6<9flv8#m@2X=Q^VmKe$^y^lL+7f?EH68;qMW9rreTGDhRj zqb5jm@|g46hj@?d{kl25l$HuXF^oMKOOM-+}g`&8N+LA{*539qut zqPJS{4+mO?*GGl;!m8nCP*DOnlF;k7=lUk|;`uw)Zea>-FWgZ&>IuIJlWLgU z@IPMDF{utKEggE}aZz3LXJ@YoBBq@%bZjbvA++IIwM|-g$os@0oNYF5Iio9le z)zTxPl8Um*5#P!-g~&x;O9fitX*5p$g=fbaT*jukQ7SULi68US9b6V#dN*~F)2Zsr`~WPGtv2$ zQ>o9#w>T(n_>zLQK*#SiSwhj!o-G+2uT5>8`!aWhC$HDZ7K>W2s+P8j05!uMLxvT2 zG0i}0v)Moc>nOe?B_0m8WwYR zcPdp0eU1{C=FBzj@&9P%yx-Yizds&DP?Xw@)fqEtN1BwXM(ok57*$%c+Ssd!Syi*XJF8~Y;AQ3&-yVoGtO46>cMR&1>DkSaccv59a#LH8+1q1Vyyq* z(zx8W=$Vi{Uythkw+U$$5gfuZ!#tFC-Kdogb=`n7pB`Sf*+Suy-3Nx4q0$i=eb7yx zDD*g+clKKR@)5scy!o@6MiFOrY^xZ0@uyegg%~8aY8_jjHP}&kL2jCR5mp>>a+vI^ z+}o54K!eaKHXU_dHsj&>PLq_PWvKg#<+=^cve{pTE`*;UrhCPofyolb_2f+1+@1gv+! z*lN0|(Y3bv4I2*HrvXX}7j+}{!{Pf2gaBB{dBd(5eZ zOjV(F{NEKAsy%30E4{s3N-NXib=Y&cHL@jv?0;_SF=7sWb2Ut6_WF;AiROcAg_Mi_Q9B+*~}3xC7Xt>u&>V*NP)@} zC-@#J8P9Io){#Pz0F?mm)91ZTZg9-9S<@T%86Pym$oKQ$owBg=n#x}!G;7{DEG3P! zq<4qB17(g8F9+fs!z8P^UHcs#h_-H@$#OD+O@g*4Q+4*)g|UK0_!SL3SPlwybbM5A z)g@eFTf2uzV=7M%gYa_PS9a)pon1PP7yD=~VFW)5&6t~CTazvBLUi|GfrhYIiDBx^fNkg!?X4}$nHlWGGz9Kh9!TR`E`%T@zk-iK^d-{#aCccmo zzv1{4@n$Y%Ih|-V%hAaJmE4Bgt`T#;=70VX!-za0ap>JoJz4xw>s5l9{Iq#I*sUu5 ztZQ9TH_mXws?HzpIN$ufv_%T$BnD6BV)`I-C&F$RV30^Y<+~J=4E+)G>Xa5K)zI#@ z;TQ9jS;F`=)!9Vvfc3Bj_s4Tatu5u@(<(1N>V0^SrK464>q=E+(lukAyc$2C65+-` zp$-q}3ttl18mqdHZlSO0XA?VeCW@~jPRyN`W*!0w^@*7ot@$F09W9WDO@YNHxX4PP0F<=U`lQJvch9fbK#X>u_ul(Npr((t-k)M(Q`RVFQz_ZPl@p`BGVK&i!~!_G=3ZSGjodFg*%RjO0j2 zntZ6_+J-RdP+LT&$?AEvya!R~&=lL9eIa~EpuQXEd3?0%sc(KOeQsJEybpEk03&$c zY{p!$LJ(1b>wz_Evgkp)@l#1l4j5lI0QPa%dQv2u3=cL*i|6o#@1FyPZ_T4u^}yWPa<*DvsG-`B3kHI|t+-AI+KQ0C)Ds3dYtE57=!=&>vmu1;kU$ zC!OW{wO3b()8nn&#*B7+NDZ2s9WNX_OF9 z4-+&0Hfa+fL12-!sh6cj&rEi?OYEjj#y8JM0>P%)$hD$hfBJ`n!0yjZP5f^w>{Kj$ z+jdkvA#+volcm{`;-1>&R4k=dM-_oMZBb8bu>PPqKv}EFC_ir%Qdr1HXaqu=e? zx@(jryT*Fvz?EEBtj)b-BjJ>}dz|;p&BvAO{f{%)L=ZfTK$fy+p$rnwyLzM(xi;!T zj?@QkI*rTP2ihydB{g=%#y901><1^N5kZ=gQ_^1U0*x+<8OGVr*&!wzO(@@`D?X}z zn4;G627Nepz>b-{jcddXkBdLwu~;5HoAcUvPdR|pew6`)GlMzh2a9ul9TXNNOfe-x z+i8=FVsharTTAGXQ_s@IIB2k`hl^U(P4$D~%h=M=i`HnhDPuL7x9zOSc1wTis;bS! z>bXs>+F$F2HiFCHPeWUol7RsJf`DwI%rBxxhoW?3V0$MagWcGZx&=@_jtfP0U=MYJe(f=koW@dOZOS@=LO+zN| ziGrRKhPG{LnD!uBAl(cBR(sN;%%IE7q)GCqVB%nS3j{pW*4+?yux+p%=@8#q*xI|% zpK8ZLw(&gLPSkhYst(2@ci8seBcI~U&WC?GSH!yQ9C_v35FIOGyz$b<;Wc=kx+V-Fu>wzq=+Vy?L(o>S&^tDLVSC|i-5Qr=~#v;?fxN4im{s!1M!T@l&%;`im zz~N5sI3Wd*+)P8`qZ4`09Ey#2WCh#|znFxn(4ivbeU-Nf68Wh+5(c0l^hw#ny2qcN zWXMG`yy3n_XN!W&-1lN6Ix6d_?+*G2-zH|yYjNcL3r@KFrx@^o-pT0aGyP@gG={*x zA%MYG{}B;Z-2XC5ci8{$y5@i0g%EoE=%~~Gqo5w~ubm`*!F9|rT^K+YX>_mRuHCEu E0pe^Top`IZSjCbR;As%#ZTY8c0abTal2S{Xl(= z_)oVnZ4VOCJEV`&5?Y=a&}DOREq%&Y$1V&hZ(Af<;$*F>UF^!;D(ZCrAkd#Vp5GWC zq2C~ULR=Yjb#V=*XCKN?xOTE~tkUQa<0F}LtGho# zw8v)RR!`q$aYztSX*EV|klou7rsVCF` zOA5bm>Khwpg@%TTzf*H(g`#6&>A0hbm1Ya8ASfqp{y!r9KUvSex`HcuGijNU`KlHJ zxE?A>>jR1c1Gww&`ZTD1!byc@58H3JYqe&EYh{j}0fb%SOb~P_<#ex{t|7i9wpVf` zsk1tq{7kWDNDT9$zlZKb)NLs0_8FXC1MeH$xD0-9VSrZ{bM#AIAl_p}V-dkT-O;UV zJtv zx6h8^x&T_&ZESopiG7(z}@DCY_ zWG=HE``y(g`7Z`4qvA&P;)P4k*Z)>zPGlw!8-JOH{<)wiw@z9qm|9(5HYd20TER#| z0sk}>V70rnyCI}1rZD`$YEt4cUUGe7V`^$@s9i@_m)(b@#{c_9?9 z{iS^|GLn{9Ih?|Ud>^G$HaPnu-cawr4%Wa{fjZp*57}(p8;GI?kKwy{qLH zQRVOB8<%JR?ke^-OZSapg@=R36e7*FJl+vcBFf!BAiT+BH}?j^?$AV{|Pl}V?aV$m80cn)N)5#$rGx8qL&iGxe>S^ z(d=3yY|4brfvTj?ry? zN|!ytOxD2Sn>8eZ+=HdT0YE%;Fiuu`wdjt0cnbZm_uLsGJ`KNr|Axw^D$x@~&NJdY zP+AcbNZ~V*r{ypg>#_82Ij6~9y372=CE4v-5>9O>a@T*cYIR^U<>hc{op+N<6Sy;O zQ7ko|TvNWdh$UKY2kG1F&isiOb8~aErt0wUQ0&EbhdzX5TVr{{ho1J8)#^E7e65#+ zAo2b$oCx{c>(xSmE@kCdOR67HKUYT0CFH)(rCCEBIOwM_gJY|rAgOZ&%QmN+hat@^aYX!X1y2Q2|hS&dK&`aCx;uWQShr7dNDwJbMKhY>YQ z)4iEp8RT*!Sw7cOYfO%fKjVz@PK`uxVd-wkH_b{Tc>LPyn#_*8Vl2#PkgKvHwRWvU z=JpweoX>;VesEmeMBj>xy43m^ntZ&e=5av~TU&g*ZK-+h@Ky=v zUc8RU4FJc~*Tvlm8cZHNP57iDaHs=Zcg3TM&$sE?+Tcv4JPs4f zX3E%PF{DRO_||mJ{(>dM#2$Rq_MUV98jR!Mf^c&&h4s2$lfr-Cba7NI7F;i?%H}$9 z2k-783}o@-AR1=PT=ARIhxJP!3!^ch87^J$P)y`)zEajS>s-j&N7vt zZx6fQqq(VHaA&&JSgCc>9UHuUva+kUjFw8s04+V*@kw8?rPafF#W>dr*>ks*6|vQ` zYl3Jr76jCcyg+Us(9~W7zWX^Z14pudQIVnY`yna!hk$@O?u*amUBi>F8wsA)9qlZM zJVsO8HWSnkZ>WUYc_6GZlD3jpvLE5f z0BPaU>$GJES1^4-g!bhjjh{9uQyVX6d3;8ff>j(aR$&m=?`rGY_xs&|r~%ADhJa5FRp< zvQLU7qy+#fG~V8qe~m!k%hR24D>TsFVK_@r8cO@x2ZuEARph1f*~ zbaofO2b`N@7d##OAAVn5pYX7_17e1V^*kF%KeUF$ie7ePvHASY+u2;|^l2duW}UxU z0uC(r>uf4d!w7+~OUiLp^D}$!ogA!DgQFzt;b;iRdup#Zn2!wE=W$djw5|c)@65zN zMOA7(;z#B~HT9QqOBPA`9=iVa>lK7lT+JUtAB}h?4(Ic5hbRNA34%6HPTl?O3N!mT z9o;#Yn&7&YkJ~P=yIYD5e(%qUk6338@~q35JSMi}S{;y-vuk*ONam=I|G{9d8}edo z$Ge70=V@AfhR|8GJF_z`Z4_M${hqv)I}(+q6h(YVg`*K`O^{8b!6)8F|N!lJkSH^qTt1`A(v2UuWH4_L=+#l~Rs9y(KVe$;|+7Zl~-P=rQ~+t7`JC zt0Y3q{0(=$Y{Iq|2yjg(MVvL&lSM8YTt95$P`_=jsUK@{VhQLFT4wTI84U{!$P#P& zmGu?p`e-y0bQJCT9;kan3Rd~^kEA?`#U1@BK*p>ZB?Hl%pT$no@u`}yUF>qz<*Ll1 zIJg~A1-uxf88!B~-BWjk^x}ifF;QN-vVg4r)bF)z&t+9VFq`-Y_SLyH$}SL4NqavY zR}&mibT5!30V=eiw^-J65pBLAL4~fEt^)^(LKn*)Sqjm>)_Pa>z}j{m4xDmSG$bT7 z0dA5}qe;!f&4lnUPO)&zh$Xl#oiK}GBzAVKz^evcgBp065v%A6H=v{-Kz%7~tf!`gU+)q4HECc|Iw$XR zUQNCoJ)4b*=+Pyk6P!J|(E%cHX)=m1tX(w0SlstNO=r@^0Al6V`Gy|(e{l4Ijzki( zX9=|e4Gu)WjgS>^_oi4f@Fv+gmdz0NwD*wf_L8jS?yB>`L|I_7JK{$eO%yyFB6eB$&Q^8;e}1pkUDgmyPINDFU z%|S6ORmR|>LIHxO>ENuJ{fHkULLP_5{xb5C!I*`xm1bWfLpjXTZFMDP*(de){bn}d za}xCje0vG;3Xs|MI)CUc`t*49Ih~qIv1cCJBZj1%W4R>Y(VID2M19&y+yq2i7N#P4 z_g+=w=H_n~6X`nZLc=8ihmRmt@WGPbr~5`jx!3caEY0EuH~ZT)f%g_ScF&|2dpnVHrxIjV*tK$%#?*K@TwgxeKIlQ(Uuy6pm;9x zL9^HI$0FOu1GXP{4kP(o-6sjdmG(!%tGFEch6N=HRT+XEZC}|hb1humjf=C`<(69C z{|LTO>`JbiF8uy`Vp?0OJim~qZj#`5hBcja)VAGogAweIHL7Mj_(S$_x&40FDo$$o z&w@dSYUAUH;$UqITBNSnjBBxV1%Iv`m35(D(Byk=-(LC2XF$xW*bTW1B>v)u_ zB=Y3t{U#`|Lt%5tW2n2`@ZsFES#^g`FH7rm4>^N`b=z1e^Y(~FpztthdEmz8rHQ7B z)eo6N$cb8hcOl3ppm7zKT6N{xuwq45QzG5erk`yJc8L#?L+Qe9c6d{}b{wur^_=ty6 z)_=vzn_}Bm3fW{>nUCws&uZrS@KV)5-3gd4oqJ|)j7dg}c5-XjGOIYyd@#Kb7G|L_w{{|1E4&vm1gAlyUF z>G(Xj(P$PnF<*~ve*vEv&yk-$^XYB};q^SG1u#Kt#2id4p9#4khSQSkz0{3|km4dQV#k+fLDrMInNeIm6 zy1}*Xvzo(uk2Zn163$LDKT+uPEiK&~ z`84oLY<#;`FS`p?3S<%FEPmeZ?(^+n&K>?jcb+)g<}m!67V%P*YfMMjEvywpZ|t9K^lU_=u{(U zt5I#-lgrxrC}s!=$7@pNs{F?FG=%@B1oa|w20#ap<0>I_uJ*BFe8GMN>Sp0E%?0vfABCp-nQeJap zlkvgJqFV=>vXGf4!7U9#P|LuGT1Q=T17FgU7mH}%GCLX1QaekkR@SC0W+kq{PUmIv zUxfT$8GAF>FoA-Pc7VBoJG=WoC>t&}%L*lUlrn)DWn(e~jSl4or_3UTO0-Ka6VG$P^(q~eG-%4xqaHdO4E{h3dD%km8J8!xvrqbDj?=F~CD{vlD;s=!+6N`*Nv!?!C9j>1LasjaMBxsr$ZtPY8Zo)fWL`%f=Hptoc3!E;NmT zK#_Iaiy@3>w_R1e<0!jh*7rfTmNz%Hqv*{VFR9+hD`eXlcqu^veeq*9c8Hl~WcRv%bCjJfjv2Hvx(;+z^EfDHy7RY{E@xdC zs3M!sx%uzr(g)0XEP)xtH%j$RtXP>-{*-r?hNw~p!E_{vk zMeq-AHis%9HnBHk+)H`P0GkeDjFtA4hhoF@&>J*Jf|WtPiFB)$gXqTGa&3I8^h&NM zLO1un0&UE7$o$UKsi=bcxg1tvbQ^z9S1N=DelRKuEIXQU*$&O(nrB1EX-?Yu9F{@- zhf+(H+k0N#(zjz=!?(6`GqRfV+V@fdxe_GRO=Ee6KOcQd75>bzn%!}fBa}D?ueb$! z&cEaK;HpWhIwm?lu~K~g<-H*SK90m`_fMckZd_Sodff3)UopX>M=^ppUmd!%x!jA* z%c0DJ+A3D7%^q(dJokSFzB6#JyDhrzFEwk15kU&`N_j7zwrB0>i0u?Ocj%i4U^~)8 zCKFT4^LTaeAyV$6(w%`jbh_E4Pv=2rU)%P}le78hS|tl4y5E_}#+yC1;oGdLAkJ!6 zh!y?N7IHCF(M`HYqJQQ7Ml_&ri}?EVNSh8Z0V8=g8#19EnCRZJTS{^9u=4F+h_+2Hf>lVL2!qCR80A~N z)>j|yZ?Q9DhH(U^9l&1ukl$F!BCpFQVOjevwnOL z0jZ{(fKRg93Vut+t<0Gh8zw`EoqkbZ77V!9IXsA(eu5A|KwP=eL&cUhI*PQMmHi%E zFs%)KCTAJv7<4PisloEp*00JMHzAnhTGh4$Pun$J1XEHx8?BE3Cnk!PD+XM^E#>e^ z*$L8^vDMYjZkX*KrX-X6KQG=KKzK+6i*@d@5%JvDqjkeVBTijkkG=&fP+VE)tqluo0c&h^AW8NGeZpVpwa>=y-5Z8Qi=z$a`^- zEBA8l@uMkgV&(?r+t?DC7$dQBSVvY?TpZO?f~L^gfUR#ZUK@)mU?t6%`e> z+XVzBD(<77H*|R<6hk`E>OEA7b^ylME|~yAl;qrzj|_lqDo0z|B)Z&5cBl z{GQfAa(0bNF64f9e4fanD^0B~!_wJ2Nc1=Q8~rDYG;ze*v?Y4kaE#cJ^FCNtQR{^p zPy-D&>WZ9txv7E^T0PTDKLPUtFAzF-m0OKR!k?sUu+RrH@Hu_hxMcvtJgsJ0QdyH3 zjaL@hPOOxk{mn)Y{OwD*Yrc-6HWge zfBs)Wf&X$eJm23Ne;nKzIk;Gf3MjKVT(MrIRAzm-;*D54k`@yb&fRYeHEH6QupZB= zR}Ay|G+bfJTsr508-4Sy(DXf@)STxde;Pm=leCdx zw`)4VSCdka5E140Vz5koI~ee)OBd~he(elGDJm*TCNHh5%t}u;oKW~+8pIk!`cnB1 z5qIEZE?Vig2*5j9yl^A7D!6GWvd&-bgrx7`YP8IeNC|4%(&35<){=}CC~w}rRi6f# zot>QtWT0m`OH4fWtsMJ(ESTiWAY)4|gG#2D&e4jg;rD;3;Uh>BPu+C(YM_oBLzG`| z3jN#ZbF2;M8Bo>im1mGk=XA*{MhlA?D^CbZOp8fPjJOub9>oqLhj^?fLmwz6_}r8mhO>Ydr>4h zRm3#L=UgG0v%OP9%#L7JRK?h(&c zX9xQ&r}Vt`?`rvYzJH$uP+?AV=FgzC!raJ?McC)yV^8h-sH^aSE$0x)6J%DJ`!gm( z*|edp2Y4ABJuNN#0IWK%efNVgtuPVL9l-Sdy%r``& z9{VMJida4ei11U{_Yl!>30nraA8Kf7YPz$|X!-iyrEr-2jUhMe@b@zZcL}<=oo9=Z zR_B%mRBGtz>bj$q=Ucbr>2oC3cBj-;jY-&ou`L;ZeC{G>tz1I{I6Vo=j z;yrpu-tXUPw0NKSnG;a{bxfi2@Sj-Z|FwGWeg=1A5N9hfYr7*{FW_x{Hit$8;s%b&Mv>Fn*ExAE+~7=%Id_}UVCLz!*-pBbTQPanDoK;DaC$fz%D+;Xs= zd0Ie}k%6?7^R5l!B{5}z=%ZhcO`&x*&o7_>+izLq~OKiePicDMed?`sB}d)aJK6jLD_ zN7_!>vN}<@T5@1tXelhvX!&Rt?o;G%r$p(X?_WC3^hcYrdCe!s1y-I;)XE}ABXY9| z%a09ySoYylZ>zQ#!E9$xd3Hr68N|u-MI$64D?flWy3eQ4xJdZ9&Hgd!nw8$|wO%n$ zUw?m%ytanP*u<#)CZ?fi2vin#xA$O<8)H`J?mD~k%Sa&m%SuJ9j8590W@9st(fBaV z+XW&UD`cIIW{n|aYLu;37F9aRKqpx63Zql0F1V__3X;z{q?+6`?KaWP6KU?MEN)k2KTth%Lgng{F z!BnNG7z}?_8ID4H*qkYcVYi4$ievSa_Y-m^n74?q64nqf11>)+U-a- zN!Dw~dLx_@7tMAfw1&THeZ@w=S@NyhFME9V?mMC8C9|Lk8pU~fhy8xZ?`Ygo<=cB> z6Hnmbep%~+8+n~ml8$H#KkTlV03e4#EXF>vtIRS=AcWGik5PYZ9o9(M;dD?kaWsW; zv#TaE#-8bKKGo1(kK`4|>N>hS;zE=?MkpryAYPQE{Wo0E>+iQRU`&L!GUaZ*CXUOU zc&Rd}3BEEu3k|M8Ao(eLh{dv^*-*prU{kS7ylp4!s9#Ajro7ogY3ii#<8#ty^X zoY(58DCY7bk^0SfDAvhG>=pccz?5XZyP8mE$;*Q?17(ucd?|(XD%s6BkRBCZZ6t8k zM#&^y&IkL~bg}g>lSa*rM$pb7@p;P9vP@>HpDT}o&eS{sLf^k;g&uv)H#aww8e3X8 zUhbopvDiFW>}d=Ev4!DCUU^$Y6q94SE=<=>$W>Zm7T9bbTBbEw&UbRN1W@+H-eY2> z^8)uPvOG`51MwTDxc4zhZqv(Nb#a4s8$Y7e<)ip{^=U8Enul4aL@*R}k4cM!3)UYv zMjYg*lOH;{#Mnh-1k=Waxj;?;mpu22b-+*hIDU7>yjZgjI^_uJ~!N(?A+@*(%G;&5Qw+a{xfnut%K{r8%Lzj@TL;_ml#rpFY ziAySSTc>4HljeKOl;um2@n(-%rL2Hl`AlyXo)bqNp1QL#)|OiPtzHd`?z?2pOAG&P znQHBW{4dudhD1dQB3a#z?P zCa@9%0C*j;aG{dHG9-CfFz*hX%C7)jK?jv54E#sZ>#d- z1Q>r4)3SRU{P=bJ50-*V0XLJn{h?{8Lfldq-_PlDXKG3pk$o^``HoQ%sqem5bBhsRKN&7t=-&#ZX+Lq4y6(&cJa}pwY}rTiHzwLMUUzzRB;@*$`*xb z!s~EPUedn1Rnj)5By@SjQ)~vJx0jWFU7qi9L@AVNr@mtB?g7qwDP-n#v*~md2eudS zcE#GCD}08B?29RhtjKS(ZC_c~ns5eUPn_MK+e&V614hEi4c$^7X!&-pt_({y40;6z zg6uG0P0E1 zWp@hOi1x!3>4Lkd)-8Q>SKP?kb4Jp6@}(G*-8ieU)0(Vue?<2D;f;~kq^SQS+h967 zZhzL`rj4UOpLkkw7Y4fQo#Q?D{5_KJ){{EAOA#Xol;{!twCL^BT&9Me zr53oOQvHB(uC@HYCv3LEu9NhnQi%>H;+X}*@)@GOhRa{z@tRHKGJu=0%rZhL6lBp z>D+a?1*miy?1*B}$i_q;A)2_5gPkxHzevN(EU*?Rg-4tplsue71W+VYHT&9kM>i=7JICO$5#WKwu@&uL+sKW{u)_G^K^4H z#^u*UaJAiV^)bB`5(1H+(T*D11+*69jfEudyh)UUK6Wo#aJ9p2nu7yWAkKF86z*|=`WKnZmN=khUwnF6mrJ=hL8HrF99g4^-=fg3F!sfC ztL>e8Ha>nI0V)nH!IpPx+k2W|3QH%<5ln3Xc)H?2WB)fv@8-zUqwJ>2-|8U55zj-4 z-MuwUL!LGD5<6Cm^63#~!AsapN$rL3$e6by*Tk>;uaz*bqZ`ua`#cWIr^y$9g`2c8 zDvsYDA8sZm2hL(UeA6ksSU?tyVhj3hM-He~SBeKFh|Kq0WEck?veug?x~``;&25vL zw7Wk>6H_;Ow`V>0^JH}lVID#?vHgcJ)%IuyEG3KB1ml@m!#jLet$qzd#zv0q-~}&& zLj5ypG2F+O=`pctJ}x)=b_d2cesM#=wz3cDQJddwP1$wLBoRE4{oZftF)XTY);0OD z<6*L;pd;k_dPz!4Q&N^mHLK1FcudDc`D-q1qDt0V^0U8xuI?iWdmF){AYGvQZhwx6 zL1VGq@Xqmc`LdlcrGfj0k-?Qk4Y?jUi=amgWAR5yh2^DL>7cwwh{ZO+0Gh7YC;5Jy zAt4OOh9W^MREiC`NoNI)qWaU1KUG*!A^LOFU(P2x9*nDt6!Yl67vHRvUI+vPszd`ZlNxUeTV&a zd}gLn#;0Y}87S{_xK!CqoKF(h?=K_xtgD)MV+xs%I#kiKMXrN$9QsjJoivj4K5BQ3 zy~tgAl(zOdPp!4-rG4Dw;nG|YLXQ6bsSuBg& zHBmWJU!geBeT(Ltt0ul<{w0B6$HJ1q*r0=NSzx?-^mXI-e5X3&uY!V~mn$0k4Hw?A zY{p~$#Mq4FhKBXY?2|J~Ez!GsCE;gZ3DLc*OE#sfR^KcvPR1qYp+oAQ^-V(z(tiBN zKLC43%b}=yb-eh>(VDK4LM;Y64O9m5k$snE#%VcE6IeT2`mn}F$rV@wyknXOsoI#r z@RHih9m%rJoWf(&~$NQBu?_B;34?A9A? z1_qkCXIez%sQMhP+gsz-i#0~1;Mvhu7q*|=Bz*Y}tg!q;Dh%rPuf|9WR0t%UA}-jJ65OI7rq$vJ}WnuS?2qD@AE&b zEnLKp7S|_fv|}*~ZLZgGo-r{wTA%0LH&ZI@4R+0nznm_C9j2o&wNRBM1~0d(Wr-@VwD|HfF^g*j=f>3?`xA^9b?%YzO@#bA0d(Bv*b*y~|f zTr=ZrcDw>SjP_+>;=5}H?{<@M_4hK$4_}D%Ma%|<+mT+}ybFp(PjHQP30v|x zhVoR{{VE$Q_|AU;4-}5g!hDT?F#^CP{^0*DVCiRx?z#U-eev4F@Ae=fL1g_tb)L%$ zE=7@+Jf&DFJ9KA2dz>cB8dl8a1Q zTB&bkL`y?M=#NO=&&YH&?zR2=xD6r-S}cE5h+OW**J#3G0N*{2xj9%_Ov+cwtZgDZ zjRFf}8U(k?#LcCwu1LHrdXnaAXHEQ4)8idC{>&odHiz0%@On3UTo|hkws^m1`m_|> zFe~}-Zi|MA$PSrx+^t)%g`ewT@9cGIOICG7Y_`|vNDxD|)yzfXRM#y{`j=*Q7^F2> zFV6x-rZ)D`*Lpb8k1GS#=JM?0h#)8@B!+`jD7#a^^~ePviiBcLnV!p(OU z9b8muw@3ad(TUpDC*h9&<`u zK{^BA+PUF}kxUj)QOO#R*jaXe+w{4@PJvo9#zF1+rs}JM+>Xc`hZtNBUG?1nD~~Ow z>E9pXGesba5fQj#9@t_u&7WswhX+y0OVapdZWci<&5|yB+4-==f+f4tPe4Wv9?fTX z+-8n85;9wx=Uyo6n|zt6v=YW0!p}elu=!*c<@EZ`D>!#T)q9R#SE{J69YBNmi(YWU zh21VasO9sS6sR+PVXp^f(rnQeD7Ay942pWJ{fxQv$6WuUt)44(|22TS)*bb+cW(^;$@(wGJ>Zonl> zkar!MQKT9M zX*3MWF(KjI8*kG@mIGuIB*r8W?O2#^4g`}(vLVXi_@lNU;HjZW05Vpt7M$#!3_^hc zs+cLSjIVH*B7!89Hc6->9AR;EXXMc$7Uo+6@OM?l!1nmC-L))+S9S*}k%;)oMxn}% zjdbPH*ZyG=nT2W@QbG(;hL$-_eatxz-1roI4`N}hx zP*UXN@h+)wwf_TbwF8U6w;_R~z@)>>Y^FFpmNxj98(vK(LP}d@ZFj5e^te+R z;YugezN5n-LJpRwMlEA03lU`5LXTh4*2Mw{?LnvCI3#3cHSF=>ycf<;y3rZ^dgL@%9M^|{Ad2cUgf%ZjwJZ+}I2e)&xvWFpe zO2ImxksjU_Y#rs48V(KhMn#vCT!e$>G7rX~R%xPSsjsdI)a6iQ43fR~0kerV`)Yn+ zQ%0q7l^AXaK{*vktFztgjMn4atLi=>+ktUeL?2REebf1bX(A=HWoHi&GksgIw{3R0 zzgdlfN1iQF`%TWZydp@I{g2>M))l&fUcUQRyV1Shb{^Lh&yHZEgHxk+B3gQ&MRpzz zNZDzd37z+L6fDb|nJl8p9=f{tyJ7Vq=Jym`bm+z9uwa9!o9E_K*v>^T1L!pg1oCQ% zRlj?t=CZ2d;!|JR##^0-3xQk95ZQU`Y>~Xw`1<&O9KVUJXqHRi$@0bac1#^bOI+Qs z*4JY2uDX+*Aa}+b3Rf>l4hM>j(T-v+o5u9^@rHt%zo(d!?74 z!;Sp+WrQXM-Xk~l+PPq~DsIi(d-ZnaOo?1Sht zV+;A$i7`Z$45D7}Ri|~s%B0Gq(B^`{HdaF#?Y6r^u~Y*i5)c1JzY+ROKj3O6YCCao zDErR>fU&^Y(K4=T{up$DQr&8QZ$p!PoOj1{uECH=RW+->M9kWN7%JV1uJA>FF*RbT z`Px){1j(aYRaEZ;e(0u&O)l?lbqLG_n%Y^K+2@4D#U@4(6&cO*TaGSpRhLv{ue@HV zzV&^+GTPlc%ahaKy;OfIV-XnLswCQeDnQN3`u>&L{AM%9TBMZZ<#J3w=IJps>u}9u zg#^Xb>L|^J*|xiv&-=pNLQpb>`f>gwacH!}2#jv z=w|UW+-mcO2+%AIG1l44aO?t3D<{O^4!)8xPBTj1a<$h!UyH41sFXQBbZ(~mJk!r~ zVcaL0SIHp)_EKjYkzvaE-B!0%jGHL}Zwi*L$-}DD!_9&Tdyb~a{yk05#IUd*IVR-; z=J3I?YGv=fEdFYaYq^>-{U$r@;kWvA-$w2VrJ7fO+3CTeSmv%({@ zpsCaMjn#%`qP)_bBQkyuOLt0z)2IHX1=zFjqeiGo?)nsp`CDBg_>mxou(ryStM%!? zydMZ_1?OHzee~$-V=VQ?)ii7ayU_Q7T9-g%S)c*!Nn;kyyt(G(Pq`i6sVK#4hlKO zCRf0WC)UD+UO_*pxD(=vvL1j-t!AotF#Bu)>t5wat6@0S9sX2k6xxH3=kOKzdPC5n z{_11t=|?=(a){FrE8-SXWIScx)*vcXLW@U{PH8fhF=9vW(Y)q6_gO#eExw^4RkJp) zAiK@R=G(BJo57mhz4{vyiKO$7EvD*ZSiQN9&wWvtu`1p5`Ko#n9}XDEu)?IAKD@w8 zcwNhYN;UayX%7G32=tPjY!a4SIO^4xWbb2hp%`m_NXoyDI{p5+;N|^D$1C0f%Ru-; zLo+dtLA~45+PFZRPf|#w;7ya>^3vbINeKq)%RpDK1+0avy%jZJIl{wx51t=6=}9QV!^oNWUGB;PY@$b=_Tss=X%8uN&zrci$ruHLH4ajJTylTz_qA!J;9cepk{b?)?g18`E{Pq5-s zT7v8>hIRR3x>!Yuok2*bjAUW%YZx6_-1=7dy@xJ(%L>38maej;yi9y^YM*GOusk{?e73ouoLu8(dpP16Vq}ov>^9Y< z>_j0I%EQy?rM9=*3IZ0gd3~BN?>Syc*K=Y*wv@wn(Y2JAj?qS;a2X~mkDk6x5a!!H zuIXjC&Xm1$o|3dj-s(zFltj%WZMNV3b`XjzS;Wn?j)U;{$DTXo*AwlvJ08_NR{07= zo^GGd+t+o178X#$H@7-d@f$=McdK`gOjxfG?r|)@iOzQi!d301k-AqEN&FB&|EaSB z4>^;x{z%V%**;onb0C?QZN-S8W%kDmMQ6 z*7`R*>I6}tI_H^A9|tXXUGX{6 zGBTy$@M;D`u)(x*38}!H?vx4oDZD6f^eGfB^SWwd_@kX@jQ)?daFLFH1K4*GDV-R2 zcj=o%WugwtyI+p#vEx79xrkD^!rIO|6)E^%W4wh{jZp>T$b8i4iUgzEX}aJ8a5YGU zHqnISLN?*^{9Tc9s8j`2M--6uv$>HTL`iSQVWZEZA-)Uo9Tp#WcYPw_5#lEJ ziU+;;DRX6e&QrM)cIYQSjVx4UP&$!5mN07_MR&wZDhD1|6yBH)ZBun^^K)D0^~-vL zN=0Cz4DOd#RqT<&Mg}sfjNa$(;7Mcg+N645l^guN(@Rs|Fb;T_C~1IiZ%d`JRXm4A zMZI>LereSDkXtHlb+zheujix$oqCg54b9(O4~{R>F)3KOCqF+wM1DvlMWrKXYp&-T zE%wWKDSDv88&lfcn5{p!ro9*oXpcJ-yqoGlvd!x)iL+EOj!=m|Sh)7w?wq#P1n5VXX-`jg2Fi&KTYOKB9`|r=&ZDh+> zpiRVENoc&Ku?ZJ&#%^ISBb(yVplE*A8rkN=xPZ7MJ;lb)h))Ht(GA+#=%<5yiN{>6 zgE%;#+AXH`+|6w%@lzt=&V@;QGQcl0+wnGQy2|0Pu(YvD^n!1Ck}YY*kz02MN0MKV zEjk@s87Oi4UQIp%y+>Lm=QHfkGRgbPc@{$p#GjXBcj9xr@YzDdTVTBJ-$#*V%XE`8 zpZ-b*h_^|tQ=~y*nxu-8N~IF*x@H~!URT7p**BAFd_pamUF)w$k)xvIoK&2SkWGtF zb7DmLTUmDh5c5nF&WAL#IUgsKR3Uo8s5?00hC#xam!7NwtC-}@Tw_~6Gc-KpGpQ-k8jh^1u zBx1M@yl{bab0jvYKzWoQ%-7{_E6*3SNi5)8FssALI2prka6WB4ynu|-FlJ}q>^fhV zeoc1&m8w?Oi?$*gbcXnSftL@zc7G1{BnVTh;rr`3Nhif+&~tI}t>H>)*<7RvH3rZi zuAaHm5C_LthxZ_96G$Tanvl7m9F!jMAqQp&ddf3Xyn>%qfJ%DpI- zBO-5fmGEUQDt^CYxF!#C`_1Gt<5F*nZ1}R?PG@Z7&9a@E+h-+YU*dJRPf;vc2SKXd zuOk!i?!({c#_v+Ba>%)~ThPj5vKuU2s+n^jr+3)(FEpbF~7*u)0`u6pFBdV zd*7`tmRYGnHxIVv25Y|z8B!CoEO|pxAVKYSyf4*0j=aI4>NfE8LIl~D$|lBU%?+XVjna|Z7xZcA$aW47i#mKpEX3YT$jxqVL%qnZaWqZ0y_$EmIJoGgxcUK0L4%6vIC7GD>_TLSq znC2t)kqm`=MEOUq`4#`(niz#YBP!+}UYUi8W2-|ViOL#MmhIrO2hq0d-Q%Y7dH)e% zCD(eb>eY9PyOT>%l5GahV56e`vQ9!tr$Z?tV-rMz=>0>)HwqQ`cPv>=gx&sy8AM96#D9;z0EL1LJ(z_a4RlLgQfj8om z|;za5=otr3`%O!rJ)CLW$Ed^9d-3in6>&8uLW*AJ9pMMNU9aYv!tA3Lre`Z{6 zsHu)YpJQ`$L@3LqFIRO)*dq^TJr8Ja;wx3}K0V$Tu?^_{451zzl0xK8vmaisZ4$PF zwJ0F_zL8A{vB}G2pFqC}&3so=eJ{Wo!C<&iYbXi5Kx6|lnmtAg&5D=>yii_O}?qxd3w{z15c9`maMVN3mejUj?ECd zj5c)gF<4#5?v!pE*N_#&D9yx0O$uM{r4wt?(Yb9!6t{&UT8oIRK|5m4H8c3GXNq z1Bf_>s9IA-gffq)@d+WplN=_o*^^w>`@>wTnjS?Tj(57*G4DJ35l1_%Q>3X?tJdv_ z@H21cS_?d_Z^mXa|H^g`k}3jbnxmF1tSHIsQ}#hM%&<%yU7etVFMU7)Y(iA?=67o6 z(#WsTx!?P*5%~zT-k75+^dT*dauEfS-;di9+;aCbOL2iJ& z^vaP-&Gb57MLjO>sqDm)Gf3dw=#9~6eNUvA3l}Q1kGG+tAKq?MoPI%CJ`U^ChRtb@ z+MKB?vzzC_5~N$?>-SYA8pLh%pHjR(Ry&pg>csNpq-Ra3MZ7_ zD>>n8O2040xsSdzDJ~UCgPU}{+DqX{fXk`X)vMSvlxs2l4~LFIUAZX}xY89SXwgTa zUI1Y~xZBZ{P0jSTxL@7h2fm>hWGRl61?_v!m!DHsypP=-!{m*r_wL`u(bs?lrL&n9 zetd<^3Tjw4%h?&sRwo;5U1lUicHy&sLvG($%n0=bm#t3^m_Mj5F@cjhY+sC`u2oLr zR<2YY_Pk@ZG47X>QnOlL82sExn35dI3axfjqeQkU`I|fY!(`=-mPr*(rNazGs;)Dq zMsw(RrnJ>zUE9jfq2`bm{|G>5rSt{5=ehkjW_rKV|5&!_#q9Fih-+)S3M_+E)MtR} z$~|nf9ma%&fo*!8(dq8wD}_+7%5r4*@M4`|S9Vj=vq2??R#DfbSIuOqUFGO!k=Ij; zxRTkpTChCq#uAdx``WWxk7@^1&(YqNZ}V8O76=)wF^JZ5=K_R11ZrPY$a~7aS&Wg& zb2#_wQkL{GNO&P2-LG!U1CJC~!&%;~uw92F}!Ve7fcA>a;U$iTF|Z zME+fIyZf)76w{)|i8E?~iyOYW(oj@Il!4FPePhy&y|ph)^5w&lTKeF#yOB#B4ub{a zG-){cg6P`dkS|QZAN?$^M3)q>CxcJe~)Q@BC zk<3-DeA4=O*in5inz<#9iWvYimmlyIBma)Vcbr@6snNkTeMqp*;XgHm*{RmHcUz=u ze=_xkVE0-${3or&+;guf*^1`(Rpi&BU+R7>ur;*kYQTIa=9@made9~;*l1~kQNg>z zuh)_gW#QK~rmySIEO$l zGi)IEpbL}xg`(>CyX(y{N#2!xQ{weOA+MJ!M30p3G>%mF8W4Mr21+XWn^A5BEt1pv zJ2=_LVhU$K@{>dqwK{3&{+tqzO!p&mCLt>rq3 z)m)*OGm3eWv6{}hDtA^N+FDTue#s=pSxT3><4%x7eIz2JO=;8fZmmauX2SWIK~*t! za%qa2qK|d6?YtkT7PR(^E_p2`rZCK#ePLcnd2sx14PUpa8#c3p9+8d-cUb;SIPw`N ztEIrB5PS1_rv=o=eqvK?{n+#J}19blw>f_h|r!rdxjw=E2;YI*^8EE&z}E5eS!GW zW%#lC*|QJN%vF&=*G@qmsns4Eqi#6h!g$<-e=qU10f9gh|Sun37`Cj5eZLq;6f8 zJhW-u{HItUOQlkqi94n2K)jf)PPa_8h?fLY>dQiTUZ^TVTp%`PL8m@ZoAS4BYoU0I zwsv-P2C_YB#w&yCf8(BY*q>QRZFUmG$*YWjj z(`G6^Cn$4bWMz%ax2n=EJrL()WMGhAq*hmN6na{Jm?gt#iPItJZxL^yraumQ??}e^ z=cGd@16kxjl~?US77js|&qo#l`S(;e7>N-*GF!$!D+k=4#24<~)!0dNrd;o=Jb3Nb zJ``DtTco9OI8ICWfKlMRW89J>!tru3tPU>`ggKR=62ce^=~Kp?A?B{lA&C6*OzQ#& zmto20Iuik3r7J|5iEu*-ER`>TzKapU4(C+c*W1L+eBa(9=qlQj69o}XLUuc%b@k(MZ)EO8b1j?2WXAy|~Te9<;abuiop*llyKH~#LraHs4bzOZ) z;UCU-M05Bn;Y_F$f&CLK_Q?%G4IK~_s(~VLUFDBV@YnLnxiV;{XXuR?4osN?&5-Y_ zok3GmQ)>>%DJesy?277oE9y}qHA@WX*Tn}6#hgLnSqJZmIiF_HDdZ)#Y7Rw{GdWAP zv^u?+i-Rd`fdKD?TH~634Vu^dR?YIhG6)hEtI@U{P2l!@|GLSzD;Vq1$ka5qs;Vl# zn3+7ZK%a<^(0DMf{_9|#E1q%_=ciBYu?luYlxi$D-oo)FH^Rw$?7Iy-TFS|8L-3F< z=*gh>xD8=#O@tx>914nW<^v0B*lU{1x1>>8#(0RTA_Z`P^Y{UGoXsQ|+c zF3g54&Rg!gf}EhVoB#>L72@|{o1KKFUG;<~(;+%MgHtJspOXe&nCtFFObNT@diRc&1JUBRQ=#=;X0jKQmi^$$cq@<(>?UI_DSR{J~W=OT=Bf$g)HJ?F|yf6@i z`7fxo|0g2+M|$$VI-q1tmRMTCJ-c4kxY3geGYiNWc+_{YnIvDd%l{1gl!Hnk>FK+r z%rPdn>js{$freT!E7EzK7I87Iu?TvVz_91Cj>f_du9KOb__r-4SUiAz^V@xvGl6o( zSnc7NZwf!7kXprR;f;a8d?2>?$$2FZdjL`)#keI$6dreVVEKS(oMwUz(d!Tyx2J3ZGfloyC?k$TV8aKklm!i!38YTf*Mr|4pMTavwW9u&|ZG`N*K`{p4_xdD49J9a~m zQAB`@A`rX0tW^Wvl&ilm8Aut3&F*!%Us_tamM~;meShygqONC%&}8DWVq*RXI{>mw z)}+Jz2Up2`d>5Ksi{Pp})glIjnp2^h`lp)X&tJva^NxcIjMw=@o^ZL;IM{~jd`e?a zU(A-3f633^v;9gwvqVA;Xv#^^L!2(;6(1k3dG917B$QVj?IsT4R7CKkpE;k*q>GvD z&rnWf`66{q5JV;F(vMo`rLfqf%gGIXo5p+)O1(tNiC^1YgJHk&f%4V7uTW84(GOW* zs3m1CYF1t}WisnuKVCg11JHTb5ET^_1_s7ZsczYyCmScpgs%nSFb|6QA6AYY;IY8+ zmv{#TbLKU3vu41-vwC#qC3&)Q44lBe^{V;(Xg^G0HS?QS}gbWqIcGxT4Q;@&vkzzZ^RdN`x+Ckcm@8a6X`s54cXg(H|FG%b4Q2QddrF*#mfu zG2V*ncb%tBt;i38QS#)r=~3SWA~;Y*E_N9&`RHcyIvqB{M2?rig12xT7zuAJBTd1c zWuXGG=;1DVnMAb@f`Krj312}*X1m#tfpt^$uTU?uYE<%%5p%yI zfil4oS;hA4Gd>dOt}=#*(Avkxu7Uc_uQl_y8k!FqaSC!KM2!HV8I7YfQfK<@oWJy5 zwVvaKMGlo%S~+!y0~h5}RZT4z2HkUcS!h41%-UfDNMhyj!TewsS5?>R6|MQC2lhcX zI8UUN9!T&hcQ#!L2bR1-K8E7%E*7U7dS=bKOstg1^v)D*JZK@B9kWUEV9wJ3K+1;m zKGpd^#3VmXOEw^xzRo^f_i=rP7PxdGq*wjugmsRlpMtp%Yrw-7C>#hSsFNv88$ZpF zLfzRH%JJ3D7BN1`g~$VvnCLkRC%L7$!v)(!$K zIDO0clefBtRV9`l|9z`;05-_&QI`wJ{LBk5T=t$17m9j+fr?liUnniNd#m~Nl)aY8 z-s?JpF!Q+Bmvll={f(d+!gmPPXeZdMOXX$b1?)nSX7h~hqO!Xs&ir8G^&V$4%fZ77 z7oQ#(VI*?t`#{18u56v52p`%CaB?2Q>gJ#xx}PQ6=J{g5ojIoU)zBV+wfK~Sy=~~> zY?B7C9?^NpL*%H7RdxHL?Tv}-7-ktI{{@`c{Bbh-=te<7zkuR+8$Ru-nC#0faU=97 zgrH1bpW~s3U)Xj|A_e-P&u-P{Q!jMgSGCENk9AgxZbSDmlL9E*X|7VI^O15m=3H2| zSF;{LXUd-&>E98*-maV9AU`W}i z>M+)G4C##itk)FPu*u{ZpuS_s=FYnD?X9T#VldKW%grSokpc-1m*b zh-Yn2e}$L1UDn?25K9qYrbW9)l1;T&UOP9WAGK#le3K^UyK@!gISI+gc2?dODX^`q ztgtwtl(p?kSGeLg(>{S8Y>JDc4i#@kV)WorNIE*tu9$|{2T-kG(EsJTBAffR7FjTA z_PNl?)LPOoZK?4f)Z~>2qd`N*3C}CPF>;+Xq>@AZ*0Nc%gMsja9_<2RgdH!D#Gn~F zXlq_RGI8ZLB0n`Q;iqM8{bh1wdY5(QZ??B#nc0$-TtvBsMLccAs-{lUfl1C%A3Im} zg^?#)NeF(CAb>4Cr^y}P1C0TDr{{lOhSbc!uV!6ApITMy(vtGbz2MbfFE283D3KoF zJ##%^G55QSkP9p~Y;RbG_BUlD#hRPj+ZP`Z=ljD?im(o$6E0tQh9yJn{K~M1Z(az0 z!P`)qjzz@bEwQjZ9s4Tm3Vte-v zK@6x0ewsP_Z93TgI+g?Zh~+VMu4~9J?fY$K$nQ5&2@$CtHv5M+1IQ_MuuY0lu+!n_ zT~zE~$@H$)AvFXj4| zd-tVKE#aDQ%k`YD{mnpZ*O77`31~Sn`}gUdT<;*JhtB)9sF=&GB<(7C3Xe92o9>gd z(T{j^)6p9odYFR7eAD0Ww=5tD=P&AQx*c$Y+U5q@9gmAlBU@fQdv;whH~O$0xlFtO&K1QM0^gfX+&gMk=A(qq{Xw;!n+?Ll(P%SyKR_k&3-HHRtzKJxnsqt}K+uuHWyu zt9ujrIC+~ji^(Jr4X$~Nn)Yi9bTLT9P$>rWD%5xZy>CkIb{CZPa(y^veP_E^5Un!5 z-C7$xf8f4Z0rD`+kBltFL)EA<;v`1S9J+B$HXUJXozyu_D@TNtT$e`8P`# zfRB?Rki<&UruWe=!)(r_s*gu_=LzUxD6a@cG0Z{03QFojn3yNf9k=f$k=7YY>6vrl zYBuO^w+s=j)Cr9+Fk;J-0&)nyxFxqSwnG{~2RtIvKe5H9JO&2j(FIJ-WuMx)Q;+z4 zP4Ws!@;mZlX{y_eJm6N#mrBHQQ|pgWF4KAIwmPq85Ymq6<7aQ%_qZU9=tJkg=@KB8 zX6!nK zhElrVR))e@X3B&i#wU*p7Z+CrSL1Zd-@H)0Sl$m6;ejDsuhX#(i^M<_-DqFdRbSn< z)5!vyDrRpYj}(qJFa=}uJO2o!lcFE*cJ@>zD3jDLg2JC-4Ky?azH$b|6PtwI*)pg4 za0WR7)hlTV>69Js@bQXXBh2g2b>;7Rg=>^1W~W*M@oCj>mMXM;@TttJEy-Prkg7~I z{lof*un^``DsL#j9}!n*Z@P^<{+t@K$ zRnX(aD~B^$3*NbW)Aa2qsOG7?3;vB6n;sV@=Ba9Z!YgAYuL^=J^s1Z(g|CIi4j>#Z z`IwEZHK^~Rw@mo~e_J8K4U+Yaw!P>|G?E|9=2A=e%*wcsk^z6QEUL8;Jjj@!NSA8K~=4)JeP;ZvWs=zQgT^h5cmDC;E`U} z@U2mjso`byV?`eSms#ue!M^u(64#Z9$B&O$tWT&*p><;~CRg~hIJ$xA7m0xT?zN_d zP(zWli9-l3zH;W!-FAFn=5lcCg7Q{11rOylX>FfvkYz zj^ihXpCP9k@)cTWk-=)KHH1!W-N6$c_$0HTVXN_Ihac6dt>bfbrGOM*b*UbOV|%DbOi+Z|s=^iP65t0bS#L6Y;1=bc~g>=e0OGp7Qx8;1ygJrODIPGLg zZL-f1FcLVGA1xlR)>}0>`0KY{Jz(nQ(_Yj+f;gMYo0!@0Swv?Q23##Sauv5E;bw=F z_%s<7G8}h{vDMtunR%79gV#a&VvbFZU=;2ib2WxIG@++pI`5~!NWE@HS2I1DxNOIR z0IN%BDaO#^$DU|$qz0uf&|Yhe3CpH8uA6D3ChG#@1;*v7buIT3?*<&4EbciL4*>LG z*IteFOY04`_I*wSMDoc(Vo87-o6FHkcvkr$5z22edFPqO8Q77@NuQCIqQJs3+8Hfk zYWbl3%W5e8c3l$tHm!s4-fxfbb=rM2{rQz@eFG~6mS7kOq1*b}p4jty9;w^<;(`Rj z9j>(6tG%cyfXiT}Fk%tKqK+QZKkvdH^>1w!QL+?4ig2$+jisNY^qaOSNI3waxqlb) z6=u(AUd}|15FFwM&W=+R4-X||?9MOz9?}r$(vk>Rn@BZeBiMYrRW*eCsskf`(|!uQ z{Cb`C8r)~X51CWfNk{=4>85k%x=l@SZS^I$B1W$<_F@$T8XOW{4-0tyE}gctizU1*3(%geV7NG zK4mV0i=UJb+ZqgHuKiwQhCof*_81X*W5UYZwg8;F%M;OkG*@NvC4;YPBmViwqT9|~ zl@CzVtF;UVZci~RA^%mnyAYHV*a7pd2#dHQHAeT`BKsyLPN z`$s+naTW;c#qdYo167>~>Q-AlZyVbAaCy}6i4$8K^$S5uW20Z+<-wvGNlSdm(Nh0x zeX1fdLfoE>7-JJn-HfsBL*Eh*G@L=|-uNq6!XnliSZrqJ7E4JYU3(yc*)Q3*PY~J> zdEi*By|2f;svttOgR2#cMDe65 zn%mwHHFo5zy8_f6U<&h^zS5;-eK+Ri<1hVIWh^wh@F#0uU_CF3~~q_<83Q1>BM+r6&$?EgT96B)W7 znWOS!Q#QQTzFJz`6oD#&K2)J}8NDOA7lPl_hb>FO0-Vi3F+315Sk3t4BEM&BPDkNqebD$~ zf7{uyNM`0dViOF96zKgj`y%g@9+yEHiC~D?nH7ddeN~nNEAhADsDyk@rqa^VCqo(x z8us>wZV%?g>U$w$Z1z#1Q!kyG?!BN^n>td~Khbhk$zI?MU6GbKHR&TzEKfEKF$4w+ zXp`UB*jZ@nyCwq7^KkbtB`Oh)*?sv){em=Y4Jq_rJTSrsIO^o&WQ^>`9@ep;p&U9A z_e}*eyQsliH?g8FJt-LErCI5|IMQO)$h8RcL63E#;IiP(7Mwn{pe~v#CB^wxH4vgI z_jZKfSfm9xJ3CvrMGz4lw736l_H|zIqbG(Vuj3aXAhCZ*SeDQM{;fP1{5^4J!l%LV zjbum1aDlHoCwycH_Z~)o@tte`2ENt6#v!8^jLmh)stbSL^tM*ER?BFS+8bD2ThEA4 z#<|1U_&qT~zfx*=;bIZ`^m5JBR@(+JkiVw>f8bEXZ8E7K4&-a`emTT@ETi{Izrp;b z@Ydc`A2;~l>dM5`~MjW{-*$u*b%hH>XyaJ=Pi`K5cbC(=jZfyHGZ^NzT)zi z&&##~O#zG05P79cy3lMoJFVv#qCiX1WYK1X_l>Ej(#xP~`S2;}r+V-z^0sglEqobh(tvG%bn@otyOS2s&}QE(=8!5$T}nA|_0kI}@Mx#ioiX-l*SsQ?Xw8 z@@WlRicm=AshUm39b;eXOL;`b@#y+m9RJVZ)MFNP4noZDO%WMte}8{&YbF5%Za^7@ z$j+=Umom@K&kK?%e|%@v{D(oFCT4Sc8@9WvkqOkKj!8&BB#!b#=1<*Qj_z>L7M5-P zd(8CrpD~kk7&;BYc<|+J7WTOQuZb99VPgczV`UcF#GMVA!*)QnUtEsDrCu;TvgCl8 z&uaDGBC5Tk>LrjUUi>4gg5Yz+7x^FmN7?*!X`%cnHX(uM`(IHztt=geIQcS7txU6A zM)Dx>j&D_Sw)Ic9EfASB`MhG$Az3Y9`MhXs)m^QP&!0bsg@sMI;^Dn}N;uej&CSdd zEz^9u0)I6(GF$z_^SI)_1>M0DwBgXd2qug_Ei&XGZ*(QLmxTdbYIz6jnIz(tbPlFEkvR5(1JO3k z5e&a~cQwl(=Bg;CHOjj%Oz`B@n zdMM4WT$$iFd@=I6<1Lo4|6@pcu#=>x+1Y|tmYSx6F4+CgBT7AzhN1Bo6?iSkX?dFE}$Kz~XHyEv6zVwbD#ly=xAo_t#+1$Y5dDAls5)>wF_uo9=6+0MiXIA2<#)KXyUcc%L%r?*bY8b8Z z^ar-S7cCK&Do(&fH5ml0i%G$CUuU(AS(kyzm302R}zkr-&D+w8|dW#90 zky~>-RZZNisHh1;g*~?HuEf58AD5P-JnYuj zt~m?L4;H7mn!vst@CJK;kYW?BwnCEN?o`Jezmn^8@vEtu?^hke+KE2i2jyxBIJ|bf zSThVpN(YJRFo%iZ)-=KU$*J3eI<{sJPVyDw!E6C!9=2U0T8sc zwLE2$_h_oJH)VhVc^bc-pP%Iv7{7Kjr4$Tg?nLI0q$ zdajuPcq>ux#%9;dpZIrPWPGb4f1UfpJqKZNq=lR;slXd+=FfgP4x>W~p5FBKm(VLg z-B}(PB+EBustyoQaP9S+z#37#eiw+8sCAj0N~vJ6vHZ|;<6xPCCzi`vH!DOefUZ?H zs;kQ^gge7T!)>Bsyf|QF^X81~HvIiU`%fxmA!m4ygrY@TJuuJ-RS2=_H9h|Mq~v)$ zF!`Lu`SnHzE-W8#aDz(`_-`@H^hY z^Mv#;2?8-mr>4-Z#<@aS1>Mb7kZap~Y6E)ZvDs1-*Tt6g`FY#9~A4W)BK|x+X zN7QzU%0{)MENWyaeos&=JDdF=kw?O~!SY3QgyNlDN#@v;F$Pm(AcU{)@x3cZ>9dP7 zPAU^u=qR{`;{^}Tb1jW&nKdRSLYPJKTmO}GuLf56M* z%JrLndQL$?+VgU)G!l-c5P|KBoW(1nx4`6;a`VJp z45PqwgqGPh(&h9%R5bCrxuCsek-Eb_8gs@#Lp^pI=4*8CsmjgH9$xg)Iv6Y$`M?f| zEjjqcC=luZ--M$Kmrn`uZx2p5`jN6u<*YC;wF;FEBRG4esruXa>!k2;Sf5n-D#bJg za-&_bSnbA2{_pWcqupb4v~a-|JH-Rxe8x74+tGZU|4qQf+0}Lvx8+2x)vs3m&D9*vI*Btlk}mHz z*E|%t7^Tu%o2}>rt+V1AZhQQ#Q#t$g{lV(Y7O>-jzctl2Uz^2Gb2>g({fAw%)y%|? zb8|bR`I~p_q(q#joD#N^bO5LOVSvk6;)y}$o(JkX5qKF?LHS4mBd+7V5mI}QHIXxL1e7HL|w3;&9xmdePb z=xg&Z%$UBO!|$Q{J!TC0S)R}9G*83Pp0|>sBiBEJnx@e@TJUD4Hzz25#lx2v)!3WBc+Zi}bug@lxtuT=ad+odPC~Vi`Y0XYPSS_dNOD5S#;qrc@vS>m={HEqHwH!( zw*xO|`Mz$@fBKn@60SC|$q8MeYRo_H&z^pb()K)pCSKTIDe0tUyF%nU zI{FkITm>`&@!04uHcKm}ED3R3CStsw>HnPR?MPLVoMB|yCF@Xr}FX{22FG z)0NnLoN#w zqo}itBU#juScg7_i7rEpkA>2dq1gP+N7r8>sp8>VtWAyAkq8PMG2l8qe4dSBO4&YzG3IB;^)(JA&-#;=eltjR-{kC>A@3{ z3TUCcEmsY_({cjYTY}|6-@BE4HzpPUS^y;7di$-LHgJa+6D|<&z0w-DM>Ut!p#Czn zv)s@Giw%e^FQe@0wLXCnf=T}Q)6TsO0gsPn<~P^8FaPQx{3tTe-@)irXL13aQ?|`QBcrAIqqQ#10{bpK zP~yC2hw8>EW zM~$=S-JxB}@yCzh*QSJFqHd9*A~^y!j{_J?VoIG!`i@*t;UOh#C>mBT^q?nQ6I2~_ zHZz#6BO;AE684$ygWClem3ETS)2-j}e>wy~RQPuquvmq*Zn@EljV&w~J~D(dwA28W ztJDo5k3pB-q2J%wy!7qIc)JSc)#UmeFDQV`VLw=1)~qBreSv91L}u#bx7-%P^y+vFI0QP z#a4}JKhn{FaC`BpQy6`r*ZHp6q5uw|Tb=#JqJr?`tG#^%YFnsBUpo)vONL^oGt&0F zT78KO*PFYE5Byi1Kjj2GL?o3T>e^f$Q#G`%>ykOqvDiV)t{rzvnFsF}`J`rY7!%&9 z26Y_l4PwD#h{MPo^lDwsvShNisDfp9|GtNifIji9PE5LmfkHHnHRIcCX zc^4!Y+3(o;fH6LV1Vzfqa@klGa1xvsY&S|h5#Lf7VsoCoS5&ssyWHDn6sopV{ORxT zBj=YQY9Ayog7%#Rea;yUD+#~*<%&&xQg{*z(AW9&sBW-+T&Tt6)c#PUz!ldpLP+9{ z(;i!Qk?BCGUW2*xZ?2rn=rp)b`L|Ev)$L5scD$YM?poX(g13bVb%x9l$hhs6oxh2w z^TybfB010Fa7jz|(Cj8$h$`iM+mXZflIcP-;PFh_!VG|2^xKc4K!^&1HjTag#?+cr zit>tDQ{c;+moGK^9)x+OqDTy{mF<5_P%HBbdU+48;!2Izs4ZUUtMR{bPi|G@O|o40 z@B?7FC4Jjhg|xt*Z>wABbmu>m8gJtJnp5%{ok8(%pn$_?<`rtT&4+L`EOlZb2it9P z=9E_pdnzR9am^w7bDbAgiuVtsZvcQs%O4X`3h6Y0CVGjuuh{ruJNL-D%;t(m#N#by ziOp|Qdfp0nrHCx32(nD*=MMEne>^t&`;3M9g@TM85)1Rl*yx}Zwmh_Cd*h4mSi)yR z&&Ara?vqu|3igkQi@FON2oF7MK^>c{)pX@tgn)&}sNsX}B{V_9A89+>vY#J(Qz^H7 zC`=g|U$W2t0Ph>#6`5{VJfD!ZAk+PHB?-EHNC>hj3aaNK0j&6?0bEx4!}-c+!>!uo zj-p_PCMGD`Uty6}6;e z=C>!!*A?KF3T)LY}uOd12lo*W+;For=ee0kqFwMA^W!T-R$1G zRYUhX^KAJKegl(l*5f!?V@c5_-}s2ctOHceId|xPBoVHH3Fmp<^2|)A~Y9OIgpAMN#P& z|J7&_OjXN`IMsqPcn#ehfogXpWdAKs>*=$A*PV%_Cu8fJ4siU|JS^u$7PIOI{qu;C z=H}BA7=&d6nx6Knf<@AM0h*;EEv-i;U4!Bh8DMMCa?TFA7r)8y z>?QKZfWH@*Yy>>?6`HXG49Zj>`YbObtkgDJJgI6wZN3%HwRqeIbXyF>Zb_4~C={0x z>uoX5J%pL{Clnn}2E%81aF%WJfGmTz>~CpYqwT zZ0+q%vS;~i6v8naDSuA=4k|xMe!ge>s<^lU{A}s$V5F4K$=e<1n!`9T=TbPE3bflfx zn8n%6erGBPq20N$^vlIu*DI@%g;sfAMPgmu_g{l;iqr&Gh=guHv;FiwJ{a`E8LSE; z^y*PqKruBC=4uxK=YCwYYNm;?RW@+yO&)3uZClX(bnB3o{fbu<>nARbzg4JTsMF^z zJF`q0C1$dcIL3G}lOfy=7r)XzGIbAhGS_AmypGVsFxg$WM$sBxtjJFxymNPrgul@)ySyK+eMv@UvMjQgEcHZ99Lx{k6fe)ZP@Z`4E`G?K0Cb zpju-(KSnO3#5}>q$yt4dQ9007x!#Txu;4$9fjz}3opg4-7X%vv25xbeKNq_syi2fa z>}bHD!9!L~hKw%<(vEmK-gT~Cm+93Xwk4VnZ`cHFzL!rc{tGY{UIh*>{q%mx!_6e{ z$I3+KynDZ39%)YxxN~1CGplsC+-5d(Nfmj$(!uq{kyF&FD-ngpav;Y}t$-BIl}L!Q zQ%dr!)MZ)P+4iCP=8DLkRso}0Z~GCL(tt zVtH$1|LX;us!TUIEj9lWpt4`cdY2fo4Yd~)y{YDF?&c+Z4J;PAzy*r2MSkPC>P`i z;A|6~2b{HoI{q!MoIlPgs}wJnrbk3&ExNZ|Mtz;mNv1=rdigdA+~ZH)%Az! zZd@5H+g~zXvFsNmRDKaqb;wuC^FWGa;%42ssX}9#zeFIE+a1BC@65lQFi&bcXItf} zZYZgcNS6|xg(Ea^6vO&$daD+Ygoyj30lrg%qhP7EShq6=4cWNhufud$sW;0BekpKC+?&5%b$Ves33b zR-g@AOuXT!rr$kjn{&#{p%npZLD6et7*W!%Pf9Jd1Cy-fDRT{8N4^2C&JVdhSYOPm z^C{?$qzX1Ye7-!CnTz-J#V=x2MLd%W?dvitaT%|O98U2Nop;fG%*0yvvtY!13Hmd68HXOP5nmu&*@nwOL5e!v!l|CI-xOv zQV$7-%e*F&f+J7ekC!kWYHQiMg<#o{WU<#5LDi|Lk0O(m2lv+KEC>8a9d5tg3jp*@ z6RCpFe&i#-T?yMNXBFnvvJr)={CSjHd}u-DnS-s7-*RnFq<{Rix8A}^#XBJnRV{K8 zGT_>tPUAIC;Rv|NasI7qNE9hxltu5o*DAbqQlNgB`-rWjBt-Z{rFkVrDv}MlgPlHz zwM!VnCtyFgPdo}%BAw_S>0tiU-E=%vELG(u1y>Bv4L zjDOB}(?71?fcj`Hh=lG;5%CBmb( z1zViiU55tVP#rE0tgJ-y;K&(Eo5e5gzQ+0|qO1Lwqr|fr@ z+%NmO=jqJ0FFz(|c1)MdYq(W&5Ey6r?q;85km#~si~$PB^YVlRn|yqh=Cy9^>#T34 zOLDHR_eaEGe}c)e8clZJzyEsdu&ZjSKYy-u-nqpRjSW{ux~Tq^P|~{biRn^bd1^st40t$+Wbe?eq;TqNEXmu>f)k#9|`_t zDqndN?{52Wk(Y~?Bu1Hozj9-;gaVm;3O^u$())gcj4V4+*x(@J(~f6X91ih1y&zGh zcazOpV89v+6-uqkcmXQ2Vr!+<$^?}Z1y#Yt)ubXHuk$G=?8h2%Se=3OrsTGPfuN_D zYI`OW^h);_^~;tpZ>8;F@2hD~$w&vYYfj&R&N8j)8=6~nxL&A^}q7i@z9H(bzUL;;x+h3+Oq>c299STB!4qb1=1hLFc@q`$%BxtT1`re6=!0 zl_Rsmo8&p)o}nhf-OX{qg9It67?N zeKL-wFdgcXt2P9_Eyy|csAqoVQq@`m>qp01o#!MceXy}H(p!?6eaU~-(W<5NyiGb| z-(WD)b*v2|FT~A&KKJ$NuTtxoBDKk0Y%1lf{nf!MLjK3yB0Ct*0r*1Kjual?cX~UY zav zb+)%7lUp`t&K3m*dKvH-Pd&q1=i@)W{XUa&*^Uo^0zgyUlko~kd(%aDjLH`H z6)!%>fv$LEof=6MU;V? zJFCSY*IQ}0g+v-%C?zhsoLCoKKr&hUm{Nw^7oST~d|>t*uSr0>@nyG+I=d%pC{m9!sghd;nFyL>jf!rq0GzG;cJNhTAt#C>0K$WM{9)dmMtQg1WXh0 zI!X6>CqyjcB|y-XpjThu!Fj^|%~5eF;Nf8}_|@D8w%B5~63Iot0iJouP_}#gH176n zuMj)>o61Ma1u(;U_idy2<012>hKln6)zR{dv)O$q8`pGix`s07Fg1to!RsQKUm*h` zF_e}A2Wd7H$uchJg~3wBqAA!!!kK5RqEUx<&z@m-Km9KNGg;NKc$>yD3kHchZeOKz zCIMfK`wcZII2g{ARwAHHxJvjbS#-DBDD9Wf&CJZs=5F7XqJXRIp+%yjG3<0&#;9^x z!j`>4L9P^^v?WT7~(292>>@H{AzSTav`HWKdED`Z2-uP*c=f@K| zRea&W=NRl_NU`iULqd}@4hge&9+u!sz?&&h#374)U8-4u7Blowb#`TbR6RjrfTO&( zmkDG!?`7#lD=2_li>}5ZB2FOuD~;Wb$4bP+`qkZ9)YpmbWsZEZYBIhf3pej}X0yHX zb%lC4-E-h~+(JXr2j{75m}go3=tEDAyN{2?%H-rpNA;i;iAe0e!!Ldm;1pQeG^2`^(&k1@KQxnFL3el*`~DSW`qTe}$<~#C|Q3>v8wFR$G%Fll^kM!ZZpC z5zz-p;#iu^nz=6~>j2P5guP7{b>L_d+-+(}k0l`I)yrgDx1u66Lm{v99`^eBD(tiI zq5RhqH5{G?Wo$J`c1aYfi3&j*p0 z(ywuQI4)3~7zJCt|931#Mk^t*B#x#MgQRu&vxf3zk0FQsaC^rjQqO#N*-AekLa}pg-o0|sG@!Z zkXBH{3Z6`rGa_@BPj5s;PF6@5YnIlNb$SPtnpA^o>eIV#fJ(=4vW+HQe>D<81 z%~@ej#n*6_XD69Sy>hNn{`az53lcs2Ca)++SooV2ra@xr_lGZ-(1D?~)#{zH!TOlq zdRN>+_R-Od7Rns>QH<|*9MwSV&9lbB9*+asi=yxu$V-ix9_pB_mD*hafT;=NFzpPd z?y2Q=n8^A>SXvm`yA1jzPq;8BZgX*CwtK4g^Ob~Y4m9=J>GoZIWQyOGhT+;KEcC~U4-w2z|1t~Q0Z#sGy|Mpc3vpp?2-5mxa$y=m zl&3^J!uqEM@Mhl|sZ`CC^|#O0^TT)&OH^i$TD!g4F3;tBMbf!8k28q%Z-IoPp%Yu3 zv3c!&jcxNyX8#9-q`rJN-2M!S-*ZeOn_R;<72IO_X>lsi>lR zl!fLEZS7=YzC?h~37A1G`|(wB!mLiT>~aLXJZlGX#BtAyLXolHK`4n#AhF~ zqySmxyQ`!PBVG~qI+Z3@K5=r8b}K)`zyViBk9gkXu631BYQ9yiLVl;&XGsj=1VZ5% zb!$;t;Ql{u0f3i?zuVAjuv+Pdjz6O{r>pps|9mil9d=j|;5zF`;^>P|q?KCa5 zraCmO{y|x|noqddJVf*G+fwH=D*xSHvXyhhrmVwJGc~5ufPmMB>HPBX9vyUY;xijv&1& zNC0U{Z$jXLfOH55p-Tzn0EaGwE}$UAAOg}mCQ3`_pweq-p@!azL|UlQZai~;#Qm~A ztl4Ykowa86%$~KLx0L3KR}vFzK8b36j6|XCjI96BrEjBJ=+CZQL`SKW5BI%!jT^@! z@u%U}jl+AIolj%yt2<_mOawm!zoz(I($%v-KUKAEG42j|YQJ2SadFM3sVPS_j??aw z@V(=Jzm{mNb(8Sv7q1I+2y~*jQD}%Hzefrd*>a6QJ!ourxpB4RY62sJDNvbs&N)oD zEqQF-oBVFVpt860mPb*>kAAfx8aV1@3&d6|93c{+E_+oQ1^VZ*!}Eh+EV=kl&vmHz zeDFWSWssVPjgav{=T)}pkwv-f&JzcrwCk`swP@+jAUgJZ-4UGZNp7)P*#4BZxwMC# zO=q+%*O10=$QHIHtz>#+DX+jj|8|Xtz$$HJFo;X`v~@<|g_(%524&67LHMuv?H49c zlAeRC=!f`wC#I?zk5s{AO!)iMV*ZBAwaiAJ3L8MC{e`^l=CK-c-a_%MoCt6-nA{3s zXGBj9W_F^#LzTv>2n4A$5DI-aCNT1+w3#Qm#76YR?vG+MM0c!3{u_9N|OOh|0AjVd^gVLLUm`MtgH z{9wi~oYLC)&g-*F3%P|U=>u&=TSs6H<_n8Y!VAji3lS*@6QjmM&D$%Tuz7HoLXA?P$FK7Mi`D+SH7jSpGk}4jULXJE4pIppbRZ@CSf7S$G*H(Ds zX(i{q*4dS(qpa^wsB`;fQdra9p`Xql94`CCZu(@vf|af;z4!ofdEOn=hETa)D!P!9 zU$JtX66|p?H5_MNC}I%mdX1E8NZ~H7lG!WM?%B@TFp`9XpnxF zilX5PyRt5x|{OkyJ#1yb5T5+gBfoX8f& z10+a8$@c}O@J12Sys=IugnGx0h&hc%Y+)Bc9?v%&HAn^SduQM;&6SHOW|H zPW*4nE9H_JDE!fw9$%;(i2?nUAtn5iH? z+?;jfo?QEldKNQ3`xA7@z_sV7Xq~oomGd>q-ZGp99VyZ-g9VYIz6d@!vx?~rfx1PH zg$GoyA+-+l-~@wtk2vF!#n0wv7VTz6D+x5TPjEb_OL0N&w~Kb2E{*I#Ih*SWQ@!dO zMM_c}*ZWBQc7%aWOIed1-BK%}UpZ8!-t27iv1Mxjj5Og%1Wo&?Y=S((QGLEmrAAil zk?`r}48IMUi7M*89D62mW%13(XTJ{tY1Ya?GC!I$+l}*9e>M+0MEYpL(#_G$=x@z} zj(;hl{BRA+-yTATX~JYJKER4KHPG&e?T5D$njB zq-zQqLe>S@wTD}Zf~iKEFFs8nC(MF9Ao+350Jhj!mTt__Kp_g@sVwZgjXX)urahdg zaYf(gCFZ~vA&<07J?5;9X#99Do=Xm?T;`M)3vT1j#{C3@w&8JJ)6Rs^-_Uv;juNuh zF)#D;Y6|eR$a!R=n4QjaL5lbO4X^Dn{~R4nxcMdl zHHbvT*SlP%b+jWHnRYI13dCpuffiYbxGW6Yk_Pnj? zTC9>j&be^a%$P)_x-0)EZ5wRFUAX9 z4V7Yd?Ryv3B=3fv%bq6_38%R-ELjrDM*o_ z^%x7dU-WDN%98*aTtwl_N&*eN;2&>Up2;WzziYuXkHTPFcruV8LcKk8r-{v{!NUYu zsqF;$JGjz!%VxFkJp*&4!yp_8~iIOiQAtjqhB0)Xq3LfKXj zlqAuGd&9B`G%{}nQye5%<7b+X8At;G<7unxv{xniHjz4X2|_ZkmG*2lS(5tT5VYtD zOKrK_cP8Ltj4R;11vaS%O16ot;k3q={bjnbUN1%+N63hwWG*i*+%?EsAIBYU!~51H zFBwinH=Yn5EUhO)A0xB@qk#JZT1JGimRSS#-%O>mjZL9(zWiJ2e~qtY%LSDqHI>|| zl$E{pY@dzy$%fnr=8-F1;_OpEL?;+S5OrSOTwci%!{J?brsW7ugG3#z<^gf)5!%O} z?DUBM7HZ5m zIhqEg(*@e-wK_)16R|u-+Iq%pZQV-astl-{)eZ9956dcOwL<(YAiX+KlK+}v&n)UN z@QNB}R_E(iO)MbWpE$rU>Q6QRbi42mpChRHuhk7du|q^WiENa30#fh)>)v6Vo_A1!9+U~(0f!Z4S>J@5sQU3*B>fl`f literal 0 HcmV?d00001 From f567df9bfc1faeca7e6e059aac7f68bd9b82ef76 Mon Sep 17 00:00:00 2001 From: janaobsteter Date: Wed, 17 Dec 2025 11:36:20 +0100 Subject: [PATCH 42/42] Last edits regarding sampling functions --> I've squished them all into nCaste --- R/Class-Colony.R | 3 +- R/Class-SimParamBee.R | 582 +++++++------------ R/Functions_L0_auxilary.R | 35 +- R/Functions_L1_Pop.R | 4 - R/Functions_L2_Colony.R | 6 +- tests/testthat/test-L0_auxiliary_functions.R | 28 + vignettes/H_Parallelisation.Rmd | 32 +- 7 files changed, 275 insertions(+), 415 deletions(-) diff --git a/R/Class-Colony.R b/R/Class-Colony.R index 7bdd2595..d5fcff2b 100644 --- a/R/Class-Colony.R +++ b/R/Class-Colony.R @@ -94,7 +94,8 @@ setClassUnion("ColonyOrNULL", c("Colony", "NULL")) setValidity(Class = "Colony", method = function(object) { errors <- character() - if ((ifelse(test = !is.null(slot(object, name = "queen")), yes = nInd(slot(object, name = "queen")), no = 0)) > 1) { #Don't use nQueen because of the SP problem + test <- !is.null(slot(object, name = "queen")) + if ((ifelse(test, yes = nInd(slot(object, name = "queen")), no = 0)) > 1) { #Don't use nQueen because of the SP problem errors <- c(errors, "There can be only one queen per colony!") } if (length(errors) == 0) { diff --git a/R/Class-SimParamBee.R b/R/Class-SimParamBee.R index 3e99a4fc..762541b5 100644 --- a/R/Class-SimParamBee.R +++ b/R/Class-SimParamBee.R @@ -670,16 +670,15 @@ isSimParamBee <- function(x) { # nFunctions ---- -#' @rdname nWorkersFun -#' @title Sample a number of workers +#' @rdname nCasteFun +#' @title Sample a number of caste members (workers, drones, virgin queens) #' -#' @description Sample a number of workers - used when \code{nInd = NULL} -#' (see \code{\link[SIMplyBee]{SimParamBee}$nWorkers}). +#' @description Sample a number of caste member - used when \code{nInd = NULL} #' #' This is just an example. You can provide your own functions that satisfy #' your needs! #' -#' @param colony \code{\link[SIMplyBee]{Colony-class}} +#' @param x \code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}} #' @param n integer, number of samples #' @param average numeric, average number of workers #' @param lowerLimit numeric, returned numbers will be above this value @@ -695,35 +694,35 @@ isSimParamBee <- function(x) { #' @param simParamBee \code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters #' @param ... other arguments of \code{\link[SIMplyBee]{mapCasteToColonyPheno}} #' -#' @details \code{nWorkersPoisson} samples from a Poisson distribution with a -#' given average, which can return a value 0. \code{nDronesTruncPoisson} +#' @details \code{nCastePoisson} samples from a Poisson distribution with a +#' given average, which can return a value 0. \code{nCasteTruncPoisson} #' samples from a zero truncated Poisson distribution. #' -#' \code{nWorkersColonyPhenotype} returns a number (above \code{lowerLimit}) +#' \code{nCasteColonyPhenotype} returns a number (above \code{lowerLimit}) #' as a function of colony phenotype, say queen's fecundity. Colony phenotype #' is provided by \code{\link[SIMplyBee]{mapCasteToColonyPheno}}. You need to set up #' traits influencing the colony phenotype and their parameters (mean and #' variances) via \code{\link[SIMplyBee]{SimParamBee}} (see examples). #' -#' @seealso \code{\link[SIMplyBee]{SimParamBee}} field \code{nWorkers} and +#' @seealso \code{\link[SIMplyBee]{SimParamBee}} field \code{nWorkers}, \code{nDrones} and #' \code{vignette(topic = "QuantitativeGenetics", package = "SIMplyBee")} #' -#' @return numeric, number of workers +#' @return numeric, number of caste members #' #' @examples -#' nWorkersPoisson() -#' nWorkersPoisson() -#' n <- nWorkersPoisson(n = 1000) +#' nCastePoisson() +#' nCastePoisson() +#' n <- nCastePoisson(n = 1000) #' hist(n, breaks = seq(from = min(n), to = max(n)), xlim = c(0, 200)) #' table(n) #' -#' nWorkersTruncPoisson() -#' nWorkersTruncPoisson() -#' n <- nWorkersTruncPoisson(n = 1000) +#' nCasteTruncPoisson() +#' nCasteTruncPoisson() +#' n <- nCasteTruncPoisson(n = 1000) #' hist(n, breaks = seq(from = min(n), to = max(n)), xlim = c(0, 200)) #' table(n) #' -#' # Example for nWorkersColonyPhenotype() +#' # Example for nCasteColonyPhenotype() #' founderGenomes <- quickHaplo(nInd = 3, nChr = 1, segSites = 100) #' SP <- SimParamBee$new(founderGenomes) #' \dontshow{SP$nThreads = 1L} @@ -740,327 +739,129 @@ isSimParamBee <- function(x) { #' colony2 <- cross(colony2, drones = droneGroups[[2]]) #' colony1@queen@pheno #' colony2@queen@pheno -#' createWorkers(colony1, nInd = nWorkersColonyPhenotype) -#' createWorkers(colony2, nInd = nWorkersColonyPhenotype) +#' createWorkers(colony1, nInd = nCasteColonyPhenotype) +#' createWorkers(colony2, nInd = nCasteColonyPhenotype) #' @export -nWorkersPoisson <- function(colony, n = 1, average = 100) { +nCastePoisson <- function(x, n = 1, average = 100) { + # We keep the x because for nCasteColonyPhenotype we need colony/multicolony access + # These are used inside other functions when these n functions are called + if (isColony(x)) { + n <- 1 + } else if (isMultiColony(x)) { + n <- nColonies(x) + } return(rpois(n = n, lambda = average)) } -#' @describeIn nWorkersFun Sample a non-zero number of workers +#' @describeIn nCastePoisson #' @export -nWorkersTruncPoisson <- function(colony, n = 1, average = 100, lowerLimit = 0) { - return(extraDistr::rtpois(n = n, lambda = average, a = lowerLimit)) +nVirginQueensPoisson <- function(x, n = 1, average = 10) { + nCastePoisson(x = x, n = n, average = average) +} +#' @describeIn nCastePoisson +#' @export +nFathersPoisson <- function(x, n = 1, average = 15) { + nCastePoisson(x = x, n = n, average = average) +} +#' @describeIn nCastePoisson +#' @export +nWorkersPoisson <- function(x, n = 1, average = 100) { + nCastePoisson(x = x, n = n, average = average) +} +#' @describeIn nCastePoisson +#' @export +nDronesPoisson <- function(x, n = 1, average = 100) { + nCastePoisson(x = x, n = n, average = average) } -#' @describeIn nWorkersFun Sample a non-zero number of workers based on -#' colony phenotype, say queen's fecundity +#' @describeIn nCasteFun Sample a non-zero number of caste individuals #' @export -nWorkersColonyPhenotype <- function(colony, queenTrait = 1, workersTrait = NULL, - checkProduction = FALSE, lowerLimit = 0, - simParamBee = NULL, - ...) { - if (is.null(simParamBee)) { - simParamBee <- get(x = "SP", envir = .GlobalEnv) - } - ret <- round(mapCasteToColonyPheno( - colony = colony, - queenTrait = queenTrait, - workersTrait = workersTrait, - checkProduction = checkProduction, - simParamBee = simParamBee, - ... - )) - if (ret < (lowerLimit + 1)) { - ret <- lowerLimit + 1 +nCasteTruncPoisson <- function(x, n = 1, average = 100, lowerLimit = 0) { + if (isColony(x)) { + n <- 1 + } else if (isMultiColony(x)) { + n <- nColonies(x) } - return(ret) + return(extraDistr::rtpois(n = n, lambda = average, a = lowerLimit)) } -#' @rdname nDronesFun -#' @title Sample a number of drones -#' -#' @description Sample a number of drones - used when \code{nDrones = NULL} -#' (see \code{\link[SIMplyBee]{SimParamBee}$nDrones}). -#' -#' This is just an example. You can provide your own functions that satisfy -#' your needs! -#' -#' @param x \code{\link[AlphaSimR]{Pop-class}} or \code{\link[SIMplyBee]{Colony-class}} -#' @param n integer, number of samples -#' @param average numeric, average number of drones -#' @param lowerLimit numeric, returned numbers will be above this value -#' @param queenTrait numeric (column position) or character (column name), trait -#' that represents queen's effect on the colony phenotype (defined in -#' \code{\link[SIMplyBee]{SimParamBee}} - see examples); if \code{0} then this effect is 0 -#' @param workersTrait numeric (column position) or character (column name), trait -#' that represents workers's effect on the colony phenotype (defined in -#' \code{\link[SIMplyBee]{SimParamBee}} - see examples); if \code{0} then this effect is 0 -#' @param checkProduction logical, does the phenotype depend on the production -#' status of colony; if yes and production is not \code{TRUE}, the result is -#' above \code{lowerLimit} -#' @param simParamBee \code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters -#' @param ... other arguments of \code{\link[SIMplyBee]{mapCasteToColonyPheno}} -#' -#' @details \code{nDronesPoisson} samples from a Poisson distribution with a -#' given average, which can return a value 0. -#' -#' \code{nDronesTruncPoisson} samples from a zero truncated Poisson -#' distribution. -#' -#' \code{nDronesColonyPhenotype} returns a number (above \code{lowerLimit}) as -#' a function of colony phenotype, say queen's fecundity. Colony phenotype is -#' provided by \code{\link[SIMplyBee]{mapCasteToColonyPheno}}. You need to set up -#' traits influencing the colony phenotype and their parameters (mean and -#' variances) via \code{\link[SIMplyBee]{SimParamBee}} (see examples). -#' -#' When \code{x} is \code{\link[AlphaSimR]{Pop-class}}, only \code{workersTrait} is not -#' used, that is, only \code{queenTrait} is used. -#' -#' @seealso \code{\link[SIMplyBee]{SimParamBee}} field \code{nDrones} and -#' \code{vignette(topic = "QuantitativeGenetics", package = "SIMplyBee")} -#' -#' @return numeric, number of drones -#' -#' @examples -#' nDronesPoisson() -#' nDronesPoisson() -#' n <- nDronesPoisson(n = 1000) -#' hist(n, breaks = seq(from = min(n), to = max(n)), xlim = c(0, 200)) -#' table(n) -#' -#' nDronesTruncPoisson() -#' nDronesTruncPoisson() -#' n <- nDronesTruncPoisson(n = 1000) -#' hist(n, breaks = seq(from = min(n), to = max(n)), xlim = c(0, 200)) -#' table(n) -#' -#' # Example for nDronesColonyPhenotype() -#' founderGenomes <- quickHaplo(nInd = 3, nChr = 1, segSites = 100) -#' SP <- SimParamBee$new(founderGenomes) -#' \dontshow{SP$nThreads = 1L} -#' average <- 100 -#' h2 <- 0.1 -#' SP$addTraitA(nQtlPerChr = 100, mean = average, var = average * h2) -#' SP$setVarE(varE = average * (1 - h2)) -#' basePop <- createVirginQueens(founderGenomes) -#' drones <- createDrones(x = basePop[1], nInd = 50) -#' droneGroups <- pullDroneGroupsFromDCA(drones, n = 2, nDrones = 15) -#' colony1 <- createColony(x = basePop[2]) -#' colony2 <- createColony(x = basePop[3]) -#' colony1 <- cross(colony1, drones = droneGroups[[1]]) -#' colony2 <- cross(colony2, drones = droneGroups[[2]]) -#' colony1@queen@pheno -#' colony2@queen@pheno -#' createDrones(colony1, nInd = nDronesColonyPhenotype) -#' createDrones(colony2, nInd = nDronesColonyPhenotype) +#' @describeIn nCasteTruncPoisson #' @export -nDronesPoisson <- function(x, n = 1, average = 100) { - return(rpois(n = n, lambda = average)) +nVirginQueensTruncPoisson <- function(x, n = 1, average = 10, lowerLimit = 0) { + nCasteTruncPoisson(x = x, n = n, average = average, lowerLimit = lowerLimit) } - -#' @describeIn nDronesFun Sample a non-zero number of drones +#' @describeIn nCasteTruncPoisson +#' @export +nFathersTruncPoisson <- function(x, n = 1, average = 15, lowerLimit = 0) { + nCasteTruncPoisson(x = x, n = n, average = average, lowerLimit = lowerLimit) +} +#' @describeIn nCasteTruncPoisson +#' @export +nWorkersTruncPoisson <- function(x, n = 1, average = 100, lowerLimit = 0) { + nCasteTruncPoisson(x = x, n = n, average = average, lowerLimit = lowerLimit) +} +#' @describeIn nCasteTruncPoisson #' @export nDronesTruncPoisson <- function(x, n = 1, average = 100, lowerLimit = 0) { - return(extraDistr::rtpois(n = n, lambda = average, a = lowerLimit)) + nCasteTruncPoisson(x = x, n = n, average = average, lowerLimit = lowerLimit) } -#' @describeIn nDronesFun Sample a non-zero number of drones based on +#' @describeIn nCasteFun Sample a non-zero number of caste individuals based on #' colony phenotype, say queen's fecundity #' @export -nDronesColonyPhenotype <- function(x, queenTrait = 1, workersTrait = NULL, - checkProduction = FALSE, lowerLimit = 0, - simParamBee = NULL, - ...) { +nCasteColonyPhenotype <- function(x, queenTrait = 1, workersTrait = NULL, + checkProduction = FALSE, lowerLimit = 0, + simParamBee = NULL, + ...) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } - # This one is special because we cater drone production from base population - # virgin queens and colonies if (isPop(x)) { ret <- round(x@pheno[, queenTrait]) } else { - ret <- round(mapCasteToColonyPheno( - colony = x, + ret <- mapCasteToColonyPheno( + x = x, queenTrait = queenTrait, workersTrait = workersTrait, checkProduction = checkProduction, simParamBee = simParamBee, ... - )) - } - if (ret < (lowerLimit + 1)) { - ret <- lowerLimit + 1 + ) + ret <- sapply(ret, FUN = function(x) round(x)) + test <- ret < (lowerLimit + 1) + if (any(test)) { + ret[test] <- lowerLimit + 1 + } } return(ret) } -#' @rdname nVirginQueensFun -#' @title Sample a number of virgin queens -#' -#' @description Sample a number of virgin queens - used when -#' \code{nFathers = NULL} (see \code{\link[SIMplyBee]{SimParamBee}$nVirginQueens}). -#' -#' This is just an example. You can provide your own functions that satisfy -#' your needs! -#' -#' @param colony \code{\link[SIMplyBee]{Colony-class}} -#' @param n integer, number of samples -#' @param average numeric, average number of virgin queens -#' @param lowerLimit numeric, returned numbers will be above this value -#' @param queenTrait numeric (column position) or character (column name), trait -#' that represents queen's effect on the colony phenotype (defined in -#' \code{\link[SIMplyBee]{SimParamBee}} - see examples); if \code{NULL} then this effect is 0 -#' @param workersTrait numeric (column position) or character (column name), trait -#' that represents workers's effect on the colony phenotype (defined in -#' \code{\link[SIMplyBee]{SimParamBee}} - see examples); if \code{NULL} then this effect is 0 -#' @param checkProduction logical, does the phenotype depend on the production -#' status of colony; if yes and production is not \code{TRUE}, the result is -#' above \code{lowerLimit} -#' @param simParamBee \code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters -#' @param ... other arguments of \code{\link[SIMplyBee]{mapCasteToColonyPheno}} -#' -#' @details \code{nVirginQueensPoisson} samples from a Poisson distribution, -#' which can return a value 0 (that would mean a colony will fail to raise a -#' single virgin queen after the queen swarms or dies). -#' -#' \code{nVirginQueensTruncPoisson} samples from a truncated Poisson -#' distribution (truncated at zero) to avoid failure. -#' -#' \code{nVirginQueensColonyPhenotype} returns a number (above -#' \code{lowerLimit}) as a function of colony phenotype, say swarming -#' tendency. Colony phenotype is provided by -#' \code{\link[SIMplyBee]{mapCasteToColonyPheno}}. You need to set up traits -#' influencing the colony phenotype and their parameters (mean and variances) -#' via \code{\link[SIMplyBee]{SimParamBee}} (see examples). -#' -#' @seealso \code{\link[SIMplyBee]{SimParamBee}} field \code{nVirginQueens} and -#' \code{vignette(topic = "QuantitativeGenetics", package = "SIMplyBee")} -#' -#' @return numeric, number of virgin queens -#' -#' @examples -#' nVirginQueensPoisson() -#' nVirginQueensPoisson() -#' n <- nVirginQueensPoisson(n = 1000) -#' hist(n, breaks = seq(from = min(n), to = max(n)), xlim = c(0, 30)) -#' table(n) -#' -#' nVirginQueensTruncPoisson() -#' nVirginQueensTruncPoisson() -#' n <- nVirginQueensTruncPoisson(n = 1000) -#' hist(n, breaks = seq(from = min(n), to = max(n)), xlim = c(0, 30)) -#' table(n) -#' -#' # Example for nVirginQueensColonyPhenotype() -#' founderGenomes <- quickHaplo(nInd = 3, nChr = 1, segSites = 100) -#' SP <- SimParamBee$new(founderGenomes) -#' \dontshow{SP$nThreads = 1L} -#' # Setting trait scale such that mean is 10 split into queen and workers effects -#' meanP <- c(5, 5 / SP$nWorkers) -#' # setup variances such that the total phenotype variance will match the mean -#' varA <- c(3 / 2, 3 / 2 / SP$nWorkers) -#' corA <- matrix(data = c( -#' 1.0, -0.5, -#' -0.5, 1.0 -#' ), nrow = 2, byrow = TRUE) -#' varE <- c(7 / 2, 7 / 2 / SP$nWorkers) -#' varA / (varA + varE) -#' varP <- varA + varE -#' varP[1] + varP[2] * SP$nWorkers -#' SP$addTraitA(nQtlPerChr = 100, mean = meanP, var = varA, corA = corA) -#' SP$setVarE(varE = varE) -#' basePop <- createVirginQueens(founderGenomes) -#' drones <- createDrones(x = basePop[1], nInd = 50) -#' droneGroups <- pullDroneGroupsFromDCA(drones, n = 2, nDrones = 15) -#' colony1 <- createColony(x = basePop[2]) -#' colony2 <- createColony(x = basePop[3]) -#' colony1 <- cross(colony1, drones = droneGroups[[1]]) -#' colony2 <- cross(colony2, drones = droneGroups[[2]]) -#' colony1 <- buildUp(colony1) -#' colony2 <- buildUp(colony2) -#' nVirginQueensColonyPhenotype(colony1) -#' nVirginQueensColonyPhenotype(colony2) -#' @export -nVirginQueensPoisson <- function(colony, n = 1, average = 10) { - return(rpois(n = n, lambda = average)) -} - -#' @describeIn nVirginQueensFun Sample a non-zero number of virgin queens +#' @describeIn nCasteColonyPhenotype #' @export -nVirginQueensTruncPoisson <- function(colony, n = 1, average = 10, lowerLimit = 0) { - return(extraDistr::rtpois(n = n, lambda = average, a = lowerLimit)) -} - -#' @describeIn nVirginQueensFun Sample a non-zero number of virgin queens -#' based on colony's phenotype, say, swarming tendency -#' @export -nVirginQueensColonyPhenotype <- function(colony, queenTrait = 1, - workersTrait = 2, - checkProduction = FALSE, - lowerLimit = 0, - simParamBee = NULL, - ...) { - if (is.null(simParamBee)) { - simParamBee <- get(x = "SP", envir = .GlobalEnv) - } - ret <- round(mapCasteToColonyPheno( - colony = colony, - queenTrait = queenTrait, - workersTrait = workersTrait, - simParamBee = simParamBee, - ... - )) - if (ret < (lowerLimit + 1)) { - ret <- lowerLimit + 1 - } - return(ret) +nVirginQueensColonyPhenotype <- function(x, queenTrait = 1, workersTrait = NULL, + checkProduction = FALSE, lowerLimit = 0, + simParamBee = NULL, + ...) { + nCasteColonyPhenotype(x = x, queenTrait = queenTrait, workersTrait = workersTrait, + checkProduction = checkProduction, lowerLimit = lowerLimit, + simParamBee = simParamBee, + ...) } - -#' @rdname nFathersFun -#' @title Sample a number of fathers -#' -#' @description Sample a number of fathers - use when \code{nFathers = NULL} -#' (see \code{\link[SIMplyBee]{SimParamBee}$nFathers}). -#' -#' This is just an example. You can provide your own functions that satisfy -#' your needs! -#' -#' @param n integer, number of samples -#' @param average numeric, average number of fathers -#' @param lowerLimit numeric, returned numbers will be above this value -#' -#' @details \code{nFathersPoisson} samples from a Poisson distribution, which -#' can return a value 0 (that would mean a failed queen mating). -#' -#' \code{nFathersTruncPoisson} samples from a truncated Poisson distribution -#' (truncated at zero) to avoid failed matings. -#' -#' @seealso \code{\link[SIMplyBee]{SimParamBee}} field \code{nFathers} -#' -#' @return numeric, number of fathers -#' -#' @examples -#' nFathersPoisson() -#' nFathersPoisson() -#' n <- nFathersPoisson(n = 1000) -#' hist(n, breaks = seq(from = min(n), to = max(n)), xlim = c(0, 40)) -#' table(n) -#' -#' nFathersTruncPoisson() -#' nFathersTruncPoisson() -#' n <- nFathersTruncPoisson(n = 1000) -#' hist(n, breaks = seq(from = min(n), to = max(n)), xlim = c(0, 40)) -#' table(n) +#' @describeIn nCasteColonyPhenotype #' @export -nFathersPoisson <- function(n = 1, average = 15) { - return(rpois(n = n, lambda = average)) +nWorkersColonyPhenotype <- function(x, n = 1, average = 100, lowerLimit = 0) { + nCasteColonyPhenotype(x = x, queenTrait = queenTrait, workersTrait = workersTrait, + checkProduction = checkProduction, lowerLimit = lowerLimit, + simParamBee = simParamBee, + ...) } - -#' @describeIn nFathersFun Sample a non-zero number of fathers +#' @describeIn nCasteColonyPhenotype #' @export -nFathersTruncPoisson <- function(n = 1, average = 15, lowerLimit = 0) { - return(extraDistr::rtpois(n = n, lambda = average, a = lowerLimit)) +nDronesColonyPhenotype <- function(x, n = 1, average = 100, lowerLimit = 0) { + nCasteColonyPhenotype(x = x, queenTrait = queenTrait, workersTrait = workersTrait, + checkProduction = checkProduction, lowerLimit = lowerLimit, + simParamBee = simParamBee, + ...) } # pFunctions ---- @@ -1074,7 +875,7 @@ nFathersTruncPoisson <- function(n = 1, average = 15, lowerLimit = 0) { #' This is just an example. You can provide your own functions that satisfy #' your needs! #' -#' @param colony \code{\link[SIMplyBee]{Colony-class}} +#' @param x \code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}} #' @param n integer, number of samples #' @param min numeric, lower limit for \code{swarmPUnif} #' @param max numeric, upper limit for \code{swarmPUnif} @@ -1097,7 +898,12 @@ nFathersTruncPoisson <- function(n = 1, average = 15, lowerLimit = 0) { #' p <- swarmPUnif(n = 1000) #' hist(p, breaks = seq(from = 0, to = 1, by = 0.01), xlim = c(0, 1)) #' @export -swarmPUnif <- function(colony, n = 1, min = 0.4, max = 0.6) { +swarmPUnif <- function(x, n = 1, min = 0.4, max = 0.6) { + if (isColony(x)) { + n <- 1 + } else if (isMultiColony(x)) { + n <- nColonies(x) + } return(runif(n = n, min = min, max = max)) } @@ -1112,7 +918,7 @@ swarmPUnif <- function(colony, n = 1, min = 0.4, max = 0.6) { #' This is just an example. You can provide your own functions that satisfy #' your needs! #' -#' @param colony \code{\link[SIMplyBee]{Colony-class}} +#' @param x \code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}} #' @param n integer, number of samples #' @param min numeric, lower limit for \code{splitPUnif} #' @param max numeric, upper limit for \code{splitPUnif} @@ -1178,14 +984,24 @@ swarmPUnif <- function(colony, n = 1, min = 0.4, max = 0.6) { #' plot(pKeep ~ nWorkers, ylim = c(0, 1)) #' abline(v = nWorkersFull) #' @export -splitPUnif <- function(colony, n = 1, min = 0.2, max = 0.4) { +splitPUnif <- function(x, n = 1, min = 0.2, max = 0.4) { + if (isColony(x)) { + n <- 1 + } else if (isMultiColony(x)) { + n <- nColonies(x) + } return(runif(n = n, min = min, max = max)) } #' @describeIn splitPFun Sample the split proportion - the proportion of #' removed workers in a managed split based on the colony strength #' @export -splitPColonyStrength <- function(colony, n = 1, nWorkersFull = 100, scale = 1) { +splitPColonyStrength <- function(x, n = 1, nWorkersFull = 100, scale = 1) { + if (isColony(x)) { + n <- 1 + } else if (isMultiColony(x)) { + n <- nColonies(x) + } nW <- nWorkers(colony) pKeep <- rbeta( n = n, @@ -1206,7 +1022,7 @@ splitPColonyStrength <- function(colony, n = 1, nWorkersFull = 100, scale = 1) { #' This is just an example. You can provide your own functions that satisfy #' your needs! #' -#' @param colony \code{\link[SIMplyBee]{Colony-class}} +#' @param x \code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}} #' @param n integer, number of samples #' @param min numeric, lower limit for \code{downsizePUnif} #' @param max numeric, upper limit for \code{downsizePUnif} @@ -1221,7 +1037,12 @@ splitPColonyStrength <- function(colony, n = 1, nWorkersFull = 100, scale = 1) { #' p <- downsizePUnif(n = 1000) #' hist(p, breaks = seq(from = 0, to = 1, by = 0.01), xlim = c(0, 1)) #' @export -downsizePUnif <- function(colony, n = 1, min = 0.8, max = 0.9) { +downsizePUnif <- function(x, n = 1, min = 0.8, max = 0.9) { + if (isColony(x)) { + n <- 1 + } else if (isMultiColony(x)) { + n <- nColonies(x) + } return(runif(n = n, min = min, max = max)) } @@ -1245,7 +1066,7 @@ downsizePUnif <- function(colony, n = 1, min = 0.8, max = 0.9) { #' Note though that you can achieve this impact also via multiple correlated #' traits, such as a queen and a workers trait. #' -#' @param colony \code{\link[SIMplyBee]{Colony-class}} +#' @param x \code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}} #' @param value character, one of \code{pheno} or \code{gv} #' @param queenTrait numeric (column position) or character (column name), #' trait(s) that represents queen's contribution to colony value(s); if @@ -1293,7 +1114,8 @@ downsizePUnif <- function(colony, n = 1, min = 0.8, max = 0.9) { #' \code{\link[SIMplyBee]{calcColonyValue}}. It only works on a single colony - use #' \code{\link[SIMplyBee]{calcColonyValue}} to get Colony or MultiColony values. #' -#' @return numeric matrix with one value or a row of values +#' @return numeric matrix with one value or a row of values when input is \code{\link[SIMplyBee]{Colony-class}} +#' or list of numeric matrices when input is \code{\link[SIMplyBee]{MultiColony-class}} #' #' @examples #' founderGenomes <- quickHaplo(nInd = 5, nChr = 1, segSites = 100) @@ -1347,7 +1169,7 @@ downsizePUnif <- function(colony, n = 1, min = 0.8, max = 0.9) { # https://github.com/HighlanderLab/SIMplyBee/issues/353 # TODO: Develop theory for colony genetic values under non-linearity/non-additivity #403 # https://github.com/HighlanderLab/SIMplyBee/issues/403 -mapCasteToColonyValue <- function(colony, +mapCasteToColonyValue <- function(x, value = "pheno", queenTrait = 1, queenFUN = function(x) x, workersTrait = 2, workersFUN = colSums, @@ -1369,107 +1191,129 @@ mapCasteToColonyValue <- function(colony, if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } - if (is.null(queenTrait)) { - queenEff <- 0 - } else { - if (isQueenPresent(colony)) { - if (value %in% c("pheno", "gv")) { - tmp <- valueFUN(colony@queen)[, queenTrait, drop = FALSE] - } else { # bv, dd, and aa: leaving this in for future use! - tmp <- valueFUN(colony@queen, simParam = simParamBee)[, queenTrait, drop = FALSE] - } - queenEff <- queenFUN(tmp) - } else { + + if (isColony(x)) { + if (is.null(queenTrait)) { queenEff <- 0 - } - } - if (is.null(workersTrait)) { - workersEff <- 0 - } else { - if (nWorkers(colony) != 0) { - if (value %in% c("pheno", "gv")) { - tmp <- valueFUN(colony@workers)[, workersTrait, drop = FALSE] - } else { # bv, dd, and aa - tmp <- valueFUN(colony@workers, simParam = simParamBee)[, workersTrait, drop = FALSE] - } - workersEff <- workersFUN(tmp) } else { - workersEff <- 0 - } - } - if (is.null(dronesTrait)) { - dronesEff <- 0 - } else { - if (nDrones(colony) != 0) { - if (value %in% c("pheno", "gv")) { - tmp <- valueFUN(colony@drones)[, dronesTrait, drop = FALSE] - } else { # bv, dd, and aa - tmp <- valueFUN(colony@drones, simParam = simParamBee)[, dronesTrait, drop = FALSE] + if (isQueenPresent(x)) { + if (value %in% c("pheno", "gv")) { + tmp <- valueFUN(x@queen)[, queenTrait, drop = FALSE] + } else { # bv, dd, and aa: leaving this in for future use! + tmp <- valueFUN(x@queen, simParam = simParamBee)[, queenTrait, drop = FALSE] + } + queenEff <- queenFUN(tmp) + } else { + queenEff <- 0 } - dronesEff <- dronesFUN(tmp) + } + if (is.null(workersTrait)) { + workersEff <- 0 } else { - dronesEff <- 0 + if (nWorkers(x) != 0) { + if (value %in% c("pheno", "gv")) { + tmp <- valueFUN(x@workers)[, workersTrait, drop = FALSE] + } else { # bv, dd, and aa + tmp <- valueFUN(x@workers, simParam = simParamBee)[, workersTrait, drop = FALSE] + } + workersEff <- workersFUN(tmp) + } else { + workersEff <- 0 + } } - } - colonyValue <- combineFUN(q = queenEff, w = workersEff, d = dronesEff) - nColTrt <- length(colonyValue) - colnames(colonyValue) <- traitName - if (any(checkProduction) && !isProductive(colony)) { - if (length(checkProduction) == 1 && nColTrt != 1) { - checkProduction <- rep(checkProduction, times = nColTrt) + if (is.null(dronesTrait)) { + dronesEff <- 0 + } else { + if (nDrones(x) != 0) { + if (value %in% c("pheno", "gv")) { + tmp <- valueFUN(x@drones)[, dronesTrait, drop = FALSE] + } else { # bv, dd, and aa + tmp <- valueFUN(x@drones, simParam = simParamBee)[, dronesTrait, drop = FALSE] + } + dronesEff <- dronesFUN(tmp) + } else { + dronesEff <- 0 + } } - if (length(notProductiveValue) == 1 && nColTrt != 1) { - notProductiveValue <- rep(notProductiveValue, times = nColTrt) + colonyValue <- combineFUN(q = queenEff, w = workersEff, d = dronesEff) + nColTrt <- length(colonyValue) + colnames(colonyValue) <- traitName + if (any(checkProduction) && !isProductive(x)) { + if (length(checkProduction) == 1 && nColTrt != 1) { + checkProduction <- rep(checkProduction, times = nColTrt) + } + if (length(notProductiveValue) == 1 && nColTrt != 1) { + notProductiveValue <- rep(notProductiveValue, times = nColTrt) + } + if (length(checkProduction) != nColTrt) { + stop("Dimension of checkProduction does not match the number of traits from combineFUN()!") + } + if (length(checkProduction) != length(notProductiveValue)) { + stop("Dimensions of checkProduction and notProductiveValue must match!") + } + colonyValue[checkProduction] <- notProductiveValue[checkProduction] } - if (length(checkProduction) != nColTrt) { - stop("Dimension of checkProduction does not match the number of traits from combineFUN()!") + } else if (isMultiColony(x)) { + nCol <- nColonies(x) + if (nCol == 0) { + stop("The Multicolony contains 0 colonies!") } - if (length(checkProduction) != length(notProductiveValue)) { - stop("Dimensions of checkProduction and notProductiveValue must match!") + colonyValue <- vector(mode = "list", length = nCol) + names(colonyValue) <- getId(x) + for (colony in 1:nCol) { + colonyValue[[colony]] <- mapCasteToColonyValue(x[[colony]], + value = value, + queenTrait = queenTrait, queenFUN = queenFUN, + workersTrait = workersTrait, workersFUN = workersFUN, + dronesTrait = dronesTrait, dronesFUN = dronesFUN, + traitName = traitName, + combineFUN = combineFUN, + checkProduction = checkProduction, + notProductiveValue = notProductiveValue, + simParamBee = simParamBee) } - colonyValue[checkProduction] <- notProductiveValue[checkProduction] } return(colonyValue) } #' @describeIn mapCasteToColonyValue Map caste member (individual) phenotype values to a colony phenotype value #' @export -mapCasteToColonyPheno <- function(colony, simParamBee = NULL, ...) { +mapCasteToColonyPheno <- function(x, simParamBee = NULL, ...) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } - mapCasteToColonyValue(colony, value = "pheno", simParamBee = simParamBee, ...) + mapCasteToColonyValue(x, value = "pheno", simParamBee = simParamBee, ...) } #' @describeIn mapCasteToColonyValue Map caste member (individual) genetic values to a colony genetic value #' @export -mapCasteToColonyGv <- function(colony, simParamBee = NULL, ...) { +mapCasteToColonyGv <- function(x, simParamBee = NULL, ...) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } - mapCasteToColonyValue(colony, value = "gv", checkProduction = FALSE, simParamBee = simParamBee, ...) + mapCasteToColonyValue(x, value = "gv", checkProduction = FALSE, simParamBee = simParamBee, ...) } #' @describeIn mapCasteToColonyValue Map caste member (individual) breeding values to a colony breeding value -mapCasteToColonyBv <- function(colony, simParamBee = NULL, ...) { +mapCasteToColonyBv <- function(x, simParamBee = NULL, ...) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } - mapCasteToColonyValue(colony, value = "bv", checkProduction = FALSE, simParamBee = simParamBee, ...) + mapCasteToColonyValue(x, value = "bv", checkProduction = FALSE, simParamBee = simParamBee, ...) } #' @describeIn mapCasteToColonyValue Map caste member (individual) dominance values to a colony dominance value -mapCasteToColonyDd <- function(colony, simParamBee = NULL, ...) { +mapCasteToColonyDd <- function(x, simParamBee = NULL, ...) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } - mapCasteToColonyValue(colony, value = "dd", checkProduction = FALSE, simParamBee = simParamBee, ...) + mapCasteToColonyValue(x, value = "dd", checkProduction = FALSE, simParamBee = simParamBee, ...) } #' @describeIn mapCasteToColonyValue Map caste member (individual) epistasis values to a colony epistasis value -mapCasteToColonyAa <- function(colony, simParamBee = NULL, ...) { +mapCasteToColonyAa <- function(x, simParamBee = NULL, ...) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } - mapCasteToColonyValue(colony, value = "aa", checkProduction = FALSE, simParamBee = simParamBee, ...) + mapCasteToColonyValue(x, value = "aa", checkProduction = FALSE, simParamBee = simParamBee, ...) } diff --git a/R/Functions_L0_auxilary.R b/R/Functions_L0_auxilary.R index e1198751..fbbb20b5 100644 --- a/R/Functions_L0_auxilary.R +++ b/R/Functions_L0_auxilary.R @@ -341,37 +341,6 @@ calcQueensPHomBrood <- function(x, simParamBee = NULL) { return(ret) } - -calcQueensPHomBrood_parallel <- function(x, simParamBee = NULL) { - if (is.null(simParamBee)) { - simParamBee <- get(x = "SP", envir = .GlobalEnv) - } - if (isPop(x)) { - ret <- rep(x = NA, times = nInd(x)) - for (ind in seq_len(nInd(x))) { - - queensCsd <- apply( - X = getCsdAlleles(x[ind], simParamBee = simParamBee), MARGIN = 1, - FUN = function(x) paste0(x, collapse = "") - ) - fathersCsd <- apply( - X = getCsdAlleles(x@misc$fathers[[ind]], simParamBee = simParamBee), MARGIN = 1, - FUN = function(x) paste0(x, collapse = "") - ) - nComb <- length(queensCsd) * length(fathersCsd) - ret[ind] <- sum(fathersCsd %in% queensCsd) / nComb - } - } else if (isColony(x)) { - ret <- calcQueensPHomBrood(x = x@queen) - } else if (isMultiColony(x)) { - ret <- sapply(X = x@colonies, FUN = calcQueensPHomBrood) - names(ret) <- getId(x) - } else { - stop("Argument x must be a Pop, Colony, or MultiColony class object!") - } - return(ret) -} - #' @describeIn calcQueensPHomBrood Expected percentage of csd homozygous brood #' of a queen / colony #' @export @@ -5149,14 +5118,14 @@ calcColonyValue <- function(x, FUN = NULL, simParamBee = NULL, ...) { stop("You must provide FUN or set it in the SimParamBee object!") } if (isColony(x)) { - ret <- FUN(colony = x, ...) + ret <- FUN(x = x, ...) } else if (isMultiColony(x)) { nCol <- nColonies(x) # We could create a matrix output container here, BUT we don't know the output # dimension of FUN() so we create list and row bind the list nodes later ret <- vector(mode = "list", length = nCol) for (colony in seq_len(nCol)) { - ret[[colony]] <- FUN(colony = x[[colony]], ...) + ret[[colony]] <- FUN(x = x[[colony]], ...) } ret <- do.call("rbind", ret) rownames(ret) <- getId(x) diff --git a/R/Functions_L1_Pop.R b/R/Functions_L1_Pop.R index 114c7b26..2503270f 100644 --- a/R/Functions_L1_Pop.R +++ b/R/Functions_L1_Pop.R @@ -3,10 +3,6 @@ utils::globalVariables("colony") utils::globalVariables("i") utils::globalVariables("cl") -# Protect from accidental multicore use -options(mc.cores = 1) -Sys.setenv(OMP_NUM_THREADS = 1) -Sys.setenv(MKL_NUM_THREADS = 1) #' @rdname getCastePop #' @title Access individuals of a caste diff --git a/R/Functions_L2_Colony.R b/R/Functions_L2_Colony.R index 867cbd4c..7320c3f6 100644 --- a/R/Functions_L2_Colony.R +++ b/R/Functions_L2_Colony.R @@ -553,7 +553,7 @@ buildUp <- function(x, nWorkers = NULL, nDrones = NULL, if (isColony(x)) { if (is.function(nWorkers)) { - nWorkers <- nWorkers(colony = x,...) + nWorkers <- nWorkers(x = x,...) } if (hasCollapsed(x)) { stop(paste0("The colony ", getId(x), " collapsed, hence you can not build it up!")) @@ -628,7 +628,7 @@ buildUp <- function(x, nWorkers = NULL, nDrones = NULL, } if (is.function(nWorkers)) { - nWorkers <- nWorkers(colony = x,...) + nWorkers <- nWorkers(x = x,...) } if (new) { @@ -757,7 +757,7 @@ downsize <- function(x, p = NULL, use = "rand", new = FALSE, } if (any(hasCollapsed(x))) { - stop("Some of hte colonies have collapsed, hence you can not downsize them!") + stop("Some of the colonies have collapsed, hence you can not downsize them!") } if (is.null(p)) { p <- simParamBee$downsizeP diff --git a/tests/testthat/test-L0_auxiliary_functions.R b/tests/testthat/test-L0_auxiliary_functions.R index 1c5ffcb0..5b32280a 100644 --- a/tests/testthat/test-L0_auxiliary_functions.R +++ b/tests/testthat/test-L0_auxiliary_functions.R @@ -1101,3 +1101,31 @@ test_that("getIbdHaplo", { apiary <- addVirginQueens(x = apiary, nInd = 2, simParamBee = SP) expect_length(getIbdHaplo(apiary, simParamBee = SP), 2) }) + + +test_that("trackingHomozygotes", { + founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) + SP <- SimParamBee$new(founderGenomes) + SP$nThreads = 1L + SP$setTrackPed(T) + SP$setTrackRec(T) + expect_equal(nrow(SP$pedigree), 0) + expect_equal(length(SP$caste), 0) + expect_equal(length(SP$recHist), 0) + + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) + expect_equal(nrow(SP$pedigree), length(SP$caste)) + expect_equal(nrow(SP$pedigree), length(SP$recHist)) + + drones <- createDrones(x = basePop[1], nInd = 1000, simParamBee = SP) + expect_equal(nrow(SP$pedigree), length(SP$caste)) + expect_equal(nrow(SP$pedigree), length(SP$recHist)) + + fatherGroups <- pullDroneGroupsFromDCA(drones, n = 10, nDrones = 10, simParamBee = SP) + colony <- createColony(x = basePop[1], simParamBee = SP) + colony <- cross(colony, drones = fatherGroups[[1]], simParamBee = SP) + colony <- buildUp(x = colony, nWorkers = 200, nDrones = 50, simParamBee = SP) + + expect_equal(nrow(SP$pedigree), length(SP$caste)) + expect_equal(nrow(SP$pedigree), length(SP$recHist)) +}) diff --git a/vignettes/H_Parallelisation.Rmd b/vignettes/H_Parallelisation.Rmd index f6e4f504..d967704b 100644 --- a/vignettes/H_Parallelisation.Rmd +++ b/vignettes/H_Parallelisation.Rmd @@ -125,16 +125,38 @@ create_bee_colonies() stopImplicitCluster() ``` -Here are the results of running these different options. +Here are the results of running these different options. You can see that the +time can be significantly improved when running on multiple cores. When running +on a single core, setting up the parallelisation cluster via `FORK` or `PSOCK` +actually adds some overhead time. -```{r meanRSS_figure, echo=FALSE, out.width='100%'} -knitr::include_graphics("RSS_mean.png") +```{r meanTime_figure, echo=FALSE, out.width='100%'} +knitr::include_graphics("Time_mean.png") ``` ```{r meanPCPU_figure, echo=FALSE, out.width='100%'} knitr::include_graphics("PCPU_mean.png") ``` -```{r meanTime_figure, echo=FALSE, out.width='100%'} -knitr::include_graphics("Time_mean.png") +```{r meanRSS_figure, echo=FALSE, out.width='100%'} +knitr::include_graphics("RSS_mean.png") ``` + +The functions that are currently explicitily parallelised: + +- L1: cross, pullCasteP, createCastePop + +- L2: supersede, split, swarm, setEvents, combine, setLocation, reQueen, + addCastePop, removeCastePop, resetEvents, collapse + +- L3: createMultiColony + +The following figure shows the benefit of parallelised (p, in blue) vs +sequential/non-parallelised functions (np, in red) when run on a Linux machine +with 16 cores. The figure shows the mean and the standard deviation across 10 +replicates. + +```{r functions_time, echo=FALSE, out.width='100%'} +knitr::include_graphics("Profiling_parallelised_functions_Unix.png") +``` +