From d1939bf5cb669d651006cacf234c75d44d1950cc Mon Sep 17 00:00:00 2001 From: janaobsteter Date: Tue, 8 Apr 2025 16:47:41 +0200 Subject: [PATCH 01/56] 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/56] 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/56] 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/56] 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/56] 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/56] 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/56] 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/56] 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/56] 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/56] 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/56] 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/56] 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/56] 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/56] 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/56] 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/56] 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/56] 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/56] 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/56] 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/56] 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/56] 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/56] 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/56] 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/56] 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/56] .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/56] 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/56] 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/56] 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/56] 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/56] 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/56] 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/56] 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/56] 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/56] 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/56] 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/56] 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/56] 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/56] 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/56] 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/56] 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/56] 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/56] 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") +``` + From ed15b9aeda02464efea5e644152d91d4b1c4cb6b Mon Sep 17 00:00:00 2001 From: janaobsteter Date: Thu, 18 Dec 2025 11:03:07 +0100 Subject: [PATCH 43/56] Switching to future_lapply from foreach --- DESCRIPTION | 2 +- NAMESPACE | 7 +- R/Class-SimParamBee.R | 91 +++++--- R/Functions_L1_Pop.R | 132 +++++------- R/Functions_L2_Colony.R | 79 +++---- R/Functions_L3_Colonies.R | 16 +- R/SIMplyBee.R | 2 +- man/MultiColony-class.Rd | 8 +- man/createMultiColony.Rd | 4 +- man/downsizePFun.Rd | 4 +- man/mapCasteToColonyValue.Rd | 17 +- man/nCasteFun.Rd | 203 ++++++++++++++++++ man/nDronesFun.Rd | 118 ---------- man/nFathersFun.Rd | 56 ----- man/nVirginQueensFun.Rd | 127 ----------- man/nWorkersFun.Rd | 113 ---------- man/splitPFun.Rd | 6 +- man/swarmPFun.Rd | 4 +- tests/testthat/test-L0_auxiliary_functions.R | 4 +- tests/testthat/test-L1_pop_functions.R | 4 +- ...indeer-clipart-cartoon-hd-png-download.png | Bin 0 -> 107612 bytes vignettes/A_Honeybee_biology.Rmd | 4 +- vignettes/Colony_locations.csv | 135 +++++++++--- vignettes/D_Crossing.Rmd | 4 +- vignettes/F2_Variance_calculations.Rmd | 94 +++++--- .../F2_Variance_calculations_functions.Rmd | 190 ++++++++++++++++ vignettes/F_Quantitative_Genetics.Rmd | 22 +- .../Profiling_parallelised_functions_Unix.png | Bin 0 -> 107647 bytes 28 files changed, 770 insertions(+), 676 deletions(-) create mode 100644 man/nCasteFun.Rd delete mode 100644 man/nDronesFun.Rd delete mode 100644 man/nFathersFun.Rd delete mode 100644 man/nVirginQueensFun.Rd delete mode 100644 man/nWorkersFun.Rd create mode 100644 vignettes/582-5827311_reindeer-clipart-cartoon-hd-png-download.png create mode 100644 vignettes/F2_Variance_calculations_functions.Rmd create mode 100644 vignettes/Profiling_parallelised_functions_Unix.png diff --git a/DESCRIPTION b/DESCRIPTION index b2842785..79503518 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 +Imports: methods, R6, stats, utils, extraDistr (>= 1.9.1), RANN, Rcpp (>= 0.12.7), future.apply Depends: R (>= 3.3.0), AlphaSimR (>= 2.0.0) LinkingTo: Rcpp, RcppArmadillo (>= 0.7.500.0.0), BH RoxygenNote: 7.3.2 diff --git a/NAMESPACE b/NAMESPACE index a61e2857..5222f2f6 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -143,6 +143,9 @@ export(mapCasteToColonyGv) export(mapCasteToColonyPheno) export(mapCasteToColonyValue) export(nCaste) +export(nCasteColonyPhenotype) +export(nCastePoisson) +export(nCasteTruncPoisson) export(nColonies) export(nCsdAlleles) export(nDrones) @@ -203,9 +206,7 @@ import(AlphaSimR) import(Rcpp) importFrom(R6,R6Class) importFrom(extraDistr,rtpois) -importFrom(foreach,"%do%") -importFrom(foreach,"%dopar%") -importFrom(foreach,foreach) +importFrom(future.apply,future_lapply) importFrom(methods,"slot<-") importFrom(methods,classLabel) importFrom(methods,is) diff --git a/R/Class-SimParamBee.R b/R/Class-SimParamBee.R index 762541b5..9e7130fc 100644 --- a/R/Class-SimParamBee.R +++ b/R/Class-SimParamBee.R @@ -742,41 +742,51 @@ isSimParamBee <- function(x) { #' createWorkers(colony1, nInd = nCasteColonyPhenotype) #' createWorkers(colony2, nInd = nCasteColonyPhenotype) #' @export -nCastePoisson <- function(x, n = 1, average = 100) { +nCastePoisson <- function(x = NULL, 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 + n <- 1 } else if (isMultiColony(x)) { - n <- nColonies(x) + n <- nColonies(x) } return(rpois(n = n, lambda = average)) } -#' @describeIn nCastePoisson +#' @title nVirginQueensPoisson +#' @describeIn nCasteFun Sample the number of virgin queens +#' from a Poisson distribution #' @export -nVirginQueensPoisson <- function(x, n = 1, average = 10) { +nVirginQueensPoisson <- function(x = NULL, n = 1, average = 10) { nCastePoisson(x = x, n = n, average = average) } -#' @describeIn nCastePoisson +#' @title nFathersPoisson +#' @describeIn nCasteFun Sample the number of fathers +#' from a Poisson distribution #' @export -nFathersPoisson <- function(x, n = 1, average = 15) { +nFathersPoisson <- function(x = NULL, n = 1, average = 15) { nCastePoisson(x = x, n = n, average = average) } -#' @describeIn nCastePoisson +#' @title nWorkersPoisson +#' @describeIn nCasteFun Sample the number of workers +#' from a Poisson distribution #' @export -nWorkersPoisson <- function(x, n = 1, average = 100) { +nWorkersPoisson <- function(x = NULL, n = 1, average = 100) { nCastePoisson(x = x, n = n, average = average) } -#' @describeIn nCastePoisson +#' @title nDronesPoisson +#' @describeIn nCasteFun Sample the number of drones +#' from a Poisson distribution #' @export -nDronesPoisson <- function(x, n = 1, average = 100) { +nDronesPoisson <- function(x = NULL, n = 1, average = 100) { nCastePoisson(x = x, n = n, average = average) } -#' @describeIn nCasteFun Sample a non-zero number of caste individuals +#' @title nCasteTruncPoisson +#' @describeIn nCasteFun Sample a non-zero number of caste individuals from a Poisson +#' distribution #' @export -nCasteTruncPoisson <- function(x, n = 1, average = 100, lowerLimit = 0) { +nCasteTruncPoisson <- function(x = NULL, n = 1, average = 100, lowerLimit = 0) { if (isColony(x)) { n <- 1 } else if (isMultiColony(x)) { @@ -785,27 +795,37 @@ nCasteTruncPoisson <- function(x, n = 1, average = 100, lowerLimit = 0) { return(extraDistr::rtpois(n = n, lambda = average, a = lowerLimit)) } -#' @describeIn nCasteTruncPoisson +#' @title nVirginQueensTruncPoisson +#' @describeIn nCasteFun Sample a non-zero number of virgin queens +#' from a Poisson distribution #' @export -nVirginQueensTruncPoisson <- function(x, n = 1, average = 10, lowerLimit = 0) { +nVirginQueensTruncPoisson <- function(x = NULL, n = 1, average = 10, lowerLimit = 0) { nCasteTruncPoisson(x = x, n = n, average = average, lowerLimit = lowerLimit) } -#' @describeIn nCasteTruncPoisson + +#' @title nFathersTruncPoisson +#' @describeIn nCasteFun Sample a non-zero number of fathers +#' from a Poisson distribution #' @export -nFathersTruncPoisson <- function(x, n = 1, average = 15, lowerLimit = 0) { +nFathersTruncPoisson <- function(x = NULL, n = 1, average = 15, lowerLimit = 0) { nCasteTruncPoisson(x = x, n = n, average = average, lowerLimit = lowerLimit) } -#' @describeIn nCasteTruncPoisson +#' @title nWorkersTruncPoisson +#' @describeIn nCasteFun Sample a non-zero number of workers +#' from a Poisson distribution #' @export -nWorkersTruncPoisson <- function(x, n = 1, average = 100, lowerLimit = 0) { +nWorkersTruncPoisson <- function(x = NULL, n = 1, average = 100, lowerLimit = 0) { nCasteTruncPoisson(x = x, n = n, average = average, lowerLimit = lowerLimit) } -#' @describeIn nCasteTruncPoisson +#' @title nDronesTruncPoisson +#' @describeIn nCasteFun Sample a non-zero number of drones +#' from a Poisson distribution #' @export -nDronesTruncPoisson <- function(x, n = 1, average = 100, lowerLimit = 0) { +nDronesTruncPoisson <- function(x = NULL, n = 1, average = 100, lowerLimit = 0) { nCasteTruncPoisson(x = x, n = n, average = average, lowerLimit = lowerLimit) } +#' @title nCasteColonyPhenotype #' @describeIn nCasteFun Sample a non-zero number of caste individuals based on #' colony phenotype, say queen's fecundity #' @export @@ -835,8 +855,9 @@ nCasteColonyPhenotype <- function(x, queenTrait = 1, workersTrait = NULL, } return(ret) } - -#' @describeIn nCasteColonyPhenotype +#' @title nVirginQueensColonyPhenotype +#' @describeIn nCasteFun Sample a non-zero number of virgin queens based on +#' colony phenotype, say queen's fecundity #' @export nVirginQueensColonyPhenotype <- function(x, queenTrait = 1, workersTrait = NULL, checkProduction = FALSE, lowerLimit = 0, @@ -847,17 +868,27 @@ nVirginQueensColonyPhenotype <- function(x, queenTrait = 1, workersTrait = NULL, simParamBee = simParamBee, ...) } -#' @describeIn nCasteColonyPhenotype +#' @title nWorkersColonyPhenotype +#' @describeIn nCasteFun Sample a non-zero number of workers based on +#' colony phenotype, say queen's fecundity #' @export -nWorkersColonyPhenotype <- function(x, n = 1, average = 100, lowerLimit = 0) { +nWorkersColonyPhenotype <- 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, ...) } -#' @describeIn nCasteColonyPhenotype +#' @title nDronesColonyPhenotype +#' @describeIn nCasteFun Sample a non-zero number of drones based on +#' colony phenotype, say queen's fecundity #' @export -nDronesColonyPhenotype <- function(x, n = 1, average = 100, lowerLimit = 0) { +nDronesColonyPhenotype <- 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, @@ -898,7 +929,7 @@ nDronesColonyPhenotype <- function(x, n = 1, average = 100, lowerLimit = 0) { #' p <- swarmPUnif(n = 1000) #' hist(p, breaks = seq(from = 0, to = 1, by = 0.01), xlim = c(0, 1)) #' @export -swarmPUnif <- function(x, n = 1, min = 0.4, max = 0.6) { +swarmPUnif <- function(x = NULL, n = 1, min = 0.4, max = 0.6) { if (isColony(x)) { n <- 1 } else if (isMultiColony(x)) { @@ -984,7 +1015,7 @@ swarmPUnif <- function(x, n = 1, min = 0.4, max = 0.6) { #' plot(pKeep ~ nWorkers, ylim = c(0, 1)) #' abline(v = nWorkersFull) #' @export -splitPUnif <- function(x, n = 1, min = 0.2, max = 0.4) { +splitPUnif <- function(x = NULL, n = 1, min = 0.2, max = 0.4) { if (isColony(x)) { n <- 1 } else if (isMultiColony(x)) { @@ -1037,7 +1068,7 @@ splitPColonyStrength <- function(x, 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(x, n = 1, min = 0.8, max = 0.9) { +downsizePUnif <- function(x = NULL, n = 1, min = 0.8, max = 0.9) { if (isColony(x)) { n <- 1 } else if (isMultiColony(x)) { diff --git a/R/Functions_L1_Pop.R b/R/Functions_L1_Pop.R index 2503270f..77abab82 100644 --- a/R/Functions_L1_Pop.R +++ b/R/Functions_L1_Pop.R @@ -621,45 +621,31 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, lastId = simParamBee$lastId ids = (lastId+1):(lastId+totalNInd) - 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))) { - 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, .packages = c("SIMplyBee")) %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( - x = x[[colony]], caste = caste, - nInd = nIndColony, - editCsd = TRUE, csdAlleles = NULL, - simParamBee = simParamBee, - returnSP = TRUE, - ids = as.character(colonyIds) - ) - } else { - NULL - } - } + ret <- future_lapply(X = seq_len(nCol), + future.seed = TRUE, + FUN = function(colony) { + 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( + x = x[[colony]], caste = caste, + nInd = nIndColony, + editCsd = TRUE, csdAlleles = NULL, + simParamBee = simParamBee, + returnSP = TRUE, + ids = as.character(colonyIds) + ) + } else { + NULL + } + } + ) - 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)) @@ -1268,20 +1254,23 @@ pullCastePop <- function(x, caste, nInd = NULL, use = "rand", names(ret$pulled) <- getId(x) ret$remnant <- x - tmp = foreach(colony = seq_len(nCol), .packages = c("SIMplyBee")) %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) - } + tmp = future_lapply(X = seq_len(nCol), + future.seed = TRUE, + FUN = function(colony) { + 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") @@ -1661,15 +1650,6 @@ cross <- function(x, nD = rep(nD, length(IDs)) } - - 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 # This is the crossPlan - for spatial, these are all DPCs found in a radius @@ -1713,15 +1693,15 @@ cross <- function(x, FUN = function(x) dronesByVirgin_DF$droneID[dronesByVirgin_DF$virginID == x]) names(dronesByVirgin_list) <- IDs - dronesByVirgin <- foreach(i = IDs, .combine = combine_list, - .packages = c("SIMplyBee")) %do% { - dronePop[as.character(dronesByVirgin_list[[i]])] - } + dronesByVirgin <- lapply(IDs, function(i) { + dronePop[as.character(dronesByVirgin_list[[i]])] + } + ) } else if (crossPlan_droneID) { - dronesByVirgin <- foreach(i = IDs, .combine = combine_list, - .packages = c("SIMplyBee")) %do% { - drones[as.character(crossPlan[[i]])] - } + dronesByVirgin <- lapply(IDs, function(i) { + 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) @@ -1773,25 +1753,25 @@ cross <- function(x, # Add drones in the queens father slot - x <- foreach(i = 1:length(IDs), .combine = combine_list, .packages = "SIMplyBee") %dopar% { + x <- future_lapply(X = 1:length(IDs), + future.seed = TRUE, + FUN = function(i) { crossVirginQueen(virginQueen = x[i], virginQueenDrones = dronesByVirgin[[i]], simParamBee = simParamBee) - } + }) if (type == "Pop") { if (length(x) == 1) { - ret <- x + ret <- x[[1]] } else { ret <- mergePops(x) } } else if (type == "Colony") { - ret <- reQueen(x = colony, queen = x[1], simParamBee = simParamBee) + ret <- reQueen(x = colony, queen = x[[1]], simParamBee = simParamBee) ret <- removeVirginQueens(ret, simParamBee = simParamBee) } else if (type == "MultiColony") { - if (length(IDs) > 1) { - x <- mergePops(x) - } + 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 7320c3f6..4bb61098 100644 --- a/R/Functions_L2_Colony.R +++ b/R/Functions_L2_Colony.R @@ -176,13 +176,14 @@ reQueen <- function(x, queen, removeVirginQueens = TRUE, simParamBee = NULL) { } - x@colonies = foreach(colony = seq_len(nCol), .packages = c("SIMplyBee")) %dopar% { + x@colonies = future_lapply(X = seq_len(nCol), + FUN = function(colony) { reQueen( x = x[[colony]], queen = queen[colony], simParamBee = simParamBee ) - } + }) } else { stop("Argument x must be a Colony or MultiColony class object!") } @@ -384,7 +385,8 @@ addCastePop <- function(x, caste = NULL, nInd = NULL, new = FALSE, nInd(x) }) - x@colonies <- foreach(colony = seq_len(nCol), .packages = c("SIMplyBee")) %dopar% { + x@colonies <- future_lapply(X = seq_len(nCol), + FUN = function(colony) { if (!is.null(nInds[[colony]])) { if (caste == "workers") { x[[colony]]@queen@misc$nWorkers[[1]] <- x[[colony]]@queen@misc$nWorkers[[1]] + nInds[[colony]] @@ -396,7 +398,7 @@ addCastePop <- function(x, caste = NULL, nInd = NULL, new = FALSE, } else { x[[colony]] } - } + }) } else { stop("Argument x must be a Colony or MultiColony class object!") @@ -1045,7 +1047,9 @@ removeCastePop <- function(x, caste = NULL, p = 1, use = "rand", p <- p[1:nCol] } - x@colonies <- foreach(colony = seq_len(nCol), .packages = c("SIMplyBee")) %dopar% { + x@colonies <- future_lapply(X = seq_len(nCol), + future.seed = TRUE, + FUN = function(colony) { if (is.null(p)) { pColony <- NULL } else { @@ -1058,6 +1062,7 @@ removeCastePop <- function(x, caste = NULL, p = 1, use = "rand", simParamBee = simParamBee ) } + ) } else { stop("Argument x must be a Colony or MultiColony class object!") @@ -1204,13 +1209,15 @@ resetEvents <- function(x, collapse = NULL, simParamBee = NULL) { stop("The Multicolony contains 0 colonies!") } - x@colonies <- foreach(colony = seq_len(nCol), .packages = c("SIMplyBee")) %dopar% { + x@colonies <- future_lapply(X = seq_len(nCol), + FUN = function(colony) { resetEvents( x = x[[colony]], collapse = collapse, simParamBee = simParamBee ) - } + } + ) validObject(x) } else { stop("Argument x must be a Colony or MultiColony class object!") @@ -1278,10 +1285,12 @@ collapse <- function(x, simParamBee = NULL) { stop("The Multicolony contains 0 colonies!") } - x@colonies <- foreach(colony = seq_len(nCol), .packages = c("SIMplyBee")) %dopar% { + x@colonies <- future_lapply(X = seq_len(nCol), + FUN = function(colony) { collapse(x = x[[colony]], simParamBee = simParamBee) - } + } + ) } else { stop("Argument x must be a Colony or MultiColony class object!") } @@ -1493,10 +1502,10 @@ swarm <- function(x, p = NULL, remnant = remnantColony ) - ret$swarm@colonies <- foreach(colony = seq_len(nCol), .packages = c("SIMplyBee")) %dopar% { + ret$swarm@colonies <- future_lapply(X = seq_len(nCol), FUN = function(colony) { addCastePop_internal(colony = ret$swarm@colonies[[colony]], pop = tmp$pulled[[colony]], caste = "workers") - } + }) ret$remnant <- setEvents(ret$remnant, slot = "swarm", value = TRUE, simParamBee = simParamBee) @@ -1637,18 +1646,10 @@ supersede <- function(x, simParamBee = NULL, ...) { } tmpVirginQueens <- lapply(tmpVirginQueens, FUN = function(x) selectInd(x, nInd = 1, use = "rand", simParam = simParamBee)) - 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(nColonies(x)), .packages = c("SIMplyBee")) %dopar% { + x@colonies <- future_lapply(X = seq_len(nColonies(x)), FUN = function(colony) { addCastePop_internal(colony = removeQueen(x[[colony]], simParamBee = simParamBee), pop = tmpVirginQueens[[colony]], caste = "virginQueens") - } + }) x = setEvents(x, slot = "supersedure", value = TRUE, simParamBee = simParamBee) } else { @@ -1810,10 +1811,11 @@ split <- function(x, p = NULL, simParamBee = NULL, ...) { ) ret$split <- setLocation(x = ret$split, location = location, simParamBee = simParamBee) - ret$split@colonies <- foreach(colony = seq_len(nCol), .packages = c("SIMplyBee")) %dopar% { + ret$split@colonies <- future_lapply(X = seq_len(nCol), + FUN = function(colony) { addCastePop_internal(colony = ret$split@colonies[[colony]], pop = tmp$pulled[[colony]], caste = "workers") - } + }) 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) @@ -1865,9 +1867,10 @@ setEvents <- function(x, slot, value, simParamBee = NULL) { slot(x, slot) <- value } if (isMultiColony(x)) { - x@colonies <- foreach(colony = seq_len(nColonies(x)), .packages = c("SIMplyBee")) %dopar% { + x@colonies <- future_lapply(X = seq_len(nColonies(x)), + FUN = function(colony) { setEvents(x[[colony]], slot, value, simParamBee = simParamBee) - } + }) } return(x) } @@ -1947,11 +1950,12 @@ combine <- function(strong, weak, simParamBee = NULL) { if (nColonies(weak) == nColonies(strong)) { nCol <- nColonies(weak) - strong@colonies <- foreach(colony = seq_len(nCol), .packages = c("SIMplyBee")) %dopar% { + strong@colonies <- future_lapply(X = seq_len(nCol), + FUN = function(colony) { combine(strong = strong[[colony]], weak = weak[[colony]], simParamBee = simParamBee) - } + }) } else { stop("Weak and strong MultiColony objects must be of the same length!") } @@ -2027,7 +2031,7 @@ setLocation <- function(x, location = c(0, 0), simParamBee = NULL) { x@location <- location } else if (isMultiColony(x)) { nCol <- nColonies(x) - if (nCol == 0) { + if (nCol == 0 | all(isNULLColonies(x))) { stop("The Multicolony contains 0 colonies!") } if (!is.null(location)) { @@ -2058,15 +2062,8 @@ setLocation <- function(x, location = c(0, 0), simParamBee = NULL) { 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)) - } - } - - tmp <- foreach(colony = seq_len(nCol), .combine = combine_list, .packages = c("SIMplyBee")) %dopar% { + x@colonies <- future_lapply(X = seq_len(nCol), + FUN = function(colony) { if (is.data.frame(location)) { loc <- location[colony, ] loc <- c(loc$x, loc$y) @@ -2081,13 +2078,7 @@ 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/Functions_L3_Colonies.R b/R/Functions_L3_Colonies.R index 1c8d7ff3..78f240c3 100644 --- a/R/Functions_L3_Colonies.R +++ b/R/Functions_L3_Colonies.R @@ -33,14 +33,14 @@ #' apiary[[2]] #' #' # Create 3 virgin colonies -#' apiary <- createMultiColony(x = basePop, n = 3) # specify n +#' apiary <- createMultiColony(x = basePop) # specify n #' apiary <- createMultiColony(x = basePop[1:3]) # take all provided #' apiary #' apiary[[1]] #' apiary[[2]] #' #' # Create mated colonies by crossing -#' apiary <- createMultiColony(x = basePop[1:2], n = 2) +#' apiary <- createMultiColony(x = basePop[1:2]) #' drones <- createDrones(x = basePop[3], nInd = 30) #' droneGroups <- pullDroneGroupsFromDCA(drones, n = 2, nDrones = 15) #' apiary <- cross(apiary, drones = droneGroups) @@ -62,9 +62,10 @@ createMultiColony <- function(x = NULL, n = NULL, simParamBee = NULL, populateCo if (populateColonies) { ids <- (simParamBee$lastColonyId+1):(simParamBee$lastColonyId + n) - ret@colonies <- foreach(colony = seq_len(n), .packages = c("SIMplyBee")) %dopar% { + ret@colonies <- future_lapply(X = seq_len(n), + FUN = function(colony) { createColony(simParamBee = simParamBee, id = ids[colony]) - } + }) simParamBee$updateLastColonyId(n = n) } else { @@ -86,9 +87,10 @@ 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), .packages = c("SIMplyBee")) %dopar% { - createColony(x = x[colony], simParamBee = simParamBee, id = ids[colony]) - } + ret@colonies <- future_lapply(X = seq_len(n), + FUN = function(colony) { + createColony(x = x[colony], simParamBee = simParamBee, id = ids[colony]) + }) simParamBee$updateLastColonyId(n = n) } diff --git a/R/SIMplyBee.R b/R/SIMplyBee.R index 04ad88bb..c138b5da 100644 --- a/R/SIMplyBee.R +++ b/R/SIMplyBee.R @@ -7,7 +7,7 @@ #' @importFrom stats rnorm rbeta runif rpois na.omit #' @importFrom extraDistr rtpois #' @importFrom utils packageVersion -#' @importFrom foreach foreach "%dopar%" "%do%" +#' @importFrom future.apply future_lapply # 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..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/createMultiColony.Rd b/man/createMultiColony.Rd index 7951d430..4298fe31 100644 --- a/man/createMultiColony.Rd +++ b/man/createMultiColony.Rd @@ -48,14 +48,14 @@ apiary[[1]] apiary[[2]] # Create 3 virgin colonies -apiary <- createMultiColony(x = basePop, n = 3) # specify n +apiary <- createMultiColony(x = basePop) # specify n apiary <- createMultiColony(x = basePop[1:3]) # take all provided apiary apiary[[1]] apiary[[2]] # Create mated colonies by crossing -apiary <- createMultiColony(x = basePop[1:2], n = 2) +apiary <- createMultiColony(x = basePop[1:2]) drones <- createDrones(x = basePop[3], nInd = 30) droneGroups <- pullDroneGroupsFromDCA(drones, n = 2, nDrones = 15) apiary <- cross(apiary, drones = droneGroups) diff --git a/man/downsizePFun.Rd b/man/downsizePFun.Rd index e340b3e7..796b1d66 100644 --- a/man/downsizePFun.Rd +++ b/man/downsizePFun.Rd @@ -5,10 +5,10 @@ \title{Sample the downsize proportion - proportion of removed workers in downsizing} \usage{ -downsizePUnif(colony, n = 1, min = 0.8, max = 0.9) +downsizePUnif(x = NULL, n = 1, min = 0.8, max = 0.9) } \arguments{ -\item{colony}{\code{\link[SIMplyBee]{Colony-class}}} +\item{x}{\code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}}} \item{n}{integer, number of samples} diff --git a/man/mapCasteToColonyValue.Rd b/man/mapCasteToColonyValue.Rd index 3742a6cb..a7801a31 100644 --- a/man/mapCasteToColonyValue.Rd +++ b/man/mapCasteToColonyValue.Rd @@ -10,7 +10,7 @@ \title{Map caste member (individual) values to a colony value} \usage{ mapCasteToColonyValue( - colony, + x, value = "pheno", queenTrait = 1, queenFUN = function(x) x, @@ -25,18 +25,18 @@ mapCasteToColonyValue( simParamBee = NULL ) -mapCasteToColonyPheno(colony, simParamBee = NULL, ...) +mapCasteToColonyPheno(x, simParamBee = NULL, ...) -mapCasteToColonyGv(colony, simParamBee = NULL, ...) +mapCasteToColonyGv(x, simParamBee = NULL, ...) -mapCasteToColonyBv(colony, simParamBee = NULL, ...) +mapCasteToColonyBv(x, simParamBee = NULL, ...) -mapCasteToColonyDd(colony, simParamBee = NULL, ...) +mapCasteToColonyDd(x, simParamBee = NULL, ...) -mapCasteToColonyAa(colony, simParamBee = NULL, ...) +mapCasteToColonyAa(x, simParamBee = NULL, ...) } \arguments{ -\item{colony}{\code{\link[SIMplyBee]{Colony-class}}} +\item{x}{\code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}}} \item{value}{character, one of \code{pheno} or \code{gv}} @@ -88,7 +88,8 @@ you can pass more than one logical value here (one per trait coming out of \item{...}{other arguments of \code{mapCasteToColonyValue} (for its aliases)} } \value{ -numeric matrix with one value or a row of values +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}} } \description{ Maps caste member (individual) values to a colony value - for diff --git a/man/nCasteFun.Rd b/man/nCasteFun.Rd new file mode 100644 index 00000000..a3ead92e --- /dev/null +++ b/man/nCasteFun.Rd @@ -0,0 +1,203 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/Class-SimParamBee.R +\name{nCastePoisson} +\alias{nCastePoisson} +\alias{nVirginQueensPoisson} +\alias{nFathersPoisson} +\alias{nWorkersPoisson} +\alias{nDronesPoisson} +\alias{nCasteTruncPoisson} +\alias{nVirginQueensTruncPoisson} +\alias{nFathersTruncPoisson} +\alias{nWorkersTruncPoisson} +\alias{nDronesTruncPoisson} +\alias{nCasteColonyPhenotype} +\alias{nVirginQueensColonyPhenotype} +\alias{nWorkersColonyPhenotype} +\alias{nDronesColonyPhenotype} +\title{Sample a number of caste members (workers, drones, virgin queens)} +\usage{ +nCastePoisson(x = NULL, n = 1, average = 100) + +nVirginQueensPoisson(x = NULL, n = 1, average = 10) + +nFathersPoisson(x = NULL, n = 1, average = 15) + +nWorkersPoisson(x = NULL, n = 1, average = 100) + +nDronesPoisson(x = NULL, n = 1, average = 100) + +nCasteTruncPoisson(x = NULL, n = 1, average = 100, lowerLimit = 0) + +nVirginQueensTruncPoisson(x = NULL, n = 1, average = 10, lowerLimit = 0) + +nFathersTruncPoisson(x = NULL, n = 1, average = 15, lowerLimit = 0) + +nWorkersTruncPoisson(x = NULL, n = 1, average = 100, lowerLimit = 0) + +nDronesTruncPoisson(x = NULL, n = 1, average = 100, lowerLimit = 0) + +nCasteColonyPhenotype( + x, + queenTrait = 1, + workersTrait = NULL, + checkProduction = FALSE, + lowerLimit = 0, + simParamBee = NULL, + ... +) + +nVirginQueensColonyPhenotype( + x, + queenTrait = 1, + workersTrait = NULL, + checkProduction = FALSE, + lowerLimit = 0, + simParamBee = NULL, + ... +) + +nWorkersColonyPhenotype( + x, + queenTrait = 1, + workersTrait = NULL, + checkProduction = FALSE, + lowerLimit = 0, + simParamBee = NULL, + ... +) + +nDronesColonyPhenotype( + x, + queenTrait = 1, + workersTrait = NULL, + checkProduction = FALSE, + lowerLimit = 0, + simParamBee = NULL, + ... +) +} +\arguments{ +\item{x}{\code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}}} + +\item{n}{integer, number of samples} + +\item{average}{numeric, average number of workers} + +\item{lowerLimit}{numeric, returned numbers will be above this value} + +\item{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} + +\item{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} + +\item{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}} + +\item{simParamBee}{\code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters} + +\item{...}{other arguments of \code{\link[SIMplyBee]{mapCasteToColonyPheno}}} +} +\value{ +numeric, number of caste members +} +\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! +} +\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{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). +} +\section{Functions}{ +\itemize{ +\item \code{nVirginQueensPoisson()}: Sample the number of virgin queens +from a Poisson distribution + +\item \code{nFathersPoisson()}: Sample the number of fathers +from a Poisson distribution + +\item \code{nWorkersPoisson()}: Sample the number of workers +from a Poisson distribution + +\item \code{nDronesPoisson()}: Sample the number of drones +from a Poisson distribution + +\item \code{nCasteTruncPoisson()}: Sample a non-zero number of caste individuals from a Poisson +distribution + +\item \code{nVirginQueensTruncPoisson()}: Sample a non-zero number of virgin queens +from a Poisson distribution + +\item \code{nFathersTruncPoisson()}: Sample a non-zero number of fathers +from a Poisson distribution + +\item \code{nWorkersTruncPoisson()}: Sample a non-zero number of workers +from a Poisson distribution + +\item \code{nDronesTruncPoisson()}: Sample a non-zero number of drones +from a Poisson distribution + +\item \code{nCasteColonyPhenotype()}: Sample a non-zero number of caste individuals based on +colony phenotype, say queen's fecundity + +\item \code{nVirginQueensColonyPhenotype()}: Sample a non-zero number of virgin queens based on +colony phenotype, say queen's fecundity + +\item \code{nWorkersColonyPhenotype()}: Sample a non-zero number of workers based on +colony phenotype, say queen's fecundity + +\item \code{nDronesColonyPhenotype()}: Sample a non-zero number of drones based on +colony phenotype, say queen's fecundity + +}} +\examples{ +nCastePoisson() +nCastePoisson() +n <- nCastePoisson(n = 1000) +hist(n, breaks = seq(from = min(n), to = max(n)), xlim = c(0, 200)) +table(n) + +nCasteTruncPoisson() +nCasteTruncPoisson() +n <- nCasteTruncPoisson(n = 1000) +hist(n, breaks = seq(from = min(n), to = max(n)), xlim = c(0, 200)) +table(n) + +# Example for nCasteColonyPhenotype() +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 +createWorkers(colony1, nInd = nCasteColonyPhenotype) +createWorkers(colony2, nInd = nCasteColonyPhenotype) +} +\seealso{ +\code{\link[SIMplyBee]{SimParamBee}} field \code{nWorkers}, \code{nDrones} and + \code{vignette(topic = "QuantitativeGenetics", package = "SIMplyBee")} +} diff --git a/man/nDronesFun.Rd b/man/nDronesFun.Rd deleted file mode 100644 index d701da01..00000000 --- a/man/nDronesFun.Rd +++ /dev/null @@ -1,118 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/Class-SimParamBee.R -\name{nDronesPoisson} -\alias{nDronesPoisson} -\alias{nDronesTruncPoisson} -\alias{nDronesColonyPhenotype} -\title{Sample a number of drones} -\usage{ -nDronesPoisson(x, n = 1, average = 100) - -nDronesTruncPoisson(x, n = 1, average = 100, lowerLimit = 0) - -nDronesColonyPhenotype( - x, - queenTrait = 1, - workersTrait = NULL, - checkProduction = FALSE, - lowerLimit = 0, - simParamBee = NULL, - ... -) -} -\arguments{ -\item{x}{\code{\link[AlphaSimR]{Pop-class}} or \code{\link[SIMplyBee]{Colony-class}}} - -\item{n}{integer, number of samples} - -\item{average}{numeric, average number of drones} - -\item{lowerLimit}{numeric, returned numbers will be above this value} - -\item{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} - -\item{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} - -\item{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}} - -\item{simParamBee}{\code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters} - -\item{...}{other arguments of \code{\link[SIMplyBee]{mapCasteToColonyPheno}}} -} -\value{ -numeric, 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! -} -\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. -} -\section{Functions}{ -\itemize{ -\item \code{nDronesTruncPoisson()}: Sample a non-zero number of drones - -\item \code{nDronesColonyPhenotype()}: Sample a non-zero number of drones based on -colony phenotype, say queen's fecundity - -}} -\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) -} -\seealso{ -\code{\link[SIMplyBee]{SimParamBee}} field \code{nDrones} and - \code{vignette(topic = "QuantitativeGenetics", package = "SIMplyBee")} -} diff --git a/man/nFathersFun.Rd b/man/nFathersFun.Rd deleted file mode 100644 index 6c4119fa..00000000 --- a/man/nFathersFun.Rd +++ /dev/null @@ -1,56 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/Class-SimParamBee.R -\name{nFathersPoisson} -\alias{nFathersPoisson} -\alias{nFathersTruncPoisson} -\title{Sample a number of fathers} -\usage{ -nFathersPoisson(n = 1, average = 15) - -nFathersTruncPoisson(n = 1, average = 15, lowerLimit = 0) -} -\arguments{ -\item{n}{integer, number of samples} - -\item{average}{numeric, average number of fathers} - -\item{lowerLimit}{numeric, returned numbers will be above this value} -} -\value{ -numeric, 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! -} -\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. -} -\section{Functions}{ -\itemize{ -\item \code{nFathersTruncPoisson()}: Sample a non-zero 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) -} -\seealso{ -\code{\link[SIMplyBee]{SimParamBee}} field \code{nFathers} -} diff --git a/man/nVirginQueensFun.Rd b/man/nVirginQueensFun.Rd deleted file mode 100644 index b213356c..00000000 --- a/man/nVirginQueensFun.Rd +++ /dev/null @@ -1,127 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/Class-SimParamBee.R -\name{nVirginQueensPoisson} -\alias{nVirginQueensPoisson} -\alias{nVirginQueensTruncPoisson} -\alias{nVirginQueensColonyPhenotype} -\title{Sample a number of virgin queens} -\usage{ -nVirginQueensPoisson(colony, n = 1, average = 10) - -nVirginQueensTruncPoisson(colony, n = 1, average = 10, lowerLimit = 0) - -nVirginQueensColonyPhenotype( - colony, - queenTrait = 1, - workersTrait = 2, - checkProduction = FALSE, - lowerLimit = 0, - simParamBee = NULL, - ... -) -} -\arguments{ -\item{colony}{\code{\link[SIMplyBee]{Colony-class}}} - -\item{n}{integer, number of samples} - -\item{average}{numeric, average number of virgin queens} - -\item{lowerLimit}{numeric, returned numbers will be above this value} - -\item{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} - -\item{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} - -\item{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}} - -\item{simParamBee}{\code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters} - -\item{...}{other arguments of \code{\link[SIMplyBee]{mapCasteToColonyPheno}}} -} -\value{ -numeric, 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! -} -\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). -} -\section{Functions}{ -\itemize{ -\item \code{nVirginQueensTruncPoisson()}: Sample a non-zero number of virgin queens - -\item \code{nVirginQueensColonyPhenotype()}: Sample a non-zero number of virgin queens -based on colony's phenotype, say, swarming tendency - -}} -\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) -} -\seealso{ -\code{\link[SIMplyBee]{SimParamBee}} field \code{nVirginQueens} and - \code{vignette(topic = "QuantitativeGenetics", package = "SIMplyBee")} -} diff --git a/man/nWorkersFun.Rd b/man/nWorkersFun.Rd deleted file mode 100644 index 4775e95c..00000000 --- a/man/nWorkersFun.Rd +++ /dev/null @@ -1,113 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/Class-SimParamBee.R -\name{nWorkersPoisson} -\alias{nWorkersPoisson} -\alias{nWorkersTruncPoisson} -\alias{nWorkersColonyPhenotype} -\title{Sample a number of workers} -\usage{ -nWorkersPoisson(colony, n = 1, average = 100) - -nWorkersTruncPoisson(colony, n = 1, average = 100, lowerLimit = 0) - -nWorkersColonyPhenotype( - colony, - queenTrait = 1, - workersTrait = NULL, - checkProduction = FALSE, - lowerLimit = 0, - simParamBee = NULL, - ... -) -} -\arguments{ -\item{colony}{\code{\link[SIMplyBee]{Colony-class}}} - -\item{n}{integer, number of samples} - -\item{average}{numeric, average number of workers} - -\item{lowerLimit}{numeric, returned numbers will be above this value} - -\item{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} - -\item{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} - -\item{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}} - -\item{simParamBee}{\code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters} - -\item{...}{other arguments of \code{\link[SIMplyBee]{mapCasteToColonyPheno}}} -} -\value{ -numeric, number of workers -} -\description{ -Sample a number of workers - used when \code{nInd = NULL} - (see \code{\link[SIMplyBee]{SimParamBee}$nWorkers}). - - This is just an example. You can provide your own functions that satisfy - your needs! -} -\details{ -\code{nWorkersPoisson} 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{nWorkersColonyPhenotype} 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). -} -\section{Functions}{ -\itemize{ -\item \code{nWorkersTruncPoisson()}: Sample a non-zero number of workers - -\item \code{nWorkersColonyPhenotype()}: Sample a non-zero number of workers based on -colony phenotype, say queen's fecundity - -}} -\examples{ -nWorkersPoisson() -nWorkersPoisson() -n <- nWorkersPoisson(n = 1000) -hist(n, breaks = seq(from = min(n), to = max(n)), xlim = c(0, 200)) -table(n) - -nWorkersTruncPoisson() -nWorkersTruncPoisson() -n <- nWorkersTruncPoisson(n = 1000) -hist(n, breaks = seq(from = min(n), to = max(n)), xlim = c(0, 200)) -table(n) - -# Example for nWorkersColonyPhenotype() -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 -createWorkers(colony1, nInd = nWorkersColonyPhenotype) -createWorkers(colony2, nInd = nWorkersColonyPhenotype) -} -\seealso{ -\code{\link[SIMplyBee]{SimParamBee}} field \code{nWorkers} and - \code{vignette(topic = "QuantitativeGenetics", package = "SIMplyBee")} -} diff --git a/man/splitPFun.Rd b/man/splitPFun.Rd index 880b7553..d4f222ad 100644 --- a/man/splitPFun.Rd +++ b/man/splitPFun.Rd @@ -6,12 +6,12 @@ \title{Sample the split proportion - proportion of removed workers in a managed split} \usage{ -splitPUnif(colony, n = 1, min = 0.2, max = 0.4) +splitPUnif(x = NULL, n = 1, min = 0.2, max = 0.4) -splitPColonyStrength(colony, n = 1, nWorkersFull = 100, scale = 1) +splitPColonyStrength(x, n = 1, nWorkersFull = 100, scale = 1) } \arguments{ -\item{colony}{\code{\link[SIMplyBee]{Colony-class}}} +\item{x}{\code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}}} \item{n}{integer, number of samples} diff --git a/man/swarmPFun.Rd b/man/swarmPFun.Rd index 27b62419..f0ef5bb5 100644 --- a/man/swarmPFun.Rd +++ b/man/swarmPFun.Rd @@ -4,10 +4,10 @@ \alias{swarmPUnif} \title{Sample the swarm proportion - the proportion of workers that swarm} \usage{ -swarmPUnif(colony, n = 1, min = 0.4, max = 0.6) +swarmPUnif(x = NULL, n = 1, min = 0.4, max = 0.6) } \arguments{ -\item{colony}{\code{\link[SIMplyBee]{Colony-class}}} +\item{x}{\code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}}} \item{n}{integer, number of samples} diff --git a/tests/testthat/test-L0_auxiliary_functions.R b/tests/testthat/test-L0_auxiliary_functions.R index 5b32280a..7d7f11b4 100644 --- a/tests/testthat/test-L0_auxiliary_functions.R +++ b/tests/testthat/test-L0_auxiliary_functions.R @@ -504,12 +504,12 @@ test_that("isCsdHeterozygous", { colony <- createColony(x = basePop[2], simParamBee = SP) colony <- cross(colony, drones = fatherGroups[[1]], simParamBee = SP) colony <- buildUp(x = colony, simParamBee = SP) - colony@virginQueens <- createVirginQueens(colony, nInd = 1, simParamBee = SP) + colony@virginQueens <- createVirginQueens(colony, nInd = 10, simParamBee = SP) expect_true(isCsdHeterozygous(colony@queen, simParamBee = SP)) expect_true(is.vector(isCsdHeterozygous(colony@workers, simParamBee = SP))) expect_true(all(isCsdHeterozygous(colony@drones, simParamBee = SP))) - expect_true(isCsdHeterozygous(colony@virginQueens, simParamBee = SP)) + expect_true(all(isCsdHeterozygous(colony@virginQueens, simParamBee = SP))) # set CSD to NULL SP <- SimParamBee$new(founderGenomes, csdChr = NULL) diff --git a/tests/testthat/test-L1_pop_functions.R b/tests/testthat/test-L1_pop_functions.R index d73e5420..dc31682e 100644 --- a/tests/testthat/test-L1_pop_functions.R +++ b/tests/testthat/test-L1_pop_functions.R @@ -67,7 +67,7 @@ test_that("createVirginQueens", { # Error when testing on empty MultiColony apiary1 <- createMultiColony(n = 2, simParamBee = SP) - expect_error(createVirginQueens(apiary1, nInd = 5, simParamBee = SP)) + expect_error(suppressWarnings(createVirginQueens(apiary1, nInd = 5, simParamBee = SP))) #check that output is virginqueens ? expect_false(all(isVirginQueen(drones, simParamBee = SP))) @@ -195,7 +195,7 @@ test_that("pullCastePop", { apiary2 <- createMultiColony(n = 2, simParamBee = SP) # test on empty apiary expect_type(pullCastePop(apiary1, caste = "queen", nInd = 1, simParamBee = SP)$pulled, "list") - expect_error(pullCastePop(apiary2, caste = "queen", nInd = 1, simParamBee = SP)) + expect_error(suppressWarnings(pullCastePop(apiary2, caste = "queen", nInd = 1, simParamBee = SP))) # Warning- if pulling drones, pulls drones that are not yet mated expect_warning(pullCastePop(colony, caste = "drones", nInd = 150, simParamBee = SP)) suppressWarnings(expect_s4_class(pullCastePop(colony, caste = "drones", simParamBee = SP)$pulled, "Pop")) diff --git a/vignettes/582-5827311_reindeer-clipart-cartoon-hd-png-download.png b/vignettes/582-5827311_reindeer-clipart-cartoon-hd-png-download.png new file mode 100644 index 0000000000000000000000000000000000000000..23aa9b67dadcc360c8f5747dcd064ba90af9f42c GIT binary patch literal 107612 zcmcG0X*ksT8}~V<&5~pfMcJ~BgdyummJqVdSY`;7&@i@Sts`U?(a2a%G_XV>#{&i|DD{}<2m=6S)@)n&fxy?pM^{rOJVU41PEIxf0je))w#`?k8# zFTb3C0Y6BZ)4=~IMmUB2^2_sIwAF8#JRMxD_Rml0O_(uv%%R4JnwG1p{Hb<1ar}3| z;3b{Ujck8j{wvZZyztsN<(6CBcT=9Q2xYj*y)_yP1$BM&`Q@sz9$K4`>HNdrfBjYO zehBB)SHJ(l@+%WU{dVF>Eoa&|!{3;m1>JEFN>JPyQ0biaEZ^Gm?C@3jvbmgKmEv32 z*}S}1Jw`c5F6}E0urHdWplbFX6khdPsXfE{{nwbz^xh?*lPcTeFBpIPsy+4NFOL58 za@<1pXUZ{;lGbBg7%O9>n;4xYVXke_b~r^3xPk6dmi@x=R+<&ff2t3ecu9FWy~dD z{TpVe`H3p->DRDjxDq93>wOxh>h`!L{J2>XMAi?!me*W5^qU#n5-8eSrHoZS{i3Y} z8ug?SBmdj_2r4JZ^Spju%y4E)ZgN$gF#ZBC;w|LyBfoSC<;*q`H-~?Eu!jo6?k(da zMznHX{`Xie8mroix7+uZTmp)>XCwoPwj-?fl~THAhTOiWF~es4x3e1!{5KK>%HplE zv&qymU$gc?V|IcWfAXOMI)ZC36kVUmS@{I^>>6gJUMou&8tx%+kl%uGCT{gvx=7Xh z?5l)?+AXSAK55VEq=&?b35VB!Viao=D6H2bJ4PjXo? zQS)inUfc&ay0q?XH`3+?#aAH$Ylu^+@oc-c@Q|IpkYN1tyhPfxF4SYxB}6e`Y7oaD z>QebAjC~^RLu_`@U!OEk>aY0Wh~N%k7;_-A>BDeC&;gdKP>&j8cYFy2>;$|8QCrY<%y64*XLuXpt0 zX5ekYZ@2@nnWSW^bhi* z#<7>kl6wzRS6{ebR?Iy@d1pVWV)%0vr}FfPWs54?i4zX>S!wX@xMzx;+qLD)+mk+<7W$hOwMC!#vRLQ4 zJc|HJ?+M4co+KBK9cub8RKJm!w2RlZy)!E&SuMY+Vw3;3OaGIE$kJ(YF}v)lH!=&9 zuOq%5?(VBv?Q?uNxnK4$5@`yx3TK4PY z5Cq&qc;TE6c34!!VBVcBoyXWQQfXmg_hZ`r+{=3MC#N=}aLUUV{ckF{8cI|k)Mg5Q z&uVKfWZt2J@oOn}Wd*_?A27})$Lk*?-#K~z&ms@s<)zA|FSHH79Abq27E8XSbTKbb zJ3oAvk1rhS-?;=AO5DBonkHXItZK?2TCcErCz9bPz7TKl{wJ*yZk;5TiK)B=d+S^> zp|b(uk|Ei9*>b>X5)#_8TH+ad^#`te(D#^*ip`ko^6Ys@V}iF`{FIQz7H%APhkeU% z@uwg-149mgEYlYx4>z_S1nN2jlapQ5bi{f>3=Dq-3_GD?wzSZM5U=m6=0(C#YdfVo zIL_e^Mvfm{6q}dkUrg<`in7!Xqy#+c-C1 ze}Pf+i7vO-zRAmssE33BAkt7RU9?i1O?yuR_5VFpZRz!PrH>gR1?gLVo$?mKd~2u9NV!LrL1?7iWEx>2w8 z@+k{GPwn=1|2T;78u4+zzIzW?@N0u}$;<|%+x!|uqI~dOuMvYS)I_6vdfwCp$9KRP zFIX%Mviv7A{U>6aJBi{m`}m^s6tv{!a$d9(YY~Q_h>w2o)q=?~-wX#qW!u)r>Wh_` zAfEMCs;tJkiHJTo@$h&oBvy`F3{Gj(V$!afHp_;O8!d%{%dBzt{N40f zBaCW2HVjqkcNMF4Y)c-or?<^wvI=y`i5Jqxb9Kai3hM>P+Jr62LPm7n64MPfo9+-} zaoe6IV>CP_E#o9$Z5eAsBaa<|B6jbNPbv)ANPazTdMi!w``%3vHu-%%FFrTeBIcI?-YuUfN8 znQC%*`}g9~+qMR_s%Jw2b%i*+E#93X&q#x>9nbBMxbarRgk6v>-<=vUx=dqk6}Ih| zq*k&i@>9a+O-sX*;n3JZmoEX?WMK|qm7=6+g(f5SNmq3g^$O$SGYMs|OWoolQ~=bX zFujrxjb5C1Ykg#fMfd(jeh*u+W(o$!6HY=|;k%V!pYR|cKnn#V1?mi$D-#Uk8wCLs)oNdfCjfy5u{rd;CWC6TM_q2++XSx_z3nF7SIR_*q z2z7Hn02dDtmYVIOIjT3l`;EK!QKHs0MBb=N$XcoRb?vKDVN&jRt1+EjZU(s2x@y9` z8pHPSa2)WKg+CJ1$$ve{EST%sHMOIFN!YmYkKQ3v+=ky#5I$~^1v0gmY(tScLDz2R zi75gfOkqqZ*qvY(TR&2O|Lj+UNb8UQULe{i$Z4sT^{=@V^R4OM6UM_mfy*x9 zg~BiWY*uGap}6QO!Mfa)faN8Lgn2`H;Y!Gc$t zXRKe(8HqY`lcpawf`>kr9$^?*nWkWst;GA~H1xwri)L9#3MxYFTL+NG{{=P$j{801|?GGX6S{KHwU+I7ko9)Zfo8@>sfU z;(y@e#aox@)aq%AiLWzUz|BagCGz@%C1!V@e;=QiGTtROg`t63)wAh|HX)u5n<8@< z$xU~V8dyR%9bgotY;YaP$Je_;4Mj9U?ZV&nEoLx|$lb5pUo;MJ2rXK5J#zc6zVDjk21eH-Cg!%gsRQr!)dmc5-pu0c5Ys^2a(p4!#|PH^&?R{_B1cm% z>aC}vbQbF;VPRl*df}bvRxeK)FLozHV4pf&Nl1zoyI%ISX@y;}t z;JVoKBy zaj@pi*SrVUsvp9mG_3>k?k_NP)0O_3fbfF;+5)WnB59f*a16S~33K74@LhAVvCr`3 z-PaKXN|%!X<*?(Y>+e?~mUI%zqmg^PW4lKyhVv`M z$lsLgl2z&4?;)n>gXmi0DmG%dA5mkdaTGv6_OLyKI+SOrwbRH%JjSh20o3bHq->l2 z(t1%nO>%N`Z{3%?J$G?Bf*UX?8qhzrtV`pHLw#nHM7LlEmwoJ#{(jvUBZ+apI`J6-H+PiqF$)HYA&(X=N_=M+{t;%)Et4K>89 zMp&Ma#e1xi`655=N3_XwaIhQ%sn&wWlQZXg29u^byok}E!Vwv#q-I*^hjTYj&PUqcGe$4nS zHY3K&Z?8bE+bPPZ836Sz7gem!EGQh^-w)+t75*AS17 zKwt~EJaFBVHSdx6w$Ps04)zsuyQ$2L+DzlljM>6GN>b@~Zul3biNNoX;}XQLECj#` z2vuyUme9L00ROR2*5$tL5w>8t++wuYIOTo$vBcuTaR7^?x5a|OVpP^|};28WSNhr9G9y%J4*V>cOsc=*= z`L9-B4MBd)n(XkRtG)8+VhRUGg=r%Yh3K$zcg=hX-?P?zC%PcYX*CR}CA`t=cplR|&#+kC8}G{F-nq z7G4pBRjViB%dgtZ`zIbG&rq zaoVfe9`g#tVIdk&OWp0<5;f)7%*|#ZoB`##KYcEk)MrIr0P3lq%+eC6k)<{=bAZh~ zD=L61d53?vp4mrwkEPgYYE0-<<8l{pnoCRdyDth|2v6ZHAQiAC54qyACoCMy+y8Cw ziYKi2VvVkWC8}Ql=Vtg8cjln=k>A-LYu^ma>&W>a@OU_;t-}cp48{gK%B(qGF`qOH zN#(8!IH3B|3zW3tDAGcyLuC>kaZk5$(?EM&^?dimzX}}Yicb(F9*)fRqP9v8>q3r4 zBtyR&f61ILZnrNnf{jq^Fw;5C80YcQ@-0Zui%*gm{VFPv=`K(kSWAle#I~e=>+_ z=1{nRoV8Qr>zdH-Hsqsmj__@Ay&&;u0}-80h7KMikX1QcPe%NnI8MhC*3F}8UAQ$$ z5DU{Onhq4}bJ=uAtUWdXQ7}#J_U@CaDA$liy~XBUOmv=@wKD^63SC~;CDUd>CV3qx zm7{B2-{B(dir?UPB1H;4z-Z@3;d?**9kmdl4An;F_^VZ6vu*?&x~Z2}*l4m^;(KeX zOOSlWqKVhjRfp~@v_4PaM`+g}Zew`_$A)M^6>*wa(5CB+2djT==AKo*HTTmlg9G8rTqKwRP zDMa zh7Zo9ksW|xzoXVX3uMk|G54QluQK>r-^XE-567rX@x(e&!s&cO%UpDDjRL$ zv`_InDmK{aua+BxC4e?z72`(lecn*67AM7xhd)_4!mS5CSo(7{@oK$s9*F1p&&UU` zW8ixG`%#Txy=4<2x!&pvOakIw$R8 zA{Rh9`M%>?{d|y)Vh_n);mWZ)E$7?bSSsPZET-1Os_n*lXRO8P_0ye!tUGtkFT8pl z9+;;?({#GUK$Vc?X#sqWV7}_$ztF!mJo*B%s!M)t>`6_B36|G6&?j9G^A_=Qj&^KmS#0`4@oH*?I>;L- zNJu6RU{L=yLWmmtef=!AH;n+$pMd+cG*MW&`!S3bIW$s`7&U2jJLc z(=sZ&pMfkJoAKG1C3Oz{SZJ?{hGF*DfmO1;JYvY_@5TN@AWx0zYfVP$AUzq1U6MO08eTxN#jJ9O|eqXS{~anZV@ci?$n z<_GvRbpU22C<8oZ_nQ(!jyGgPnpzIUL0%T+i$ zlbGCKlH!{lB`ttU+I?|!B3df+uYtxuze4F}hhTiC2K`n2c*(wiHw)#tU9<;B=;a5B zpsbfKq>bSpBtrUylBNI3iKKB_J|4ZOR&om(fs0&@^PbFJ4?!0;FIgEP#uYO zZa%HobntTg7-3nNoEzYJ@n&{Q0#=*0x+iB+o?nTT^A1_9+KT0up8%oj!E7>^d>FH zwU-t$QW)uYQ#%nw@HWf zvm;r=!R1yCy(hVg}5bgK#Mb_U2 zN7}$X{>bW;c9vVUy_seC5w53!c;Y?net&NB#2zC)6cm;$dV(QMUo8K6(R{szq4o2g zfm-U=ml{gh1M)S1(fOCOQ_SC)Z0eBZ&&Xs8__{{#8-rZ(b#`HfO**i6z8>$IS?=oY z1E|A-M=I9nFA1|fb;G~&XR;}@ZnWx3Mk7)uGDK58^emdC@w!Px?jO5RMndfs%X!ys zI*Brmp_k)EtJPq)UCnAxT>`g#zUmAOK!LFlQRU8$u73`l;UvTT&0PY;tRi-88@~h< z1+=LxPZ}H8226ZU3M-~z+&7Xp-$LX&n0yaQ5CIoQSPTL>mq9%J-z=6gUjvDzYQ3>% z@X?=4{JP%px?A1;O|qRWF%q*NnM{^1!vqAU+&cXjP&k~u{7>$J>(j@XNnUrfcqg7A zk+?g_qWd^t_hov<5kX(E$&doG%8F`=H-V&D?7zEt*z#C zFKCh1Qtv&vTB7(U=SdtueaNo<+tB2GYantHQ&N{H)PgVUrn{8FMSe4wl?p}U!6Lx` z0kLn&whVxIOKm@P<=i&6z0;hJOa>aLF8FhTuhv3WvjcTS!c9pMSuD;L&n_Ojtrvw0 z9(4D3or4#6-)F?kRjo*y4PY{HY#aA{?x-9`VN4Ev@{Jos)q>e zzw-mdtp$j-*fkx-u5Ue3TKwqE1i8zzuro6A(E8_VmvXe2$WrlXzgDmUw0cCVtGwC0pG3+jl+!iAm9;rYs{Y(=fza!7$5+?Co{)6e z=@uDWup-&1;JQk2in#-FSh&>F^AzV&%T_QUh*NRfVA9^6Z}I&N2yB)Peuga#!qCyP zH@w8-FBnZ(XbttK!6h++1#yb+ES3p0 zrWND6Iqjdotp~(2v8Y1U=~na=Efxl?3fpJ-nYU4e30J==#ql`ZggWB#$s8}ACK2ud z)$9*r4W?8vICVYLWfH?M09=#NeQiFy7{tO0*&G_waz=CZGbVtz@2!*5iPtSJD*L$L z^XmNi*d`{zh!&x09qz25_!PqfhEsn!*bhvvG5BsejyFNNtk+Equ{QS|wBKtZWh>rn zE*U*yA8D1ph5pQ4j?h5XmgjE!DIZ}jaiqT*$vQHLo9HC)xSEUSiEnXv5!)fp^}TrlM&XKu8AW@z_i-N{k?g);>rD_pKBs zjp0ZIy33Qh&kOaW@6+;=_22Be^@d^n;0r!swt1{0AIFUpY*3OApyBpoh8OjG;{Yaw zy@6a9p&Qzm>awfZOL2+1G#%I9r74x<)e|N`uZlRUTI5U|Zg)w*VqR44 zDju0GMq5G|OBtqT`_w1G^iZy@>Y*5i!{z?G~5IltC_b0lP^9y=qT(O zLmCDZ##mshB%#_KB5s0)g6}eiw%vJpThr`V6`%fOM*tu0HfW-~k=+S_8(@W>cvz$D zaeopVZb5cWTkAWF-Ue4c$>BhqL}}>pXeTx9=VsnnZj3z{RdDKy(u%8p{zZaWn<>Y1 zs|J+SYPCHWqWw6^_Dtt7WHK(c(wGV>x>kd|3jL&Xi~A;mrZSUlm!PBFLv_5>uYr7f z6J57lv%UXuOJ->&%1)#xVHYitqT>}QD+}O>-DtPQ+tB%0e0*(O|3@?T0|?3q4Kzaj zWkzc`&Sl{a_U&EX3*V9He551RPLu{0s5(!%EY|>Cwk~(|?r3l(Cws`?^Dn;6%Xdzp z7!h|(uks5?>9h>O)F~I6Q>Z5hhUqZowK6wJ4V>G}gfxsygM#Ar?3PNe!h^))b3t8O zly0Fbz%!hOXrlCD>etP}kr9#B={>mD=7U?crh*%}`4h$x=25cyGEI`;*L|l=AM)vx z4|`9n&MVJvU6@uw*2+1?w^>KtKC9ts!h9Fr`CvXsmmE)!ziV;jxFxupB`B;%iu!&P zZV-4?BGP^O^9(24U~@ZmJiKrK;_->gin~G7Y1^UQWt4p9x1Je(h0XG)7s4pUEOs~l zzsS>Vv<2>36(y+)?b1!mFkNyWLg zT~OU{dnmJchpLMd;qxNS=(Pp4ivwJCJ(ns1a-gE5678m3wpaTg#s=VOXErvcHmv37 z3LS%#a>v&?v19nHuke)gzMldBSM6nb_h-JNeMXI7!Tei1F}1m%er1 z(Gc1BYT-+5%NlkWk5EL7wH_@Xe8JUG=P;SO3PkQJTTCNv2X6?^9rjMq{j>oMhA#OT z&cSSv>zU2vMWHbvoP)!Sp%$m021|pA^#)IvM%(CmRCO5PPM_u5v3Q>Vcz`rl{Irb zJzvTp9U+hDH_d8#!L6m@4_xMN^!$Fqz&`m5z(fHx4}j9fK8BtG@@JXWCq4q>dSq3A zZs*8!1j|o;eui+w1A$%3LS0yd3#7Xa>hJbdPZ;RZNRLbYh zvC?ml)UHQPPZ7V*0xhHIE?X0|HvkCA_Oo&y8$S4at>7-%2pOO(dD%p1O>MCa{|uXu{8>*Ac-l{vA3}~mSGZ=tm>=(@4*A}W*L@i&yHWKq zl~)h|pZjK|_5eW_=b(8J^(c82AdkE4@IB2)|G%J)d3P5+0WH(;5Kd3o#Gi(g+Q|jX z^Q(^W;yB=h!s{ihPyGK56)erm(a0YF33&#V3@?4=enMM5(;O4mJrGQGO1_2 z*1SnAHlUov#?-$o)U&XGzEo4TTH?}Vvi#{lqy502k@32QB8V2edPPa>YrBaz?i@z& zP;Su}?h#R0)i>0Mqh?n(4QkZsOVtHqUO_VnHMXd3lKmwPa`VI|IY$edeXpT5ss(^x zfR@)kN;-lF9Totc_yn5R3tbOE<$AnV@d@-Gpa4z_TCQn&TRh4x}>&k z3qrvU20!PdnHa}AaoIaF6k6n((||Pk;=2TE1y?zodI8j6{d9&FIJ@fAPahgRVS;v% znVHRi;RD>_KVl|8?_riVB@ESu-Ldr8*%ZKS==qm~q&018NCC)}x(9#(VVv`D8C$LF z1C^-Kj<`R~awxM-#ZH(0)-5@n^AiP;1 z8iq|!2q1u_ugxi7!3VeyS=bAc27szg0U8Ma!}1@(EZAVOjtD6=&vOb$e3V|zP4Lt9AuTx+_KF0Z$ePj1`#LHMKNL9i~cICtqd)Aghcu4(rX#pji z38bvaB>NJl^v))^`EI&)diI?P_L_LEnA4T3De!#Di zbuH)im@I#If5XF;;_Drsn@A5?yV+q|W3HAy{)jnh5^p633fyEM9#&6Sz~NL{Wi7(* zW3oHDL~c48=9fCXPA~*$x1ykLD)hA&**T9f1xn<0<(CM+e7{rL?!vf|*j~*7g!GiQ zRs{iByZfMtvztrR<%8)hJL%Y}9oKx>2>sx(gO2j^FqX;n#9U`xyMo)%CsBlpNS&-1 zUFCca)j}$W{QTUe@j55DL8iG=DO`!FJb%#3X%7&xfF9u=urijs?(iaOc7Fkz;$W9W z%vUGpKc38RZQ8Yqz7TEAo8yDfqc>562;$lkE$iDJ^47|l*J46O^ozUqTYA*p-^=FJ zD7N-Okc};UvS_(WtnRv<8PwlJ{EIKBN`LAb3CzR(di@`@9bmA4)fQYnLN9VMpYL)R zkG^oUU;!{ z2F!aZcmD1|Zq4J*?oKH!fxNsaMg59dbgGSXj7hi_89GcX6)qlKH{m&XQa-Ej4}PeelEqR z=O((tl~BN28loxkfExuKFG?-wiO@xR^s+eE4Wo>&khR={blo#*`03IkXLTWw|1 z;6=lp_aU{qG30{OPD8I13LEhdNiHM+Pq>P7e23TB8Izb!Fk?Ngp3ZNLG z?eMl`XI6Hmv4-i8tX?f|h2Yoy0AQc2a6_cI0N+o>vgZBb>)fp^3F*&?4;^j3{FWWH z0?0M{shQ=(hfw9e#Bpv;+f^JWxjlbZH~$h27;}Ai-JsH~!1@plQ%@M_Vk0q+4dcc`%c)fdcg2XFI-?U)u1-dpu3=7249g}U zT9bh{TeY8d#ptnx&z8PSBzfq((})W)W7XdAd!t_J3!fH}3Q)-sQ323*PC-qJct?Zl zer>!d-|?~8RvPE-7&}e~Xh8ERAFnjZ@WG-3ssLWq;Wavf_;jWkCqQ!^_L>Fe2wGBs zS-fViE1N6#4w)$c6?}GoEcTRW9XY9x(yO)$FyeZqNDY$b<|+F=1vU%hJo}MX{TuBd zG}fsW@(6OB@S`;atV$PtkjM1z>kvQ71bfW{vxs2_ez<&zf6U%8l#GbRm(&ekyS1LR zTX12bD_Iw*UFB_+1rQ$6I>>otGA;JP1Q+!3@gCKRUaSiM=p~9LQ#BoJ7CkX~rB>yg zCD^iN0Q7V@p@K5Ic}fk-6=BxZK=-$o38dvKj#HAf5M#ci=McO)JA93w4zy*~J;+;L z*egt#Z5alDxFYLYL8qtmpi0hgui@KbKbbh|_GJ0a_2}CNVSPN2Pc&GTXqMVogC!!#`vIwlUjF9#9xbc2<{Bn<8GUgrUM;F z$hFJAXB>`uPVzr0@)sx^1rrEM>yH47ud~IOe~Z4}kl*cCZ-Lj(c(NGh9k6VChDdih zC%8z?l=b%O^YC0sm*#r@>lpOlwubR3`W$dIZuet|{edY^l3-+JEI3j*IyJ5*Ucj-n z4%PrC`C+{4t)k(A7cobp-C*pgf38RYiEC8zN|9BbK5_^D6YOLAYnF&k{tdxa$eN$n zA^WLEZOh!^SvylT!Uuhh+}Vy(=a$fYAu4>hgmGAl7VD~&K(!kn6#Ay9ZxTo!G3_U+S#lVLxe|)Z%E)L zo1mLA*VQkO{R{HOdzl1ML_pNwKf)oco_1nNS`>ab>pef1xD$KVGX)KeS2m(qa zkX|RT4u||Gw-I9zy}nLa+N?UmQ_viazu^Pd5BQ)n9)UI`f5xTi20n^QZ~MA3sMN-% z=&YF~6~O#F~ZE)oFjM-jHC_!fzm+UH?df z9@T#P=qW%b1oLtEKlZD9|3O48T>-0mIMolS#tna?t(ARCFwtT1xb?+vX?k*))Ni&& z2Db7_|J>UbEe}3Dx9g(VL&7wxV}x;QG*BN&X;v7e~+pGy6|5qkN<-?P@H_>)#h&X=A8E147`Z_!Hs!C^hdLEWy(Gn@`mKQ+OeGD6hAg75j z_9D23g)POHz%~i~{oq^SG?E8jc5nRG@yWb>v>}LJD^aV~&#CDWXfABc`OwN`MRdF> zLDT$p495gj744l`0@^CBWA45$pLwym@|=Qti1t*eUs>F_i$GCvw!8&pfo)VhzN>Ut zyzATeaU;bbP@ogc?k(09DO`4XiO+W30plL+F0rx$sA>LF?$sxCq77)zZfP0`2p8tf z>w3)Jn7)|BkTSfWInv_k3hQ117`SVQ#k^#?O*svdpAgkogn7PdN=dqLA}9#D#2g=WvF= z+Y6uy)<({^oeSgDniTqE4+;};pHJ#}x}Zy|#oL%McP*{+7%S8ypFSQ|DmzHCC5U%( zrR*jfI+QEU;1rRV&|wv#ewuqr-(MSVQHe|uu5YfzFF1b6p|AwM3KDHDF&#*tx(XVY>v zEZqD1YW{s1=hDva{6#<~9bOf5+d392?9ASDt#i(?tzefI!6V1M5X|>lZmSzB1qf;d zXebv&6t22H7TdfaA`%v1j#cd}9evSlR$5X1yXZhYRmG>qVA1=&KF5r;38dp zTOrV_p!X*MdG?`Ii4-{}DoZXY1F7d0z^@f~XRc>2c05!+Vz)vxP@XYRw~3RKbB&`; z(Dy0kuTnM`MyR!z8K$6Y?d+jMr9oY!Nm0m_0>A9UR^Yf*^M&E&$WjY*_&*|pI9hLS=+z3wY8z**oVlhfA!^!3g(y5_EjXe4?)!a&9C z5yQ8sR4oPiTJ4U)8;io6#wsI}ux2!R9w2VuO-*Pkjm4_i z`0>^emP>j?<7-V`Rwq$%Uk9A4Gh6WJH2eD31)%wnkc=%F`9!5#E2M?B+!eBF31naXSC+rEq}<_oP&e}idp0+>bQQpR8A}yZw161guDgZV@Ao?%U3Q( zZ1)06$C;`xP1E9G5~Z3gBN8Kw?T{7jGdXAylMz|b99otN8DQ#)JKe{zNos&ZK{n`_LQ^rMhZ5+?f@`T$AfS;vIXd z%#b-e2Kv5vrpTzl^HtHy0K;kB=hb%bSGu95Rpm60IDhC$7zwoNjR9(g9s?b|CZq?k ze+q|yUkoA-fgaRF=2%XzeOsLbZ~_p)Wja1ERE*js6zqzhf?92{o4^7rF4%>pp9a z+UZTOs6A{wobL_L+daV>b$xgxx${VG_nif>X_V6@VVZSl9M-d3rl>*sGFxd?2m#G6S~X%a&JS`>{9vIr55H)PN(QVS!;lj z#q|co6)1|>jcF-VpF5@4BLU}2btxGLYYupe@~1sJmcBCE$>nq5-1ljD&?-~&_Wnmv9?GLVaDh)G z<8jwj5!^5bu}P3?*=#Fbk!|okpGvb*evN!8dpZ3JnmeYKQ0@BS0uuTqkaX`hC3=vQ zJl-QzVxM-I(}}2YCGS>;mfzB+etRa2@Xv0+~`c0B51kUG!A zM`N2oq$DwTlnT7)LMwJh%4ZH0Ry$rO?e=Z$7RY!WXIAt)$*Xp{hXAk%w(`7&$VL@2 zLu3xNfSMGstlbe097+I>V8RE7fXY7b+7F1OvaLBzHTGz<5JlkOE*J*yVY4U7Rjbv2 z?wYYESQ62dfCoprHVFVPn(P$dqm`nX^N$(Q6jeLW*SQ$TuF$S z^=5%Fj=9g?{bgDf20UUYAsGVCfsQnO4{XH>hZf>=%;ahaJUxthg*jApV)hVB>==?| zBrx$G6_Vab2_4v|Q2&-9J@j(_wtURT=_byiH;=7mwuTvbQ~Gn0PEnQTmPuTPfT%A7 zJ>hNs%(eRqt9*495Q1PF7RJmSg3x+zR+yvKy_*9_eH^;u2NJlVw!y= z`W&Q!8B8p+UY>8>y69)ktFS#CH1i<}qkR0HT!JzfNv1ki+|_TPZ)9 zEo1dc1vMasSL?SQecHHhbqdw+p6|8(azvfe1%Iyh&#k-<=TjES()-Z~nD%Wk>H+r<%rC5- zdz8$$Xn?*WHRr7(@@PjBjy9nOh5g|jiUf*Bc36eHt3qbM#Cp_oak*llBu-<-3MjvXqI#dTHNH_#z?KS^xzPh(U0_$q z`&gn(sfMTcsHy+1?VUAQ2!v=(JPyam^-LNlK6Q3DGY#115kG!yLoMQp+||B^F2EDG z2%uY8xhT8IKsa=!B3;JUXCikMbH@9pUNb8y=8(d$ir!%*?Yi4*-SM{0gNYVz^VI_QdP`!77>$2B;l#D|y zTcfsRR^6jysoXZod-52d1ciWqx0(mIVM3o1DAe{63d=}#t+@0@ANnZ;-))i4Y`MB) zJMuWOf41wFe~ED%|Uuz^6IcH!SGNa?-&06;trg2cF00-&KE$ z9%42iS8QDWb)fbXCnN2Kd-T{(K{^6xi;JZ#{Qt0=me2d*EytZ5giKr#(~GHss_ z0k2n&h<>T>Gl!h=#~B)MA>7!RFZ?hhsb+;R_w# z&-fq6%KpwHSSLtYd|20wSFsIhn*o^ywgrkL*$a?Lzh*xOVP!Ys;uw)EPu#Mz8-bt# zEKQfM^qp%=Jk8K^FjkUC;$peiksu=m9ZHv7A^R^Sp2a% zx{y1Cu51x0fQNzX05BUu>uY z76_u7#%)p3_&(R^KwbAtD>H>%*iK2PKz36j!N&Ds`)T-0eb7uaf_sAQ*Gz@Ext51eGa%a;{ z;a#82(Cwrz8AYT4)ZFYk=XZhG8SA#WkaPZ)sTa?pP6nz671R#(HyQBNJs@H9>>u;N znCXBXo7U;0E_H~KXA|e>t4eHEA#wYC-`Iy=*9Q5u9G?R(hk+LziGV;#r1+d79pnaU znesYKBAR>F6YvPfi{#tfL;ZACq=H2KY;w0kB=sXGiTHQP@t@d;X0jfBrR`CH`n+q0 z-&{yCv9O7BbD&f>HE$-2Ef~1(FD^jslPBVDSF+)Mb>ltF?2lEAnZ_}^(hY3uoAd9% z%0|5m&OfWOF=)|j8o~*0fP50DSFS4@Jj<20!{>SL>>D0h&_l%KN2|H zjtUBL8uQ@JxLMI{JNk?Fs1aT%I@cF?pn3stLYvQmO9hg(f;Wfm)2ixtwB>}61a48L zC4X&Vx)zY%r&$sh1>fQBMyIsK>J$Mhbm{LOG z1+W{$MXEv=6cv{G4PD90Wx2n;6ZzvCwOk^JX&h%+7+Z|X#w zhjj^Yd(tvS4K?NSl4THGm7xgbEbtT--979j)e-9OC-VY4>e4PV%<;7IOK0v{Ysu8 zI`~x}{6OJCSE?r09r-1r{|{GZ9TwHvwQ)cMkx+&XMN)DQB?JYeW5}UvkdkgtKthll zx{(ft7+MEkNfWTevCBav^ zkP!bdU44(uMM~Z}Zr-V7%QpUP<%%$es|b^eDIO=mQlA!9!>lfC)Yr{y<}Rz$_v{M>|5XtiW(rNtoGSS z+lP%ed+e+lpp5*|ZH(1vUhVatAp&p;Ty)c&hxswXg<-GR$k7}LVZcXMayUm=qX0g$3kYiaJwHMUNRuj-4>%KS49o@S?j{pCa9Dv+^M`G|0kd6v+4=celc;61n89|-( z)DCq?1r#`w)zk7TfdjdqyByok){^w?!__+(d{>oq+lI-JQit4pvh~USb6@Nt&r^LR zk)<063YsQS1{qm3KWaR5icz+5AAu>XzO%qm-++1@;*eLFPfY75n>mc*{Gfm8Z1MMb ztho;qzxXH2#o`;B_22JIT|*aVg|hUNn^c3qyUY)4rdP_WJBpF$UlIVrBw)_}xo?Lb zuaG3_#MRfeId7A^)2Z&{vP_|MOfpY+Tb8ZeRfekbDW{95z8KXDM^;m?ykUN z!Wkfm_3wf|>wB^wDIb|=KIW_j@Eo=(2AwcvW*3BkbVF&Do^__D1*>I`jkQ_U^E`k& zb2(z{@jEf}Yyyu?U$ zCmL`XwBn^$<2{oN^L3kT4UD3^&51+)f`b>QQ#n&d5ic<$zF^K-AVtZ`%j)=JKtcV% zIHNjOXKh6tmi#tky~#tO>cn00Ur-vKK|=yE$1IAT52QD_B>$y|O(@`YsOQ+qa0T>- zvFv#DY6M_%o*$LGapY{5yzTJl&U_vu+D2tm=5hRDHc=DPCZ^T#3{Yqh46p4yG?I5T zY({jhVBL$Z6?&NlBF@tveN_&a(c-9a0=D9Bm8zLWarGT;ma4~8BabXJ8+q1K6fK)mZ!&?-oP5GhtFJc42*=oeI3sO2pDJCHnN?ZWV&Y z1oJVn^|RA?13pUbV*4Q?OY^|`9zwmGxO9OeWz7!icxa^Nm~n3QQ?H+C>cU*IdgS@@ z;#ojZ#S|Sf9a& zvFMCVfbYk(|BS7&#{`p>}J@EW0#9qDHdt<|(wF+cq8{Gk7jKzT2ww_}q$m-2j5 zZwXz`Z8H3O*iF)Js8+tYBMmVP4uWQ6Bjo7Y2k4p={C~8q;_gbXqXm|rOL*yHEiiLFAlMZ$9oyfm8Gf$HPr?gK&9#?6LL#p~cpnLqb0nu1 zvWDUqIU3dL^YuSO2y4fSIi~6~$6J(8-yV%8Q(F&UjLbeZEF&*gxp^*!zqD9?NnZL+ z4O!!$J>}>qCN7D0alBEy@d>Ks`7v+IB3Ff!L0GuWx~EHoIa_p&?P^g+doyl=PYs$&FJ{X4m=ORQNl zJRhQvjlakUpVsdP1QUE@yC+RLbvFt}1g4wy=L*rIW^D7m+eYv2h8lw!pA-94J zr`o_GnY&<|CLp~dK#Y8=xGm*4W7?mSefU^JU!!p}Ms{2(4Oyu#DoxFcz>;iMdt52& ztn>8V{O|X~2a@hwlZTgNX^Ke>xGC9YCx>3Ncm*FGo5vt_lTb zXP*_WEub`54dQt*;5M$8<3obsO+m`XrE^2pDdXLnmDG{Fv$%ikbR_#Suf*pOcLI4M zu}Ix znVPJf8(PuPa;PgGw-lW`3pf+0L%why%p)C`%h_N_l3#C(oh%l2_AR5-uES0nnwVI%GN_l1=P#IUo1YjJ5UkbD$~<$@RS9_o7Z7yEgybhNxS zP%=^-4Y)~OO4Z*BGTZ0D0c-7TUQV*=3+GD~u`q(+Cn$KReCX&O0hi1X5G0CYf5}UvPK9#SSX^W{-eB_p;k7MGlf(q@v&CN z{wc=4+sGW-o_Q7(-`7dsuY7UmCM<~l7B;e1(IA*Lrly{8K~O$2wFf_v5U8yZEkEvH#Ao#=MOPo1xd zKk@x4)b`riR+p_0R;Hcl#KhCFmqmtSO++ByEiobEhYhS z0jwM?mu1wb7%+)nJa6}8Ogt3-+$!~@{5;9<9(%1}ICIeLob`4yjWox6dlc=ICu*1n z@a311<3IDf@yR)=A=b?mI0UANID{0V=isE9t{kdUYh$g))BN^i?c?v*B&(pfAN<$U zVF7Oj$2+c4`pN!1onh;9=%>CR_lwuV*jH_3zN-!$VXF#7y^marc%^xVkOHUgWxJAL zM)+jbU&3r>ErAR@`Xsz(48&OmfVzp@YUy*%>TH5UU#4Z2xQw2xft&|Bf~YdcM*i%q zWIXCr=I7Vg7er$cmB@|$1J9q*;}TEy{s;t1jymeys3!ydQv}{@TpIv)lXoa0&^`@p zTS@W@O3VWPWbYeK&j5O=pfJT^=Z$lpuXTHz9<_DKtaIO~yZ7HEKR}D?41!H|$v!gsn40+5blo5H zx@Nw;PO`y4D2RI3vbFF{H^K}BAe#gjWJh`H*^BdsSW1a!a1JNc1`C;5@q(&e)*@1X1%2o8|5460vTiRW)rL+V=2a8vI$B4)qrdJY4|G%E~CfofcH~vwvc=V?o-mg zNl$6gH6XT_hx+k6Hy|HwBd`76=ZL|Gw-re9bnk!S(IZ%B^(Et=qBf@06(ab(J^j7A zjJRw>HNew=xy`~K$&ANzKo%HNUH1(n4579;BB8o0%f;WGh%MT*;^Bm!P~PbO7^oQ{ z_EKShr)IlYwK2B1QL*5~nnFSj5C>HZADBEmo?}!wo>!VkQn+0r*T%TpNYgm~(V2g| z*APhutI6}>y?7dD=a$S{3u5MV>T1_u`DOPIQxhz0Nb}UX<1*D@o^j9-pnH7Ijo15$ zR0vX?K@Ez8$NI|Ut!kwh`1=k4_35}?U=^S&6R|+J6dZGMVT#ZkAJiRzb z-*s}n4)HJ!Hf!#`Py~Y6Q2%PY@lXceP$XC|R))N zh-8(HRd=T9)R+yQ4>|@`bZ^vI3uI(Tka9eXCimEUe<_1^s>C2)j53ZpX%}CB*ykO234<_xhSk8E?(be7bo~^V%G9|VKV+a|lrz6b+Wx?K)@^-jV1`b=s|IrLpymp72FNFI2$1ZWmX#WhNtj{J+iPB-`7=M;xZj4%)>tUX zI%dO{I5zUzN8Y2!i(2y{aX$s?FuijUmGf-t24%*&y%_1>%nK)D7P2twVMf4*XW6*$ zyt`biWeqUh7jSoX&ERAq++{|(Fc~P7%H%Rgna^C4i@^;yZg*H&m~MF`Gzz)GzdX0%Vgu8xv4e+|gO zsSwxv?(Ax=+Bive(F;@RTaZysvwS%c;rRbDFFm<{*=ABBW8yYvVC%K?n6vgWjOViC5uM|LuK_J@BD6jR{~v~`Z`&UHsS}-nvT~+tYvr;ColA#@%41k>sFdn&A9>6@_L-2HECv% zln^jhZ+6xvDdLY;Gl$wBUqBo#Yh{1=o7oOnpu;fa-p=YboZ_0dK2W(=VSwtGuF&T? zw1fF+EZLWXwTDqb9F0;qg!NuHNZkQ(^z1-`Xf6NS@$KQ3NaRLUhnCl1WQlQ<^3zT` zFAk|`r1&G$zc8A==vl7MF9%v^-$}XytjcemFskG6-0=>ot#F?3g?xBc80Qfl1V1_+ z(6eoG(7*{+1_874a=G9P>%v&)g(NL=Ys_@ylSJdC74k$Kl;s3RskNBVpHre4HJ@wQ z!2V8Hq7f`;Ju~oDsP>_@d#pvn8R6}5lEG7K=1rH3$XPS-EA6lW7ThbBZ!e!zd4uOQ1^n< z#MPKqWMIPW_#`^M2l9i3)A%KYVg^a4p>%dY)mr96qI8*`C5R)ap$?YM;uo=b>t8`E zaCDIm>>n&1YWyakOZD!PP4x=o?S=yeyF~qpvP-*@s6C`w_3+2u_7`}3S04P$C=OWA zrqeksk3;}C3QgZ(Or_>`4AtarFBu=&tj%WQ{kR3104Nf_rBG*k(U(Zo}R6 zJdaocM&3&-!d*#Vygd;-S5jd@bUcw`%4&^_UtNMIbO5D9QQi73Gmma53<8b@>C{je zM32J_ZDYDf0eHmUgrS>3O#-F00}?XEPO*tzHV#h7df9bV~9on`_+%#CkIwV=U0W_(@zw{`=Sbl@qkhr`%Y|84t+LJ z2XM0fI_jj224Ffa#>4cA!d+96`!8G^`suOhwV&3LAM8fCu+bgO}M7R4*7h5lu& z-B=lucb8irhLSB1CMpmHa`#J32YaTTYuTb=fsV=x1y`qhaLNWi-uP`J|Vsutuf zz|^4g1v~+yqhENuWUOR-wX6jB*Gfm@$NxK$jvYB>$|2-3E_!9IDj*ur-M2i+Z_C+= zXQACNFfnl1b_Q4>%U|w0#B|q}EFCaE!{tdD`*mZXnLTtXJ?in{C`Q5ag578;J&(`V z=|le;i@p5%;5yYs6Adv0h3v_=su5)-03jUZc~JznsUXqeI$OG<7NRNRA|rk(M`yXS zEx;q>Dfjb|B+E)n`FK8Sc(Hx6b&vz67#aPaATI&aS;d2TmSJIn%wJmdJK5Q?1p%3#9*agnYWgt7@P-OS>lBv5|8|ILvv<)zXrv z{}6pv?)Klt(Hr+D%H!iT&`1Gl9go?{W19RVmbf(m%3Qj)4(VfYfR)=B<~QhAOT*zXozI4|x4x#bGI8^ZJg;GVgRI92oF3hEsC27JHlzjcwD%SCxiIEyvX zG-^D;GTm1x#O{!zHq+c6rl?#AxL+XDr0h4yMw~R|c6AwQiOr*vs=9~yPH9mTQn6f} z08SI3^5&6%%Koy*rRMr{#iHAP!m)}HV2wlQq!y$MjiQ|Oc54nOk!fduTvew7k(kT6 z%U!f)v1q6HxE%R&l`&PdlhNBG(&QsS4(Eo)dPA-AXZc29fPBFnpytu_-%z}}92^No zkc06O&t&mxit-f)NzxRR!4&V93kMez7xIJgFPJ4M5o_w}R`g5BZsbXiI=MTB@{W^z zC;fS3T)x2{-sFn^)~f?^UY#q=FMjB3x{NK+9PspH>SWM~0xSb1HxHZ$Av&FCp?pl; zXy)h$RbR-qmQg{P#|6*|1t1Xru^#2e_A4_5fwhv^hInuQxrT$D+tsH$nz%NZ*$N$b z<$@v0r9*8!Izz5R#BrvI^4E;Ri>Ta~IS1o>87q4a;Hv#^o1g}@o4T3N6iJ$#Xa+;= z8L$$l=Y?#&<3X|+#O6uRv=l74C8UvRkZNvin`9tVM31gs*y!-SlQ#_hZ-mkb1%YX9 zxj@QW&29d}?I)4Vu* z(WuR9ikz^Zul(--ur3CRHUWMhidm@`$l$X>^czXA*lHth2MJ=Nk$K#KmRRw43Qou# zoO3bau}DF$zOMUzz*VWf+W3sNQ|fRQDNuWdIeEHS35rCtU>btJDx8KyBcLBpXPhW9|J#l3F;lJ498w{p8|LpA53g5c=x*d(+ zQJ_htr7ltE2{q7}g9o|sWkWo^J#OeEb$Y)`u0s(Y5gV4LvdA0OWcV9363E6jwEFe~ z$X&2REkg)#jW0xUrfq+%I7-Osj9DUx1k1m(JHY+v!s z{NWh9f#)we`hJ#WSn_G6dku0Y)%%M$k+k;YdDvQa@3SJ!lUE?;qIL_SWe2Ao-pv|* zfJgFsOQ~6dzW89I{iz{CcJZ#GTZV5arb59g@H~h~mQO0&5;d6;UpFd$cy9KZBm?%n zf2-Iu?g1?NWcG}-8MO>r!SM>0Q^Vog=A-)g#k=Ptw@q`*RAK$2z<|?PEGE9=sU-n# z203rY{P!!^(&!bO-2vWS_tv`59_!i+C6Lg1z=e;JnTggEbyt zWI(Lv2E*ygE*IrvkE?%gya-I>-?D5~-6wm@>Muu&WdxJK!sjstORR7@zJbsdS>=b9 zsY9CzLQhk4gpLA&y_}CqgRd{X8x7^9U7tVuk#=Rh@1HeP_%KT))R(d8z|Hf)VHBLO zi1kNyYvgC3j`NG7;z>5iReRdQv>#q-zCB)Lb8aW8F9?70zTN~Qm40lOK*@DQ%-Auo z*2@^O!XM&-gV}KCgK!aRDZqvlWfv7V>A3~`_)6v?nQhJM-i2RD!U=tx`ffXQzoM}f zuZxDSi#jjz_l2Gi8+twn;zZDByR@6>qIQD?vkxw0Z>bt1@9pD#rGaZ?vc6*v$x*qx z{U4qL5YMAct4_@qJZjHKvNUU&pqM=vJ&`%gMQ>p)?jU7Sg)^;%bqLu*Vm-c!=gz`2 z*Ry&K7fONa+iv(lHOzHjpsCR=0OHpjb42!>XieuH$z^uc*GS59goKYe25BrZi6GJf zuqftL>EG1H--tzNqt9)Dbr3j?{-eGJ{*CNrjmfV3FquQKRnL<(6FRn04ggSnJ@znFqq6LH{pz z_5UlOzU{gWKfE_l&gLiI=fYcSN8CflCRxfrezoj%>P_tGFd}0J!N_AMaxg$lflXyT zoStUwfbyS{2tqm3iS_h4q^g8H77rPgV$`39c}u3M=brHdLxWW7?}Z}7H%D_CI7`!< z_w3i}0PzQuaupzAzPpnnu92dA2RNYqo_Au|laXFxdAs3S0f1Zy=(TEN%?9(%*n-)E z(4>odcmIK@ zwV3Aw!BGuOOE9YatZ=D!JeXkl^N_sP4|BY}YFj|uY`uPYI~>?meoMyA5(9?Nn(v&( zPa@k!0|?~FMmk_QnJ-AS)RYU52TkV5jPnR$$sm!@cQQ^Bi9Z%mm0AwO*`Sw;k~N0f z87^(B+U3x0#E$^XUmD;STq#fSN>89bFTNnz7w&)xM759aKQD~4x4f_bz^PyFmc{Eo zC)VOhT)qRpDsmE$dd&bM_RfPF%B#F~mf?#@h?JJ0+dFxe!wi#=tDty+I0&U&hGP`U z+Qn{+%ko%~>VujR=_MF=Y(cM|0_x9><0tSztp8l#xq0WlB1=xyy&%uZ{L=8mAyV-o0 zH;dz40}*kV*dc-nm@??*bC0u*SqBdQEsNeKZSrfT3`Rm^r|039#o>MnfA&F!d6Qcq z*(%4wmxs?KzHx6+I)*w=aTS8}_3t`cf_fZ+%Xgxt=5O*G-<8~@okAyvgE#+W&jJ~# z01o}w0VuvYi#5=r3QLeuzU@x8ERmKo#&WjEX9$76+cqfWVKLMqBN>NN@cKJ3KU4sb zDUHmDVjittkJ)ihF~-TORUzb<(a+S#^Fp=`?S~0;AZjbti1SpHcoZtr$1ZvbcTw9H z78BZ(5-xvU)&aL_^y|RP3|TXljSPI3R9RjPfRu#B_oVp_+-z4S z%HSGa)@3D0Dv%DJiID^3KKDbZ8I8ziK~y+e6N8&00K?_V+B8teb$UOsOvncH4t(AVYd=)WD;Js9H|*`6F-^Uc|Gb|% zk3O*ufZ^P~j}k%j$XKy-N8uLgFx}VE3d)4|NN1B!vW;4P+nb3joX!@c$%(pOn>Swo zLDeBzKn)xGwG9ffJ5e?MZZYO~>~+YEy3E3t|M~xLg>vp`o3W^U7c7tIi2MHVzIOY8 z=xCw26_oQ!bU0+N2)L+53AVB)9`H%@vWHEky2*unj$NrQ++iJc6+^kZtW{oT3?6Oyr%HSQ(R}LVFP0gZx}7wx;>fC~S1IM=$fq@SiX2?yZQ_o3 zDw0&PxUsaIJGy6jqB4B}AXIHy%3UJ?qu6?{lpUy(YD*6b5@5ef(V_yz^uIyV{*3y3 zQM+{~MUE6?r}A04o5T!=jxj*YW9&K5aSmKc+x+ZXVx{iSY3|(1sOM2@%1-i`GJtSU z0A9_q@Oh<6KzQeU|3Ach|3%_1Uj_ye{-P&-rGKZvg)b+m|yR!%_Vp zdp8cLhRHje61@k{aa?hVLz`cV^~Su@J^qx@Y9!+x>z4HA478QlY480B-0SdDa4NLk zW&KD}*Agz2ffvaH7DDf)sR+)rLNIznAuZB$mW!ocB`5c;tY#K8u1oC1>~$L!b?kRzE15GG=NZvg za^w2|ODqEFZk{6RzU2hJG{?^ue{K= z?q76%4mIo0h4;00^upa(L|1{g4lfoQw|bFi-6f&&_8h>csn>z2(R-{{|Ed7C|J@F> zp=K^P&u{QmYo1?CJHL-ro~`?2+|jlA~677 z7cfF`efXby7+e2A8gI5h>g5rif0B;%PAtp?H_z`Gp^ohEa2|6+n{8rrmY1+Ztg#jC zZZvLTgM>Pu8W`yz8XGrccU&ZmLZ1HgZZ3#nj9k#(&I1VRW~oG7Bk`hqj83e13=!e zH?g8FNVOT~ zNhaEm#9|U_hEC<7!&&X9cr5jE-eslU`1c`sTM&ILcB0po;j%`t!B2ulm|Ie3&s7WW zL{kJX77)GX>Qx#n8Wuj;YJaf$@Y4^CBpwyUh66qvzMw%chMYe665V&3WO=#*C+lh^ zD`MJ?Rovh68gW5I0JBTjY*bL1W2Ap_XRGf1AP)|oD9+tWUB*g726GTbk0Gme%j#u~ zEbl&lG=QgMy;Nq&1KPGq%Mw|AwXtCt|6WD-+5)4n!Xi3S*H^|YrGf#opMQR)g6=2K zh=k+nEJdFO7C)FSCMsw8E%#$T*>9GOod*tG5l!`x<@T}OVyW7JYm|*|d*ppa(`4yH z2tSzz7Dg?9?Yll{ymWrr67d@JF_GqcWY)Q(bIHB55^u}TuI+g7709_Ij8#e`jJbhZZu+O{VV_|v++;-DFPpB~ zt7hFCGf~BbTbp=7Cl~*M{hF(MPLrP^Y)|&xz%^Y4B(t`x8R7-L-guA82Q_-f7~0j# z-=Qp}U$fj++6uU7GrQ!^jFkfN1hhI8V5e(ro0EVZtA%`+l<;Ol6()8^QA@rxCXfcH z_a8&*67h6+9Z7jrpM=Ma?cI9(pyEVv>|w!n)QQ{mP~McV&~9$V9mp#7Jpp>{!1Xay zD}YLkX-n`;=mQiRQN9U7_KykYyOUn+pZ=B>vh~}KEm+_q7@Eml-B5I@vFVBAI7FQR z9jHF#j(>R-g%)KtWLaAkFFuPcY^VFHX6qw1$CR^IPzf%o-ix_T*7?n#s+jUK3Jc~1 zM#7~Ay{Zrjo?bm}jwXgW<0e`z=S!SzJzd>*-@SwsJ+Bw8FC&5BrFncgzi@q!K_C5f zLF?n41Vscbn8*N<^8f^?Fd#JsYCsXYH4Ze$O&y}70Zz|i7Cr2BfBxHd zPpH@7hq?}Zj)JK8+*QgKu}X`%xltWzKI(LmggFiPPczpB_aSC7?CXcdHW_P*(F5Iz zLF720<1_``)AVBjEbU6iGcG@A*sn$>Iti#A&8n`=@Dwd(HBc*IT6RXIM|GX`($LhO z^v#X*gY*~)v-gh>$B*svP9vL~m9#$@O$v$UKX;6IWam~DN zbI)%Fa_weX-Lz?5zf}X&DQ1C&n*0T;LmetxcBR5(nfYIzC^<wJd z?1%8O7PH#oGF9QZ5~YXN;2>n9R_$fdqlUPk62y5!y;FW*yxj9PMxhkh%W|#&1q7qT z6~lLiSNqR+tij2M^N!9ovqTj@m}aeKvGa42Y|8DoiI@L@(`Lg^Fdo`3ds%Z|?-#u; zsNgAGnk zslhBWBh*a*^-!*i^^@77+R30>)^m(sxKjt2vx?W^+T&~v1>Eo@(y8Z%HV8p5%Tqb#NHY{#4ZS4KX_)jd^B!J--kR8-L-%9TRA=?@9d&*si#UEy)Je9NaHvvclvf z$!o^DvveAqIZ$c$rtd-oSNGC5TH5l=;>4qT<83@Pj)y3=qthC~+v7d2q;5gp2XW$X z>V15=xTEYK`IpexE8%}zc~#3vUEccx@Am6k{D2pMvph+i92Ql1?zg{2x(FUX~Y_Iov8EOy8d|^|8dIis-*M?loLK4SR zVO5N~#ZDT9-xxA|29R)@OW}`eahQp8&Ta%>fv#;PfWfye7}Y3D;rLuYjj_BoS^2}d zYkQ7sNakjTwa)1u>u}&nUa1Tx7ijA?E{*OxCoG);Qi_B ztf;4g!{`JoRgue+NK=|xwjhoaxTL(Oo!*IQPWI~cz3ct!1W#L_ZI(nll!l|07{B1@ z8x}zI!2NBb9>SUdy?0m*b==Ob8M##3MmTi|0X(XPi)m85+7&1K4Q*<^iim#U8`#(X zD4>tsxt!O5POEVf?UuK4d+lx9K6J6#4lN(#+DDhHf$%M&Q&$t21*a=OsCVB7ia}sl%$%Czi|>S zHt1PzcCe?KJfc5$9o3UpaWZ#bGCTqLG#UkgZzjm!hq77fU5P=Uni&j6bjpaE?L)$g z-ZUf3WM_SP@_a2M3v%P8?;Tb#S26?w4ILDmsQQI4CxK8I)QySoq+hYD?7So1_{i)+{*z@a5e5$4u3kYf!g&nOpSu z0QU#zsQdc@6Ub@v^S)jdg4hD+V4Qm=hE8O0ym`t(PgG*-BZw95d9mYlnSW5lTpgpG z>lNRnw2_vnFL0d{3?|ocl4!2DUY80k@&%ydv%z?h4n}cMC$__B3&I&U)B7{fMh+aZ z&{%ODjbXBxZOFCod)r$^T3RdTsd7)FsY4x!>=LuTn&+O{*u!^Gx&L)E~pIEze}Yo%a{(w496Ww6n}WYHa6T@3e++LJ`+ZO9a9=oTnIk5D(eK;&D?jRoAZCTOZ@+lL1QkbFq6pIq>aC+X~v`iznStj(?r{VTz#esH9 z$u;O_OBBY_q1-Qbwo!Pn^HSxyE9YQ(j*;_7lOsW>NP0_c=lz=``PuHOOg(BX; z$G^y`4Pzi_xUWK$i^yj%_VUapb;OI9-Ur$cnq1@yzeJk!4fZ4>!-7xUula|Iq7S~e zFkQVCuQ7{DhT;Y@qd2{GzcgO2U{u$k7xteO{Qt+6_we#eqmfmf^XC%m`D_!!O)H^u zaN80+Q{424@M|iMTE`)0SGF{yWU?tI{urulA5r59&rar3Vg!>VWn(p5^-)m^UO`DqNe9I%Gr?|A=;?&CB6D z;Np@G`wUNa%+%w5AHL1AZi`w?_wM?L+j*Hp`xQmF^JI}t|j@TTGEJaBO zOnqz@nhF$178$yW&hrWq_Q6f4Y5!X2vRAg6l}ba;(^bC-k(&TBRhomR$@A`72_y1Y zIfzO+OBQx{u)jYQ;3wMRq|^PGHR93UHSx$ilWUTRta*+7`Ba7O_>irDQOm3s7FaRx z@4%TA9VN>E+L=%Nun3b2#lcmA7HP(;u()Osz~I?vnwlxMp7aauwR>mkV)!4YIE(9O z)2=&S0=PtOdaqQpA}V8+iijSOA)KJF3RoGAY~A$}H@HEn_a@zWL?S4EdraKGEs{^5 zNbWKFnGGQcJ!QM)VYGrK=`vjuZr5(@T1%VQp>C@`7#&qFKaNrTe2iQ?`SQ|qZtq_9 zKTn7;O2)BBGwrDFQ&bj~;ty^T9rT@+GZK15*5ubpv-SRZF{qgFtD{8CnO^!We5)*D z&k_rP?omkDoIn%CK@7UO)+K3ZFt*I&kjn-)XC`(kGYukB7>y(D5ltn(`cHA}ARBA^ zbzhYS(7Rb$SWU4xL79WM(d6wwixMm6Bhq0EZ9)i8tE$$S=xcy?)K;DM?2y*<6!ZcD0z3HhCtcF zP0fVxr;B)>jI0`WCsiE}*Hfx0()0AkYY*xiwTlG<#SBR72Q+v8c##UychjeFuqTck)(mMBBYRp{JuA}zLUyl&Hf`sGluiA&o8i5F^v|-uf#o5~ zHQjja#rwl~!nLrrNToBb96`RtN{YKW-f#pQdz!Ozv{kf76+Ig@coHYG1b`i=c zsvK#GT0En)VD-bMduI-7lyBtYKj60B{}62S^Qdt9=s3;0M_BrwDG@9|Q-ToQs71R= zn)z869mbw6lYdLV;r=Jf9RNHfO^;cgdfA;yyu9G`$@IVi12hj^k7e&eg+55EB(y_! z`etvZv_?1S`-8gH%>AYGEJvoeD=Y2xvye4)?%vmF^YzlGTh(ZcHRzxj^v_45a*sc+ z1UZSOH|oDQu~7z3T(KGAI4KYNmEPXwT%#ne!_<9FhYZ`C=IQzW0F3%401b!8GJ=U) zd-`7Trv&9}VXhf+$y<{}Vv!;@thwU}i>qCjd}5`lFkuO%U0}}vZf*)QhNNw}A?H&T zDFz)U3UfRRmq_1enBc*0GQ6Uvz~wb$rhp$iz0x zme!bd=vdP!Q&MP0?JDQlBuD6e64qx{ktor2!Ii-_vyPiylwEW}lW?gu!}n;E?BlNC z2I60l>A_Q1$5k**w)!V6S`=3JSzGLqRp3O;NcMSq2378uO*AsXqO`P<0;96UFJ~O1 zAOZ{Q*>CqH99e-Kn$|Jc=I1m?24#6=@TvlFac>Zw*EL1;#Yf}6m%S?K!*(;2?PIUu zlcqzBY%_wn*bV!R>|(Zsb{{ns{VCQV{PSNQNs4XR{F85K1>RErK%j*F8mDsMQHz9c zAoF;o5J&qyOyTJunz%QZbn`Pgv=h@84R$GjwwJ6>UvpBRVdJJlrMbL#F|3}W+II5t zaGH|TD(@|Bl6$%eLA(W9x{!u0hVuF5XChusqf2$}?+N%W{TaB07FZ1pxtj~ml)P?p z<72>H#yd&C`kPFErRSfKPdn_Den#x_&FqmkDskCdS&s74qdRwoGvDfvzi=a;`a;`f zXz+dWmNq$c$vC#0p=$n5kn}q0Wfop-47{U7SFkp)8|~pM^82}xotHjjcH-p)?2{yg zi{3KSc<2RB*<4fmH}Rf@DwVXa5?g(1NO5hkx^1T%6Ug11mw2cn-saMHopW6&8$zg*CS-V?xoh^@NoZsAQVLXT|oiIsRF|JEDNqO$uDo8(vHRFO%8 zMsq*4fp+ItAFUrf!$XU>cJ(SjmEHdv7%qLf12hnLG;1=ZF)3l6J z`ga(YHGJ}VrGd$L)o|8y8CrPbHMW}%tom}t}8Y5}hhXjkph3ZZC;?z~= zw2$A>SB0}<7I?+mQ_JBd!ksXks?UK0Pte7keF_s`(%Q5i+nt41DAaJBUfq9W>`m~f zOsQX187J%x zqUk!*>C$jeKD<@pz&yWnglP*`Un{yb(eCjZXHq>XQ%nSEf!rg-`eK68BlV zdA{Ekh-hYHy5|!?UB{d3qUz?wa~BJS733C+zePoAEMX0|AY?SQS(5HDW$=h#&K?q; zApOqRglTtacK9Xr!QCK+Z@YGt-uYGv^m4d$<2j!oPKBIwdQH&{h(5Ab{lQ zv%$EN7sw(zR!0z1n$Yc`At3y585NFU3I?P>&PFypOZ6mf7^+XTz+>f3Ae&)SGxWz6%rVd7dwSi6vKKP}* z7H)MaOyyoRjDz}aKYO~db)emYg1B31bM2-}QPNCl@_FSBysEVsa=d74Lj?P4sIvvn zTk(JFF=HA!vuwq6QFFnA#g)CQ$-F6v&xPuhuw?^n(6!MtgwxelwC_0K8>T9odV?MB z4bcT14B%;s5jZ;#E%Cnc?~2TnmYwQBx2k-^?sb_IDr55+^7 zk00WP?qc)wuf54dH!CGyJ#4fag?9*F?dni9Hf%j8?CJ3OG5MAX*FICyr`Xt$X6S^@ zxBaZx01sU~q2trNWsTi9aYF-ZwQO6$Ff7HZ zS3uR>ZjJ4g*k64tvy=Hv2wJDh?wOhC&(-A6yw?;ceYJ#|<^1EEp*1Tq{CJM81<_F= z9-#TNZ0+%+gcIB>9*TP|!$uwFD%rqnir%+bTHS$(8DTMPCzfTuc+D@E7!lj?{(Apl z;JUVvA5&kv!MGCr1G=!!lfx7EBT|Ec;Q^z=m;8@0H0y-6Z!ei8v1Q(VX)nVa(4RC_ zzDf{ng+25$p&#ZQ?8Zs)X6JO3vKk4Meiu{D@w$WtO`p=|i4b-=a%G;T=8(y&k^Hx9 zss36SmE~P38e)fMw38TeB81n!-GUCL)7=!?rYFr2uS5Ib%%&f2@zr55q;?L`xwJy@ zk$vS*myTk@hH>Do-J$U8rKvT&h^AxA57-B?NX|?M@^}G?l38snjHJCE{AA30=eZzu z^#V^!!?(>IXFELuhnDxHm*^a$Z&;wwIWz0mBHj@Ba8%eMJLg*^$cGLNHf^l>@~w@R zJ7QO!Tz03}-~M-vscnr#W9IEj!SxuAmEzz}aP?fpwu`jzTcq;8#okh5+^jHz8>~9C z^#S9R$k+}>v5mQZjSejeyKoU|43SS$seLq{iWWPE+%jv{AUth>rg4j<2cQSujUe^| zg`i7W(THeKe;Gv?k<=TaNp9XP0~O`xkQTX%8wU=F4@@ef>xiKjWv=hKqZh%Bh=i~& zC(Aw3ytX>8Jo$n6#W(xkKA%-o9LD8Cy_xF%Qzw+ub0xK7G29)o>!)~ay{H$Tf*N-i zojQ9s>#_z}uXtE@UAFFgu2m2-O62M(B{kb_OR3m&Th}15X(6f9)ZH8dgLI2!x#X0* z8N=KkO*Q2Vj35%ac=t8h9P7<}npr2^S#v)OwA6ccjAj--P+$&Y!B~Ekd;rUlV*+x_ zaKHEPyS$vhIkAK_Tx^gPtVTs8s)qFfa$z&(^B`mx|hq2hiv{lSmL?l-2*;KHtJd8U$oj{iStKP z#qyD0D1LquP_>hcY=j`SvktHSH2;ofY#oqd~CLe6x(^jRFeGBO~PuS zTC@*r#p_T3+F28KKEeGqqbrYRcCMoTf59Tn5<;W5H9TLyy^f*NOzKN8yG7NkMxbVK z@##2y{<{F~l4mD;$IYmH;JpD&;qmI1+a?E2-5=!QW!r04TFQnd-atvcj)v2mW`t%Q zeLvT~_F7GQ$&0UR1kr9nT**aa6i2+tU6U!;-oS)CMa@MqldrzPQU1z}N87(}mT?77;+0m&f2e~X;9hu)}ORFiunf-B&-@#$+wc zm*4tkiK_x?u=P9*j{iThzQQ5OZF_rYkQNwPa1iP4&H<#myQD)xYG6o_A(fJr?vj=m zKthmC0R=@#De3-R&OP^@)>itlm#Wy)U zCNJ|`*~fR_L247$WsCak+35)KCq~j=3End5Y+Cs2^6dz19NU=LqH-%+c;$ih1iGb` zA|G1VJ?;#=O$*Oo)RwBglr_HL@2q7M3-Kx5zdNS{)xCRnG*ItAu_!mufo+AiMDlz& zSj9v_A!Sp^TjA(H3*Xem0$f6!FI7F{3y!fP)*c!e)o9o0gL zYF0?iyYYlf2RG1YY0Ni*?PNW}9SNn%Ru!WVl_bCKks=_Q8rM0Aef|rn-=#o#cR>D5 z@0Z0V)55{HOB5r@0vc-L%;D_dcXnDu!o{rl#Ck099r0x@6WLttr!y$^_lX#elcxD6 zACloCh>DdA^+faOQ>Y3vZ?807`CRiYhvZjCz_OX=tx-8wQZNJ;{qo@!YtX|K#rLAn z_GG6Ph?juwGV2APpOKq9R^q5s?%Fo)6|jBLQ%}Wd>AWbeR52W?!je0NwHjN$7kLgc zwTp{SX<`|-&H=GoI>YMr>f8r@q28I!e|;0Kszpwxth`EIkpno7aojSA53N1}Hy=j3 z;*@SFpvpaEM;Y5VlWdnuVjv)6X!IzSS+x=ep;b#k#sDRmA_i5y?g%D>b40Dm;f~Wu z9^2xYe{SMcX>B{d{i@llhhhGjaRn-WxYaY0c+Sv~C<0l)@JsSlYI~@~2}fY?;jYs% z9&4P3i9Kh@!e5Euj6{B^HmdBPvUj3YpoL>e^rCkLm3Wu0mZNgUO0C^%DF->5oMk-= zv<>Ez`Wb!n19FvY_7(?~oIjCntFRDs%B$J1!%;^CK zHnn%CphY|(Y}8%qO0&XOb1@P2j%QiS3A3=N3i$DE|EQ&OveGkP^4I2nxM6tb8Ct?ev||N!^ZV$rTx?iX)}B-a7}=9&Q4&$v zVZ!X#i@6+M8{Jd#!0nO2Roic1`9U z>8B6zybwSZwFmWou#NGw&Vlc=B-J>C*G{-KNz7Iw9GAZ{COFK4|MC))XooU-W9K zZrE&Rt#o!J&j~(p)8jyjclb_U=v^#~SgpO1q22vqP}l;{}9Ge)HbxiX?Vv^&d&cVl_ms7zi8OyZIZchaCl`nPL zQYS?|r|EoPE9~}F4$WqN8E}xLzK`(>#RBh!$?5RMOTQ`Kf_;+mYD|;i2f7-DG=PO? zuM3F;b5&yUAtvwZlbg>c&&VxNJhU^+pvG3>4=_w=_*_CxU^&BrWFC61;WSOw3=W~m zQEoa3?3QoN(aR}5vUtt#|3cBH0)bD7uhDBseQa|$#rz$WU)bGVucul3-pdRfCb9kt zw>A?U_cf4FoisT`#~gLni>9kfM_OUx(m`EIE9jr~wlqht)b4{I6#V5oJ|EWm=jK)f z!95Pq0aPWiY6+~u!`cj|GZFRX@Jf^9>N)0l!zZNdG6vCMP@xac&3w&c%x4`x;lW2< z^nXI-gkbzKkp|Zu*GPqM9uM~z5fvbK_aRiNs+2t^Ia`Tfv6PZn-%zeKI~dPw)CRfb zAS7Ffz(Zz;65$8YDXXrC)-4*&f8g9dZgX!Obsi4tAN9vH@n3l0Q7|o5L?&3@(1YE( zaKk1WfpAqJbuz)x{key0%ae`;$4-REVi56Yn3m)4pha6dn9q@&YQ2Ukvsf0j+L>cG z;qjxGh{w`$oL4=+?er3_9#KXbKDQzVF zu`_V|?djn1i&I6!(SFWkYu%aYB%$iP(O13sd6jshF|ItS6x0f&E;en9y@U3rpX*Ww-_Xr@zW4b?3z#GCFE&(0 z$}}hU@}8ky=@m3X(scy@21S{U8Pa0<-`9_AGNtR-Dz z1-Li^&QwgM(A?u!`HLf-a7}(OZ5@RlKGH-GpR`~eql=;s2n#qkKQ~c@8HXlAEKym_ zu&6>S9P;iI01x zkSwiRzvjkiZ**mCS$m!}rEQjksTI8!e7OD5aqoOR*i_^WL^&sA`h6*RqNHI=WqoR=stdgaA6lHoDc9d`pMo(P|x1 z_HKhGq`&I7LS$y)nu878cr9h8NEgYfC?k^tiSuWDyYfVih-`}NJ*A_= zegNu|c%eUny=E?W;0lGgE+i@DMu?xBot@xi7Kq8yb5K^{SQbu&@XCwgYlPp26>RaZ zWpD4iPzP@Fz4~FZtV}-$x)%zSJf)sfZ-9=Y+qp1JUQ92&=?-i2Y3h($_}(cgQ<=+b z=qWtzl=C8mawoR}Mi?!KdNx;`2DHCXWC5o4SzS9M zvBYVC`0+frdH-dTNB+H^IIMAK5?_R1!Kp(zlO>`r&PqXcN z47;+gY?AdydMN(9RTA@fxw6iZ0g9I0?u*{&urKE9+Hbbgqtfx{NHJ`3nc15dB8VH8 z0!GMa1H*pCz45}PwikUEg7iY?gc!k7q_;oU{Cb08j#|GXWWM-Jz}AEPL#aVTO~VS8 zqn{a8XZb~=r`Sr~MeoP}%?3ki$;bKx6k^`ham^TrrkWE(x}Om@C@(fy1o{D;&yFFC zaw3No4X)Tl++a8Wjffc=K3O?@=Q^F7F(#gxjb}|~Sv~*Q^ws^+0JiGqVbxahm%ryM zF9$~wb^CM%iW3-(MgM~Ce^-r7q%RDA^}j2MjvFLE zoFApN&bPRzVOiozqF8e=uOQ9L5*s_rC0@e8TO7%Y>j#c0yhO2Pr#bZn)m_u(Tj>cN zW#fqyvrg95o;|IrVNT!5IKu-KI&~*Ul`^Npv+s(aN2C~tD4OuAk4KS%j{-o@yqDOs zxXZ!ZC}g#aD={m5D?D&=5N09E)(r1wW;kCDId0&J%3<1jYjt0T3p1R4MxxPnqPLI2 z?$Pr}Nz0qpkn7kqj^Xg~lQQbGLAW1tzwSo!=(mgg{UdcfdnHy&NL2Uvz9js9+vhRe z=CaplEDPpHaBk8Daqeqa@)(3kI%f=KH!eUulF&@nXyqbS{Vp5BB&+fdcP@S87)tHF zIw08%?r6+FI22($dlEqJ7&Yyq$Kh5HAj~m+UWNLuEd)ss4~J6__vp-JXMsPws1`2d zfK}psuy0`n;~pBkgI?RlMU6M2R7SUyx@k08dV1zgeu>fjP|r+p`6}NsaJQAM$VGpo z2Hug$0l;|cE(LO2w@Y zT;xlJS=pa*@vu5c)|%Jf1wgWv${vkxYrl}odwzs%$ff1mv`0DB|L~)D%a-7Tk5;d% z!9?xffYyQpQ=N^*Epyz!GMWBW#IkeLpYSArTh}e~DltQh*+GUB6@;ory1y*vetc>^ zpYh%D37qi4B6`S?5WPBMV7>q@qp$y9T90t@?CKqc!P48y;$u1&Vh4T~osuJdqk31iWv% ze2#oV;Hw-l$I0z<@Y`04XY2!|)gjAxra46ap|<#!a@`Uq5LdP9BQTJ#=es$?jQdv) z#9<<_J}M=>HxGyk9C^xeCu+l?l1bovtHR_uL)Xu9a}l+?nTM>{6#(WTRdz??e|9P% zW2nap!FB$1x%}=tAKfZJ@~9~OvUu0VA_iZtcaZ2@++r52H~Vy$`JTh~vOqFc zWF0Sne>GqM4xy~rh@@JY9)N%(GY@o^o~{1Y ziC03(p({^tgleOgT6L2ni!!)Ae>(g+=NfeA&Gr6gjoN;nY}S~EFN$RhdcP|ui{<;2 zGHn%nfz@G`|M?dMCe2LN{H)hlo`ca5gJlcci3=3e40ArDOT=5{emS3n;0$maKOL@j zW=2l*9*h-!`A+h+(XmjZGC>mbkwJWQxy>Wk?7#Rh%i?q71rYwSB8A6oghMjwb4KWi z(XFfIOxQMs8R=`V zmk*fBsB%_o8TPU$K~3f?LstEb+{fn zXTFa7ryng!k5rP_oND0}h6AZ+`uw!_9S&$K_vXzDjBjrKDW@u^T9|rEwXAo}8tF|o z8OD~MnI&=Tq79)tBY(IwFOmk zZlIy@rvYXhPJf`QGx5so{U_FGT#bp^I&KSbbstR^zO7Ptoq;oj<1eoKB)iR+>=l=C z$g%f)Em~W#)%%4;1InzK$Ofxo(tML#TqfBf47UpI zy20(rmbmr0xUyyI%X;@3LdO{C6g*CJ{ewWAqzZ>4RLi8V7hl|iJGM{X-4R3n=dg@d zd+9)ZJ@82QWKwc@Q5)8bi|2`e1-4%>d0MB#(LdI-tmJ@j$Mi7Qmki>~c~KxV`*%QS2@huu zPV%45&GsBDxVZ>#ru?LPKu$IF#ct;2pGTX!gQ zm@juEQt=T{TZx(A4y9Ou5b4O{$>D{P6V2lEqq~YH%<0kR ziQ|oz@$l5rms&ELX|W(ot>48L(+vF%HeSWB#Z{iScbS`SW}|D4XqYZ>#)EP-+k+3< zXZw4yfoWUqQba@RSmo8mfwnfiFBKav^2+G4=yfgoo~{IHHddW$a^&UfXSpzMtIY4T z9GoKlDPn+*aMGjoixyJ8S4!fhqz4y7q9eGvQ=4;-XE3;rt%tKgt8^1H8?mJrqPQU( zZ7=0hX2N{xMQeC}Yz)w9vApD=YP#8&OAAYfSliJTclTr~y>j}{wCv}K%7eUzj47t1 zcZ_O34&lUVuPd?P@>P#38+@Fw0 z>tQ{2mB--a%h7_kLyZT{eD}+}R6neSZtF2UzPh&lUn^zA3wAZAIB%_`i)pf1xm%~Q zXjxJ2uz2VU>yYnmD^jh?D^fI!4MSmJkN#Po<`f+e9p)2W1H@tFC&}Tt(s;t{ZP6?8 zM2NDN0676Tu*Ej_DHvG$kqvU!EpT*8Ean(Ahe=H}gWWa*{def9jvp4$?flhrJ}3V4 zCxAPxERKPGeW!=?(a$72Fy`S%ywx*dRFsAsEBlis@^CeiDzMr>CCG_uC;2}RgdEkX zs724QYb+-;yThJS>q2X_f0U=C0*ywVfBIZ-$?nwAGi{ZE$o{g(ipRo@E@0U~|{Wa~wR5GYwL|R!1u8ik^rLZXKDSx+Bee!E1St;Pr0tgCWHa@Bu z%(o_atFA3zMcm)QAxgk|_Nx%&1fqdsp)qT*KHTq1d~g0aI$;>Awy^?r_IEU8!iXY& zZk~F1?puck`z6Nw0ytkaa;w-Hz@8rt!h}_ z`~Z?ukTEUiMEI|?ZBdBL@LgQ?{SPf7q;tV&KtfRA1J3TlX(Tjeb|TKt;U;bpHM$=d zT;*-FfpCxl1(9&sMF6CN~f2=f$0PdWiv<)Vv{8D-8! zx1=u5Huq>Jh$*Q$z2x!Qv9(Rbf*IN8{=mal<~6h1cVA|7cF`Mo&Q{c1FEijOm)Vwx z4Skm@N%r~Q|2khn8pmZ(QJ77vXZCNq^W_nQ+Knx7kr7}=&xvp6jh(HNF@NBshlh=pb*D&#e&875cot&_P|jnpA&ZDoy@)cy zkhGF$bxfl7&2S$S>at3^kglt~VXT0saa=07FEcplx@MoQ{7nz+oPA?(@rcEhW!8m9 zX@CkhK7yUq&~l@)dVTIf;fciqjEXH>1^0sY&-YYE-e6cMLq9O10|*{TP>z^3g~7*T>qqKUe4e zXEs1jNY%^gZJzak393tD(S5LwiLmEPB*$3Iaa>p@tKtWmp4zRO!78D~3_cyglZ@r- zY+XKR)ig&Rs??ijy6ju0&!eq<(CW;sDoKa7j`Ex&qsH<|-$>&-5SM;=gYTxJtF|v# znbcKMjV2Z-=Up?S*{WhuUB>C9Im;c$>fF-KCI2D%e;#4l6_c+C0mH0@CtyZ8_G5NWFnay?`GosODOjG?9;i9~Z|4czDw(}m zQXNUk+Dh28MU#Ob7-c8+)!MF@AbTqz0HfYqfyskkJnDKXI~3m@(@>2bi^=a z>GB!++#mY)`qXtkH?5T{8U*P%?UyBIz@Xl^1$cSChP>tiE{&GMW=lwj$D~eIr^jAC zFc=HA(^zd)?3@qd=$|4CE_Rj2M(ZTSw*gtbDpOgr+|*!L$w&`-?Z9%bt^=g#NK4GU=F=)EW7>vwNr!p{2z=ErONaR)3g`8 zuD*0Wq4Vl9C3ln~)_`YDF*7rR_H&;J3d()Z5W2nS#4Dl8ojC~)=7Ro9^{8nXSdJLN z+$Koj7!v{O)hA6OuC+J(RPov8ke90L?5q|r-{%znN&9oa$x@e_8uwka3Tl0Sje~7> zaFLAf@B&7OaPHt_Uw*=CJo$JyB{U1dkMAX)Sbl1I zf(4roK{MeO##D!F(73EnDP&j^*oq`WodYl8P=HB-0e-7Zw|=&(@y)bfS}tSs;<|#j z%a3kH)~j8p#dqspr_EByXOL<=&8q*Ms4G=|>Ce$G;BGv7_Kq*LWEi0#&JM%MHsc4z zN_VWq^f%K5JM=%-n(Km;3%sH9koSt$SGKAH`0ADaq>9_PEy5&~8?)ID+h)qYVFMZ| zCS8Vk88H2w{prDY+WP8HyvN6di%CWYCRBh?+A%?H+IWoxti(C`lx0@|U@RCvT3Dt%~jgC-)!MI-#heeqHDHR(&-hf3y7J z>_c*f7$Sgh^4^%(CNr?I9QR=I&9hZOW~gyiZ|pvi(~}t9-{~oTAQqH|a9DO!R97rg z5_&|1L5gA}-|1^AoJwC#;=$v`o`BZo#~D5ciRn8f-jlh|H7JqVwp$3W$tT*^-K2h>K$&TPdjIxSyo0=tz8R~S(DIdXrBLd zf|)-2MW3wUTDe$B-8RwRZwdJ+fUnbsDj!8Do*FsEz0@Y&H7hi9;qe%qUZETKgnYAS zQXdS%qsbRB>3`n$Kz-#f`^g81pyJ3=l}^pqhkgMkxW@HJ5Vd?4!$f`$QQy_fC0oZI zEcdD}A#q8WaV|3_d(l^rAkHe#7QdV#Dfw@kQu&MGi2ESlz}O=hg3vA`Ob1J|Er{$hOK6Y2gYj)dYGnMo%I|iADakWyRT2gJDlF=~@`yZpB4f1!PR>~Bti+9~?vM(eCyK)QC9b(}$ zB`Z@{4G+8kFwTEDL$FL#-5Ga16!J#XnrN9c{;L9$4wFv? z$Cs%6{Q1OK#5~$W0$sfuUPTSP!Imo35r6Co^*s;Q)-Bhn8x!J|a)@d5xBAY=a<086 zSS})M0>bd0*PZz|Sc|Eys*gMkkz~&8z_mfj^G*blWuY9CIEUBWe|#Al${bd87jO0m zQxOsM4~KLuOw;-u3R$u26E0trD+}jT?NR|jtP0zh9o-jO$OYW-Ym;EcN_%D|cAERYU z9^mG`V~4g(m+GoVhRe6!9Vga{`4SXP#b*1ES~E|U58Mo>23*UGA`V~f*s}n?@d(d^ zKlt?Deqy;2l^mf8F&(RUW7J!Of!n<2ZeC3*#@|gj<`0zP2uug=aBJ&y$?6Jj?#*Jd zax@Fx3e;A`Eg-7u^GgpDQ+`#&b0sXSWhZw>m#};b^9XF6PY#BaLvjt~hfe(CZbJ=Y~~iCU%0q|1@Dy57-^)#`<;X4E_K+OPog| zm~&(}#J|^@cJA})u(t6xp$8X}v3z5Hqo<*p4J?f!5-h+DB|MTI8)6z9y#INi*g1*% zcm*eV!9se**1=ATyeUBK#mQfZ&VSwc81mSGBpp=pvcMu2%*d{8eOu*c<`@a5gh!ct z1Nhsg0N`k!IgQ7iExFF!0CzOge953*`CdrK6!HuiGe?6Kq@@a%YK&j0@7N0u*yhcz0? zO=!vGHpQqj6YPl5E6x0OjqkvS7|iL}r?A{eDNx>Es@3)ih&(aV^j_v+?QsU%WcwAs z{iqV@k>FKm92NI<9HxnWnkyZ8& z4jTF9I@U{3N*9jz$Ex91Y9I(>(Uhu0VZdPRhfiNrTzGEYQv9SUOdSRiP_MTdg8RTO zn?(SKwFhH=>ryc!&B9Ne4VIXpRfMxks8wZH(L3>#NpSGuP z=-!-SHw?hm;35 zy}X@|;E3)ftbkC?$=A)`4p7RZ_?yOJX1)PSP7D*nfo+YrDp-&qAYlEQIwrJ!k?$Xs zZ|XciutW88GXLq=*<{mnPqvWzlf7&q?qlGwrrW?{8z%2<_TAAFuAkQn*NBP3bGb@$=hFJm<=8r4C&y83Oez8?-{t;(4w)4s)^>Pr;@@( zy{80?Z|m%x6?8j9@Esmgukd~-o11THarH?8&|QB|Ce7tap!+J& z$X&B8dN^N%(>5yQU%8q;2rLGc+_C_9PRhx^RD71(EXNCR#b$*9l;5s%<{4WpaBKA= z@eX?<+_q?^gAT~NcH6V&jn+R`*?1Xf6)p3Q)2n&7znJb>V$Hd@2UY`7*Bsn6xQ~7) zPyr4TU@;iS-tLz%O$95FMs9!+fuE>=+fK7F2dAgX;+<7F%hbkE+e!&B8muoYOG;D! z?<;CTjw`&+$GEztl{p@%d90SpE&j?F-fBg+aFSInL_~7RjYf)i`vaEU6pFj@l84Ox4ENx@Hjzc2kl8ktXHxtv{u z*N$D6$veXS{Q9-H&bv(VK6@Q@dHMR#TW1RoP8S&iuWl2}JK&g!53{qUoW_O)th;is z`Ss2^%y{w$u~gNH7)aMUHNw|KC9Z>l441>OINhcHlS)SxadCQZcY@O4)peB`>SW$( zsWJu=1eC5=bNUbA=K*)a_nVqZPdtI;Tn5FDl$X^_2Ps!D9r>SX!~G|QX#pVHCI zHqZZ4^U9Mfy7r8E6Tmqt`i=rJd3=`f^(|r@#g)ByRBW>}wbM#A4Y2eE>DvjyoD4Vb zC7@kuBIG8ytiONwsER0@q|<$9LH|D)|KIt7yUgbBTLd#%$Fo@>t`g-eTrnB)Q5zBO z>t7{Oj)8Q5`^GQV5QxrQx_Rrk;-$sQ9#jN98kURfyRLUzuwZ}|B;>MqI5Y|W}~7l z`Zmygq^3dENix*_uaa8m@Lx%dyViz|+FVZHZbm#6sqcaGTqj;zn^C__yNr7cNydKP zb}jQA*#6HmJGMw%%BoP3?iZ2te>HhfK>5=;K3N~z17#$9+VjujZN7=tmTx9r%dZvd zP{=d$RwHfY*E$osiWXL0-1I}R0f04Ukx86md*5eElm-D7gqs&rVO{kX97U<2qQ`?D zAKbJsqRsuEhko6h%2ynRl7?nflXZ90>f~1In~|#}XRdC2QVpL&utaqzych4nCn+6~j@vvc#SDfRhBKknC3Eb+7{k1{x$gp-x5twRt|L<5;hg5Mx?qI2 z-pNDoF3|hk#1r!asO-CxQB@NFD5-Q?zS!+QcP?fym1m><2GrvJE7{<1f{g{;zSIXk z*&bdEXhV*jP;|a*wdGHJ^BLfDguWM~IlRazFw0r)tI!}$yd#dL9GfVcp|$L`_^8xB zOc+VTm-I5|?PK(M_*8aFROH5{z#BLfz{HII%8W!|qTB2SEyU6*2UcXU5g z-rlh#A*p_?SN=f*7~4|^V=I?MbgOuOz7QK$*Yy2P8kha1_?CErHNgEROO)M;041PA zZ$QjFTsHBk`FFafOopX3jrZxO+{#bpcJq^QCYWnW^446V0EN@98j_uR>QPxcnC*tThi&ZXcO?{)3%|W!s=|O^@_0$7W)SDfJ)77& zR>{Y*L|Gg+*6f$R^cLD>B*(4^JI+xyz_&W@H# zF3!j1h2Tjnmn*dPai9{PZo_uOYMQ#@c*e?c_3)_k)nC5u)(W1s{yey-q4TUqiV+*D z6vR$*&#`#e#|^8g#TI0`RN^fQtY=9)F2iepF>#k`{_AZ%I(T(kk0q2E%_yjdb{3XQ z&u#$a(~SDv%K(?+>>?Vlplg#~y7Rr!vlOu>#_R_OK`kt@Eb<>J+vr6g8e}JNQErYS z4;eQj3ak1gO);w{qCI$+;Jk_K&wGLcJpS}t6B`HwBlrW$q#k=rT`*R0O)JLmrQP59 z>C(FX-23<^{q09JMWLJRb45XQ(eH`+7kPPX=1;qTOT&QLpu{TP8V(}l-(G#}!ifN) z>Y1eKN{(w;L^-63MlLI$T3x=!$~Qygr$wiaY3?6UF$x(y6wA2yzJ#*3$Vub81nVm& z1+t)I$xyI9-7fr`Gs*O1X6{RoxShLtxT4VTlq(mkgc*JBiOc>$2HdBR*;#kaW!XQpMv z*cLg<6O$#aR>TA@#4~Nc^atvY;}?pI8`=?UqW6DGl|`-By!lH0`+@^)&VlNwrC*OJ zZ1pYI2*~vhH)Uio(j`8!56tkH7Tzl?Fg`Y`PfDv(=vs+v#jK8M*Z;K|={bPaY%0aD zRfJ*Qwd;_x{B27|lsRNf{J=2A@QeTFiMRxJQ9y~j>kxnIdr*$9FJFglBHzp@c~FaP zGmSk&@b%aPFd=KV+Fwtrg(dOtWSx?WzIxGQEeh2vS`jxYF6l+Q9+lHv14 zyL~yKOHd`Q6=Ihv#4x=}y;7-jLY?`u@4aE5d3@XZ;jT9K?!Wco++%zd3pd-hoyv6~ z23;#;X84r+=ACV=pb~r4>vlgbRWWpnyY`nh+p|{MlY5q5Z!w)&q~pLzRc0vlzNEyQ zZZ+JM)g-RtWosEavjcI3sj|dY)I_o`TaEF<%VYnFLq-}K`I$Uh7mXPcwJ2pnG%w`;i zMj%LK^NnKJG$h1l{5_upJdC=FP@)`bJL<=bXVN#XbtzRgyd*UBSZ?m9RLb(R}oSw4~0dl2f~=InoWw~ND6+OK7mzUb+70RPXsv7is=vWAK>IK@auyRgZ< zd`BXmHlDEkpB2V>__LD4&nn=pq&br4b~*5BlC*AU3cn)X{2;jhh6b6jdM+?bl~5@u z4xQFUFY=HijUaYK`@rpq#5lM^x8S*>+l#NyAMA)gS+RH(C{{m+aC(7gmod$@51ni9W6Lc>ZfnWG%5|>V<42jC!fa4fN($o@h*A|< z8Js7wmTrD16qf?4<(Z0K@5t3gUteA2>f5yc&no4{NxM}-4BOC5^fse1Gc{8cJ4B0U z*4$o*z&!)y7{Y5m=7aGl3a}`+6-ev>!7Onkg1h+bEg2))5I_9gT~&b|4VfGloFOz?7f=Oc@{7odTqNcsU6_m&_WLS9M$|1>@dp)`)7}5#Xb`6~5e+imwNG}EV zlly36U)~M4z^pz;GrgghOI+jf`79&;Q z82b!POn#G=i*L{}z}u&ZbzJT1 zy1pG-UVWEd@7LgLm)=VrT|?|k ziZ6^bEI`pEW{W<#oK)<@2m@R^9(kCl6KLE&|xc>-F6gs8^KbXg;%`a&z( z_y(rafw69fs|Go+O3%f{w8!sA;$^abl~e!xy>~~z`A>67X!rvCeyb#VRox6`#>RE8 zrHsO%@dc>kHY=q{Qrgs7kM;%FTPXK^z30!eDNeULC{P{H2~2y5`)kk=kWH(@qVMuX z{=3mXM^yDZPvun(Q$O~4st_!NEb*i7w|mX8y9YjK*4hK{Z%Fuc)ku1TtiIWkO7b3m zS3WBEiF%WB`nu*`=e+u-oxAE5riK3z8!E*q8nrON3%lvNE2^O%q zGu*|{g1cy)rBEvmx)t>6q0Ej{yG1x&pcPyBJa}GX2 zBc)4=%FSU5ItM!wS5cdMeBd5e8&17jM(p1BEZ9y|J{?& z6B$$&J4K# zkpT3TG1B;p6E-yXoir2bZ%FZOMUP)4vCldY`WB?3S%mRD9%PL7pw|Y&eyM+(i0pDo zsK#mLW8k1j#fV-#u_FYW-4Z6=%V~1pIXJp}DIib+lF+PJf5BXwEVvE}BOe`%*?b*S4BSXuNiBdj5^!niW!4o!PB6+Is@epmy_Ohm; zQF?)U5_r{fum|C%RwzT4zi&2(vNjJv!935v1-3DEPq)5V~b~jK{V!XwUdp00o zwfPOG$AO!3312Og^>>3P7T>6#h|nus&?4_=f(Q7alk&&n)fQiZI>a(h(HyAYRGcwz zs)={%3^JyKu!bSbJrW%(3_-gn3V^o~;JyhtPJ=Dn&F;HE{%y9M;l+D*J-nj$KC0C7 z`s*PG0R`>2$&<}zG4{lt{g;gt8z4H!p?JLd?>!!h#2>Yt9>RML%l04wmFznjn=e7Q z`#q}|g2aAD8DYis%nP-OSC#V~>&R3zx;9E4<l^O7LkAswlV#%*JQW=};znbpVh z^;@T~-;SE1hN98u=EH6nmHfBrYeJH^=jQcR3&OTD{Pg|PGACtPC{^M;eLMpHLeT(J*`RAcC3>Jrb_dV(op97#T6qh?*z%;9J{0U7B;eR6}^%IyV+h7mp%o|dB z0wh`^GqJ6L)ny$$*OY97^aQ))i`aWg-xzutDulPyNtqPIp=-O_nSYn+4o-eTGzTlelA_vGg&$j`}}-pYRpu3_Rpfz+eDHn6flP) zeVo!^O0EZ2C>4>3P+A{ev0#bE2e|Lv-Ak7X0}CCJzJ?t1JuYecMI+Z$BjUvRFCZcA5&} z$(OxtU6mC&XU~_pH~WkP5rJ&H;y}H^iY1m(X4@>dR=rcvYPnHaJq0C*P8XS=jPvcb zi=-uti_AV{CSW76aa@`-%3;X%`+Pe>-IDn;B@uH)7qM8DYHrqP9KWlZ;u9lM^ZK}s z^Uh7ObYNpC`{i2@q8pYf3b?xBbJtbfsx+L=2g})jx1NsU*Yd3w@N?bXqv;pT`S=_E zr)yYkn_%iU?T_Ysxmes=Xir;(oHd$!QJ`eCfvj!eeOW10?N%Oz0y?^J65PCkZ3F%@G=esL=R>~Vl~{)*^eqI`V(|0_#66MYEj;hdws z1CFie{7%{dGP2xAZAh;r)0s>9{o5KqEm>e6CXGr2 zNqh-m(`_azcYsVoCWv;F>8$H7>AL&&CydQDA(c;bBtq&O7>I6UH=bR40L-$fd&Vsb z;d%a5!1OhX%8b!2%amd~ZVy@wYMRs;zaKkGCtcd3?sFs|+4; z`bEiaGchrcwqUz^aJm}CfA`v1TGvSYvLj}+>@;9W^~K^SE!Pb;cnm~O!(WS^%?G~Q zbt94m+NC6}aw26zyGGI(Kw8h(o)(6DI{w_%K+t^IF^TGpHDfWbkRwCdEIk#g7(q;R z_f5-DJz2T~#(Al_0}QdOa-IfNt6Vu`yqFDJ+dbTnhpOoq%raJ*7{>nhJ$dymAvFbJ zuC}$#*Y41te&L*oZO&C@*|eqN%^QmvnnTTFW*C-Fs-!qk?M; z7|#4oOgh%TgfaeNUs=6RLr0uL1EtrfsrC6eUoFua*>`F2jwoxQ*lYrAGH{*$x9}?l zV=~JoRnq0exRZmVX%M{XJCl8>CAR&&Pvz)e+7l|+6&fc{fmy>=XhSEiGl3Z<5yYT zNbmOjH|A{g${1tTtDiKa@G$p75&NIIZ@W5y4J5yN8SGGhpw_7#OE+VhbxBg~_r$~W zjR>}LjI3Hc09F`eOH#SKzZs-p?%kvRhq|x!?@lEUi0BHMp~;skB91Q**-vTQbc%<6 z`X*#}rW8`r8oF7pO=O%TmB#<1Mo%PF8m7M3V^@P^6IzbvdJ;*Np>~}qW_Mpi)w^PJ z%Qb}sVQ*9#a1V9YP}Qnbe0hpt?B;U&o9IYmyT!;Key>?UW9AlX9-djn(+@RHP4I^Z z{_JQo(OFNLiBu{jdTA6oclWh;>MVt#QuZ6=**bFx3F4tBP~C}++0Q9AG8f4>jCUWG zBrG%U>m4_CRR@_az=nUJzDGcJwQV+XT`i;r*sRD*jTVg3a{720ezui*Z{>GvMu*%oP$WrD828zf($z$?y?a3FFKQlk<_A0oU>1zF#!@ zTwH6WM4f}MUIx|Hc;$J2w8-TMsYB8hz!Ww>&<-gMps_=7<}-2vxD}^{2sL-4?qHZ` zdix8hWqJA%!iKyK$Mr0H=N9ns(u^}$UEk=-ZR2)Pu5N1oQW)b5h}b5t^|9IgXOvvc z-igWUNl=;jaRbyLjA&OdtL)cB&8HTuFNC%%_O=k~1UcG)w3#eVI&$qr{B2Xbnv~M3 z1(E(j!{xcrac7xKOgTFfmpta(UPLlBzlektlm;R^uT*b67I)!9^ zuL5fsLkw*Ol`0^t+AuPf*K40VUT2c%=cL`SNM;ac6NgQk>=ng~8HWG3VUAvERRgd3j^0B(ls}t<4p_V zok3Ne8+?4U=WAr6w+sVNvJ%xEH4I{*GzT%IgjQ=r)<+&=Jk z@Ks_APPKcaQk3;*k%Exs3{vk6Z%_pkHOk$nSf{79eE}rhM1=KJT zjNpmySjbU$I;Jjt8&C~YIx~;R$%lFVA6ynI-A6qPoPp`Nu9B`3-$7ycNRKX}WS#~t zes&KEy~LI2p2+OWFTJ~u^E?4iftrdJ7N6$Uz{S|V#uPiwk!@TO(v|)kY65x)$y?rLp<{-9^KJ(f6W`gcaday2j zuk#i?9ZDj1nHAkvoadEfOG-#_eV8RMc}s4EJaKB}p2Vw2TXIiiPsKd$55`r7!t@O( z7X!98LMD5)GJJqQ;zsu$^2^lsd zpH$8Mi&qmC0j26@6oI*q0+D}C-AJ@>G3rYD+49s#^c;KceG(l`yEnT1#+y$_=CPWT zS^_c5hpLF?L`>7d-(}|XyNLuRB#Vrv$0~e>?*r%%2`7(|CnRJ-*><@Y&=$!fI*S3t z6D253{>{8dG||D}6SF~Ea&HQoB#=L1<Hu(SVRF=nl+|HN2cw1hdM=EU!7#4xkABqck%0{=%v1vz&ZdwV|Ql%bR> zD;}HhOi`ngk92ZPmmakmLFhcKXiozRk`|R$R%(!HBHun%(F5*8?o63c>~R+^a28VB zhEA(ZFv)pnNG<`~*sALLN^d?jZme9Gq0P|MCXn5`}l_0o7<(UjbU~G^4726bcK^ z=cebG%0B}r*k{efyWmIJSfe@pQsAa{Fhc-OOJwc+ar9M(Okc-cP82y2gi+K3=A7nO zb{+ow0=|Nu)(kk4Z>Gl~QB|gw&MnRsr|WB^#GA1XRT$1qw*#*{fl*$HG;=9*dbGkjrvD<>ehnh-C;+cs@JaRMz zbZx@N-rUF!O|t-z;{a`PySYZu7v4xWT{o^Z`4dhq9e04_s2YHB*~mp! z1^tB(%`IwmEYQb%4_mzhYa3LM4eEP&O77yjxhoHN&q;%Jdq+0;4ZY9nk@Q1A-^RND z`tJUMoZ55}ewaX5z<%&p@#^!*UsncS04&y!`oGXAaNbgMVJE*is;OCsgt9GA^qUA3 z9oYkT)vb~fE;9@WS(H%=M?$!#EWj~cyz_|)+qPq{=E*UC zGgVUW!$lzF#O1z&^yfdmzk4^fJzk4x-BM)58%{2y`GzJ*6+XjqGkU(+Z`Yb)*grsh zcDcyi=fG&1g87F1kIt|6lfRkgmWm0JXRof5{9qb=5ce4T=)rk7Km3s{`7grKGDED! zo)Xf<5FazD z!EkUe0VRe?J`&3!j${m=k$FZR^He)JuiLB){i*X=>%pf$d>1)m0y;S#2T_#;e0xG4 zWNo#;dL9E?w05s0wm^^X?nusOr{~O-81*upk4~*I-UX5=Vgh|JQbQL*4pc1jYQcJn`}a6P2A# zHzJ2VwS{(crgm(;#sXK$qbTW~a;D$s?ic155g_$7!qJ~HKxRwvN{owduG2N5x?6Suwl z!f&NmuNoYt)0*bnMw^~J?f0M>J6Fvtj(s)#ymf}ACCW>o;z8#mkj_KMvF$mWc1=+- z+DzypNN^sWD%~>A1bRnw2SoHhvaE*1QeyT;&rxgUJHVXx1?BGnzSut?ZhO*1smvU( z-CkuCu*`P@AUr7^O0FFhT|yLUYs;eng!j4)^HxK38~Jyl{;ArxrBQPATM6geOTvZ% zP7NYSzf1aY(!I^CQK|^elv#G(L!#)M@kqNf4O!a0E-a`?ymip|?4~tBs`4`43LY6n z1tM(3{JhpLf;sl{&E*qsS(Cl4o~9*jQDVH;qJYH{Zn5d>f>4K7hP=^=K}30S3*IMyK|Nk+qCOmtHI_SX(XM>z%ht#6z%>}7VTVK5|^GrfNEvBv-i+OhS&Z|zr* zoQP&Nsk-e?W-`T;83(W)4>J6Lg!{R@_piKTz-F=p(gCvLiE;Gjt@OX{)?l*)$zgM7 z;1!HeXY(!8;a3ruQx7?=CFVIOiXznv9O2;u`Xww#B8J8hcS1{v^? z1Tlzo*V zqv2hh&ro0gd9NUnySrC#_pK}bU20=t|BY*^SV|D)Ywsugt&kp}9WZf+LbkiF^O%42 zsaU`_IYZ*aWAP9)q-@jsTVwr(7Ne z9CgJA(!DQ1vMWq-oju*upga^L8hFdsl3yDo_!gazeM051lGe^t^1#Da$@!4qr>GgR zgcCHv61L;|^FKU8YlO&pTvD?vf8`b;>v#3kukXI3?pvSeeTP!uig{PQRMA1#^IYmn zka9cqyEMt4R+z0I+XAOYatT=Dk0c4bz5p2pED8#Vlt@@{_(?h}!l(Zz_4&Bd*!C~r z^6Ydwa@R`a?(O>R`#xPP1|^a6I?c~9*SJIi*#??!ldPA6Sxjy(GdH=B9G469LRe`4 zLq}lg=}KD^O{ zNqCgJKgS%r|FO52nk!@~taux`x@(O;=J1%5R@`UY)D_KkakSHM#Jza@2vjemWfSc2 z$Bq9B_Wss4k{`;ee}-)WeU~HHWZr5t7d?e-@rBbCl^Gtj$UEJZa-);y{4%qLs}`LX zy>*bz%wmFrs7HvuH5F*p1UV9aXhnsA1YMu8f3hQf!s0`xcjh=gW0|2+v|ilXrBgw1 z0DhJSDX;q~38Qn~fS1k9SXujk7@Yf5K zRVSt5IGhyJSL}C^u*rHONths5O9%S%e$8#oIYau(Wjy>Q_<;Vy-mp}rNdV850n^=$ zEFu>8k%0aMSf3N`)WhR37nd(i9aH>~FB2;fO&U6ns+4I(j) zT374K5soB#%C_)qeC_G{+KWm@*2p}62?Wj+z;CA&tVOkNYnP(`bl>!5>qQ^$HBx4pk!GV+DD22ag*V%=|a3=n$ z3ip+&E-k${acAC&DjE8-CM5~X1iA94N*vx-@wIVBh=S9$fXOR%ID+)q(?w!BWwMas zMNHfe%yc4t*rGU}A~hu|Up=3N3rG+%iK+f#e^K8b9Mfet3$9s;4IQJKdUCqaOR=0+ z$-00nf8rCAC(pN2M2d}Ic;pMU-pXzF)*z=~X2lP-d(`^E5h&KypJ>h0K?E&7X1+}e ze>|>#IfU)Vr3a~6hJX=k?BjME>i5;^1QM69Z6@f4**&RcU2Z*2HCkS>UZPeoUd+W=_&T*seTB;)>bN*>_~x$>zahis zxs+}P$XDF61a8&zi`v0Lk4FX&06cIt9L@_UNo+U+6i{VOAxadi$}kl$>$%>z4>*LvQtub8(IO7Qg~t z*(Lf&B6T7{+INH~g5I8M5?!O?(O43Pp>^Xd_`i&b6UEgSu3NQ`+DF<0q*Z(GIde*S zbsL?QMNH16NR0fbG8;!yzo^DYdZcvf1X9rZi<-gU%4)@O>peDYFm@1Ti`ml=n#nGeH8!C#$ip zq&W#`q#B`Ro^DN9qbF}*DT>;B)E@b4Aq~IdUd`*C?yF|ztFi@4<{U<^N`wY!`P~|2 zAKk>gX}&M*RqF7}6J|rLY36OF#3K_Gj(j08C$A-*=YA76S90{||2^YWe|O$~ynDJh zt+dMVIO&Ta{-x%wc8~YrP*@R*045mQ#{ey~1bO7z)a294X?vUC!jzAKX(JOfAW=08 zy4nHKdq>SM+;et#EKc=&2eipr_Hv*CyN!l*yfbpX?Hh)N|#Cwy5*JSJek+g&MbV#D~V7o{{0%q?`2a! z0mg=JxRp|WRBQklp5B@&PxU@fe4_Z`XDNo`c66HQI-fag+W-)s%}}Lyp0Q*zGO^{c ztq{|vwp~DnwGsXO#v~7S_-B+G-xUS4|Mm=IYS{)Wiz0RcR9t)wdz^EH-|rW_o@|Fl z)EuJ`clI=yC+g&9nm%@={}kdFacVf^D-k9!(F^vrG8b^epVqZYO)}b;7#K4PdHo@U zF(N$5alq1W+XT2ePjxT8Bcwyl@2gO?xaxRxxLd_y=;S2bgM^7Lfl-XAoV@6~d=(Ek zM;H@b_2?k5v1FZTYq2V4UxKjlf{X9O6W#5^7flvLf#>`9DbqRm zw5P4>WWeLvu{>Um@=Tv~BBX00NGp6zxpOXR1W6K~iXps+JfZ`*8!G(8$}#@Jm`UcM zKUc^)fpEkjIth=Um=q~^62v+77O$nX7+n@7c1)tm+=BgU56i>F+gy$%NR%ZHxyr!x zx`BYhu9%4^z4mqnkHrVYuUJOs+`Ck;*yA0DYmyS#u%#tpM{0LAmz8W_w`_vDv&W;I zd`3>$ra7CAIysDG*#zV_`Y9@?6uQM@-Xi&<^Jx_ z9y&}cB9iR--^md4=N>->rh1V&2@^H~s5+XS0UCpi3Attb8=^!tVps{QJQt%J(dnIJ zxPV-(dta+Uf;T%8M@pKfRb)!HV51({dxJ^ZN?}Z8g5cd5y0cmpRku`fx0GVMidpCw zihWWVdw=p&zCP}IbZHf)rke!p+=#I~H&4VdoFWF^##V&#akbn}2@M4xC3us(Z9?Pw;l z=O@wxn&de5keUecT( zwr=%Ol@hh2dcqIr(qUEeQ!zu7m_+u^g`cbGpG2Q{uMRWhr*)*4(-7R+9>0OJN zJAZxO{+O6qpqD*DWX>{za;O@rK8iB5F%Dph#ISdS@h-bDQm~01wdB?tD5RaTSsx^* zHFu!SDlZ7KJm-)(C+#bP>`=ZV*}40u+K@}?`NAU{=qhh3<|;AuEt0y*p=EiFQ*Lv_ zX*b#xh${67>6|C`hOIUCh7)Jb71C-c0;>y_>pd^&caWLOm&1430L6fM*GbdxW#j>` ze?kw+p`>0koXxbBnYh+zuKUB8-gGDTnp13GAQ0C5j}uiom?V@r{r=Ho&HX$hJTklM zv-Z!}+8t``rROlJeK-~Yl}8+-_HaW#Wo4aeEdn8(D2Wj6k@B>JqVM!G6CCP7iJZwF z1q?!hDT=c=&MrbA1gNq`@#fJh(-R}OY}1}7mdZ2Eas$<=-vh}dBN~U=z+%LwDrU;A zJ|~!?$w8L*b_j7Knclt!FN^iW%l2y-P!_$KFNnKWYe3wSiQVfvL))*xRvagTu4n%hGJB7)Fk>V%Ugia z3P25yu6*s8fxNPe#ZX8;V9>BY^pP7Ywr?x8VIThH8qE1hw;>T#Fhy0{k|@9Dp%S@_ zxfNUlLeziygQi;ELu#ocqVEQ%+D?GzJ=t=W%^7lnV@MBiYe3VppM4^lf3k@HQ?4urF}H7f zZayx&>JS)@hZ|IY0i%23z#b%8hrBdkF0Mi=j96$PK5?rLB7Lrn;>L~8?+{WQ5G+>< z*-z`#lp@{QLDGHYe&qEry-984-rVDfnrs#qaigK=t5qeaUmP(bIS*=bqfqW!U}>qx z`JrzK#O!p6?LP6#v%Z+9*Iiur0&qp!uA9EE2(VKRSPc>>9&>wBGUfX(_$4+~O5Nuq zbXtt0TQrS3W18Q+hL~uYPn&0oS0L_6#3&U1soR6Nl#0q*J<6S{0D~Q>QOWy3LNbX+ zW+x-4jL-!=?N_xmRR0*NOMlJkaQE=TmzZQ|@I+pV%!YkLazJMNyK$?{R#R|<8JVBT z7c(-6JiZ`MD7vL$Bra$42z+QF@w10{7hKNTqM~y7{W|YDJv-_l$qypNraA#sqa!T6 zUcBDEE~#E^Nd!F}nll+r&**K~Xu!Sh!5^oG#@Q9S{oRU+<{~2v0|Sj4gY>WW4_6%r zz8wgy6+Uv5tTe^8U2ia)H@3Yi@YhMaDBTMTf(UnW%|&Ug!L6!07SX$_KgTiC{I z6H3wX3?(A_P5(fGdBwNg%+!`)=_@QTSK8jdN(DAU^dTKGA{v9VXS$1+-<}vlH_36c z`NI-aI12=MZy2gML;8K7jw(Y^3gm964;j`9z2#bKrXXJY6g<0<*%ybTpI!QfFQ{_(nS~fjJhJ>(b(0UPIPEg8 ze|gog**3l;Vq~zz{rYL^1ev6FB@`8EN3pB*s^?_kb-m%ow$gl@SXv=UeFC}iW&vug z##BGAj}dbfoRN`ur0bLV`I4hC+$b_v1Fo+A=~svWYcHqk>yNh+>o#lV1qclpWf|GL zKw!@IV!aiQyU79sWG>XG|Ar#@@!(NC8OD8di`~ScN(D$TT4{y<2x@{5tz3;e&GE6m)Ydi+UgSKYv^wD`OvES(xie_hoFH| z`|s?kbmsK<=rM}QVIEk*hu0;@`WAQ3TxPy*4`NOV^|Ud(C{6h=@nI-qDx-Aeymfub zk~Wk*F5%CO^7SH@&_mllP#2b&|13Ybe}eGw2ygpMTrKCDhuc~o!(EO=rMK_NJBy|I zE9em`~qr!18=Nt%ayr4oo_c97O$Afed-UJ*WJ$0SMjIFPn(NVNNyHR+5E_3lQ zMD?kQ8&i9RgKCBi0TjtJ!70Nj5!#ZTD3CAihF)>jheAC#_XI}n#}u?S!`fLVg@`4xJb>`wdjOxO`w$ZQ8k)dBHInXVPC%DRwWbs6$A zR+K}RoH?}=In6_(D{9pDHZp@D0#}4;A6Ad8XY+}Tv|D%SZ=TA#+_%iBi8Q{CS1|5z z3z=44Nq+)i@>arUNoQjqk6M@EIKBR_HL=#~ug>Gx#hsXN(*^{Xy73>hbm^&*KEDz1 zXuJ_h(+cVsgJS&OiryZg3<(W&%7#mACgBW1F zBQ`MLzCo(`8GD{i{9Aq9JCTa_*4q1DU0HUHWv%Bq7S+oDi$;V>OxL9$)e1%yT8yd+&Gg4>*B~m43&bn-* z*chBbH*?3_8Yt9T&tB!-+*;42^5t#h{Q0%SS2ZyljHCImbYPEA(HKg%Q$cR=DYOOi z&iA72)27Ein6(pNXxU!ALq8JoHY(}h-oRzHiPL$Y>#>I?fN4{db0$K*((!V4BMa3j zZw4T$C*R$)D=b4i4SbK0SaSeo^Cb`b`g>F-80#xSw+3ao(jrd9_hR+ zpJVt`Q73Qhlv>dz)Yfk9nP5%>YRE%HHXd<98OdCtU29sQK3>ycfu3Zhx*Ff;6$dKK zB#Mn*0W(itc=UVQJy?e~PQ?cg_w?b&f(apCnbeEF+q8BQp#RVgC5kV_9;1s!LF$=6ktS%ViN%U(y-nqVi-HvqV&~u!U_><9r4)r`z(IXNa{u1wU2iXvXdrokLF9||XcBHcG(MA7YG0JjRumwAe#O-#4sUf1zqBg&uVpD26$|FvN;7S7ZH<=uwyx8@RvCYB?>WqTGij6hD z+FoX0ksq8IPh0Y|;($nsppClYq>(GF1RwiFM{4kFBk}$o5WpUvsp0l;{4t9fq;qF0 z?cI@_-{lfZUp>A{ylaP~FC6@sXg@a=k)B|c>)onX+0DuHI`&W3--CWyr)?#M9aLv+ z!2FiwnLiL>?7ctryo9t|ktxHHf)mX7ZY&E#EHZR(_+=4;|0|ELFR9yM`%mqlQ85$( zwk4tqj#B*I08Ncf561~D*-pZ#3hmDY-fj~ytRJEY8fCdGCh~6&Tw~eQuWk^ygb~gB zssj;oZ`*7O2d{%TDmpYb?TXo-npEvZWRw!S3I`7eUGt9z2-i+wH0nt=SPpr|<o)~=B&Eh^Vb zENfJYsbc};r^t~yCRS_#;FE&de>!n8#PlpG-&h3wS4H2EkA5ci<6>TwOyK?`xgv7-~Gc&?e39_{H%h~GRo;v7AMAM!xyLQtLNc8=zUj*}EK zw*AeMt&)KFlimXtE`+?>n=Gz}<(hrJSkOB)+L$I}eNWYWnHDwOpFniqTY5Z>-f$-Y zkL}g_-M~~h20R%{Xge8HT%c#<1HW%q$rq#crsf!a4x$d8WhkYd^QUeoFGX``i;T>1 zYkdP6o1c&Sh<-gt#{5rz{%Ai0XgaH8;ih=ul_Z!{M1KxOuV3^a*Q<^YkgBGz@vCg5 z+xE_(?}(Eb`eAWoGJ*A5MttnoVmaC;k&v-?auUJebb7H3zq`Ik!b}C9sUQ}}X6psu zbf!j2hCS(GSw+;pdIgs~Gk8+7(F3(5#48ABRB8F$M(b`ibc+D1!BpvG)$=;L>K;aX zk9~UbrA>H3d6GU@WK_%5Q^-R?$w8Z{Wl5)q2*X%YPS<2*m?RIi1`x^IP#`{kOXi)k zrP%>gzUo!>Tfr9W-+2u9u{`5s(o-Jy!XEmvY`6E#)HU)6|L_PNPd-4}({Aj9RN%(2 z6K%JI8aS3XyWpuL4N-Sc(=s$O9&mQXl;OryHV77EjP{23J_V9tkM>zI_l`5C*|=5J zr6cff;umsueJL<8O=wsXkg)N8LdPK~F(+@otDNu0npdcZs=4pRY?zUnzIzyN@mYYLa%^g3^`eN$YE*3zGAZZJvSeC)e$$=0_|=WV?|$^o zljG}Uq4ea%D^AtJ9m(e7tI#qPY#s!Tl@}Iygu9=54d|;b*yq&F4|A_BDgTOcuOjOI zd5@Hl-Hx(j+kNT?TJ1Di)lZa*7~4WP!LkVom;2H`k>{TxRm-qoDn?CsyFKkB1gmQ9 zQs5|mKXMkG<{J^@6{Qoxc~@6MZT>4A|CKkyO{653h~N{rB=A;}klBT0tQBuK=H$ zP8~#2+eN3XlFtedD8%EfzX5KA<6Ong$nJ#O;SEWvy3-IBc}ab9OEAIV8yZ$!*xcJO zawL6=aR`()#;8+#`=j;G41tGNUfV)coKgnk6_ZugsB_PqDunuZC7Mn}?M2j*UdQwk z^=WBH%+*G}0I^GtNa!r=+RCxTZikgi?f%j_B?$sxDfpVV5#ch_pM2E%N@Z2v7z)vZKM_7^BgKD;V2iBL#({hf%Pic53N}=SN2Ae)%$i!7a%00;<+y)Y zX_$FBs?0StjzjLWb^NsqI$4oxMy+O=2FjoFk1~hW5SGwEc8uEoVE$;dbPfdRLla+m zME~MbMcSWEbqp^8Qp*sG0Sfk0G#=AHjx%i}GVXEs{i~ZIGyJHpRu{!=@QMmgLaZb} zmGoyvfrIXB{ zk-E-Q2`zW-l>7)=2ZA{I5cg;L2_{`^B|3vY6Xy{02~=1S3(%x^q`)7wr`>RVDWsXX z$GCm7+qy^*7hs0Y`d8B_@C928AurNo`(R2C|NeE1HP=Oa zJ8I(iX}fJZ{K1;$_UGct7xx~>X3+&-dAX!4vJUl^ofKZ9y;^4q^%GP71m6U1^sT`h zj8{@Sga2@ZA4iNi4EXgGAkbzsdiO>r$i~GMer(-3PfGB!BBX}?Lk>TtQLrpdRZ5Vk zjyr@Uoc(!Ab0c$hExJBMOrAOL5%%GaFk_=$3M`c#IWC{JF?Obwl1NEl#pC3u4;D|- zTrK9JIfi`;(ZZIntr`w7C@*O7E!?R@673{PdRw5^nr@1flNU8YM`s-*>fTyqH=55( z+)LpaGyUe`&p6VDE!?ESrV;|FPq8%{zMCt=_S>IqoBw>-G+XYyP zhF?E*m{$f-BkY53xG!p_Y1v(;{%n~5nc4Hm!*(?&t~Ye%UyjYxo?D_ZbzH-rPy za(QobJJD3!Y%jt91omOqnGPd+;Tdy(M(5XBdzm4T28VVG-9g;d9PkPD&D~Jos$b{I z#tHS*&|osbynoG3_+x?9o!zN{_xT5#rLmG^+#POj1r*%x zH{ADGbAr!J*Vo&wT76t7mwYS#t+We;2Mzp=`{0^Z6htbj30n5zL&86P4OB*DU}lS? z{1WG6#JS%rh;w-<-6oS5eSaTn6sK?4R7Z;5idZ2LHCXG1%P;>yVHJIxf_V0@t3}<| z&Cqa|p%z{#{f|4`EX5%os(n!U0@`$Njbm-Cf7a7IaKsLzWO~{GBElK_Vqrd^a*#c= zpHAf&JhC=bSoW7POVbe*vm8zpPfOGUdk|)SbYjn0VmZoO_$x?x*pi*B)y8I2oy);U z9LdI@FOb8z?7o5g?=@+c(2hB_ls&1O@%#sir75qoH_-mMuJ3AnBP1Tb>wS(_V*>_$ zvt;O#`-JJ{h6677ao$1}FBT5o5>nS&8~PFu%_tLIskw0yrL@SQYUbwX+Df8D2m8<% z$Nk8z^RmDuG_lum$YSD!&KTm;mNUQihDMTpLCD~A+wUn)b!HRTq*^Trk62#}$!MNa zE(ayj>50BDs|hL=iw`~_vS$Zugf94iab(z`LG2VONEYc^e`)y_F zn!FABtiPUEYvuLuUsjS1kejiper7{wYHBK-n9~JYw_bme-~yTx6&=XF(~JdMl72#{ z0Srb9I!I8Se2Hl#1(H#Fdmz)lQA;Vc7DDaxn-14yUi{icGi+<>lzVrK*9K($o)Cz( zsHm#=zuShAVT1&wC8Zq`Qqz#>#tt6X>%&Ivb$(T#+rkR%OhIy#XFbWK_ zUkH2p2G4-@wp5vMC5>FgZk?Fi_g97r4A?TMJp(?vcel-@kKV0dg9gi$I~m5W2Ok77 zCNIs4xE;1wV;o%qopVx5r5!#_V$!2+TqtTt%7KbMiv<&1yZ|*nOd9rQR!+Fd9dHNa zc9in=snF}ca<2c8uK)q|tN+B;IQ{N~xYP&5MC*Ks1K_AwOc&4H3Ej^ zTH@C|S&F*vlAy2iBQO$Nz*>%8G@>RhMFws}rV}mLUmS@nZxvLJuf^tI!7V&@ zAZi`pWsv-AI0&z-(5$Udk^QLI|0XPr(;eLz6IJ}|Dw&OTGuJl;Sp@!tNsei{WmOH7 zUN!sBA>uDb?1*HLyYz5h-bySrPuB`5Qjj9e4!wgEm12Yp=2brVEMOU&rb^)LOgBpk zaBP>+3@j1Au%<PdNNmvX58ejQQ4(4w-?hNs%(xRe6QXVg z9Mo(G8|h(wy*e8?U=U*%M_%ebrJsGLK;KPhfKJ-RsqkR}EQBCiPh}e*ddhNcp|+DJ z8e=!aM`S(l^<9l6Z>8cY`@L{&aoN&R)a;>cr?Bmb*V952fi@<{#bd zb?fBq#5U^#g5>bfi3Teyl7E1)T|!uizFA0MS`lgR)N5Boq4}GB7uIJ-3jV?hht`G< zNXXkv)qf9A_Qq04kXUIScW;)l%JK-Sr1pa7Iddd(zkv&tkFs^ifSI#m)KzMJKvTZ4 z?>py_M;e~-nAQdej_ zRaB_&%}T3zCb=kJC|a1yB1LM=Vv&*}T%eHsqBHKKSWq}vQ-^G=?n2F8eYlavp?=`z z^NthQU-2HMDbVaKpb^^;qr;$7Lax~jE)jj&!E8m==*rseU}os;FHYAG{5xuqq3$dE zE_hy5jg_4?4L>sHyK8TpGHMMSq+i9j%gHtpANagQN`)wi`@ZjPU_Ma5rib5YlG9nl zIUyVRSsqonb3(q3a;Rb#ve6#S#Q8xY2XTLpBN+qE**sgxZnSe!D$-c);J1313Kn&Q zV{hVwJbasr}9CyAl&WZ75#ph{g8~&1%uMr58$ax-zE9@PsUk=YD~S7}G7jTRIGXY`U)6r_`$c|W zZsqR-%=?Sge5WSNdtF>6hN64U>pCITs)WuP6F46*zHe#f{QeRmA0N%Ewev>fDI^Au zGd|kw%@CS}rh<*%s43o9W7Tfo5J)REW=aX$bYRmO_>+j*OCDh1HStyV2SftyJPS8jGvRS+E@pJ|x)-}$`mQ(z4Q zWHJ{bXmy}z1qeZBix;Z>hl~Z#nvPG!X^tO(?2!Hd02c`A;lZ5Iaf(vci7r&o{JBKT z9@IjVJtlN~cCAHSeWhBba zdYyaaz4I*!nqQyw^hb*#=%wR(QJf3+m2|tO9(vm2X5(V`ma6EeGY$}v-#)`+pDW}! z$6wfr)U+I4Wb}dVftAqLzrEfgIKuDi&((fudVPC7G{)r+U|)7vhRDpGHedV)RiE9< z!V)ad&s}4*W6%+$>=T#xo8JLW$NI@dt}d_Le+omoTd+@^7$(qcOHe5znnjo6y^vYJ zsXL5_(n;)0cZp!Ge&TUn>04-|7X$2up=jD6Ic;y>flZ{LzHsFn%Y~j6%6a$JsKK>X zfU!h0Ga9rTMirm5PCE#J=I+24b($LwxE@UZA6ehw4_DiDJ)?J#Frv3abVf)JHG1!T zbfU{>N%T>JQ9}@-MDL;xf9Jb~pa2oA09)?!4^eP}Lpm z;8qy)B4>&c_LooIDy+4TfchO1n4Y`xV0?IYoQF$5cjNiET(#UXK%{HBM`Tj>xkm?L z@1w{kmz|Si+Z;Z!V6553u1B-4;5lbfc))SP5j!TAI+Z@pg>)DC0J9mBS!LoV00sJk znKS`-3Hc29<5O$>=#_k3B12;MA$FDcukO~acB+d3aEubij5erHVKPHD6S8nCa^57L z%%fFFRnN9Ya7q7sK~+B4<(>71VSGMc^^lyS%WkG3f=LuB%&sKtiiq{) zo%&pA^`05Iucm_9BocjD^UN^TY`aC+b+pvC3JimtX}={pJo=xm*93DqZOEvCR0XH{ zxnI>SWcV*TE9Awj$YAOqpwR{Jhuv7=Cz$cQuQV_U+{ZlYWju>pllk8{Uvb)1#5*eB zRBAh!&EZ(?vz$@|BjoRwSbe<*;ysEX5jjp569}H&A};D9unvLNGl7=$dh3gdDX>#~ zS#7a%ww2t?Skv}|bGquA4u+o6molXWKG?1927OCbAs7XlPIkKk5Hg!>e^lark7zP7 z|H0@S$ixm2=2lq-8oz$?7Qk-vHeutg!@&uutsQ1=v+h=ucn=unGg9hFY*-WYt@dkL zgR-1bYgyZ$xMc&Q5zU*ZT+#p+-}BQ>-w#o|{%+67^C^OF+Y-0W0llmXn?kz>=oXJ0 z0o%=I{Tsb^Z(w&K_>ISi2Pf|#tLzAwtbm!@Z)VYLZI7gB)-s(#+rzeoX`Q zj8+BS>feun3t)q$s;5E}5{E1C6CoYI4`IiJ)yx_+-;!RKEYL!9ZWVY{=YoHU1S7NW zMc+`D-Wfa%RIk``-!o2GaR#H(^O-hp?{lOf9$%8b$6^D~gjOkQV?SP+H5Q7WwtUxK zvEJX^6w6!~tolxe`t^>|DXS#_DD2QUQI=F=B?O*ctcI@NM)zQxEw`BdoCT>%v>_s_?pu3r5Q9h8wyZ+)H- zs_;oq<5QEdgBLe)zM6nk+_ogR;GCVE?%i$H&!156b&LWLy>vjJ(a>9}4y0q4 z7zD39L$MKPy5)&7;_NH145|F}WsGp3cr!)<27ufw`7+ZXud;BQ_6#|4PCp_?%4*{N zlX13XE3M%2Y-Gf&dAC7|&go|hx-4z!=_cwc$mgN_}ygC|W z4L*CXo|aJ0aPTVs&&#JetrT%KZKO8bj#{dF9504^8(2uA4_V`RfAhuHwh}rjE;>Rj zHw!#UR;p;X?|h!ipi1D{d%?fWvl;R$x$`_NGKAw4?anz~V1vY@wauJJ>2N*7YuO7g zPkb8IT+g^ji~Dhand@aq6G#s|P#o%~LfSrtg|kO1J#)pa3%Q9cFO=VIvADojee~eM zEjj|)@bownN6$aL>O`%SIn*BRCeW$1ymfxt5Zjh?v%9-hqFmSN56{v?U*E+4=1{q8 zc2?h%V(J;;FPdCQe5&CUCH@XL6V3Tw4tG{-Ref@=b|{?YQK+>|=*YdHlxLvSuw2lv zLIdyDS;$~H)Vb9w{Hu=^L8W_p`FLb4>lHd!iE2b!(ldT*;hfPCL6U2C&TG8dOR?zG zhI8i=vzM^jY)l!oAsI|1F%_Ep-`h<$z^)ag;QDx@IuL?VX^-Z7VaFLBJqx6&A1t7Bj?|;8PRYbTE#Uz;mDdu@QkNjlw7OiiP z@$u58Nxhj-8vGW-E{6~@3Ijh0DdCci8oeJ!%QyA9ue*{25v;C?(~ z4Z7h=Gqx3J!hyH(?4=5*fW)hZ5avFUDbFmdD_07Pb!X}a!aM}T>3zMs-BHJv;)1DN z2IL>T&5!2gCmevmd%hV%-}1W?44a=peB&=(TW|brDrErFU^=<&!$~!838`VBJd8}h z_d?3B-rGi1nwwvM?qbb!cYLr;BQR9+9PcEZ6{S42e%+x>rcHd;rW)+R8^QQQ4%GnZ zm7A-Y2#}b*2_HL(JEEnduW5bw-z+t>`6b{RUGwx$wUDj{?+ygu-wSE%wBH57YXt7R zwXD^crxZ5IlSARa&Po3;ZUh6UH`md1UrI*vIN{Z3Flq%o!%wS6t&v{15Rm)cfe9Cd+J){$qF?(4O~t@@ zljVQ>($?wKcX~T^Vmw@gK<@ja(ci5wg8zM5?~RH4y0wV1X0$vh(pg?S9gEr$Zm*n& zDK)875$WH|+EfUA@dJP&&dDTRDY@&YSV>``dp+-nK&*)#e0EW#O{XO|HKr5bv01bVGaX?K(`_XWyne#D_HXVu{$M>Ld z-@;Obi7I2Ta8X!XAc}DcVRItpXD<+C3qV6JZ^^a7KYqtf)xukig8syK@WCjHsUM8` zs0h$)tY3P7W0GK-4nCA!2_WXhw;$tTw%Xm_LuNFPG3Sy@{&nUi;m|Np8 zdI#a$X7saqqD^A5;KFsxt7$up)rF#C&Im!(+9=Y{+7f4cdip5N^mOPfUUTT}rO!yu z^B!WUDbz2x<8v~XdU z9xF=eUjom*EL_>M-5UEx13PyrM00UoBxO8?{Dl6lUG#J+yoe!VhYmr!9tq&B(P*XE zVC8viaV1Xc4%{3E&|P%upC>eFF?1*|wGa5uAhc2x<9GHC`sf=#Y;iB^zFwYKh^1eC zAtbCzaa*XXI}TR=WU=2m4Ei{*`3-X4&j%Fe^;jOIXR&cMYE%F46<)G{GwZ-%_VAp* zWUK4Hk!Z1X=%{l#)LGTiiZVLa=@nG-ec5}eLYzAt|3~Y~8OShS73*BjR z`Xm@b$vn;=FSmX^p{bU#8&WyWp$mr5DdO-+?)&-jAA~A>9-GK9b__y8IHQz<@M{p2 z77GpHksf=-3(NM5m!C)#E7odfjJPmln5A>9B6sc0p&Rj2WUxW#2SXpS8?Arc#;>ac zb?g~H@B|p5b?1%&#RA@8g>|sk=W802=7wW1Zn1ZsG=m65i~|R0{3X5+j+q@Ey-yet zz>}=hH*eU4ZM~X^SM8Ov;FspAx;x?g2UGW*gNgzg7u5&x1uMn99HGaTwb-hSV^~)y zNu%GeOk#w!q58Q`>3>wHw}k{4RT< zaWBe4_*e(frs54BPM~XPp04=X-OWzq&gE%Xa#+9Uo8Fla9d-dhvMs#cEU3i z+Z8&#a_6_amPg@m0VQHMl@z%+p%`AU^23{x!EZu?ehpA*SB7K!QT2$Mxw>6)j>}82 z?HvnPOIcz+9QgU_z#=YQbz%?I@T)srnK9X2XiwZL@PYqh6-& zErG;}Q--JJc$HZS1Gw;#EGMI@doOZsukkpex{d3p3JeeC9mk2!C#|>U0!7|Xa6X=` z>f2TSzh9RCWxa0$8BuqwmmqQJM~*$UIC_C7~d^nFfN} z3Bz6z%}9HZIHyDVXxn(E;*W@lCBD*%R*L)T_mYGan}s!h4NkPd+j+rj-h23((U}zW zqMej(F}gnge>j~2;DX;9?j(&BgKQcD=TaZZK1hdB^cn%(Q)GpQ>q+Gnf~X&T_GXh2 zO#?YMsj^slpg>9UnP<Ik@b4OeQ>8!sw^z3dQ@zFfD8empd+h0$R}OrT zt+Xx=RJp$1XavHhV3p5CHKsoxFt~sm-6;w6VO#3@y!HMkExWujnu_f?;!a|DIOx?W zE#`{>dNr=|x8#%u)#&S^mGK!Y!N9nz=hX@>P)$yr@w<(XwWofodJgNqjE2zN3TimO zM+FeMSzMTlnn3n{OS_6#I5Z7q1P3N|@W9j-MM9IEmaGanfD+@=!#`(kChvUR!Dc=} z9QesN_Tk0~-;6}#;qpL;uB0;>?&$To-yJP;P#e6gg|Do&;L&#P5#GkN^f0A#DOfia zN$K96rG!!*@6kGKx?p|@z!`A)Owto_Uwo!({OdM)jb7M?A>+-8T-P-afYeS5$-a}g z;?`tGgF=*vo3Jgv9Adf9C<#X^;@k{i$dd*Qo^0+>jqiA1u*`vG8{m=qsG2wKrOX&9 zk7VL{an`?5n)znd%R?7N37=w+cUsv(?lZ%YoUbTQ2bV&xznR=@1w!pMDh`W!_j5*- zk8?ar^0n0WdbY%1T{rn!9{(sz4M<|~>_`S_HvGyoNN>Vcb`Dak1m|uDg;Tnl6fJmZ zzeCD6E>42V*GgWX-?{Yo%wwMp7nQ4PEM)R-O5? zZ75;RaVys>AOOg7$6NbyRd#XVS7uax$gwxyzm{KK;cPQR0nr|2tFY5%aD3;X)J$=Mb_Nz3w+D>w~=E7f&x(+0d{C%sSsV3AnwM9 zkzmcya9vhQoP1Ya9iCu$5VB)NZc(5^={=PWC4i50t~}Q;eK0&r@s=o4=l>*5U=L?? z4;##b;8xm4+RASFW+082$PH0T@pAxcglZZix%%(ql@2RwmO0;ypA$0gHqisDbiD z3odB0QC|ml9Baj|pUw}G3-21ly5UsZSL&wp>TVzfMqm#KV9)_KOifz}_CHv)@YK-~ zlD}}IWyCKOc+2klHu51LzA1LzWQ1}I9s}W67GHubT!&iCdVjeh+#MIx8{(E0sDJ8% zh&aLydg}bd#{y5`1WHDW6lR4%L-5n)M1b@^CDnNdV56G*pNU7Lt|&=$wSQ!UK*rI< z1@=dT0`_$BF56{^p##>+VJe{HIPGd2v!Uei^^nC)C`xqW_BHqSmku+`W-oN+pK}BxBX#gxFn=O5L?aZ))DEN8 zpVCf%&PHFP6oro<^yZuYyTocjml|GRt6 z;?Y4#;1>0W#20{yp)dJl^%#%^OnMV8w}JU`U;EIwa8AXo4|j(PpRbnNzs3{DWi;|( zDkr$}l9-t#{f-SG`pK-H2(A6kEKsx2WGiK^n_azQHF&>)^&%ek?oj;YT9D`;horUK z>ie--jyo}{rpR?m8oi!C*tu(5ynJcweQ~_`F5m3o@Su@jft=Wt4p{fq!X&U}LXUy~ z=k{xp0{{rV2f$q2AG@_yI*CQ&oB6CjGYvN}CScRd;D8Ub%=>;k&Bdv?V8PhSU<3Th z!2LhVw_ZSx({~BmzI{EJufh9N9Y=gmVHmn*W3=TLe~4=;O?X7O8-9FY?5z94p6sgj zki0DMyKe2Tlk78~xs;>DOQO=y%rkQGD+e~^5Z|>VBmm{a>B*ryW^*H=2q3uoW*pip zih29H-Q+GNr)9`^O)0uetWSu0VkfagFtG=$%5upd(Skp`$+vBJa7=y8v&FdO>yOX3 zzND}qm#u!*gLr}s*Iw`kO}KyRHS+l56_XFk4fo}PWZ?4wGOk{goW(!iMagDCYtrg; zI$8zDqkFsDS#&@y!*QET_{-MO^#F1Leb7v0MeiMqHMo3Ui+^dZ$(f;Qh^H!X@NV4; zEF7I5`T{MH8_&>>!+3QJap^!&xl-;NL~;knnMh%435uNIgleBvs(lCj zq_SB3?e|)VpeH%pg}o0%4dTMtF(0Hx=6&D(j}XT-J-GH(5>?7i%HL&(&&afASk%O^ z59F9_`1uOv`+c6WASET-H-R@vzY6djS$Bro25bJUEwm1{0Lz0t+D z#6`zU%@;}-5#k=f`W(bOCIJbgr{heaHx*AIFm?a9JPGxvROzVP7p8b$V-T3#CHRvvA z>aw=};g217q?;@6TM}JgX2-Cz2ZwTq0n0m`MADs0+gf`M_i2j=VD8J7fgi>A0Q)l4 zA?29&^7oOqo7iYm6&nXExf$)TDp?0!4_k$cz8sW^EbJEJYuB9Kt$oMjvIkph!*#Q5 zZ-cM`+6nM$&`iLQ|KNX5O}wOhW0vo)UWt^SdHL2pYR}e8#_r^xNFB3%_$y$pX6xGAwvtG;0e~xg&CM25>3?ro41eP z1`M5PW?)6TnEmdlm~X=zPBtc@{l3 zcc%YAy84)bnpv^-i7-c8Z)4NaafC9bnwH@!owRm#iGfImkLovNXXfIaR0-Qr(Z0Oen4A`Q+AXqMHOzNA@4hC&nx4%w}!!2 z7!s|&Rp-~ zT{HMKbFmNB^{XYd2ofw!+(pui`fi##2Kta1no+lx(pJ*Tt?2c&^2)|*Be>lje{lTd zVZwsA%dC@U|0mwYe(&BVKl$&QC;={Cd?Qa1539l8GM);7xq!3QmIlE3i1*vmuge~+ zw&Evwy)7e`3x9q$ZtN$rU2+Hf8SLF%pLX9<(`J~d+f7Yl9P$f?^1$60BgGXl9xCtt z6$3rCV4TklQa1PBmH)DBg>>$)hv*0$#XK5!ZI&FP4eVV_y$1lc!DR?sOB@dHfRQDb z`oc1w3rkLHQR>6e!lBWKBJkPiP|M!4@-sg4b{%v-7NfG}X<#?Y#@U;m(A$uiHBCum zPua)V_&s00-(d7g2bI>!?wjtCvT`W(pwHN>-b5T9@jC6X5`$ZeQ#bj=*=PH#ooRQo z+KaF^hbDtEj>!b6f5_HCVr3)Pu1$fjX9_(7YC`av>)49d4ZOVev0Q$~s(x4M>jX@p z>wnD2*$^U#FeW7EyCOMO)#Vdqr+~>9)jPS3u*qoccB(Ttp&X^_&4WHm+vIRNH4D~P zIC>@EUyC=4ZCtkKzch?G^T_`aV=h=7Mi|ncGD>xgU`5I80E1w5j^X~R{+{3RS{xYG zSx=wmV4=n5sHUtZ5Nr33vNv6+rgRoc1ZM}>%+AFf{c8uGM6y2uQI8(aP-l%g*yNL- zX2tzSc2xaVMgM#B?@t{86|Y6sd(~W1^MgA42BXM2nucHV&uLTvX#(FAeF>p+X?Syh zZoGuQaji`Up%#|ELMoa|mJmT8K&z-J%D^-ezV)t7xx*|*M8bQ{LyYZ`|NU2hSM!R& zs>-D%f;CilL(8ZNo~cxH5pZ*(au3H#mlw_xX7 z6Y(yn#Q1$P%c{%W6b%wF0n>;OZ8B3)82aiC%_q>%zBPtjH@FVLv%c@H4nKA z`l)ID29n`H02|cV8PNIBWA%n{f@n%Fr9E>K6>Wp;EoL+}mCZ+XGb_-_9WL!9KJN2N zY`>Qm(-mM@wrw=lu{+~>Kp)Hm#o=aB^hsr+bTEZxFS z@HojxnfQT2qfe3Zwd6ftm=NdhqHlMqmQ8qq`3|usFwaHIN&l$p5oeqTCdJ60sdPC` z=<)??93-@s1GQ!CAfmqc1m1TRj@xkjTmLbK0S7E;}ENze!O|XQ*wD!2hy85AO%K|FTLXcHwO9&i_)_rmKqP^?B+gxas&-Rc(FXcjW$ba)fU(tRhgNX)~XyCtMNz|&BZ=|Fff+4axvHVR zUssKrr%PlUw{9l!zL&2c#^?!T%j>1(cMo?E8jq*dD0PyUmdGR znv0+3+EXXe$RiMCBA}$I%+moXts0|647C}>NsF9&uXfq17OH_C0I!I=+uL*-ttvHh z@%*?=x_ZHV3Oa(JuZgVK&x$*WXGU^RkMU&@e+}I{S=H;>DAmbpKSxnR=8&p;U5 z!sz6k0S_)0%3x;&AaF@5`-rZUWpLBVKGN!K`{XWOR zTjf;!mVa*5wC={Vb1eefYn>ceB>~ybG6v@gAkieU*nMJ@frWg@KQFr8DN<1g6*vvY zb5ACCX@R*KneTuth{MlVczbr2YTc=%%E<`8S9rei1wdt@CDl7GlmC?j*2 z%9OHwTMg*rcp7mwqz7OQn-XON)D*3Sg*2WW!a~7L_HN7cffw)i|GNBN2T{$b2RDo; zk~0C~lBmEjD+VvIayD4K&C`4vMtmq`Gd96b%43pL3wi<_%*}T0-&HK`1G|{a7}qNo9KnGzD&GNeLLn1iXbWmHJ&2{cLho5Eyn56vAwXF`b zATtrszT3xj>XNuTd`FX3ukFjz+4M@$i19B*wtY4JK|@;de|JZgc!Xf$QrZR<5$_nXRG2sOCy4)Bt!(T8V1q zqIcw1)*uUVO)y73nKS+gA?4=51nm{J$1>xct`Sawvi&9#W{eM+wx%$Fplwm=N!vvB;=;C&asW(vW2rb44XA}~O9L(- zZ3pO!c>+VX8bKrh^++ZA?g*-h4Wq*OD${+vn|i$IHl9gqVD&#r$V0VsQ3r|BzK0XG zm4#`D>EEoS@|1GKEJrhM)QR40)<-(H2N+F~c}fhZ-CydA530prqm*l{;N7#$s$Xm&zXrR zHUX?2j2Qotyp%Es6@zy};ZksmnxCsD9jhdTM0N>OTZn`6vnl>;RqgPt%0J6EXVU2) zHE&TYfgWZ|Rda6yxUQyHPqNfJC}6c;+%aB=_rk}5Tc)}E%~nAj}v zm#>V0FlOQ6o*xCQuTsAZPb?$12I@t$@*APHyJHQ8@+czMp$X zf=-icC-)mvhgE+TMsgpqP%wj~*h11Q)ik1-dxh{^u?9&Ijo5c*5@s;<2hCVqtwG7J zkWU_PUwdZs;Eotb%Y+7bmW#h!s687$fCZj2wHx~I;Yv6#`&zYtj`15s4t+gAFtW0up6 z^)ft#mFd~d3|Bp5IPQ$xp$WbU!trLT9yyM^kW8aamJuA_)+lkTNd8pJ`|NN726`zc z<+zVzr3(w2d`UZK;Ib+iIzMo*FUrSyp=9<6oz6B7HS6v{zQ=pQKbXo^y$>fzAtU$U z5tFhL&|h8e8}TTYYXq643$_>Tzp=-jNs=$2Uqpm8S_B4SVdpM;GnZLpw+AND>UzebnpF+Jf_tRap!20V}Nvxk^ zsS}xpY1ZOdv=-^DrDcHS3pmcBwf-sl{4^9b5lr@9!W^-wj}rbv-aeEK5QlrF7Byd# zZFbIzNY+_e>9s;y3e>i#-@03elsoKKPIeHOlumgNExP2I%oX4pp!j%J(MV_GJ!iC1}#&Cmz`Gi*Th*;C( zZWb>ufXJouiw98D@gb_hzLIa{8zUr#f3|Gu;;BJJs*Jwvzae-y0)7A!_%sV6VU3Z4 zf^eDf?|nGiIWe+8M~|giWsmq~k$TLs-BjRW?V*tCLO@wvn`i3Y<#$}LBToT>j`m#q z=-G@M2OU(WAWKUSg=zJhcuk#uJ-I`G>0)?Mem`jP^T&+tb8a(qZuuhBj|^OZx9n_U zK_J&iNAB#9NBjr-dK!JY)RnTDn2#D&^4QIK{;ZdGw^@=(0Qd>l$%%v0#`(Fp@bIq8%4?=;F)jV$Tu#bYdt5l}&V4*#7c>7h|m(A*$wWtFG>ZwBJwu_&VS0;EkW*iE0V!uDRnTPm# zhj~tz`!2<8>;o!M%(uxi?!eV=-<{FXo>=q_>w)Y)Vyl~QI5uNq7w_MAzEc)QhTd6P zI*Zwf=uX2Qxe*t&98)#Yt}OLsRes_o}`0XI56>04-D<} z-q;p5pgjWeGwEK(<2!SCwdhaykNU89A?hKu1UCMfCH^3aTU2AvXXe=fs~b3~-gr`~ z`LQMup?*)*QwBn~&F|s!)XDd$w9I7ohxaQxhN`{Ve`8iH}Bz*LDG4p7*+#uRlFY zKg@WWidqtD(#x1f=$hWwi0|)n2(f3I)OEmo-dhREQrVXXDS23C0)5S@P zok&W3`262CQg^hd8yETTFmEYXBhJ_5PiZqPBvyRI2UF`{dsC@p@Lqc^eve*~4urv3 zaA}vg+*a-eDS;8nS%$x2?B?eL;V%a=2o?31H$S7Cx_z_iUj(e)M|?a{=d%i_5WksN zbWFA%{3+8iwmD0r_y<@Ahg&~1JFk&aSbEPsxXqpH!c`|x6u;>k*S!`QJ_PipE>*zZ zxm7?H)=ZtRd$*pnt4=I2YIYkv`|-N_0?4+9@&R+|PXw)GZZj+`CDhk%*V@>qTE>7Q z342}?b3ZQZf1G_r8k`ZB9YtnV`jX=K`;f3_Ug(EEJpw{zqpvve7Lw{uO(LCyD=x4a zL=1B8+mX5pvr@`wMQXn>>Seo?F8FdxJDY#ubU?Pk=g;?&rxbcNDw)7LrE8R&$^u_* zc0q!j=P3Bhr2v<*0QP=wp+d^Q%P-{rcD3vkn&ie#^uRe9v)X|22E6d}R!Z zmmoKf4YHG0~jY`Qg@ni{4n0FXo8*mDnJNM^Q?bzS{d^(*W*-EZ7_T5+^ z_P%zmh?M%TCRXe$hK%?JucqXJq&+mM;6f*yF(;}$vw3~`>g@^NLJeQ82{b%mUz&@DVkPj#@)|If zYjGBgC2g;V*R?YWE>-U6<-fFIU^p$Dpjg~*Ux|WEZVEWZsOGo9u=0AH0Ak@TzYJzj5e>-B_K&6 zfvF?7pS%;QPN9Z#?lWs<99;b4jt<>Ik{cPn{}fQ-h!0SBgeHO?LFL60ull2+KaeL2 zrI>$O3oV9thojkBmk-ABB|Ar?fZ2y>B3kfy9$6P`!}FVSaFaxS^2M5cj%fK*&hjXG8u>LgBW zcLW)_Jxerixo`2%=LZ4I1rO|!zW=Wp>DKf;>Ka9+lP5=us$51BWWO1=Zq)uD2gEMMw8zLv*qCDtf*BBs73CH_KX}2KLhLSD$iW6I4mZCt75>8?*0ps|f85qV^Q>o>qS-Z?kU; zp2?!Cr0st%%F<$d*eHm&U58_$cD%iGLV>BS? z{s)FC1i_BJ`Mf8Fb)lGi$}`v1cf>eGS?9ezK|kf(1#x3n)YDFl`}F6T1f4SRZ?)~> zeQrIw`Y(+Qh%(3hMXO+7lGxRhg3rWF2$#<_xA3%L7&Zd+2WE}_?Y3V6}~6NvPSoA@vfYMiv=W@VLk ztT2D|Fg5hyPgx6rYXvf3n4k{eQp*syFmKPH(Y!WYFeHI@f>=!#L?p~ReOckX)=^pv z=_Pfk?ozvDlWVdUAXM3xa{aXdZCWkylsT}|ih3lMU857~Y^Mm~+id(desr-afswWV z6D2HI^#(BJwN)gE%;KAqp>iluK7g~!&JR3oqS_tAiX&pe<$Psp64mi>9?ATUX6N*8~oltp1m)Y=`(CDA}R-IZ}FTEh9<|Js^I{nzI^kDiZ%Juyz!gd@9q zXHMVFuSSa;DVERvvH7)`rlyV&e*u-Z?3fpN_|@jHfb`d!Obuo_HWEqQb6x_|t;*1g z&AMdCzLT+BBI*%wATE(WT%Oj4XS2g89Hq1-&7p?GsPqq&Kn+dX{AM?p&%)wLhaFMf z#)*}h&bZIK8vOOn!>@Vs2~-n!Cykr6kq#6?ICXk0fZc0Zxdyi;(;aVnpu|pjKyA%3Bj|7q_JRdBD_pj&7*l?TN+GTw}E!x!Or7 zWF+YfMn=8fbyq*R)F~J*)rc57$@fL6HU4a50sFsQo*+%G5Wi$car&?n$*li<%=e_Mo-xw7Y2##35fh zOZd9NPd{MV7puY{bi`g-Z$r8(pZxR$m~3tg3`UXz;`t&lOuR*4?FM{rFqKee-kud* z-wqd}ga>SKlLN`==_&gAEr)EWX?&@t1G-OI|LWJnCO_5o!UUW-XnGVAW(X zE(8c-hx4Ld#=m;=tNeApvl}PGQ+q-WH@^QdWXA_aM`J0VTr<(XplxEMFXSxod2x$= zn;*;z;aJNGw0;;6(b3AJ8+M%vYTLxnhbNlz6Pf(|JZUTbB~8IIIjhO`G^5?Cre>Jv zl%Iq50FAF#Ticae87^>gH?IZdniPmn5~xBO%qV%ytSFT&#TzT@UTw{UyBV0n+d~5~ z++uJjh!;Z1qapIVT0^zoj`urS_%W*6XQLIhRZ5sVp!(=@vDnM6y^mC+ zxgil}S7Bivpng!Ij^o&mRe9SnedWI9vmF=a@2!Fva;P-j$%C|5gTIG3#Atysn0OYe z`4{0wv~ZT5%oL?Oyc3g4QWGgqLtK*F@pV{&X^W~(FRxovho2Y1Msn(?T{JbaIzK{v zr6i?OU_uwf+<5Sj{d28OT!&x_GwFNBszHFAd+6k=#tCLxF19)RPtAjeF2Fyz^L%@{ zR9lwJsHv8jOk2*fxIOo|DwQqgWj0q0T z4eznxH*By_HX~?#Y?O9fFjQZw=?DY~HB-@fG{Ec}m?>+(FuL@%#?rE*tLdv}m%c=f z{AT=k&_Chf4yMi!+3e_M|DMkf0OZ}O{u}VAAFoTYWy-!%`2>CgW?B9oV&H|=A-2vI z0#RQ=i8+|3h9po8Was#$7G$z)mt(UDcStMSDc>F%N~El^x<*>*pWKyPk64Dhi_Qtxz^MxKA&$`Si_t4 z<;1MclVrIj?C3wQnHGKcCVpWI@W`h!!Z4z|kksek%GJ&#DTViGAB&lCchrUDqOGB# zSZ3!;w=x6yr)_C!N@E2?8f#43Hnt7FfpjO#-*|>6ac6}3rU=&I-By%({GZ!_4g|YmNrZym z+q?{=NO%v)nUX_A=}qSEV^^d#K=z; zEu00U9)Zf;`KU+n4y45YIj`?eugsb&^PYNfytNHeeYPWh3tY%vVVWz;LKhB%h3C}F z%$4kf`KqDJcXGsXZ1#LmBB`$rS-()@E>)$18Ni%7>=Q&zlN$Vqi9={s7kR`;93tXW_-6=jC8R7CvUC zH5OPPIE^a-1m;US_4vQd%2ggzvUqb>yv2SySG^YB5EjEdkk5h;6|h`sPsOIn{yrMU z`$+5Vd+QtWQDh-dU)&d*@&fUeoZX|^<);Z$x_C`(JfO%Yjx1n@YB0htMH(3&B1sugG+D!zzPu|KY5WosFsl>P5rppDXWkfF8^c zfL9mWEse&_3;DsjJG3gCf5q}=+ z-^d6Wv{7H%_^?sUv&eZDV?!T7^KWSGy?eQx%5?1Fdt8cdxNR=wh)5$pd?Xid^dc{q zFnr`ZL)`O_v4r-Vq&@HaSuBAeG~{N7N+S2v4bIbC+R76!XB=KRZ#}K#T0+5Gd5uHL z&WQio)Gjc6B)OFlE=lv`!^N-tmI#`BX-%;U^NpYWt8e;yihb=KsB;cxFf#pX-UY-5 zFD7@xy)NwOTx;NDcQZTI_-~`gym0v!Dqq&o6zO=R@=9qWSGfL;<-=F>e(Xg}TD`AB zso?M&P0}}chN0?8zamDYdA!|#;qpvW!`ag&pN)Pd33DHd(~GNx4FRsBMW?(GqJ_aKee+wKLpn^uro5%oL_E;o%yK zklxhhZK2+pq&WWj7!%V)>(hDh{`Vz5)rpEe4FApP$$~BCxJP2%xZ~W*^J-F{&B6El z;;EF&b@K{LRjQk0Lr^>+_Ev;U`vXzZPznLUm|q$gY90XnhOH_;(>JDE|J%t)-GzW4&kVt7^ zrr>&@kb(XNo1N7&VP$hO_-~9N+5}&AI+}F$hD#(th&>@29_rRCaXp1>+00V@U;HK( z@KGd&+`PvbLjDFg$Yxv+GF=LzqRnIZM#g5T)$iMzXQ7{V9+{c8U+o4de=01GD&1^c zE&6(Jd!4N%N8>?6)-J^yyA|Os&{F_}EMVMHfgj+bAr=~bKdDcMXR&_Ne%z9xYJFN) z^AE~Cgzon_r>~+{xU#!M0bvSQU%zW@HZ^Ad4r=K#lH_J<^OG||!blq&?wwb^g7OOj zcannI56Ubg8<+m*euRGW{O9L8jT+XAidLLfh!ckatN%3BA1Ev@B-}k$H#C25&5HpZ zrLg2GYj1JMha|U9z9AqBpQs5-HO3pe$({&U@7Zmy#hb7mVoZq9`nbCL0ko3bK}@Kj zJOh$nr@`iEu9w_+Gk6bWenkJqE*Cc&{d*KlhfW6u3mWVXO(#H=vj@k(03Tf`J~dq_ zh?+vMM!Dy++_(R<;-{dQdHkd2yo){wx2CizkMhr=e~Rsg8{-lC)WwK_SD2WZS7LCe zUCU-R@ii_$r2{Lnt$n#s;W;X|?#~!lc7IeQeXR0*`)v@rRR>i`rZg&suTuPMkdm_; z+o-|4@oH;HJpoJ{Tfe<~&2jRnzOaPbtEg8;fbl4?>WhCPUj-fR-Tdr_k%OY&fwCs6 zio4~zkxp~Ru)KVck6w>4%)hzb*k$T5z@wLeOG-V{GvQTcD}rdBh?L!iREBCMHOj!U zKw%`m?+%7<6Yw0!HM}x^?H2?LbK2c-jQ;r)CX>&B#SatrU)gh%Oi!q^rqb~wH0C+@ zs)^YEfYUy19R-apIbYW9zXe3{L1Isla#(V>^6uRCCp7uzVBf|MTc?RmjY}uG!xyz9 z;+Z;ks>8A~bi&F=8gSI1nf!4CnxzFxM^Q?IxyL3q?ixy0(j^JV3f#?kb+^SgdBgrS zq|e*_j&5QAlL{Vn`-`2=182p2mM4GDsZPH|x7nK!5bB*zmAeQK^OH&IU2Ojdv zG%OFm5RP}3Ok?bwKxYawv87ICGJ-QuL%SI3?d@|@VLgg`9Np8v?S9rAojO25ReD8& z=S1%vO9fUrtBvzNzHP>O@u&XkOCA<$dJ=9-I%RhH_t#1+SY}N6=LQ0gSB-dDDf9n& z`|7ADx2SJG5owVQK~d>WK|)$21%?{Br4f(@l~O`bq`Pw{=@?47q!EN69J-sKzGqap z-utfge(U?^yKA}D#UxC+8Y(h8$-Oyga4LQBvLo(#IR4b|vq^ z0>~pOsvibjv+hW=Pgqoncp$KXxe-LIGbB%M^7bdJF~TzarR(h{5A9dve|kz}{@0FX?oS3iZY&?VYNzZ}eET@gBM zk5r6FZg5HPSs1>9<*30pD9Y0$Wv{{$lzMS31DU1TNHKdYZbR$bct2Uz#_$w)hMens zfthh#Jz?H^@%tt|(hhxrrspmXm$W%GYmy2jE9UfDfl>h?xu?ekfUU5ivE87 z4g0(|kP;;Y)j>0k`}%GwZ<7y#Dk9vD5Um-C~-O5 z##_#j*9;O@nE_G-ISR<~>6ztQxZ;@P0{U1b!AXfgFR%>f)e6c-holD0p9OJcKn8Z^S+BZ0jO+l>RUq!G ztMTDu)0npp5JLlCrGg^OK*|dWIoy?|k&I=BbAF=PX8+M&Fh0-~CO$<(*nl%vxn*8R z!Dw*V4+XObJ4D%$M=|@s`m?#lubiE!_HoO8l3Qi*9X|v1p&v@Hl6X$fi-B7M3^)YJ zmq8e{KVx(gv0@qi&~vRR^Rv^Hj%aSoM6mJ-Wu?3tLNHJF9FH{r5~B5ph^v}YtTdhBo3pXuZ_Xb{4J+Hz0>)qnR}J@nJdV3~ ztjz70p8T-xDx;6;g+`h7q|`ThejvjG)ElUHD6|**6?(BA7y)(2BE+(=g)Tt4>F#PI z2<->7KZ`dpQWFdUB<7c39jr#EvaoqeR+_~slBKJzG)d(NQbzCc;&OLc2ARfOHHJ`l zq91ujh|xQu!Z&Q$PoApo{6Rkr0gnK;f`<&3cC%xGTQX;ZDDtUtKVl-6z2*nq3{&Zo ztXRdEmfQOsEeA87o=587#YUK5;_Li#?F`N3zxqO;pUMy7iJU9YG1IZX!Vv{f9AlVa z#L&H37kRcX7Opx`>@=*iXMdR5ssY+PT~!{h_%2sXwZvO{VJ z>FMz+b#t(+ip#OQ!I>ED{UIWWKHuPdXxA{*w0o0&CN0TIQ_l4q&-n$w>qWf3uqUf2 z;OQ1tCZXcX#lnKa(G1nK!m6c&>n>k7dKerTLXLN?BuF(`Wo;Vi0&`P6Mb+L334PH+ z&(-!$xGL?T=Tw~0Yq{O$YnaP`3u6XBx-eGiG<~lJ5|#0P%4QKR)K}6GY(G!k1zHb0 zCCqS-?&Ot&-lAJJ#tNV!-*`J=X;|kWq*dk zlRetY_B^PTn+*x;104hjhqL|9i@c9@!XDrAuPW(#aoZpbLxk?Oyq?fjGV&b@ug3h5 z^4`)azSli?72#Bz)EUVDeh|^sYqsHOJ6P#olOWeJz*pi@Oj&Xtf`9KhcQhm zs1Jul#Kr9{`)yZ7%GIV81u($1g(E$-R`9XSx3A62yH9`FhM$!d+( zL&q&N23VD8Q@g&cj(+W_HmQy#vUv zb}pme6K){!$xWrc(#Xkb0%$eBN~>xbwWaV{j+~ALx?XSG&$0a*KLH;i_LM1our#gy&-bwhH%ciw5;U8x63 zTdE};89wqtKLFSvy8_GXvDRG(jB4#yUIB>{WI4dUo3mYe!uL@gtHMa|9^OXKf60GEus-(uNeKizfTk^R5YvU@H){mXSRXJcVkD$*JQz!a_ z16vaoMd1Crvm*i4m4JjntH`tXs7;sshNuTpw|pkIHUT$v5bI6x87^=fN@Oob%uza! z#QLu@0R|)ySuE_H2Ihp@4lX-CGo2B;fD{SwyqdY)5zf_VB3X#Yh`6OR z2enDYKJ>gZ)9mDX?|wKCzX=>rSpIfVpw9X1Sy(yAHwmI&NLHqSX_8~>V!n2{+l9KH z8^J!)wSJBG5o#jdvs!uSJ6I({OP$2`r}HLPEh!ow${o?Y_>hO1z96SX7r_D9`NL9` z2sNB;TN3>5woa=dp@gBf@an~tdUVg9iR(y?g%PE>`na@qax>d6a2IF4wGt6^h1ClS z{zD28;dta+nOBR?$W?m)+domw9jz`vbTCBBkD7~02s|}5JNkvW0A@NA1>7%m_GRxi zTufnuAK!-hYs5-zq_5&yy%g?uz#c_(vbftteur7TG&x;~?%$W3yE+Vwy_AbM?X#ir z7^>@XE6JGx=<_(1Y3N4J!Le;i$~OxXx*m@I4&dx`SJNNyQJ8LhOLV%{o;MBl9mEV2 z@EO3O&I#raz&@GwG`hxjxqq;5V{3wx_7Tezrm+IY0OJCYO#)XX*BHmxotwK#c={z6 zWALJ>;W3VuD|Y}#ntbg8s-BQ5zC6cNq5dYT)YOh{xkG{|UAmT3<&KUAj_mbV`56cC z!;=;yjSGtEfp2u~Qg*y=Bl_aRFie;98rw#)dN?>Z*|392#PS24|LJ+4oyVr+Wa;m# z+J|6!xxW(u>Sn_zOo`lJmM?`uk(1pF2b)$K0Cj@VtUk0mmbIkbQx2nEn<>dfwwC(k z&J^Axr8FPlFjn6U((xYIi#hf`PH2*5a-`9I!=*L8`*?uJs*t15NI}^&X7){0npLI$xG>4jWI9TsQR zMI*>HjxX7Q7llm+(|BH*x(m2ezfPl1%YM63f~klA6rXt!pAy-JgabTrkN6enPiK1h z=|WA-{?VQi$w>pE7t2b6U%($T5{nRL*L8c$OB5|BW+ERGp{b*c(dgSx4~}TmIWIT! zC&ZoiKFQ`ge&u(Q%#p(}J&x{>yJrg!1a1su11K;qg2zw@h$L$W171O0XV7$p-r4pB zCef5ik-Dm7j_?Zm#4)^!D!*3~nN5gRLv>j1LQPdGdlhd)3{@hXq4IvA{#fIuW5yEf zd}7n0v)W75x8+>Zv{A-*?L5E~o(f-stCKE*QQ8h)7Y<#_n7&|JI4lx6kq6{_OdAQ+ zTh&9!#NIoD$J-Y|Dd}#4B3gd&^87jnGTvrW?&Cu4V&(K=uG*a5?DpJY zAd>!CFq1vZnlgt@oo8k5c!ZPo(Nbl_H8zwP-XUPHm$E_j%iJ@qW6{v#&=(BwTkEHk z465%@86(d4M6c|mrKe84l}Dv5_ASG=?;gL52su~VpQb2FAKg1;+@y+`B{Q9R+`XjE zVy$l6353N0uOe<;`i*qi>>@??on9!S*LCE~9E)}yFqz`{qmW7z6Jx*#J#{a#eWG4t zkIz{_1HDIY0CjssS3YovNGxa0IH^mWn$9FSM(K@q;ObGq7mIH3w_Q23rhpuV7tK~n zQp4dI)Tx@LlbBwq?EUV8A8~2$s86--3W9 z^Unw%rKnB>1GJ&HW>h9parp4+kHlftguk>a(h_~b7wZufKCq~?4Zg#n)u>d{O3Z_^91sh538yHkW2M(Th@l(8CJyA=Zi#yEB8w-qT+|X==QrT&@4Q{ z;eE{}vKadyy+;P2yOJ6^2?r{#q(x`uE?#q?$X(p18{AB){(gzg1GyA~;5+$sFp_=M zp@PYvkJNP3SWa&s$X*}>*87ir2z16xe`>nfAiR3>7&C7WvPGoHi$9ghEuGr`qh{=! zmx5!-d&)D`tsDtwj2u6@g&mVTVshl7GP4cZ%|+OuDgt~N`3+j3QSRW8fHDv08HiZn6dx73!tU|E|$HAVaC1Taf~`Kg|>`CQ3sBj4L+nVY7;c*gU}3(?qV`T$z1M0ec|S06Ty8(@`k9|j%; zywF)x`j}>(bgqS%6zsbe-A9L%1Fr9Au?qii1NaW&Iuk+F(^(A|bK|??7zLRHdcNx* z*d$S1n&A!UJ1a%R_q71;sgWd$oNF+pkTTKv$J;9jC=Ijt^wHhkZ=qo*1o3qmTn9}9 z`>vS-HU#OxhT)#FSXJ)D$>${a6kcmT8}OpZyEC@KGvgRXUZLuv zkmsIR#{IZnx6>>11kYe@Q==)Whf77!Q07|PQ~KeRD8`bCdOE|Z@6$#?iv_DwYM zy}@6emJC@jByz-=;=Gi|^EfwRN(F|ZLypO_Znxd(827-QaYxqI*Lrtfs^o*!p&!9k zhWv>fJonTSiSEB8rSy9evCttnLyVgfv$#rT_LJhe4p&dgLC+=UX-FhD!U32*=~aH& z{KJTl9}qj>vQ@~)CEZq>z7%FZze+Qr#ySX z(X4a9JoV$AWJk1-__vG;jgl4|$zAvJx94`>7$vFB!v!1BO_t3^e1lJ zmp_XP79U1k`keU^$$XEIwYj#UY$;3_ci)f}-`_%gMe9lcQ3;J+D5a{26C{#$X+HXb zLb`gL$MdR)5%Ac~q~$wRX>RfAU$=GTpou}X9^ve^Fv8GB*8xxs?z5@N`i-O5?Ar^B zpDidxSz0dddE}Z-kS*s08ZYR>nt*R%JY`lexAKrgel^lQ1`h`)r){U9x?d}yYnd>CH(Vv+O%1aRU?OM@t0qdeH}1P#CsC=oqdTbagSg*?OgWM{+8HNW>z<9? zyr3Uz^2QC*qRHTC>+4sMA;IOIc9|b3=NJ1UQYN~~!NCVy<0`&@6P_mX1&1!|c@Ni- z0Y9g9qho=M!^4p31Nk6%sGZ<)jFSx#Y?)URzceZn`C*I4K}+hWJkAFBOe5hr8a!17 z%3%tlUHbY}La-6u9)^6_oO!yTbVS^5UwH>ziyuL2jU3BK47|5Ak17U@#yC)!k#C_At22hzR7Tx_+h(0 z4pK+WHw|>KrFFTSfbk`Kw0SIu1Y3su63VTmO6DDtcA6#|pd17a|p(FWg z9Fv61Kal{tz1P+PrAGp$4B+1vf1b&EN~%^LJ%|doebm9>yC*p#FUlNlrQHDk;}Tlw z=@VOTZ}m`8wp(-;&-r>}J`|Br;s?xUA!o^Dod?G-RSlK}G-i2a9k5L#wFJ(C!%t z1#)!iCv!O|vW~_ogzP@+Swymya#QNmQ$gk6M;f@4BfFPW@&)&HMh4pZvw~@-MEWj&l*RMD}Oky+TH|kDyY^9vg+sS-o7vE;LXYF;DJYI3S8Y} zd=NH86lAI5L}of0R*Z4ktSbiKykkyWNqD|e{|+$oQn0r@BFJ`I>j`l~c87-T+vn&y zr!?Q9_=TiTI4DyunP6eBHRq`x&vUu zj94OZ7v0@{Ed9au_!1To0oo)%=)5Xdq${sK>j7pe&s|`qA;`@boWqYFiQnUB|1sfo zfA~-E0raJ18b>p*aLN$@+XPulf%hz;IC~_7n@N1`$Gt6M4CM&3?aXokGNo72lUl@6 z0~(eJ#jbF-ECX^20`{F8*DS*QQu+-q`MTOH%+NnDy|`E7mz8b z?!(VqF#@+10?1#}(3H^(^urIf8zT$gKq|2za)kz5^e5Erhy%U}$2gphn|W3&HSFg@ zDAk#GJb?xVsc$Vs$-z?Y@SI%$Io(H1B#k$$QDbcUA=R{Ax9^9MO(B+``1=_Fm$+SJ z4M0uBwzdp}ZKM`-aU+lu;g4ryX?fOo!DyrGqlD*=5E1pAFZzSoj)p?380c{o?yU9$ z!{p1}VF<4I{DXs)G6$Ms10TIS9x&Kl8!NAO-534F0w-WN(C^ z8pgQR{&pwv8}X?~*i7Ov#uWhuqxpFhKSJj2QBzXTbf}C^kbDQU3TI6@;IP*cj->E3 z0~&4ID!)K|{o;|we9#g}J6GRQ)bBD5plJNP{dR$dpWIz;wxupsSS(?8ntq%kgIKr- zgfRzo(FHV?31qe!_A@ay{`7b@Szo36DXBT~t;(jDI1zyoZh_ukg2}SlsNSU|np>w1 zv1!M?e$8)c-6wo-PIE0-U@g2Il2 z@!br9cN;gm{2ic~ZFf0q(21C9&<%i(e@MMFNmg>nDRd*x5?@*Kmn+%6ZImxa222;T z^tYX*XqE9yM%$g%wOAx>k8QKku%9#)jb|El2_fW*>w8vhH;%H!0znMK;$-^OI55dd ziutH&QXL(P^rSMS%Bo8os7*5zLyIB^jZ3<3@?3G4$R7NLMyVdX;7EU3Jy1^lrnraW zz7%j`ItYzz)z5@CjNzVZ)w6jSkqxMxp`R3&{#Yrge&cibwb*B@TX76`8jeyxNSMR%Z*wVy@1sq#yFYQ2ApQYV$&Fnr=0C zrZ|9nWjm9CGn26NIp!YR9z^nSKBlwLpisPM^nObQ;h(g}Q>*<}-3%b~t!{q5)x{lV zQ%`6pih}ytD19Ddv(}~cf$|OT6T0>y_wtG?zZ5is-jhQD zrp#@TtUVH-RW5Z{+`L&v8^U>r;->FC^Tq3poVN3ir8>Co*a<=#nL0LEU+!k@hueN_ zaVi%ez_WCcM|IG0l3P?-oSS}(|7r;T_(xk?+nM#un`ctHF$T$Q2y^DNn9G0+V&lbW zdJeR!tK9>-vuw(8hm`9&C*a&if^%O1S$g$w)cW|(ho+Xh4TJA6zP_&U_(s%Ro|ZQ5 z0-19fcmPYp`=<1gb-!EVdx!Eybs_aa@)Q<1y_fUdL1C9+F!%)V?rv-K`EGJecDz}K z&_{%dEigAg$u|K9wRD&wGY4Z;qrsnCdT2MW&oGqhcQq+#MkL~8x1+EpDr96ya-6*e zU5GRH>z&FN+fDg!=2OFD}~s7A>-zjIWI$uM!i;4EB z1Imzxn(Jt+Ap!1?ngLeek*mG*R^84T_mJdm4;u){cn|;>vc0789Td1kGr`FS+Uth2 zz+BF@bL}9#R%#tzgk5BBC6Feq)Y}7UqKg*Ax;IoOzSBmgIJK4RYa{p%YG%^!N-BsJewy=msgXI?-*i2;4xTYMO!)ocnl-sRlW5Uc`BF=pFTgo z5pn0EoI=heH)+9A6f{MU^_0^@Ews+Js%p-aE()@j9YQ=a5fFerqjqr0gg+@?Ee(WP z(cW(Ic}8up6a_`OX#TxC?!qPY>6utZd!XZX25i#jMXdr?8XvhSO3whp{SAXl#bEB` zoVp620_kIdNjNchCaB=oBg;NprNqbsV9zvT{+@XQ5H?>4A5_zj4y(?wwnNLs= zCt3OV*%6?SH?wB9W6wePtsj+>Q6-;zG>!z0V=D6I&qpqNJPt{X#kzN&UT4dc}mc2&iay{1=Izf;_QUjM}>zu)`IXi~ZP1=wogadAv%gK%>F^jhcX zj?m`rTnqma>p8|$b1Z4F?W-C zi;a^_ob)4WXF0L%i^;4n6?_q@(V;@1erioO=jq)Sor?VxK^Wdt%lk>W$N zx0>{Hd~bUb1o3;}SAUJV)Q<+^s4lIX#itj;y>v?w z?Y}uZC}0->S`3!vc~0{85vv{#e_AjkXHKml?w?|stj%np#!z@*jo4+edN?flQpC7G zaUAGS^lO_dYBhUVV)6(VX&Zm)tkf{#iZY*WU!J|>1a={xxJLi5#@4qpL-E<)bMLU? z-?703=cx!+?Fa28?5so`+AzLme8*_*rrgm)f`g@%7paUoVds0pbPLfKh+MrJQ#bnq z%`#2a0Jg3r=iWCu1<{4`+57e-caPld5NVnuRTF|Y&JEb#S%}6>Jm}5?%Pit&>T8T! zu7-z{s*9f$rDrKF*xaoXK^`3+mIFOXb`^wiZmbUa*w(CMZZd96)jKY&kgNtHw^>lr zI5N5t)jaAI&#q+1l*l@YOY0!`DZpguxWeYCv{tvt^s}5Z*W(Mxoj?1V--EaC?Ahhr zF#Y<5y#M?s(C;2eoa@Q3(}w3*41zqBHpGRR-&I^y;Pj!8bx@@uwMXgZ^iuT-%}rtb z@;eI{LX{7#L(?O}$1nhrZ_R@H;%gc9V)D$EVUs*f#gtV$_cg10esfc@%2CI;S1_f4 zhbk8F6TAu*`$*ibZ=|Pnfu4uBW1j=M`TSWy^UyC|HhF!a6VEzUuOZoJD^z89XMWnT zJBp~riPfA+=+9Z>O19i#S&blG28oN7ti`kgF<3-9wR;NLr&KSnd(ts9Cu?(31zo9M zwcnTu;&*w440a`^%6A@4+!tOmY`FozkAg9ooEj zB25`!@)@+H77N}$ZNFTm%FDFLQot~Hzg1?&NK9S9Kc5wY2H*0bT72TBe_LaFOXy^c zo!r8smFdL<9LGk^B7EfSwD2<~=jpcKbkYf=e}o9hngE$Iaz!dr5`68EQldMpYI`c%DjGLE4-gXs6s)ldtHqps*Wu<>&5H5wmu9Nug7 zyyNCI1MuZ9G7(g1h6fxuDMm2snCojXphf%25?<5Lx;22>o*P-rPvJG2$(;%DJATt= zL-FZ(nOvbh&gY3RzOI|De{D+jrp}MX$W2v$nP~o!l|hvEr;ZnAc0M*z{`uChDDc`a zTTZ=&_sRY;@JjP`TW7G1pq<<-KdjPu<>;f4BiEl>26hBBL)_Hi-h6%a%GN)WF&))XAayAEweFo)~Bw~;db zo4ENe#q?ayo$^>(&!oG(RBx)D{O~#3Sxj6^auZZ2R3(;ddS(dx*#zBrUcBRhL99Th z7P(ZzJPoTZq^#P*J#XPJR8ZZHyQQ*I4BxG&%a(0=cF3uIA;cgN%_Jogk|qL(u{~pL()at~;rsOyMM4>Z8B7U{%DFr|MnQ z-o+l6M^wPGQSTz4W23zb-P23`iJg2J-FILm^8Ndj~>j6+E&pDw^u>2M%;HL#q}C~Y5G4*`alP%6Yqv+ z^*Fb@WebGx6wl4mu;D8DzEvwwX?+6Ezp3sRogwG*syo10stPe!K`H2ATg$8K0&~!C zXODn>Pj=R1jDMOV>&t2FwI7^ZoAZ!cy;AMFrG&H9w{RRt^;*Si4J644;`9R4WnVm1KW^YOQxAAFuW_m-D7CA`Jvadsrira z{4xo0pvt}8F9FmHcdJV?4)LUF)ZBvJFgEDK21V0!r!wBi%QFBuFCVTrcI4P0gr6A4 zr9KP@C#x7<$!W}G(xtAbgT|>Xb^3|O737XUO5gh(hvU?{`3Ee~)n)*m;iXbo`J`au zZwpfMNW~LZx0=lm*T9i-*gHWQDb#0?tbq{Gvu!xEE2=#`8PG+09z@!6=U?aoSp%Q> zYp*K=6JiQKNMB(<`43xQ>y#uGcfOI6_LqpAA8z)1IrHGa>IHj*OoPXhfR<4!bNzK} zEoU^1i1voZ)}00RtA=+0Q!MM#&NG+9uKD+VP0-N`>$)=e>SYyJL&9bmy=pxB)Z-S8 zw($@BSv4w#pXG$jQx~d9CDcAZXI~GF+t)m)F}Go~K9=VUy;#I1`DOT!qWdNoU90I0 z^9EccIG&B>ozRET<~sjxsFJ9%>rQxJ#3Pz;f_(7y;4v85Uz&$o$|%9TQ=Dm;8sMJs zs#DKYuAesmA~wSMA2kz{N{+>)Fx?WV#G+=E$|Q}2fu)DV8R)|1qvlCnwx>z`A$8?5 z+Y~b{blj_jH}X)8m|elA&gHNV>YL#lb_b7m&PX8>{oUH13;fG86cD3m|{iFrOkptKfgrHlxjX?)|Y^=<_Gv zID#t5h!#|_iAjiTc_bwabD5kX{aG+r(eI*%=~A-Gh0T+Q>tkh4RA%1I@>qCHoUd8q zMB{a*$@9@VlLijheOk^RQWN=KGOek!(yeo@tivr4ny$x0W=;ZM8JwyI z;b$^rD@3HkJW) zKFCXDJKWG8Cy>P-7t}&jwr5WCmgtdZMbx!-Xi+VZ&F`5s!F&a^38;effe^r|xn~r&lB!*5DJaQxHrp8|FF|8jn03B_qM^a) z8|DfuM7S~f-N_sNRFkS(D*+GDnL`~kTIKqm&vuQlpcj&rdM@v}erwG^&F>*SbWo`2 ziVS4MM`y$a$CWMl#{cE2Ky+x{Sam^F+rx-Xs)*2xP9_U(7%}Wsb*b@Ne}}wyJv|nQ zx3zwwv%in^2GDk@TZ~!pb_i;I!6&{x-*{my&ScF;%LAJfM;|K*J}_HvqZ9vqQzmv7 zRa<5-kwUF9;L^^7<~TO zb$Rd;hx60wzWBxd>_f!%nTMUy8{;Td^7%6HO}P6}TX`-8ujTlTma(Z}H*1sw#l3%A zJERHYLWd@odgfX4BG4>V$oI`V7vnJexg`WfY`ULqa%Gooa|OC`|3% zinprBhD5kAh*^Oq0sKQQVxZ?8-$mt?={l#i4*{N32TGvG5qk~F+s;?&vQD@ z^8vd|yKn8!;S}be?ufI&q->6jGr(cw)A|Y)6cHt9sGp#0#u`$M!hrtV*;_;|L(ah*W3)OJ@KcTJN_-yFSpJTrj-G zLf+#r-Uowq{o!E$$zh1fi2K3M_k%&b#cx*e+0S2Xa~9RHcqP4{+R<5b^Ds&kkIqv! zweg=W%H$Id{TSB5S*HiYNIAr1|JgD*I$J&QNnuS>wq=nj)zC)x&wIC8u0t~Ov^fpn zVrd&*+fPEr`k)h)+13g3n=+7>%hk-1Q4`Tr%yN7XcRG{jTJEKa5^#BGd*3O zII;z&%0QW|8Q(2ax1MQhr^_5{f_Fr={}B=7qA_;;qY7T@F4KX;;G6aOR^ut~cIBtw zygU%EptIPg*nlB&EN|W7Z>&Pppy%xMzoks8MMQ^|5NDzZeWKZ4`5kM%ml>b?q!n&QumGIfk!Cz&jkt?mK095jA6`53{K3c7_J@Z z9w%F&R*z-uE;JV(PmUc_-g>ney@nO4P17(k^`-R>l<>!x@iZ!vR1#W zipES}5ZCZU0u6`-^n?ErW)U0{d^tn|6n5Lb3=?dj~y_8+yzj*C8e=Pk-0 z2z**piOF*<6+^{-z``{!QMLj{&?J|3sU>+TXqivpBDQw3%4*viqMxAoD97J^+~cnk z;KMws-t=zg(*EREXxd$JNQMw&=pS_*K7@-gSKucJ9hkrtU!q&89QLD1jqs2YRprrf zd`LI_)(=AkqAw?bvNkM3s-ol@A59LePTH!6#bY#9|Kh`0$^}|`-X2o$sL|5SP1j0N z#LJGYJ#qgyGOE4p_w);L%t{eZA3U82`US(g^Ma?3VA1fXrZOeS$&Y z9T9N%q5NXnaqs;4zl8{LOW#^obxGxM62_w{DWFMUW;ooCj4@@utu9&6+r(PTO5m{H z_hDcCwmU)9Pm1z5cnUfAhAPma*zO_$Bjk}qYhDz7a9_&{>q@mFV8q>})d9Seax^ba zr(RJ61bR2}Eoj_4qj;u5EY$U46Lyx@&;KEX_nH6d8Z$O&Xf2HykLL&qj?&9vI0|w8 z>tg{k_syu5x;)~*cMKK+EdLf9?NsQvUe1|hT-0L8Hl8MhMq#oB?`mQttcGE$XXm_i zU|DKEm-5pJwKr8ie)pkSt7R01(bp8>eC=r%{7lC;Py5&a=P!%{z;2kwv%h@`qt!T4 zA!f$cJU`>);enqsl8ut%CgV4~v+*?r{FxG0J}sP=$6uv2%89fwK;=g#m!=8nk(GCO zVqFKBKVdXjwlp#*mYrY1Kxf0CtHdSoC|O`*WKxChJt~Qd6piwY_70=DuU>8oJ;>_= zbSZPb_UYLloZ**V&~6n$FUos8Qg*V)k?v(763nc~6e89g$)I0S3V#-L=o6VJM*_aJ zdm!e|1FA@JKYgN4rn5r5b9i<0K;VO|&y1$=T}uZ~dpbDt4OyQ2a@RHWk=cF+L<;zp z@kvVa==oziR_7AvRon&K!jU#j)m(SC+(2GJ-Nj%d+RIyu_LVWSG2Q*yX-UoV@U9KJ0=x^7mR)yqa z2UiDZ7;}-?u@IXAt9&4dzT0wRO6Kb6vE%>z!07Ru2pf7HApZHATXS_b-$ppj$dfZc zBxP(mRgFMv(Mu*kV#xVJixtfh_#5mKSiIDFku3O4TZXMAaqw{Gp)4h*q_fU2CSL#= z{%cPFMy#!G&AjL8iovqk8#Gb?(a?<(f%V^ws;W2t{0RI#KRLiYm$&w7s{m(Q{rg`mY9#je&j9!PUmXegKLBR^_b>cH*Z=+n znVBn?<<~CINdKWJ@S8wHb?ZM1T<-SwD*t19EI0qNz~5g(hD-Wne=qod{{X;+|1T$i zE~B&A-u>4e6x#m3pYp#%Ai4g(Q}Mq +%\VignetteIndexEntry{VarianceCalculations} +%\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 +) +``` + + +Let's again run the example from the quantitative genetic vignette. + +```{r FirstExampleFromQuanGenVignette} +# Run the example from the quantitative genetic vignette +founderGenomes <- quickHaplo(nInd = 20, nChr = 16, segSites = 1000) +SP <- SimParamBee$new(founderGenomes) +nQtlPerChr <- 100 +mean <- c(10, 10 / SP$nWorkers) +varA <- c(1, 1 / SP$nWorkers) +corA <- matrix(data = c( 1.0, -0.5, + -0.5, 1.0), nrow = 2, byrow = TRUE) +SP$addTraitA(nQtlPerChr = nQtlPerChr, mean = mean, var = varA, corA = corA, + name = c("queenTrait", "workersTrait")) +varE <- c(3, 3 / SP$nWorkers) +corE <- matrix(data = c(1.0, 0.3, + 0.3, 1.0), nrow = 2, byrow = TRUE) +SP$setVarE(varE = varE, corE = corE) +basePop <- createVirginQueens(founderGenomes, n = 20) +head(basePop@gv) +head(basePop@pheno) +drones <- createDrones(x = basePop[1:5], nInd = 3) +colony <- createColony(x = basePop[6]) +colony <- cross(x = colony, drones = drones, checkCross = "warning") +colony <- addWorkers(x = colony, nInd = 50) +colony <- buildUp(colony) +apiary <- createMultiColony(basePop[7:20]) +drones <- createDrones(basePop[1:5], nInd = 100) +apiary <- cross(x = apiary, drones = drones, crossPlan = "create", checkCross = "warning") +apiary <- buildUp(apiary) +colonyGv <- calcColonyGv(apiary) +colonyPheno <- calcColonyPheno(apiary) + +``` + +How the expected and realised variances look like +```{r} +print("Expected genetic and phenotypic variance") +covA[1, 1] + nW * covA[2, 2] + 2 * k * covA[1, 2] # variance can not be negative! +covP[1, 1] + nW * covP[2, 2] + 2 * k * covP[1, 2] + +print("Realised genetic and phenotypic variance") +var(colonyGv) +var(colonyPheno) +``` + +Now, in theory, how we go from the individual to colony level variances? +The queen trait variance remains the same, since there is only one queen. The worker +individual variance needs to be adjusted due to covariances between workers. + +```{r} +a_ii = 0.40 +varA_colony <- c(varA[1], varA[2] * a_ii) +corA = cov2cor(covA) +covA_colony = cor2cov(corA, var = varA_colony) + +covA[1, 1] + nW * covA[2, 2] + 2 * k * covA[1, 2] +covA_colony[1, 1] + covA_colony[2, 2] + 2 * k * covA_colony[1, 2] + +var(colonyGv) +var(colonyPheno) +``` + +We need to add the covariance due to different types of workers in the colony +```{r} +# Get the real number of fathers and DPQs +nFathers(apiary) +median(sapply(getFathers(apiary), FUN = function(x) length(unique(x@father)))) + +# Genetic values +nW = SP$nWorkers #100 #BB assumes mean - so calculate as if this is 1 +nF = SP$nFathers +nDPQ = 5 + +varA_q <- 1 +varA_w = 1 / SP$nWorkers +corA_qw = corA[1,2] + +# Covariance due to super-sisters +covSumWorkersSuperSisters <- (nW * nW / nF) * 0.50 * varA_w +# Covariance due to half-sisters +covSumWorkersHalfSisters <- ((nF - 1) * nW * nW / nF) * 0.25 * varA_w +# Covariance due to full-sisters + + + +mapIndToColonyVar <- function(varA_q, varA_w, corA_qw, nW, nF, workersFUN = "sum") { + if (workersFUN == "mean") { + nW = 1 + } + + # Determine how many pairs of each you have + n_SS = nW * nW / nF + n_FS = (nW * nW / nDPQ) - (nW * nW / nF) + n_HS = (nW * nW / nDPQ) * (nDPQ - 1) + A <- varA_q + B1 <- nW * varA_w + B2_ss <- n_SS * 0.75 * varA_w + B2_fs <- n_FS * 0.50 * varA_w + B2_hs <- n_HS * 0.25 * varA_w + + covA_qw = corA_qw * sqrt(varA_q) * sqrt(varA_w) + C <- nW * covA_qw + + if (workersFUN == "sum") { + varC <- A + B1 + B2_ss + B2_fs + B2_hs + C + } else if (workersFUN == "mean") { + varC <- varA_q + (B2_ss + B2_fs + B2_hs) # This is equal as varA_w * average relatedness within a colony + } + return(varC) +} + +#This is the same as above, just simplified +mapIndToColonyVar <- function(varA_q, varA_w, corA_qw, nW, nF, workersFUN = "sum") { + + # Determina how many pairs of each you have + p_SS = 1 / nF + p_FS = (1 / nDPQ) - (1 / nF) + p_HS = (1 / nDPQ) * (nDPQ - 1) + A <- varA_q + B1 <- nW * varA_w + B2_ss <- p_SS * 0.75 + B2_fs <- p_FS * 0.50 + B2_hs <- p_HS * 0.25 + + covA_qw = corA_qw * sqrt(varA_q) * sqrt(varA_w) + C <- nW * covA_qw + + if (workersFUN == "sum") { + varC <- A + B1 + (B2_ss + B2_fs + B2_hs)*nW^2*varA_w + C + } else if (workersFUN == "mean") { + varC <- varA_q + (B2_ss + B2_fs + B2_hs)*varA_w + covA_qw# This is equal as varA_w * average relatedness within a colony + } + return(varC) +} + +``` + +```{r} +# When the function to summarise worker effects is SUM +mapIndToColonyVar(varA_q = varA_q, + varA_w= varA_w, + corA_qw = corA_qw, + nW = nW, nF = nF, + workersFUN = "sum") +colonyGv <- calcColonyGv(apiary, FUN = mapCasteToColonyGv, workersFUN = colSums) +var(colonyGv) +``` + +```{r} +# When the function to summarise worker effects is MEAN +mapIndToColonyVar(varA_q = varA_q, + varA_w = varA_w * SP$nWorkers, + corA_qw = corA_qw, + nW = nW, nF = nF, + workersFUN = "mean") +colonyGv <- calcColonyGv(apiary, FUN = mapCasteToColonyGv, workersFUN = colMeans) +var(colonyGv) +``` +``` + +```{r} +# Try to frame something for the other way around +# At best, we would have varA_q (colony), varA_w (colony), + +``` + + diff --git a/vignettes/F_Quantitative_Genetics.Rmd b/vignettes/F_Quantitative_Genetics.Rmd index 6d6d2755..b9706671 100644 --- a/vignettes/F_Quantitative_Genetics.Rmd +++ b/vignettes/F_Quantitative_Genetics.Rmd @@ -173,7 +173,7 @@ values for them! Is this wrong? No! Virgin queens carry DNA with genes that are differentially expressed in different castes, which would be only showed in their phenotype. Hence, virgin queens have genetic values for the queen and worker effects, but they might never actually express these effects. In this -simulation virgin queens also obtained phenotypic values for both of the +simulation, virgin queens also obtained phenotypic values for both of the effects. This is technically incorrect because virgin queens don't express genes for the worker effect at all, and they also do not express the queen effect, not until they become the queen of a colony. We can treat these phenotypic values @@ -278,7 +278,7 @@ print(p) ``` In SIMplyBee, we know genetic values of all individuals, including drones that -the queen mated with (=fathers in a colony)! +the queen mated with (= fathers in a colony)! ```{r fathers_values} # Variation in patriline genetic values @@ -459,8 +459,7 @@ apiary with 10 full-sized colonies. basePop <- createVirginQueens(founderGenomes) drones <- createDrones(x = basePop[1:5], nInd = 100) apiary <- createMultiColony(basePop[6:20]) -droneGroups <- pullDroneGroupsFromDCA(drones, nColonies(apiary), nDrones = 15) -apiary <- cross(x = apiary, drones = droneGroups, checkCross = "warning") +apiary <- cross(x = apiary, drones = drones, crossPlan = "create", checkCross = "warning") apiary <- buildUp(apiary) apiary ``` @@ -496,13 +495,13 @@ the above is shown below just to demonstrate use of your own function, but we are simply just reusing `mapCasteToColonyPheno()` twice;) ```{r colony_pheno_2b} -myMapCasteToColonyPheno <- function(colony) { - yield <- mapCasteToColonyPheno(colony, +myMapCasteToColonyPheno <- function(x) { + yield <- mapCasteToColonyPheno(x, queenTrait = "yieldQueenTrait", workersTrait = "yieldWorkersTrait", traitName = "yield", checkProduction = TRUE) - calmness <- mapCasteToColonyPheno(colony, + calmness <- mapCasteToColonyPheno(x, queenTrait = "calmQueenTrait", workersTrait = "calmWorkersTrait", traitName = "calmness", @@ -587,8 +586,7 @@ We continue by creating an apiary with 10 colonies. basePop <- createVirginQueens(founderGenomes) drones <- createDrones(x = basePop[1:5], nInd = 100) apiary <- createMultiColony(basePop[6:20]) -droneGroups <- pullDroneGroupsFromDCA(drones, nColonies(apiary), nDrones = 15) -apiary <- cross(x = apiary, drones = droneGroups, checkCross = "warning") +apiary <- cross(x = apiary, drones = drones, crossPlan = "create", checkCross = "warning") ``` Let's explore queen's genetic and phenotypic values for fecundity and honey @@ -615,9 +613,9 @@ case `fecundityQueenTrait` in queens. Correspondingly, each colony will have a different number of workers. Read more about this function in it's help page. ```{r colony_strength} -apiary <- buildUp(apiary, nWorkers = nWorkersColonyPhenotype, +apiary <- buildUp(apiary, nWorkers = nCasteColonyPhenotype, queenTrait = "fecundityQueenTrait") -cbind(nWorkers = nWorkers(apiary), queenPheno) +cbind(nWorkers = nWorkers(x = apiary), queenPheno) help(nWorkersColonyPhenotype) ``` @@ -631,7 +629,7 @@ the sum. colonyValuesPheno <- calcColonyPheno(apiary, queenTrait = "yieldQueenTrait", workersTrait = "yieldWorkersTrait") -pheno <- cbind(nWorkers = nWorkers(apiary), queenPheno, yield = colonyValuesPheno) +pheno <- cbind(nWorkers = nWorkers(x = apiary), queenPheno, yield = colonyValuesPheno) cor(pheno) plot(pheno) ``` diff --git a/vignettes/Profiling_parallelised_functions_Unix.png b/vignettes/Profiling_parallelised_functions_Unix.png new file mode 100644 index 0000000000000000000000000000000000000000..b3111150b542e2bd22ac22e9d139584f34732dfd GIT binary patch literal 107647 zcmeFa2{_bk+dqyLM3l9%Rg|(v_AN=0kSNJkA;efSc9U#H2qD=ck`Sh`45kzkA!}yr zYiNvZEHjwj_2ub)?zg+{=Y5~|c>l-oKaS@<+{aOj>wA5#>%7kMbAHaxdG+9;uIBDt z2X;|WQSH_`cjgim)y^0ys%_`!Xux;0ho*I@s18zTol!INr2d|=n#R^iT*hEjC^ZWo zB3@`QJ~$L%`(a0^Z)X|R?&A9|-tEx;aAfA*;d@~(4&K{&%Irl$n%A3jKT?=V>+ zJk0jy8SeeJu7~t^SEL&0olusRUhY?LC*G;=lr>M67`YZh#-6H75#pkH9) zp|(XoLmw$S_}f|DMZG`pyEmW;c*ai!GrCi{opU?QL8@PWwZgA%``ynDUc9qCxf?z( zNWJ;H7hi4PWwIC+x2u2wdgI7DG?aA$LX_=3Wo<%LQ^8gV0ZsGR6&jA0rxN6Y7qA61 z%$pMrxOwE_*PF(#44uuOM>%J)uFRkbB5e2j&>nn~>2qspUZs#3a_mQ zbJ_glph`duhxYR7(0*w7PIU`V!Mddh!l~@g>O7)nL+LnAe{Y44S_hxnde9Rv!@ZW~ zA~n#6RNF=N-bIycKac}$;pQY{-sP95fE6{xl4vV-!~Czv$;BEu~bO2?#e>X zE6_Ag9liK<>+{hG>@-^g-efuEpz+YFh>mvCC|;kT!Zx$mChvqE78ZBv25x(4GZW0{ zRo=et9nhN1u!7IuN#jeUhGu+6ho%*7wopB6ylD`LKR&N%euZxP=79IL(qFTm7_U9d zy=hZ#S*UFlwbNY={9|E*VXVChib%7ff}5tC(1>Mv;PYSn{5^LiEzqFz}( z&HQ@JLJ>1ftvVI9z;k9t!3SlURmo^^?ipoT(-U-tKQ?NGZ~VUC>xH`7Br}X!N zEff)AD|^BpdCC-Kq;FnfiHmHT5A#*!IJ*p#I z@%95L3*RkcQ=h)MK9)^n$iC3z*Wp2KOB_ixZCyI_a=xWMS<gQkMF)q2#UyqN-+UO>(e9W?Q3X&^1!Ip&qiRSg2WQsaG{d{5;0aJ~lnk-+{(` z!N{)0NXH+@RXSsT9>H)za?`x5RD~Y+DQqVFssqIafiQ-I7o9aSfImb5ltMX1KeXe%9 zpLc3XHR)-9P1>CfdQLslf|X;2t99LuisY3{#6nIu+1z!B5J~7KBL_BS>Wn<%5hwBy zrBX8{-k!H6i)mYC;H&LipM-_r{)AJ!H((lQO7W3^|ds9%~~Gx1KATjM*zzS^QNMlK3#i?T6IR2VOt zu`zR9)yP>NFP%vC`Be0hx#5%K#P*xZ{Z(kn{HRL8Qq^pS1rM>Y#L;IxT-PGS$o9G% zWv>PmcIJLXpJ(xx?Vn_;;PwQIROe5@+d>&v+@=!h*XGcVfj3 zoH!g7`NOpu-D%|H{BZVqeebmH%n9GFiTr%6Rgw*9y|`Xo=JPGfAk5=!mMI77KTItocTa|2OEs9WY=HybAR(=FbN3cisS(vOJ)!|p0B|M>e* ztD;D5fgc`KzU-|_!wLGwgxF>N+VAOqI@lFCea8*JhY%nYj9*(8~aF$Vm3LV z&@uKQt%~*m1*aKpfyf1nv~N9^EODiCa6eZdA=Ss_qf1{%7c9f3E4NE7>IUP zBtIqB^ZF}!wrgON$JgeBWwq+G-LSgO%Fi3?mgEb_8l`%EupSaVe@5)g4)no2;C;gO zRkAn)-i6VW!>7MCrp;60_yuRK4P^RJ$VWOna4^b*yP*5I*=BqWcV-?wvV62b4`*It zQkd0p6?e*6We?q+yC{aYZ;#R$8h-b6TjYzHjP@T~l~pBGX5l*(j5N0w_VdLf*TpMs}=Dd!u7Lh!wr8FcI@EA+<|12M=#XZs&VC=%QMCwk!C%l;|YA^Jca_y^2Xbd zcY+gz2@wfnDgwflsXW4zxj|{pw523Vf0rh$Dstr0c`+5cI1BBs-_AhDp?&N+0A4H~ z-c9gPk zY65V%h12wn*oTw(FOrt>m7}JW=WE$bt_@sGAj9u>dEmzS3C_)BYiPVH!M?Fd50+%5 zG$27w^;oQm@X(P{=i0`UjGh zx?f$me8vvlrs0vy;>%Gk+gOUh6)ab+5>P(VU53*hIQ$cGcdWmAXL#s9laapu#%gi* z_`1DcqJz@%A>%K^$8ipQl`tDG4UHZYQQIQ%&gDW&z3R!`)CU*?P6-2ld!~2$o?`+5 zrfBz9l)h*A313J|c(*#yfgXKeZuPUQdVBm!`L&UV@Xc){l0%$wC|`t z(R?SYdoS-2_aCb$U-8kU=gW4Pma=C!r-H;0%6N5K%Xr_NsV^9=)w<>|o(0XE$Qk*Y zy5Mc&oV>}AQc-s6j*2~HQx~2S1`y-o;`@>})LTqAzT56*vqyu29%b5^UvDvi^#5W$ zDcHVq<1Dbp!#YP5$tdt18!wh@imo>e5m0$w*LvTM=pNX(IW4;{&grR#WlLscgS+2Y z(k(M0j#b?Mj`6g0JYs47zF}!NuZ6);t^_-@bgY=d(lY-z$->5Hqn1J4-*0UY(d?h%|E^AiTmjij-LY)$>4u-Tg>S6}Ms+;OkMGH{-6SbNb0ZgbqOYaw&Zz-6pS2-G zC{b~2S+=^OX=`T7U<_hM5$>x=!$ zOq8QNZJkmDQ(oWal$!~v0)8`uC^E5jWMBbNTIp%J!6?LuR6Fqef+#? zvga3iO%GL%S$F=BWDnQnc0EeUqHIIKQtag#jE zqh>$nlKg7a#4?w&79lor2445gYopL!NZ?>H`TkKVn8%p`f2Gyt?dKCzU3#1%73Mm^ z3(8z=F)DrNl*NPxgoKagRT@~wv6Y1=`N_(mQXK>a|6Vyo@7~@$$Ao@>bu)cYGgC&X zfVP%|rc_Cnnvr%3<0UV>+2VPUv-HcxN31lpY$$#3H2)`!Knn+Q0beeyr;N zEFrvqb+QJd=f5&z;BOX^kEyGTUsjk%7Xx!BZ{ z5>GSo^w?4qr_%D*ub2p4zk!9ut|}?_wQ#<;E03M7$+`C;HIf<|Wie!jYO2SuYbR8f zPpjJ1;igfA{?=`=3nmEu^2OB$k`o6oGr)fBI;YDkWZjn(?U^`t*l}=E1!Mtlbwp?1 zY9Ie=xAozK>w`jH?v=d*%5-JJ z{11NMJr9BPw1A0gax~8y1IaA@SI}T%q>%PhHi-wSfVB zg!Db_7TWGzG(2=al5n1QCODugz}G%7_=ih&*w|#TQ(CeJSov1k@1pUxCddnhaDp6!+-mU4>o`>+s)!e}f z=nV(Y3BL9qm^19S*^;XKOZKYmQ)X^%!-A4<&P}<77FEi3FLO&veswY7<4n9t-@N+Y z1=8jxM+^x>L`0-c;BloMDy^>&dK_FF!3*hJ@^FKZ6?Y?&|VR^%#6hZ6bJ5nR%-4 zxZ0R+hs6=zkU+7n0W9`fhz)PtP0GeP$F881Hs5cphgue1=H+Fk-YMd4v6Ad@KwT|3 zI;Fs!Um`6nt>5zMY9#uy%`zSrsv`U4xn)Vqn~OUtnvSRA&o%bvCrH^Uw&_UI6|cJ9 za!$k>m^pBzsNfC)9BIT6VQV zeehil9G{*HvxPB?D2&=FQp4)sP@VQl$Dcm+)dPlN72zb@Tn|Qt`%Guxhgrhe3AQQV zZ|(_`?^@w^u6RewOurho@#NkGm_7b{8(T$|qkRW$70p~byu?tuJxh6rGj&n#(fDDh z*k)&B%3V}!zkbQKR`{*8XErzo!DodbdxoI#`Fp=I9cqR1I6D*MpjRm4tQqoch0_Oo z&Us^Oqkd}_dKWP7)gv#lcTomkPN?jJ**ugu91srMhBW)2BQ3`Wv!N1K>ihzy!HW6v zCoW~+pPV}1{?$P+i*xV9-Ebl&R;-z)x%M=!_6Ub?{}%-Y80WNDdte6s+pERHurA}^ z=QSC70J+!Z9fIP&(YE^@s{M#&%EV0^6-=`VJvWm6pEvl=9{ew@h-c(VfvLP7X)#gC zrog1MU?h4;*%l4ws56N~v9`kNJj|1+u)0mbP93)t-??^*by?V=%Sw5%Vq!&C=OVj| zZP8af5_uV6nl{fl?Mj+Mn%Lm%+kxkp-j9t8(vqda>Lzfzr$R>poH|r3z7M_JtVp=9 zgLkAp%1QC-kQ0ana!qh<| zv(MUF0?CsSXP)(0A@8-J92*E{n%7!d;Q|*b)LP*cqc0XrArJM!qf~UJmeYdq82WvZ zQ}yaC+}si-1CKS{=OmBSJ%!sp;N?PNt9XL5S|57W<$v`oE=hy0mqDifSAWt92aF$w ztkuUy%~;3LkI}Gt93=#0Z*!w^4Dwtyz7w_d>G%((D`z3kWrY7%o~!24(8c>yz%?pw zxkfeIWK3qWTM_IoDzm>2Ri-Uog)BjF$v9m77q7&5dEKnao9Nzcw%ldn)R1~jM<-&! zs}(M(QtV=@xPO1Vi{`WllBcnckh~pRAQgL+-yr)!`Ao%h_4<-Yk4Tccj8*pQyn|FQ zL6ah$x(vL+;9!3MYUJpFW+OwG`pU2Zo(y?9L5aQFWCwiRY+xRg^<|G#kSZoVSh}By z-;PXK;xW<-LK!TaP`zD}B7wnv`t<49OH4S2==tZDq;54mQkI4$LX<imii(Xs6d83uS}5*39{Wa{!>OcMNQ9j!81T3aR~$lJAfqYsNXM5w2w7mijN4OP zrb}*xr#yPJQ^w)zY>w*saod?@rG+LQMfjam#@|oqnyuoF_v_^4Q12K4c;3sGY~63& z>9CRESrSp1?i^TMPub738Fx^C&FF>Z$ClQ^(O4ecP=7ncQUG%tzx^c=Ub7ZRz+6RKtDnql;{A8F)75 zCg#l$+2m9uu??BBhrw?Tw)x&o?O{;n%FuCd!TjRARRw{%u_ZU@97m%y!isB zm!s`DvCWSJkSRNA<3B(MLYVJQet;Lr6ZiNEH!_9BgvC8P)xhP3Y3SzAWgMrDF(b|B z=*VKo6#7fHimcvY<M?HDx&Xm=-IxJ;)C% z=Jw-YMU-nzfu(XUs6!rCalu5q37pCgr}=_V4Dek{FtB+X@<<-~SjRoc6fyZJC0j+I zb1cxJgyMT8M#K4q0|aLbnrVGSj9Oo?Qh4&PvedcKH+mkHiI`9@V>Fr zR`C!A=^)bVh7T(qltF(tund0qgJhA=s;0a9n+Y#~ZX43VCK&yFj7>}$W5rfQK7an4 zI&lQSn=18v05h;qnVo$!^-hCLZeHGkQei=X*s8%?@;i#xtBQ)Jf@br^Yow$#uX8q6 zD?MF=;=DIjC#=70v{;5R@x<(qi0tm@cwO0?7i)O=@^K;E9XFPKXaU%|57{b;#ngb8 zIxX@r(2)piCIkd0T{G#hrDMRX$IwLA5CmSZ&oJ=dnmvZP@>}jk)V#a9``Ac`NFl&#`6&o2fU_-FeQHLOZ{E*!Ot4^&WmP@&PHRdqg4 z4!~>Qb6ta}dD+i4UVd}tR$rISxX;}16qs5q`iJ9~J7oN4i^yEwtHDkWg5u~_P+WQR z3Ni`bbMe4+FcDA&*M%M48JO3_DE}tPexR61}1R5T5l@SO6!oW|po4PF^NZrf)!_;ZHdlhZDevV-h%pgOh2?km4agbFBf2fhZPioY-6rb~AiU6iED||di zm=zOq`hKweYZR($0ovJcn`6u>0$emK98`BIA za(C~U_p4zqVRROzIexZi-E&W90nHI`8f3(5*{9dpZw?(evp#nCc%y+KfR(!NB*yx= zK6nUKXFCt%g{N>Y{n)U&Tq&x1vCaCQf&aR;YRd)r;8vM$0HX-ML>-!cmH{Hh{+$3} z(J<CF8^E6 zue-3CBX;2C+14`r_s_QC?+0!d(-mQ5=d5%82<5Yp_S8Z1r*Oe{UlTywI0(XB zM$QukSk7Hb|Bp~2YvVs1ydT<&Z(uJ(L_^jEehp=qu(|=C{Vy}5>i=7-!TFty8w-+S zQP;nsG5{YOf<;6Bt$>ZLSvraZ6}I0FjIDiO{cO0VjA;{fxrpAq$ZLzbN2idSjMN zSNlEWK%_c2HvlmkMLbj91)Z-yCpI9f$wCgN%9D}3}Mct zum`IfVFU+m=xm5}FJx-9e9qbvSJ1Z4*c0wm-Nb96xU`kGB6nNGB-0z8TI_KTOD`YQR{|%24vQ1!0A37 zQ(KRVzOi3(-TK{&b2rO3PUC{Zn2;&XE?e9DPsa>lgWyj=!T?rgX+)v|pu`^*2%(Nf z*fwIZfJ-Z!MZ)2IkAqBX!|Ue;M}-_j4b2a<0AS1;IWO`8<0`|bc@eSyppe1U0!%AB zP&(AFck;})ZdmX$&eiSBnCODOxQudh@HlzgRH2<6?dviL<{5<+Zl0y z9pC~1*H-cDlN!Sp7-)zW7*hdjFOhB#aV~BHPTn-}=b`TfGH{Cdnr@UWwrPViyD~Ro zeaIk3m#E}4Q0@0FnI0BuUQ`67!kX8DezAAE7Y)Z= z_sYBw3wCD2Mp9|97kkbPFApFrAgp|sb$Jic%=D(qh(2Nj#MLMg7em6?*JC6w$W$TN zpm2~d15mPOGk<0Vud40b+6{j$8)aMObEj8TotzBf=YQv^Z8>^rjbi8v|L#-wfTg6X zs1rk)IY(=kevvu%#hLpQ?yZ`B+hf1dFFn^i)eI~S$A^p$76J~t=TyKcYD$Ebl5 z_Fbad_KQAq`XGq0Mt^cn26jN^dwzO%T4kbT0o(P~^~YJ>$&U81W8VEGVnx|`5s;DfIwhLjKl9FA<`qWp`jbEfMc(u2BqDLzp?mjmuq(E=yS}?Q2KzXtgN; z6?Afj0$5y#>g%vjzZ=~y3b|xd0_8md&}0e6{^A`04e?^nod^&e2M;GWX2Kpl8y;k#uaDT^v-T7+*^G+}Y(o%;t35FE@+D z@s$zcZ%k$^i>wr9yczveXHArg$?^hKTzPf(ogEg^eD5<~U_z+)b4)g4kSkzVOrQNV zP=N4sx>XvUfxj1SS`mR#3kw;c!tP`Wd&wP-+u8YiPbA1rPEU0gT7ZgSi_#mTUR9gL zsmo^ws77CD4@1gc1KIB_xfKqd$2lDjNQ_7HiKZsxdU{z=qFbEg9}z3#tAvl5OV3u< z`V`N**vUr<*nxetX}*|3O*HykKYMJd@X*_jlUruP3u4N@ziM@bS+=V!Ngi2F$p+E# zraC6oi0S6VC$iP{4ZhOL+0dV0bId0ly&XMC8%N@dd&(*gXvUmm26>mwi{`teym3oU zaA5XaAHB16RQ5n-1%TOK%<5lyV{lZ=)N$5u4BVcSU2gHl4*flf(BDo7J3h^2Z=`#U z+3%KR`;bsl{x#Bd(o~{J5>QUu=KifsS>VjzX9+m5%7Xx%HmgX*ofkDO&O)JN=DiYW z0UZUT6Df*q#ZJ>ndVPwwSJ=0O_InOIWQMN}WB{V4oq2j($-CZNJ=9!re2DXkuSwx~ z5JM{seq{?UUk-jh@%QFQB2IhUZb@af@OJ4{9T6*kabHCM_jlCz#4Sr)5{kLL(6y>iK_q?~wT%uq@2o%i6-v4(rZgVb)Go{jOM$4lyCj%a_c zR9R8Irp@&tyU-jB8;tX4F*lyST+11rc0hXeX^u*ML)E^M@fcq>@2`OiT{FjeX2*l< z$riG1ZYd|j0m4~(K=X^e)ir13R-xH~5w?oQ4@7Qjg>$oAmQTkU-gy|+**&q5KcMS0 zXyIVA8pkFYXP?I7UVGP`z)kt~-s54}l9NZ&R6^>?T*eh;S+qzxo>x1E&tlph-8`ZO z^UxiH9QCWXPzwLuIKUTvSU#^*9@8>>*nEOc5W&^ce3zJhw%mRCij;kVPiYE?%~Uff zNpUS^_M&)anG5#yVpaI^_!+aA-S9Ct#{;buKDO`MjhMK}8`WLgdbZ{9arxE;vFEFZ zKYlmx#^5P4kHV;zIiNG=nAzf4fXrmq0j!vQCGaqw8Tg>Fw?yEMKgOjofEv&rwb*}B zxE#j(T>c`fRy}Bf|EyiDo=-xAwgs_wd>qTp+NPcZbC~{Ce3=lX!<<&6p&+Ij3W4k) z^uGoID{Vp; zq)dPlu9EG9@!=%EuF85{Cl%=(z?v^7$>{Pt_4o85s~9b@l9X3VUGoBDZ9@L| z_$`QSo};*9s;gC24R}=Ee=V{!$Tgh&%zt2pmuI=9RmFxl)!DdE8A!`~t!xmL;JU`6 zLxmNa7c4LZ{v1*aAa_I6M3K_n9gQ&`)NopFk<1?KumtkS@AqwFc|SftXH!JHzJ1DI zy<%vsTv+~{kH0;0;>xIsZ*smlrOAS}pX@kO#a`@Umus&X|CIx2cGH$w@a($IV~HuJ zXP&~s!lK;+Vww2jHx^2=&jvb~tEvkex{XZYl|68esuPyc(RoGl#Lwja_j~Rrs&~{+Xw?!b`#l0j{X(GCzRtxI`~Z<@5iA7m&e?<30U*Sx?y7zWjj!H6}T;s}bFtj$_} zH`D$*ojS{^l%e6Akmr1+*E(M>J)qvkYmr3JZ6EJN<9SKx6?hoV+}OCMF`zz5b>nK% z+IvLe%fdoEXoqJ9VD+)Wt0Eglv@)`?f)JIwLa27IwH*ZfE(fI#-jEhL!RYQ@ZgD!c z!OFAkNLnpo`T1v}gk!Iq8_dYaC_yRdS`YK=KEefX1m;*Z$cK=-@ggi=Pvag@bub;@ zs$jnJz#YF2FHp#cuB$qdM|m?_#ctty**J}Wb|n<&k^L7m!~4B`8m8Jl`37e1V}4Hb zfJm>+qM!&++B{@zl$#P~IIF?ZNGxrv#EC7&q~;rMI8S?|-THKEV9&~B_WY6eseM6! zXn&>l?hqgpsCEtP0qkeg^MkC_I9;meBj9ghhH9G$O1-sMk2>xk^?Rv@sDRK+rSLJ7 zn*X6Je$P@ff$V~LNA!nATLG;FfE?XIrWjvfZmWc7>LYejpVcijMW7#|8fVCNma-;{ z@N<}vlO|O+Ytl1fySu#mGl+V-!QaB(I~CgZ`DDTLE*e0@@h`)(?nTC4zI!MJG1o~M z>`usq+j7Yrd+B=Bk;^dQv>a$(qNm43UiJN(bB;{up6@g9Fn8$;EQG!IdbxN!jyA;1 zrJl<|cFdf_)j0m}fW+_vM4TUGAZ*M)lc~&cJib?RT!0xQt1Q94N>-bbG&=^A6=u@b z3bVeJI$22AoW{i%IWjVU5^yxfq2HcR03=@~+P?UOwbp`-pFQheYIciY<5oW)>DxMJ zU;i*^sd?$;dyHxC!U2qh)N}w>NLG7b0eYf*Y=C6pCnQ9j3PeftPSk(Frs;+FdzfUw zE)*rnDg!TY`T6ztzW~m*itIcimMe~mJ8JH+mv*rV1M=yY9F9}BS1FId9H_L2>HZ=S zP|T*eWNMfGThIw4Q_+uR9TjgLiugOksPMl*jOqCMJN_0jPyGfmSEGDpV;IuDd)W1= zPEaP12DELwx@7Pv&PlZ#rn5X|dKeOJGwcb2ojLIXJdber$`npl7 zk8fM7cxBOiT0jc6$U`ayhUw;Gs zfr8^qG)C*n99CC#J4|qt84x@*(sZzTjZ05x0Yp0@2a4o{dzmzj7UG}6MOSd_+Y0y; z7v6aElj^hdjTSLC#yRCR5|n3GOS*}C{@q9~r^>aJZ))4>oAPX%0%9Yy(|2~;x&jU= z#uBg~$4peq$58KP_k+X+P}8w&L9@<3yCk5I*m6mLm%6wgGGhH-81Ys%`@kMeYRO^J z9w?a&jlW{v^D>S#G@D>CZ-5$8b?Q&#o$JlU_WBTt;~MLkc~9Q3cJGRfXmqCin;BgW zYW4i>jKIcSh7i&3H|}UY{@P~llV6CKHc@P8oH6z^B9VHmKa=BCo>bo&?>fq7iMmxA z6cCt(ZG95=P}}bBW)mM2NqhJwNCe89TabtW)?GyB*$S^Yvg;SS#woPj%u?14HesE_ z#dSamW?_@ihq>L>DqJUCcw5YGvSP7{FauM3)U(>=4uIcGbVOsHOQS(~-F569 z*MS2-f|{FK1b+wk3dQF(EjK2T^XCNP&YL0DiK3#S@B-B9ILQ_D3#V~g;>TcAW9GS= z+puEvFW)7%!qpDEgZY+%vcee57JVi_9d{%Qu$U}>mA-+F3TjR*Lot|oj6|iaj}&BV ztFOFtg&^(pR7FJDzxJIBPxm~2+OjRvf}E`;nc6VnH5fp92^O``qN=JIxf>Gc%AKZT z(VF<~h}x`IDk{=%yBv0q?bJ z;Wqv{Oi{kjazM{`zEo&Vy(n%V8!u^5B`Ksl9^u4wWCX@nOsv!h=g@KR0dgZL;uT&| z(Q<~@u0kQPD};4BJG&b|*c&_$2XwZ^@?7t=BomW09c^u|L*Je7V#*J#tLt^jv2%1p z)r1TQ)S`Gvi<9jj+|{x+qEy(ZABJAt6$fWoNE18^WGX+Zo-b0Fw&*IXZXGCxoUN;o zLz+E%l!0fd1>W>QcQ+j7l#5I*0Uk5Q&#Z}pvUU`)7lftwr^ZIX8 zvGaH?%QpTA|HL_~5y`9Xq@VW6U_(Z~4jWw(_|&E6SPql$Jqu(YR2lerV$CA~YXu}v zaEun?R3UxUN1zXZB%L~KT@%-r^~TJtb0&r-L$kri2Uk5JhPz56h&N(L zL#Muh*4(+~tCRK}0xYmVXd`U7Ae8`sn2d!$hP4MUebtxt#bjLwMP*);e4qw&E}Zh5 zMA^+L{)vlc_?e1@v~psGM@@TluHlX}2mI~(F+}}u-Vc;9+YW2uP607q5K0YFwT__z zyp3ak%!+>BlmvJIDud|#AW_`^mS0C>{RmW^TJHpcZ5yaCGiE_q-wn|2`Jd75rid$! z-Uu*?=fb&R+n`!3b|<7&2Ylj`wHB!N3S55yu;nVv1&v#KXo03Y>Lfcc0jjYPjW(z8 zr}YtL|B0jdV|{>}UDWkAd0_^VI&O?Xf;~|U)X=Dv+6+4^pai(XVsjc$eQ|?0FaW}O zf#J_#9jM#>C|!R1BJ&7n`7>axn{N$EH;)$p1%8?k1x8qc_*+A(ouCl7bM~BpK0*tK zMlK>C$-gngw*D}#OTRO&|1AE07XLq%{~x#Wqc-+Ga67vpB9TiO5_N9M2sf3f0FTXO zX{%^!YllyGZSqQ>MrUU?1Tjqr<&!_?r|FEMqG(8PsMJzY&Re}Q9BwEiT|V%9tN!&S zV;c|)K-BuHP!fr>X7BFG1)x12l#>1z^0k$gQ_NJ(vhE>eV;NI?d_zx?yo8Sh%2vVU z;Q^u~q_PFl=$}p^AH-}NMWnvBxmxO&QjW?iEG%_?N6W|(9zWyBmGtU9pdsu04F$-3#JjN;pbaebq`jXfoxKIu$t%8^v zT>mN@8CEaOsDZE+$QJ&qrehxj9^A9e{Wki|9x{faDA{bW zk8je$4l>gi@h5_2HO6bprlmlh>dT8-OuSG>Sz<&zq!)CxS6)$NzpgA$dTfmoIXX`( z^+V=iq~(hcpu0n7+tu*ek|PoaG?f>_`m6oKijx;%&tCt z<8~&$F47bXF`7!8BM4*IAa4Tgdyaebxf6m>4eH&VZrmc0l>8UoeroK?r~YrV^|-r3`_HbA4IOLQ5?hfVEe|&6CwjC7&^!N-(fnG}_1{nBrmyU`6 zR3sD;1Rw_iFPq{uo>=^dvOYjr|CSk*jvrk%@EvWY-AM9%sFrj(1FX_x6}&{ zhVx&&3PQCz-{!~$rL!w4|3mlt9JHN0(+Izm+wpL}lvVdMkZdXL=j#D2o1hfx3EFHX zyg-AFNRNm>07{!p5;Igg$Gj*^I3rHU-`m-dci;P0m|)@=41dY3A?f}*{^;rCRa71pk^Gj1LN>N0-<>XpxKa~&23G7&&i z0U_C;w}W?}UJ>-5j#V$fBA|iCx+GFNEh##%#O<{+7bL|NOX1E`-#YM_W2j5idY+}Uj~A-nc2Sh8=kZ^qS4`er)*WP0t> zn@kMyfu!za`|$D*j@*I3S@S!v@-AdTMGPm~!;zTPD}8y-J?CenUHVIF#it?Wf&P&;J~#H$DXaOLEjn zC0>w8dgFXJ-e9wzgRvw7}sYDDo zCT!i4d^Mp~5S`4{4g^h|M+hp*tuO?S$4n zUZRidvr6J2E+@tQIVbgtk0&?#V;?8w?cD~;p%(38OTwRd#Sps#w7S=ZT3MGiICB#~ zTiA=#8K|GkVBiWqvlWj0cApj2)f1_TveW|?MMfe4h5gUQVW@rF>&sSMAWRb{jaV2r z3k>O#wdq8KrKB}gEq_v57Tu_>T_~oNRUvn8@E@&O_i9*@b|dgTt#(gD2swNXYj z{cJ_3$y?vC;4C9DWhe5gfdh)QNbCZK=^wpx5Y7HFXY(F|j?&9ypm&u~7(SEaeuc!U z#B^u#A_Gv2_~%6ifA*IenfNJ{6xXpqdf}HP`OkC5$jmtrh{^W#9*53Q=G~R9pK{#u z-}gZJLFP16(Yx3P4c3wzcRif+4DO9xXN*Te!STGNb({_^Gk0n_LO8y%bgd*T z&2^yonJ2hs7IYl)#X#+Wi!3bWO>LPstDmoRt|>$Yww`7g~q&=mor8tR)ht79Cn z?n?K%*#Oon+_U*+J}$Sha_-;W(hD>5@;a?9-@~5hpetiEE+hKd;6Oi^6TvO_tpcOG*oyDYqU~F~rZK}=;AQUDWACwB%R-v8 zL3Tpldi&PI0^62*fBSi$+i<3adhne=ugE|92thX4@#ru}t$yOf|BEr4!C5bhb0t)J ze==c6D__8>ZQDt4Zwe}(UOwqoqsWU#Z`a({EO$> z3E7u&jZ1Ddq!xa*pdZWIZKwShD*nb9Mfwm1BFdf4y)dUNzS+iSN^zRfItlxJU6c{SPIu&q5RKR4mw zgzDkW*49V6l(O~G%vxYa5N_GH7=%B_MYS5BH`17IpXOkS;4sny!e!q26zY1j_l$`G{hT%QO zoLIckTK$|kyU@$u1c$~~Vu3I%72A4je?7Rs&nbCtM8X_4oNw{6=w^L{sS1judVmF+%!1xYu3g zIR7>vDt}H@MfjK;$X;n8JT?sxbe{fbX@cml?QgQ^LcmQ4;lS(vabwCqZ%Rmd+0w$Gf}0fzKEv;g4TrznP+07P@3uesyq&+k*LO_Xl9!t@_+)5Ot+dG$BR<_( znEH6;qAaSpQo%@eejr)_C=TDE3k=X6g!lwH?yZaN?`x)KXW#0pa0lvQ@)FKzZ>h9syN3S69S4MC0V$%kNMKzM0){`^MYGmHED>6S127iV)MR0q-9)^+h?`C)tl*1&ri@(2Tl?$}S zNz1#h9N{9nf(x*+;zIu1^2dn_si;txY8Sr4ts;GZmtN5sCzy39QC@TCf6*npcL*RqW}sqoirh{HG6MZpa-kO*LB z@4`%!7tClWimS~-w70$3X2@)E+9rY5KLI|T)O|L`sR3h$HrNaP0fwOPzY>4x7jQbM zO7f%ML2BbQkz(UI)hv$P7rl9B*vUV0vE^T7KwKv{u9ZFWDouGMQ4~>c!|JmWY35*c zLNI-!ZaarKH&K?iaODfQeC=i{-27H|UM6k7Bsxn*aHg2ttt$15B3d}}$y0OyvtCNw ztux?xFo{f?8q<^6mTA6vo)ivpln>gVd#)+ijtv`0pCt$U_!EYK7Z-4SK7^{2H)cX{ z*b5s9b5+S50}%4Z`g zt|G!uspBx0;FsTwVU3nzts_8dvU4-%lrnoBaiNQm%%8R3q=VY0yZZ3wK zxbD#SG|(0uo77T$#Xd{>s@GJ)J(3C zoMH>OvF(F4n95&Q2?*$jATzd_xz&;ia~*GX-Ni5YE5ihlajGwZj~2$6mUw69)=g6# z7DpcqpL~J2Ddw9A_HXzLym%&9B@(#mZpoiSpMW4uMCHADW%}lJr*(qacoMo@R}r6R zle#*YlXgK@2XR6Z$gl05XZ*Q0wH8H@9Tb{f+k*3^Y@8BSyTzZ%esH+!soT2Nfv>h*lt1F7#ktuS{gH-%MXACkn zj)nmhhkhj(ZtLo>Ja8A@FRl*TpNn^_UL7|SB6b>COpY-(-+Pz|%!#3Z`@d?E%b>HE zJM*Fkv~WuK^W56R-0o%JzKSb0QY!Jo7ozb&p4W!Xn!SSZ?QRCBVYO&@^Y)6O8A)YO z)o4C1E?Ep%gfC`Xme6kf@|LX?AXJ!3)UuI-AiWmhMGtV_QvP2`_;C-uvBCLGw?+pI zq`w>e#3wm#P@DOm-Q1^%V*PUb``NP1YtIVy{_@&0D=U!LWTIv2&i$W_Zu!_{(Ga+G zBDmGV=d-z}G+Z#{;SDpX)X>y4 z7`1KhF#e`gvfv?Xndx>Yl9-f4`rVYN5c*NlEuuzA($gzXNbQt-%@|1REd7OToL~%z zD86YV);58zti0|j(GxP?K9|y4v?>?W$1X1n$#kz=O6$@uwzsSPh|S9WGWol27~*#{ zTR}4~+D(-XQyC|EjkA9V7K(x}%{qug%1uxzefWtJB;iaeB#C`_sO`}wRDD91xPpKP z%AG#p474YWdJxA92@tT)MfA3W=EF`jG6!KdAdpe)JM{7O9PN&j)yLDu2$a(e$ zmB;U6Rf5sButQ5WSj(jG*OFIrm+n)--sYJp;IZDh&Kf}!(+cyv60gbKHxD`;w2~+v zSJ(=AVL5D)jB*^Qhj6sv{9$W=%m=nzA62RmdJ8P~-a{AvroSJRl|noEOCPjk&57Ku zsgkO1Y2A(#_WRWQJ*gM4rra|`@zN6VdvNRb&P3uKU{&tfNb?jL9#P1o0qw++5pp6P zFfwRm;uT?44pdUgq5;5LW!38&q=Ct~GugeqQ($A)FH=2_rvu9EF_`}Slu@amw&R(o zJu@@X#!|@M)z179lqD|QV!wwqt)KocuSvruzPD(gF^o+PxhCWy$_0xj^nF6hKCy1F zB@F5Ia|5CR`}(QyC0K;?tv$B~W~^OAILnb{&$WwqGHdQU8oRhX-Ck-|<>!NSfd!Fw zyMYEnbbnB!TjTtMk=a`AYL4KNo0x~neSY(#!5m26?PJtG*adqzI~~UlArCOj=Cn8t z(gO?I4@EEH1A=ZZ$l*l}LP7yiU<1;35S1>nDx-nQdr>SI?(h+350qgi4IJ+i?b^}d zj7Zg`LPK-&@od9#`*MQ#Q2!6`t#H)*8eH_83^ntHfe}9G)E(X817Di9mL7_B044=3 z*q(Dc)e-d&&k^-nLoZP0Y8#SX0lpsQn{Mme|Qq&c6we>b0t_@aVK z7Sw&=5pRhCcB8C&U&C%r=Oq(1gm1kL3<`IKJn`oQli^^tIil{ZXKK)5!)pSkFdjL* z54!n_Jm7MhK7!1!0S*Ct46%`<`GN3fQ24YrpCsw~5NhEn7C=uT@kR^Cc>@MINY8fSPME%=U zMS3CzUs(6OZ+@rZ+>X!ntgwyAFWws$;fo8Dd#!Ssb?HF{6drz`9dn#+zuT`Y`Q^(O z&u2Q?+Kjf>cY}cLpB8%x_hGG>jYjf)M#Up@Y&cPU(OxFxQ!~OWqOT)e?z> zUlLU8v0pIYVmtL0!vHgEIM1=fRfB5X#LmfLX8ToyncTz0)%<_4(#S4>#`k^ z`NA#{^?e#EU#t2N`K>LssGkeZ_bSNZSzLr8TOb{3)BGXX{*rk_w2`i8dYq&|mWKXa z&d^keRTW~v%Zoz~u&D)|fp-vZv+lQTWgs$mpENc$!kQ$)INFIguNZzf{_?BKmoIZS z?JR-j2)%HPrp(9VYLG2%fLHw!bNnZKLZ#39*K$vJTr?*DKx#aEBQr*1&DbUfU)iHJfME|hq1A_Ai8pOE^(@`am=G#QvAqKfzrlLYzHbP&Ln zu9Ss3oNxZZWQM7;{9i~;*_)x>-Bqmf|5dC?u>Wi)2B!ZP($8F=gKBv5Rc}Ai zPyJcG8j+i2lcDVsk`|rbN6h-u>|!X;2xt`cz?h*9B-Psc|LQ1M{eG|SA@TMYzNSEq zYg$1Ok&t|f74i}K|5QP4eQy(Xox|mUaC+tDJ3V)vfUrx@jlGNE8hC(>0tp9DkVmvw zkcv{xMX4P~R`H9or|?KZ$*waT!-L4IDc=W%UbVn9M*GjdURC8^zbe4>FX;sMo=4!7 zzfs8!KWtYlv#vxeh5nOHB@pO5pMlh5JtAKT5|Pg)fe&|_xP>b72nMT5z!wZL@`;k6 z>p;*zsScpfO)96oclui6=Oq!@PkuKl^P8o=>WQd!i-3p0w}F{5{dDAdGOSQ7dq8uP z%^hzBQe|0Q#Wz2E%h`JQ)Mmfg()jzYr}1gBNYFQ?hMlh6-7lr%JM1oP4_C8-3>Cs+ zBOki=-?J5+t$^A#-={}+clwM^l8z;Cx0$Sdaa@di0O2$^FZa8g`by~x^X8Cir7fiT9BzOOiIFai%oL;@? z*6;|Ew~aY&=i1y_x8MY;PML@pe{TU{`3I%W zzIgK{Xt+gRdDyo9=T8r6OJ|*w-fGa9>wIMVM;PySVdmdkM(7tmonpVRWlqAU2CFa= zwGuNXTZGGfv@k%)Hut)89g)Z2h$L>xAnd$Tw0&MW<=*S#^DKfk<>*nr8M)HcuUMJW zVncR%TR9CNZL)ba&W>ZnY}D^D_DZ8z#-#x4MPyB+j~v+v21R>NX7sdiLZmxyT7l>h zqM|z^jOsL&{XB%EzF)nt4$0jp^l$Adfa?EL?WVN*G7%p<>);6qw_x?iHw^>5s%lEC zC8qYn`=`Cd1rC^@5BT+kDw?H1ykN~)V|poC9C?xdg}t|qonkrZ^dVM+W#1vwQ=EJ0 zRmuI{`M%pj?|;!aa(^JN|AkAkvNkSnXJoQs&kfCZIt*NXpCj!xm*LqV<+9l zi}a?VjUz+qaN*{px$I4{*JyWRQyGFA-@hK;^UO}EpyaT)8coPP}2qg})4ajCnetXN)@bmScVoPRM{hPf&59*Est=ml#=S4JN-}`NMi8HAQ0) z+f)C<3K(!oY_^?2#d{9?d3>ERY?bsc`HH%ZH!^$+-3*mBvGS&k8EFtTP^jwVg{ zyK!pf7sW8U@zxBdZkJqXqckqBQD7*cL-SmHAD9id!>Q(5^eKFu85iyn<44eCG|exz zeny5hyp8#Ww`vUi8cQc_}>#(lH4SNGM~!^Y1R*0E3ZW^ z*t5(}m3<2h`FuorsgJ4Zwi!Dax+&vOlvFNzl)>Rf%tdmJ#S ziyou-^`7A+pUya&XWF|9otFQcwcM9*hU(DSemJIF!>^oF{S;VwUJH30xR(PwHGNi1 zo7Cv0vep_5a>V#E9VB>>tkacw-MIq+)XbQLLGQ&8g-(?VNh+GJb8}Dao&9=2dv`%@ z((J~%;o(u&xX;69SGz;+hWpumPxN0oSCPg`&2;ioCf;Lpo^aYM%Dh9KMl$9}6mKwR zTmB)VpPq}`^KKyav7L6%nY{k~A$H1}71b#FRJU*Bxp=~filc2}Z0_DyuUsf|&G5Rq zzuUaai3F#nwab5PH-~lCW*`oL$PJP^-Ae zejs7GyY>*(h26Zn$hMsruC6~nn$d>5v841}dlyO3%$$MWuz0V5zn4-{ruC z-xQ!#A=-3!(Q6hGv{Gs$6C2mkoROMx%2rH50HHsw(^K++ee3Fgo$E@MeRu?ZzH~3a z1#>G$SLJHwqlP%M>7tR`dZS}!lnuMpns^qJxyf+IKZaLlZ${tO8a&Ns-Pd`G* ztJK3*W|9{rkGqJXCXD*+(yCq$SJq&L6ZWF>5KE>%MCz9v+Js>izG*s_($P2!cR+uDT>u&o_1L2fSGv!R=U1pj6> zwem}|lk5iCF2M)9EA9v`TwCOXC-L39)_yG^egtnfR8=|u^lsvg45)_W8rB~_!FlA4 zKc6uZ_S#sARMfc>cXNwBI&&Cm5B_}N*s`Rq&0D{c8~;UIK6KY`SPiW0(%jh#r~Tl_ z24)kvlOqvde^7#Z>pzX9ufdR*9{tFeYxtbiV~!L*{UW1-r;2+v>YgJl}cozK#R?ExW`B~L>Ig;BL)j1Nmm#(jl@e~c-U3Z`-FNnSD(VEpn^yil) zM+#`W_n&w2TpN=Te0g*~o)*n>y<@*a4d&Rry)t`X+1mPfT`*OLT^)QG)i3P&AUIaZ zIikz&X}s`Uz_|Q^*fNd++a;%+tZs}-W>7_eAv)!;5}hnh=*+81J)FJ9!V!UyU7ta68kC1LQB1VE8)egrbvbT}LU&Ofd622YR!?Xu-5r6-Hj+Q<}Zj$&`$|Ldo z#6W2_Dr&fbF)BEK<}`$cNV#P{Vi=vekp9Dx3G4Y|{WZIhd;AZhr;|@dRPy;Fb{$p9 z*_E4g`RF=C#LXL1xfJNM`{@^j2)g3C@MMB7K9U-v{G9p<6LoEn|B zxAfw1y}v%c@FgWP+Xurue3wF0=(3C{(MrK7&oRd3M~8q=-LNaRzo=?EW*8~|Ma_?mK503U>jo; zf4p0mFTpJ)m7M~u^p+uxJvS*BJz*gq6BIO)Z!NhS&BMP-b`zX+FX!e*aL(p2!V@33 zhn`my$T_zRzIJEAgNOJ3J{eA=Jcl0YuZ{M)DUBitL? z?+y79xt7L%eXT~*aw*T13bnxm2?rr%&83NUd#oxuo_K5I#5^K^xr5t%Z>xRN*Ah<|-9=1uHHY@zfjELh*cyyS`pi;LIl)Ww6k!)$q@}?I-E|%*5jYU1yc*}M{`Z*VjF)G8296pf|^kpwDTt~9c z5gz1rF*{)0-qRJx@PTXG?1IB(+8nyD>`4<;*Hnld-3QNl~#h zH5d&hZ8?eDB=SYshr|FuZFuQoQw`>xKX;i(e&SKJd#~z<)unlW6!uSrlt?an<#n%E zxP z7Xmqq%lBXO=U~-S+Z$iOz9gLcpWfI%PUrkTPX|r}9;W9VhD#|tnww8RAcR{2DWt*j z%-_%O3kY0eAj7HgZ21xH9PF9wX?Ci0)f7Zw-dDpD3DEwr%w5TF_9L8)ePSI5QORJx zMNR=+B_OX-$dZ>Wok{zCL`0k@P1iDA5mJLr8p(X}T#L-SpkRmO3Cd8v3p&l!el}Bi zk2c>v%#coA`%`Qku}2}vx|kJ<&o@_T3TH32AGn+#W3PUU&-AAeIQl;A3&&~qK)FxJ zAllC;WI3D=Xtx{NmBKR*|9JLd{pg(84GT5N9>lQO$A9K0>_!aB=9l9TD|Kn8`jI?{ zL(1Lh1N#C30lHn7%&FaN|&bkrSF=@{=4hcU@khHIs!gH#bl=SpscARih4A+Zfq^{fv8#zD1=g$W|S(-^6 zGpP!IbAfj2e{z~{XjEUfd2w9<0Vl>4o{MA)B?ApRh)R9SA<})#PMkl{yeH?LKrzS5 zB;E||+9ldg6vP5Mh4e)a$FIi(zx>V0l7!{EF}`qfpZdX}^lEu&=a8JLpr=JMP=jHu zr)IZ7iV&eY$H>@8@stN6ry84`?wzHKr6p$YSjH6`$=|v@e0Bs95xe%k8M2~DIgs}n zBZ?>5pQ=QD&Nf6vDuc1KwY7x=2U~rqL!$(4p-MSrJa<-TjO+(pzP-WI@PXczFXud8>=D$Yq06#SRJk_djzSQxzk*W1^$s-Rx89KFQ6@Ve}Ct zo{fJTWF7V3b$!E2)s2apG^J4?1x!CeLR8e)rSgqZxNfbLwZ({qUn0CLkWY-nDH6@i zq^@R?2KRv{Kn(?rob1he>`OT=xk+;;%i^8+CMUL>T${}Y4etsI3-4%HIS0n19EwWt zBluV7T~b3QSo#qzQD@|_lH_tfZES@6F5DT{YrWxCSD!~47Un@rwrGEbSQ zgAz`*RjT$p&*c9qvHqi2v^6fDsZ9;hr0*+Qc)WkXjpz03RJWxR-@B-D^Bf!K+mo1u z`uajoo~oe=(si3TTAYx{q4EKHy;v@cUhXHP#!ySsCHYn5LIb@>fBsx8!!GPnKzbi- zZc@UzgbiqfRSq@yL47%zH}F)rYX63l=O ziq=oz1*W~m=dn>|(2zd(n7B?nyA(E0p)|P?$cCN1UZjb2$mhDX5|nX6w3OF5GdEX6k3{i#Yyt;Gthl-4(-*` zYMMUcvvd*N6hE~7{X!tydA!hfr9H;w&1HLSpu^@iGn1&nM7SLILWO2dxRmJ#k(+V! zkIn-9n<3wVy5=4G?aK?|S-Lw#=spIcNbQI?&aRe6OTrf3#SV4-tMmsI(G@e_A$&2D z0cUcD^MKcfIHpxIFBE;iEMC>qds8jWsG+&5j1-*h+8c>2 zXiD!2-ocS#iNz+8G5y)y^4RZ2a;hHMO|yIYM4$bStRMGHBALz0+g8*t-0!6{T)7?? z6gp=D2(c=piR#VsW!~RTR>jSB73B?)pSK3V9 zD_o5_Nbz9@Tay*NkUVnf$!HthVEMv%I+-k$J+@!6X}m@nifq5kczp8#Was%V24514 zHnf~GqAacCNDp;Y{2SEZND;PZ6iJ3n4dY=##q>{AB}OD9Vw+YCc}kaOgTmM1n=<<2 zx;!Pxv#PZ>q8PM$letlf_T@ZLeJzv5@qB4e2&ditT=&@L&8ra+`R#FyF!NAwpnzP% zf$@Qu;uB>he7}WGq-TqB?2U>_4TS6Biv6v0mWf0FAz{@78^@a&y1E*w$AFu#|mt zM5=Q~%jCn?t;kFSG2`Ro(_mJl>Qyj_!P71Q-1IEg;|T@`;;V(KNpW zj$LS_^0GM$lRGwPa|-|H;E0l4>GT$XQfK=^5T#?PD?@YeZ0%&_;jK8M@1HL^Eq>}9 z7*RyG#4(znM7r~A>&^ohq<6Y;cXM^XnPpyOftzoogARiNDrX52hSHg+ZZ0COc)(v6Opw09(a=-&l84EoOQn! z#>t$li%XL;*=Z3?3%e^UjU?4UeE~?SUai?QOM8t`7A=P;j_#bMYP1O7YCG)cVf@adP z8FG`#q;Gggc1G45L%I?`T{L;^MaPWnr>)32cNDeXn775YKb2m!et4+I$N8{>O5`4x z3LHYP{M|6(C=1?)PJ3Gc|EE=7R~H^J_uv5lTf+Ij|JzgTMxfYNI>u!qw_ll0M4LkS z9xx&=&kZgKRxgI3J#VneNpM^ZbYF3-mYJ7j;Kk$$y7qlyH8`c=M{Kw{4BpdwisB6i0KvdHJ&biNlD0ds5o& z4(zB#*eRHF91YF27&E%1sp#at$)+6hTpWSJ>e&Gf>x%59M@;r4sV_nIvk4YPFtMSI zfXeOO7e2}WxzsQ8kCBNKKFHJ>LeNdtWv~KRO!EnsAmw4%gqRw@0{l!A?*weJX)tMo zHCJoIK-I*5AbEE#d$PT(B6Nlk5o3FZ-mE0 z0D5|BSt2nuboM%w+P^mdY_2WUF5*CLp4Y6^!d0dBmbeF&$f z?WnJa}9oF^FIlH((y zyRf5OSDJZ|VN_(|E__7vflhlRwCmKz7d1+=x91%2*eih^XViQN?*(sOLQu`1LD@f6 zhKF<6vos^-z?t93;uTw^8VkEVXx;~ylYBA#0q2e;;?SFH+LFfQ=?52C0MMR3VFtdo zpG6sd^HS?x>tbQ-hUwd$osmHEt<|O;yY0|*UqUF~;Y=?kK$58U{>A%-@=oi8ov6gl zr~m#^gme*gf=vC-g<{jj-S~L@E4pKIV9?C_|MsCQ>@!l6UXcUxM>C>9qp^Ek&y?$l+p(3Y4~~mi?a)|yd;~>#6mkW(ITbavo^zzGCj#@4VCkWQp!+V2OliR`&HvUr!I6<+ zC3vKMXyA8pblSnfZJ}ry;(hi$N8tHCK(pxv4Uyeaa!S=?N;-Poyn(01$ zJJi!qOP2XQ|6`^{z@3qNh-ne+{aP9S{dFvVHdfmG<~9JT{$>JaKIsSkYs^g54sL^1 zL_u70UgWjm|M2$sJsZyeI#Rm!Q zpPOo5!DTl;ZXb8z3pQzfvnR2BLm9e{%f7;L25w#Y?(U_>Ea`6_bYRglFgRHgcTA`P z_W|jUf{H`EHrMiY89gXT&&H0NA%wdqoA=i?=<>EV2v4AFn7B^Q zBw0?#GmJU*^kiFb${{Cy5grW&g;;ZuDyYRV<%|lBDGMoyp74v4+=+ zU!6)hD_I4wEbiW?B)S=As(0h3vqW-}vZYx&X~evhc%|e4hCk7)9^}y z833yO2`1r}aM@4t!grNpFCVvu#-zVfgLV(XFX`9^rY!L%Qzj+yCjPVQ4}{~?G@@bl z9dUCzL;Eea@{K$bvX+{!5OPd|8F~sJ=~f>2o5yTSh^p^<3-At1PI!+i-+k<(3>ifU zA}7@G|CbUf31=c7E%7%c6il=LZdXtk=a-iGFAwP#+l2((q;qFV3W~SmR$GR=Y{($< zVg5x5jr#^LK5RMma~HfWjY{VyWj_C7B)%pr^nM142Fe>g%&p|rOy}lapg$sWBczoN zl!hi><8x;Jgj7yzy}ZkA0C^(EDAwZ;g3s7c`e_od>A()?u+=4wrTP;5n=d&5H3Es# zNN(1KN+4dp;xUXt{$pg}TRqg3{oh5%?Xg?LAslRxLi@v%@(2T^Z6gC;rX>tegYEt; z3mYKg$Nanr?!1-%@*vcYfbWD{fS)%BIiNB47ghg12C^wmjL97T<2j59oLfFZ_8;F< z`k47Jwz@8SuNEI3nx zAxQt`#Q*93TmNe}w(4_sc7{Ho9ljv_I22&=)<7G$;;-UFiE;Q(?E*62gc`|=KIZM( zX8L~PTa~f_+sG}Vy~ADaj7arZUM>{tpnkIlhF~s-r?Vph--Vrd--=3RWUw` zHyBS~LSVZ5lLEmhJMR8T7d064VgpLMdLsxUFUrdLzPed;y>3^zk`U^(B-Z0|-^fQh z@+EY)M~`qSI+~lm`blPR$w5OyYqZB^EK;; zZG9qO^*i!dTyauBfF8O1o2N2%-0KtHd6H^?!qFjD0KbHVbr=vxi-=LKF6qMGJmku7 z^G30~pf&EnK9&)uQr-`yl=KUec}_{#BgqhiSw~m0FPF^SrG#!5aD?{X;B`EKe zBb^X3i~Q}K>_N$?>g`$$OBc+kR-LGECB*p7&bIeL9Cq(ktgT}2^VLXP9-3EJ z_=`T1#x^vS(Vw{-K5b|ro(t2cSFc{BFnq+*eb33J;@X+vcer)y1^aN%8}#p70AyHg ztF`N&GrqL^*1l@)kaB2GyK&Hm8(AH)2I>qW?qB?iIC?L9+h)(xmX9Y`a5Rb5HhVGM z6?(=Z8lH!Y>zYbF6i%!auw-dgU|{Z2;k=L45}`9P7y2_$)LilOP!nU0f3v`#G+Y%tizepD8#jtc`xk7ZZMgeKQknt z>(GfC06@V|bYw4abXd>W-2?^*kLAA! z`QKPxjGg~F`9U~5<-x&J3L3$|!6k}MPwmC2J)inB8BhXY#`&m>52feqMGF4|G(@m6 z`dr{CJQ`3Yc?$ z%Ls#6HCY!eLX*yHBvJ`7sjpZsG+?eIoQXJthA%&)oKM1tLK!iUvL7u48~b%kDXF7pS_&%)XOP z8ihFv@$pHz&L=j?RG6EYeN=^zqj)?C-EUufvhAEC^L!6+ZtceH#tu9bBJbcIG{1iz zT)#6X1++W=h=uE@J<3nOn8@rj-nXZW1SrXJkG#3sD32{koZYcW6a^gAw*(JGc&i5S z*`jCLY$ob3KInl732P4MXv>FFxs_|<%(TrUPIvTCC&r_I8j7I4zd12Z4awWA1_(Fu zjYB1LEq=B{(y!WIUa)`;ztxm{bHivr6Z-mD6ajvG0K=;D&Ud&3uci~x*4oOTkhd3$ zhrMACQ%qBh|2`gP#KgcL?==i;B5#~poA*1gRjzk-tqleylYONj8%LrDI8$?f*= zCGqiA#+W$Y&9|K4D?%LDjSasyzo0q^4mB84R#A~78Bp77*0`LK{=}aAtor(TxY38z z7|(G%VJwK1v#H}?laEiib2g_M0ZVfX%f$^Sl5S+iTBcU1LiDYyi7zc6!-lYy9U=8J z`~W?{A81fwWO%Z>SB(dn)HTe{w8*Fkrlezxxp zB_~Mqy>Rm~eTD0CaojyVJ3T9caOYp0rY5P3BD>Y`wY9P#FhW*OmLC4n4csB*n7d1X zOE18SZ2N-+^IM4tic%Mi|ix8n(h}! z;L9~U6HvIqwPT}w)ulpVp5%~-iM*S8Z@NY*^q~(_Io2iQ_vby7Ml)9(UKU(arpgOR zc?j@;l-7^+Ge_`-Wp}3U;KV^(FRFHN1)F;Qs`GQBDRyVl%5|(cs{ik)M27CQ# zWA$F5pC?xV$?m7#8(nDO0#hsBBIAMRloU=vb|_$5JXfK9{KJTZsiiuKN1aw!*vNf6 z=389QCR=t;O)Qkk#dvQxcmY-{%60yu>NGOvioVeJ(!xtQ)}o=*4!A;Ln~`(AyGd(> zUn~pS^%cSqhj*lt3PxI{e(16^24_7=eO@H(H=<1|IYOO;fQ_)gd(JAfS-PcC@& z+rb{sZJov;J7C6DQT13~OnRHo^zUTe-&4M6FA!UajBey_s{PB0=xM1AVG^|ID||yY z=tAiG0R}KEOph!i`3Vj_L~7K_!R5bi2sI2~RNtyPz(Pi+ZG)w?*|VbGELLmrw>i~p zG);6)O>-N|c=YFXpuqk3ghQ&@J!d59-u%W6f_p%y*kA2|zWIb!J?UJL+v13%^8^f} zMqyTapb3V6#EBw%awLL7YJ}%oKNCBM2l*Gf8sFU_{#gL}f~%3g=<4#?Sh0hXIn65h z{_12#poM+BF~YrkvnR5e8utMK=}Qu){}t7?u~+=PP6t?<~!TsCUizSw}SR7D{fqV%ps^2K$J(ti;FD*;*DrXF!JE^*7q93}s^rY1M-Y+8S z!os|5$s0F1a>~zb#K)+%%INT3?TD@35f_#fD@xgzuGr2eSBZfa)2-CAHvR~H=?I?h6 zUF%hPxNr=@(vG)%@l$_-kWp2ISxY3H%;xR&@8iouhR;6-cVuQ{*nCKo1Thn|A}-;K zHK+1Hu+YTB#P_Z?;ecWsP7$Gj1pqReMjXNp1|IY;u9`-SZFdG^lb}Y`G57{B7yDjrj0HRqrY^(M~QL$U(C3oYY)(E4a(@kf(f)7(iPCE&wk07m1ZoXZ_ZDQj$S5l zf9rl%%T#kGM7Ro$mSu5pdaj+?5}e0de%*eH>~t10*jZnm>dWS3gYAC-7mx% zB}Yt8sv&K+(0^DWxYzqH>B%)AO)Y8WeL2mM^Ci!pe+??d3ke9!R;~_uZV-yWoqmG8 zleMnmExAhE{MzEEKBYeNamST!l-=Qb;q&&Lyzq>03)bq>NLKOSLC(jp1ktQ=)z!pH z@`ZGAI!sK6qlV453Q`Gq@Hh#2Z*aW9-)G+DJYbkneF&J)wMAhpH6(u6bCMpYNVNxv z!p*fsYG$FwiHDLc={TelBO_&hs!gc~S1ymhdt2^Q;lBU*^XJXY&2OL=;xKr4vC?M_ zC(>yv@p|B<3-pJB8n^!Nw46i#^0Y`YmKKpw&I3g*#V}T~yHoM!-Sc-`5(;%RH1dq! z-K)`aoSU4OU=`m=$IU~j;_mJ)J7H?C$ngE(=cGeMYUv$3Ho^#$UwG)~j*Z46i%f)3 zZ&)AWz4qN^PTDZuaaWn0J7$)N19(l?@R^F+}UEJnkDT{u{m}6 zyVL7i3EMB!$+6|od^vYWF>eP=)(6pV$JsOvMm;3#$*{7|XIPWHls%`b1~jOb-Jb`; zH{Tk{xzGXkTUl9oI6fr*m37x^)249kFY?C1^H6*(QPyF;WEcI;w%!2v%r=ul~N7WD2MakIj#|ttXK_P=Qq@xR&1@zL&xaoHr^T!5%bhQ|wRi zC34v+W(z!k&n^4<;xsThG}HGN@KE9f_44aoH}s=UT(Nlno=kgi1lDx@!-)8z-(9+IA{`|n1~*`FU!x*kAElI*3S5Wtm4s+=RV|!SY6U(^zj)ua z?G6Qp*Z#%X*fVdmB45JcN9GR9^%jsOojn}>Rwu{C;3}ccPDdP3_VPRJG-qjMX7wek zQ|_}-Ynx@TIGk;q>(_eP`B6SkN8ie{tKrCXYt zOYTf-$~(l?VxCGkfa{Ff=2QZpx=bh@QcTSKSwK)rmX`AVxeT>)$5V+%%aL4V-8mY^ zcV=8Q?K@`HCE$zmVq!laum(SRlq_c319xAdKE{^5^(-6`U>`N!``bH;!^+2Q2dYbv zV&Loq9}&hpJ=5+4DYFz<{a{u(u@Xu+V>5e2LXz(MJKX#V0WVRC1>rFFyn#~ZNi_-w zC=hA9(%e?z{*Its5@PO+kBv zKa_cEbWNK_oRA^(*6j09cO=W*7EPe4CXoU*QG7hhykF5P$U*xSFaTOAXe6rf%qo`> z5DOU}Outq40Pec!YyK^OWTf1Rp&e7us3_JYzboZj_kiZuyQ9jQAR@_hl;Z0+<2M5bxS#RJ32&0=herPOZ zU=)^{&uZQr)e^#;tBp9bD*vjLPwNCzkpOH&h=_b*HiSgf3CLBQk{$&UInrKE7%0~nRWW9rzjMxy@PxtiH1=Jb znIUuRO5k+$>89z@<#Gr6Lo=5WTq6@H_SIqZ^z`6W%&OoH($nLMY~vtzPA#B3mZxAn z>}Nw?nTsvx|B~kLEN@(SD&GG7{re9eCbsjUAw|vOiyz&^f>xy!G|*f7iivrqzK4Z{rQlw1 z;3F1r+AFy+lYu|lBH_=5om0_4At4auWgQ(C_^ zVIL-};Elp`_|L02qQD6V74A#5nbN2`Q;#9Udji$w6Hll4)8ed|`b7VdmW`PsiC4W% z4Kq?ZS_NFDIq&Jm1d(B&=5o=)^?)ZmcCCjrECDLV`|A+-FpX#k1MQOoXN8QQPhvY* z0YP8D3_F;^`s(#-ayDAYyC6-=i%bj0zS==M=lA}@Y!*m~Lw2GPPuv`E9U{wMcG-c4 zU8r2WDKOZ+ait8D>>gI^|0&nAiJ+*rMW*#ns6R`Lidwpi>v^dhb(=@H;+t&XEdX)q zlAE)Iz60j{Xwe=~+k@LeEmY7;OSHxo4|=p+s+hfVjzi{d#qHtRVSl^k$4E7O;*Ljx zo&$p>vy2Ut16<1WtH*n1Dul_;{xmnps{Gcr{`A4QGM^Pv5xS42<&d;G#s{F=(#g4b zWj*#-e9}3W;FsEN$T!bazRPvZ-#+WHGN){+oDcG_#dVgiI-Q{USH6YZ_)VWJmm$7q zKHKZk-aq~IuE01hscZW18LP(~kuH<%5<~rk)={m?^}r(x>K3hMLwe3yI^acXF)&%> zvtpesg)d`ZlSbFoGihTa|5^Auqrr?7YoutTalu1`P z)$bE{yjI|&4QWrUv$X3wR;3*@Tu-ParjOr}07KA)Vs^{FBMJ2d{4>3PlV#I=4h*Yg z2hFRj3GoSjR!QboSgcUoY#p5pcje*MmCjDhu&(DE*}Ru+Z1~6PYuj&nEjF--T6|1a zOMMl0Pclg@GC49b67mTUsvnyf-!5OxiH7J(o*cJvC;z05j*c^(CF@lA9owOZkkd_P z%Y@DwuAWD&e;QN{U(;*yGKz93ADG^)fBpJ(mWGu{{CMLd4vr%$(Sq>JJW%a9eA;a9 zEAJ9LFfYh>7e%^mM8VTlgN)bkU0(gev`ui!qa!1{gt~SJ1rR~iWo`*Fb1cYFO0SPa zL310>;h+Bs&TqLuP(WZwYVBU9&+}e*QP8d(6r{WLnA;lcQkA~P#6VBa9jcd_xSG5j zq!oxK?b0pAlUlX5wZ$vOTV)c*$wBnS=Zb`PPKS+%3JLS z^vB2owhwkxitar54>0&cDEo&^n}-FV;Fk{9w?918}q37 z4i2Af6DN2c_>xY|nOk9vM&3WV^&Ki3GBP^u_Ln%a^3;fUomhyCh z2|DNH8<>_j+Kh135N9v9kE?`q5E&lQSB-r6NM`$q1&O)2xnJtp70dTe-ih$vZiYtJ z>h(;~r|pvkAW=#7EXj0dW1%`N`5UAbBgjtS1#S8p;uFbXBi|Je}Dg)YoY`?)-%nXbO+kemEsWJsY|iP zRbt(w=AcgV{)PqIM%=D%&xcJw_dhf@@5SDzw(dHSL$S&HOIsyWqs9i8Jz-z|2{pel zk1a3EjN@|IqRDc_n_F7iy05k6nKpf2S{fZ4B^71qx_kXPQcWswOF3b%QePul zB~D0ectBHAvx4raX@Y2R-YWeLbUKGC@X(f&c6<=|IR3qVp#TE6FUs?Lxk~Iw%JmX1 zl=SzbsuC1;l=Ad|YAkN96_4n5}10p6~@s zO|bkis0Blqg=yDY`KB$tF$v!A*M-6{wW7ic5R zT}vyM_DtL0Qy*Z|nf2_^?U-$^&P;uuzdFdMsi$XMv!}v=spqhU`>FN=5?hzrqX_3s z4fQy9&Na?0@3;*>KQlpwhF<0oA2OYJbV#Ijwb5)quN;%rHC^E}-g-lqElZ0B; zu>`@Ca;STjmzSfXqg{u*U17oty?v;ag<0zA>2XYX*!efH&h9cy9@U?68Xny;efw4_ z0DCLVS){1tcP>De8|TwTIbe4*GTY;BFAQlxr?l@Zmo3$r3Kmwr-&Pgfy8X2-II+p% zc)eP$dex(6+q3;Jh?d#o0NzfwJ~0P5x)|KnSfC?f^`|F%(Ut8M9uhxEGR5Z{qiUEO z1n3PsPfo+A{4mPznl~z;SWuFK%*0KXs^bhd8^x4)TPD%-qB``%JpiT$Sk%y&tNU7**dLZseCyKJY!2DU!QA zSw^P+{yV|JP1|qErRr&sJ`mQ2fS_0-#(KtT|7wstjaTIN9NsJSKl4ntA*$00$jUo- zbzq&7*2fH+)^dVpw=0YsPYH_OeZVmqFtPjRXF!DsZ!4azdTSXN9A1pMk^5;wC7&r# zx1LXLGA)@?O}OGf2bLNj0_tZ7k{+0?HPausa)VV)xcBS{0b?83NaVz`^z;@|r%&07jzP{g zk7TdiU)2qH0BDqcp;g3!5EdXS;gP7htZQoh748Ml?GC18NbPJcK`S1%7Shd+n}>o5 zG^VT|X+o)KYGQId+rWKcP)d-MiskJypMXT!=kz}|J)u|w+XjtiQ86(Wz@x4|UJZI* zO~R~IE`V$inxabGI`(wLRIg0$&2|pCwy7=WFMr_?p)j*(RY<`YCCHi)TBP<&JKoHg z8IcyM1>pgI71j}eOl5`gE<}yzCXH0(Ia)oeUz}ANDv9#6ap9B7#s6xD@1miT%TS_g;YM zS5+y53o%BsE-q*v#eFePtpFAEm5ZPsGP_E;9c|PI3pVo|udCO+BxB}&?QU;wTTsy2 z)D6bPm1;&T9WAAL9#kCt&z2?Rs=<@@XMu07>cXD%P&U)~iG#M8>tdS-``zZ|ho|mG zb>0DucC@16d(tno)MZcpRgM8tX{s`{Ub>>#5m}FCcdP2Y{I*~2s@p})4XY}J(So-o zCvll*$;a~Uev;c+V~!b}6+Crc;9K{kerJGYv>%0u-F~L<1qA)neSv;08Uos_zGLjp||Aar0;LFFL)ZrP+Nx6y3^6 znivHgbRfC1>VBs83Ak7$HvBE-VdRr*AQf*=f2!;Kz7VaZn^pz=eF#9{hvgUPoB&-l0EdB{)=NYy{STc7J#OEH4}<=i*d->FW1v#_|JHN}kR|NZ z&I9~}NVR+P>-iThUP9iYe9Q?cHv&Ay^;mw9^Ehai6aMF>vBeWsKQI2@8v?ltxREyX zr)pq#?2fo!p#FLKMiJNaSX1Q(`%)URo)r|nfB9(k6YXt~;RiWVZL#hYnk)5({7S=DD#f`d2nZAsuJy zn?ukdo8;L{(q3Lg#PdhP6*wF1-Q|0hCM!vL5Dp1gmpX6$kXzvZ@rWUjWhq13+`q~| z6ieRQScovTRo{gwbn>4B%kL45JZBx^7D{KuZ$9WshFQfX-CUYUmfG18N=2Aoa}iomH@<->-H$&8*~7XB3MqWb?$GgB%h02y5c>ID zxA36@RC7jrB&WmNAsDr~Hw|j6W!6DIC&TPFVZ6n)k0P#|R=uw}R1IDIiuvV#EjLwq{mL+*>Z0uioX;?gw~7(3zt& zyuEm((;!=p{t4=+e&+r+vKFY-d)EeF2QOdp4}U}J4F$CXP}N4g2lLm&KsU+y*|TQ> zB+J5AmQw4jsB>6I_c-Cv7B{38{c&kimd7Zjbph1RMb%C3NJs1~e)*{&K)~xPJ3AMxHwM%Y`-61KK@U5y^1##T`0E4U zN5Z>?og4L9F6}n7MxSX=1OS@U0g4_CJsJ0L>SerCSZfbELc4>1KwrR`SJOW zNzxj1t4(k0(F!{1H}O~U&qUxIXoOE!&vopH<)o$E2~VStNv80u(Q{6NMXKRx0RMl$ z`WG;rqAxf57{3>prNtnDFEjKcEBO2Qn=h2Z(?CRW$odznpf12`l9A~bWd*;q2G$<_ zhG__P1B5TbF9V>*zR8VE9p?kgOF!~fKk94k^?Q{52ij2I_n9)d~y=`{%*iFrz0OpIco(|c4hiRYEs;q}{=0|`wQ zl~0ejaLq&roIGfY^Nk}^WasS-EypD7u5l%gZJaMhacyIN*%1zGmC@WK-Xw6$Q0s@gy;6|LR=4}{ej?e_DaU6=cm zUk!}U;PPGp6j%(G@_u{(LQ;wC9}yj&8JxD8LS5hZk=#dB?Y_v>F`6A270iXipw_eZ zAYLwwM_Ewe1ZTZnOaR(@IY}&y%WKH;O`tn`D(b-qJ@L zt6JQAs%4>KKrF`mf&sAM#5`KJUUn6zB+LQk$&;-UL{Omt3YgB~W&i@@YXB(>&7e~qRuMWT};l7RPZ*fxEg;<%r;f*OY z{hI?XOZ;wNVZla31^@*Q98mLWv{Uiw^U??IFV`92q*U)MYU39d4A0p6ISX>4yhnOQ z25v^43L@Q#ihkH6#eK1XfiJ+pU07HEDU}=BCHuBGkWTdW-UBrYyHF1K8{m5&5!#p( zL3IF;eGNT5h}-N5G^3R|kCN|AMa7X=-Uin77SzrpBbVac2TfXiSdbmo1OouMx+VYq zAr>TlwDk0_t*xv}MiA$(U%yJXpux>h;EmGWFUMzEV}N}gVy=3BISLLIkOclECgx^? z!1P8=P7d()_xF8~RVCoif*RHVYs9DmhzE}W!DNd~($UicMd6iDfhypiZEn6aktPTV zm_%m%{0Zh+)|pCI?L~7Eh4Z_#O`Q`>@82gj$wCd+C`Ez=4lJXmII3Sek(D({u(PU$a6l3}iokXN>|L*spFTs-( zOLC;<25d|+#HZ6w6QNd^6;FaBUN7*Vt}S4AJ=2$lA(IX4Lrjmh{el!nr#Yj!RZ?gm zF!%oWD;{-#2=lLpB*~+T1<>DO&5!0(f$6-Y%_;HvpTBwVGfuVw5k!O*vk1q!QoHoC zUoo;M9KBS_`-y*z_aB4*^-#lbbU6gS;=4VY@6TCI-dXV8O7dRJ%vkKTUu~0Mvfp0n zr8W?##m!v2iK|LIScY3nkU$b;u+6%-TR>MkzWS+~(Q8%b_|2xts>H-7N{At<-Q7xYXxIKh zl96R?Zy731(IyhkrRYeKA`DNjSE*R|OH1JEDq0aqZDqHgHCcO^43@pMdEhlyA8qXh z(T*>DT9;Dg3P1UI=&jLRG+iIZbs6aatD35TlPBo}FaiGe1&51mzxMmxaO`^5+&yc% zjC_(3;xM3034YL*8ce>~)7r6MX<<>~PFr1rxN75p4~S7~Gq&&6N$(sp5oimg;~cy3pH`DOUQ zEk&0@iHAW^3@P!%sdUu6cVlumMkf6ubNR8*uV{2lJiRc{-}1wuZc+VFPs>kW+_#Fy z+CrErZq5zt{;I*gO*`K*)Il*S8~Tt{^qpSSnt~ZMvG*^r2#?ZY`RKgYnoJdUY3w67 z$5gO2Y|U?HiV32&^dKb6j$!GEx<~oiZ4T4lFBMmo5)$Mb2lsR=d=>aI{b*<^5045S zMc=8I9`8v57}>sInvq&z*d?9_$(JixQVaSd42H?f{VK!U5f+)1pK|d2clEJ(b#r;c z1(q{yJ?~(eyes(?o(2he1a_R=c*%^tQ3p=~$HwTdoS{Wbd4;M%#Ku6*yLYw4F(UaR zMh-X4BR-9I#jCvxU6S%zi0frk=f_;uA$qq7q}BrGS?o z@ZzwE#g7*LNqreAZ9a^8kD`VR6DVowE#DpB+c!vxst+GO>5y7eRE>SE<8}}_8;##I zfqFkgJ;z#OB@%LD;h9!7(*ut`fjzAAv$P8<_t*DJJ{6s>{>cq+kzjIf?qBk zCB2tBrd_4oThC;FB9@!0P5ki_hjLemV~u+9%j)_E8%_R%QNDZhN?{_&7g)1o0hqf# zL-bF%n7(Os^vdQ;-Dg-!vFT{eUSGh)Pt#t4&k6TkXLIKJDFB6x{KYBA_@1HXT9dK; z9P`RP4EYC0nYxi5tGDdu#Ni0jzZ6;J8}&xnU*^A;jqtG8->;5EwTk(i`fipa1>sL0 z%Q7o7EAhD<*kMPq{~TfF?EovX8c3Hv%OG6wcGm&TOm>3 zQNeWLdMoAoz(e<$;Qivj8^(S;VibHVK-a7+C{fp@MoB?DbIbouA{RZluYo_N6DM^{ zJB$e&P=4tn4X>IDE$=b>DXY`4CL8o=BK|pC6Dm4Hy!FPaXWJ*m_|J=TlOBBRb38bt zOXp7yTy?}U29}P_U=aHd>!#zScS_*g!1A8I|AWb@oZn*S9|}>68eR<+)}E(J$23mS z*>Ud)v-mtbvGC~bbCyt{3DT1%;P{>t4S@yLzvx|g^o_nTjQ%jTZ6-LV;`|@W|NAlA2@Da>A z#lFhq+oDQ{{kI@~`EjK?vziyz%mR{i`ycL$4$8~sO|=oU(PMeDgj0ulQ)xhXsZ%*t zhHQaK!C}eX1)@uaNwM+s9MmYbn^P4HR}*c{GZ}UyR$mzuf9^A))3~D5>Mi@Ae{6MR z`60VR<33srP8HM#S)`j)>IrpW_^b^S$M}4VOX*pGmcR3_Z{vHM+RUoqF;9aIbz9Z7 zpQW3v4~XTsE-QWF&s!HWGApppYuHg-3HGBFiqYoRLq=H5BR7WkN@(-v9ryvQiSO7X zp0PxvB`g*7Z1q9Bb|>;&Tr!t#i|wCnMLUQ;hB*{8zLM=Xg`c?6E7SL*@gt6H&+h$8 z5&lwo&mK!-ZQ8MrV@U1gziO7dHOGYrqkkmTDVG#!3O$=^f2P6fr5a`>1p8h9u2pR@ z@T4Z8H4@?qB*A_{D+g_=@*bp|W{~+hpD?Th3iDmB*dyV)1sO4iBM0&>r;@|CD5UwE zdvb!19lmXLJt`?yKL!50&mN^l%FWBldAX|*Dq(Al=2(idHovbRWtGE=tH6patZ)?m z*q->4rqne(Fu!$Dh+3Q?KfgCQ+5YIplkQAa;5x*2T21rfm*{2pa#qRJm3y;$2B1(u zE5+pZ&hZ#R^7(%E{rxaZ#`eMnQZ#BqokhZ9`vQ>$Z9;ax6>xBhyD3E$6v?_{gn!HTGZk zU%(&T4h-_yx46&lCEAW^+1B|4272B-rk}=sMs}`J+fVPy?4yl4sWa8wbQxllXLqQh zD@z-&XH#2fl5kl5qN$f-1A|2BcEW`*kEQ3m=nI$;Z#8(CA$Iby`YsZ#=>zm416c z-g9|#hP1)c8vLYLLF*h{x_P=nZ6gObQUPs%$IP`9i5D7nL192|aoX_R=Q3p!sm(vF zN1LyJ(zq?XN7NFEm^nu^!KtPw(!wlhRZmZ5hy2P}AhT#AaP3G&C}q$1nYLyGF(GcS7;kjn$Hy02eVuX6Bsy z!e`%oPwE-@quVH>r3T6U@JnkKibH;Be$! zkRgmt%*5!c{;I+i2v6+l{p+4dhtywJ^v3lYV#n-?*!j^@o`gDgdfkMZ2^BBfkmAQ# zVKb)1c`2cXg#6B=1--soY;WGkah>>x^9`Osit%b$_)vQ;oKBQeZ(Wohp&uE%JeUgy z-U>OHj9TDYYgY8RjBwt?puG_0)x1>ue7vO|+56X-h}Mm5F`lF|-3#PhlGDS|EBdz! zM;6{|esV$j>T$oE%bA~A9SgPHK5ZCd){-E9{bG9S2P``KR_)5LA^AKZf6K35Lv-NA zuTFe-v68S&U+4_xXoYN9@Y3u=OFPGJB|Cp3>xu3ApCVuRO!C4vUSDz=I^`y2dU3aW z{c+qSr%Jf4RI*p&vT)Xg5-yU-N4aAOHV1N?i;L5$hO^MJ51BYuwL;23Ck!FqUb3Ey zlTdYs!^U0G2(h1CN0y0^dm&7%6-E5{Wl65NJF_#xhp`{ol5|9sZk85X?L;FDqubCg z#UJl&A&gpoW1(q)V%|$%b2e^`&MdJkx}tqONI%P&d6&ibX|_Yaw1uPi<1YiNY9D@3 zxM0miJEA=e1B4SFCD! zfWW)_)2ilxy7PgX|O_D#%Q!yo1 zeSu+074}3Ud;g~GQrc7X$=|9L7Hf(E_fTkXFUL$V@1kU0t!JixsBKf*Gu;Op6_(mI zom0*kjSVDTFTpXK^bLlo&Yjavtl?o$TO}`<)kCk@=)0dx*`9X^A9{}sod10F*sxK^ z$7kaAENvW~g#wB4mP7LF@@K7L3AM{|;TTbfZ}Bg_AI!JX$6ZHS`f(p*`+JCIZgnxV zOFg^lbsy0kz8fQYEayeFb?~9=2DSFU7}{koMs4V!CpCW-o|nA8e~F{Khfi)%##NW=5?Q_n*`Z+uL17=xfME zmMZQ*UtLl>^SBm9*)T@t`slreNAqo86BAxyjlbbY5Lr^0KIxEQa6Z0Q)~Tz%^kJ!- zbGx#-*oOZ?51PYup|E0Pa!*9T=%M<2mEQ`Zmd_5FUkEZFD~)Kaib!7)W%rK}hxc|? zS|r_zTnE<5X&ZlIlZ`3^YS~j>-mgi&E!UNJ12)l*FA;CA7n)Vs-Zq;|U@b*wPRfUdJ)2>}gc=h6Cv$vAivoh@J=~ zILQOMkwKlv4=K;x@dtvX8}esSBQW@A)>)$(1LD%my*`+VD08IX)gIea1*E^t30hJm zP|-d{)a*LsrRit?@jlkzH3i}H?m&8N8}XN|yutX$U;=x3J(C$MPupnteV|QxJqkS= zM|jJhsK=e7pdgxu`$h0WcPz;V3fUS`2Y5Cb)$rW6VUEY1JhWxr;%(Ge75bschVLD+doBq z_RVQ(pjXmfmUOK%%=m6F(vlF%0TJ!qa8P@I6#rg?`D=+bjR6NvXlRhKxNRm1W%Df+ znAjWnS(5pJX=cXS{(4{1wc9FeP#GE#hG%vuNkQCGfjLe7^G1=2U0Pfik09QP-i;4N zfaF6o6D*eInEXVo&5RG!uf@A67$TQy7iLtZSRwoA8UnK>68VLXXkWR2X46@^7?5oz z@jzA_kD+5@S9|%zEt@SrJD4wqJAS0M(_^CZaK`th884soANAW7QTjg~ietMPUww_a zs(K&z%)}Cq=eWYzaHuNmc(8BZ-iHPm-xz=Sw z_3$I^@_6Tu8R)DoqY&Q8$gKT1EY#dM+g)_@1kIBl3yII!26%+#;>j7V{v6(Hi;v%6aj}t_}s5S6+pu z0655dn%7}6I#)UL;0Y2`n2MNJ?SKOA$nDCGuZ^<&2si(3DqPxgk7bRQK%oxGvtGZN z~ z9n>m#77{YJIy0+=Gd4wG=^+|(uF%H%RgUc;I3S3^bEc#4QAS_(orBRO%JuWM zT~uDqMKkd)p@p*@_64QUoBbp97k>5!EZAR|?^kOl#zRB~SGS10ANv@x&_A-a8^uHi zt-kgv-^*t*Im~?upG$$sR}KRfSHMIO$;kTz2V8 z6962LoKnShUjCZo$Ue3{Z%5*N*};nA6j9fwGb6>Xt0lj3{P*N(lPY<7cmV;e)f6=Me9m5+%#0s; z{~Hkkm)h+iFQe`t@^W{<-G*BJ4Q}}VTKU0>E}S{i<%ry6C+1gL#tveW<=juCINJ6) zKuHs%Ed1M<Lo3)O5 zqEdaCNRl^}F&jmmF2x9rLRP+~gs|=?fKXl%c$Z7Z#F*u`cRCVr z+#5^D%f>GY7{iV;u2-1Te?Uxc88$hgp4{p2*b-yG`(m8e z*$ZCACUUNuQgi8(;;bNg2d`^7KxIDvucn^kIA*eHI$*fC-VJ0$2-||O%b^W z|GW{4Dld#3dVk_IHzu#WK{iJZ(ZKb}VFOSE4_z=2!?d{Mz$1=hwwbyURwl~O@0P}reN_y)*I<=4+B)E1$S_hZs zx?N+j?9)?9koM0LMOp93LPqlI{FYYnC&nd?{1ZbdUoZw7H3H!M-6hF(I7IHOOtXLk zl1>j)em-39$u?gmPZ{+K=V=bWNW8u?Z{FD%mpQ`IF=253+E%tL%!>cgAZ#sHA3IEa zwW3FO7G4D#%*8Cj2YLw{kd^++mze&E5djbU768j`N0-BUnd;j7DLt8~jJOr`_Y&FL z2~T=M{2m}iZehku!@a9=XA`qoRQ>hD(%8*de(kyvfrUe&)i) z37*k5IylkYK^Q%^#Irq&_0_rp*KX5PUFr-A%QJ|LPL@dP%k>d{hl7=T&Ob6uokupu z<{R7;qiv~3VhyNU9NCu@Jo^`cKPM`i55h<*fKXAIHEe!7t+i@0}DK)Vr zc%Gs1IYt|{`$O$}2q-?iUoF9XTF<{{>3vJ(vbA1CSt6f1uf(IHg8)~?kM7S z19J=$?TsgnBv5>P#@LVDPPjx{Q?$k(xDFqtr^gPq^pkR>BYU$W;}1t;^4d=X{fgi3 zQ?}+?4);d_7fpJXERb{I9aQJ!YN`d{T!4j@(Au@;|J2`&%>Iy70^Wk1$qTEHhj@|I$Gt$d|${YN5e))M8vRd_V@X*!o_54 z8`OTMp-|_vy^^Ex2Eh_NI2YrWG&VF}TN&4z8U}ex)#n+#yt!%-vC%s8doo(q>^kjb zt0$ZGWQMz6t-hGlrtwXQFp$VeExgSK588*XrnY<8g1$)bUQmG9VVOBvW4QY+FC1kawa3t&BVh`>-zO%;{>g2r-cThT~;br4^ME39TW?)$?T}LjPW$wa#)?z=bfPtBLsa zvxnOwYT`1E@s8}R+xAOhv!}9dtJYW@Z3$kZyrc9(Ur-LcYl0#yzvncztL1_zxCi(IhFm9+mtY;j35eu$aR2x^f80cld9_c%dZ3Xy>>QIi*&q`KDAn)Lc-g`fv#8a~S1)u6Dg$~VhijPWB`(Jy5;MrdI#twSw z;&}JU&kekh_5!@;OSPZ~bbW^(&#Vx#MYgJxSHVp+aO}L# zLN{+dR3VS_#ZfeF-Mr}CBU#d{zA3lN@-BdBSSff5$8AuiWi$smesGeS8C5Q!gUl2h zHTmX-h{=^zBeiJV0a(_~S@-_(fyc)$oUC29-QMRbnEZlLKkqg%)yisXxKFW)aaUZL zWj7WpUka_08(DpHzj>&ENZxHi;Bn^%?I*#_wBNtheX{R$Tt@OL^pNIt>uh|@Jor_q zmE@i}U6i}i{X}rVdM&)_+1+&$!X*DxC9iAK)l0KEchmd{6sJHQ-{tpk>V=EOyb!7K zElWk-{p;v^FQi41fXpe_Yg(pJF^>O`EwQ~^=7rG^0{U_avd2?IFemL#!#^qP*pkQ- z&O+HTI&xbz)!P)+Ir-74V*I21$!zOCuEfa~wOZz4D`#uxW<__?DBSA0h>?qeBR9$@ zhXP9()u{`=rvlo|YEgCxyA|ZZ5M-Vg-#=&*{Co9t>V+TifCMzA8BSu z?);GTwCR>UTRSp!>Edym?x|#7s$pxnt(o=jBX8I$zU3$FUi_^2xV_C1!`+oW9<6Re zS*q*Zy7pkR@dK+V*>3au_pl7+n|qIXi#(0zEfiYjI1?$vFJ`dFJ&?kIf^qvdaY;D z)2NqfW}8F$Pp-DJnq?9yD1V5^2n!j%5Hl*t=ZJJ)-q7mHOByQc<<0j+jrs`L$@LHM zZ(EIdEp}NkFDYK#?bHb3Dti8$ddbv+viw}tmpr#xn&X4%J*INuy5rCIo3ZvbMhsVu zpUIDvU#LW7lqoKbTa@kj#r#6+`b(^>!Ni!HeV!(363~)WP*S$7-;Tyus@%wRQZ>B~ zPv>rWf5_cF6!ljkdt&Fdhx+*~j4l+J4DWMc0=pV<8avYK=#Cf(x-_c615Eo=(YPef zDMwAs#6uq(W2Woj8-f4HeL7rD|HndzTYFvHRf2D^SR@tuQCG{NN`dK`HHy&k)oR#g z-`jtJo?3at%CvZQ-IiSYRnq6My)nGXcP4H!JiJsWri#)te+bV)u49uh;#b1u0Lmh_> zGaU(5GAZ=6p3L{{3|1}9_^3c&3G7ppB{oaMP$4^n-H@l5 zM>d+u-2wLL2Nwc8E5Ng80p@#T@Yv&Oz9=n}~5JbZft$$$5x5 z$(%R{YiKp!TM7#7@k1oK=G_~k*Htn&@&^1fbv^ zkwr=h11@hDZ63GF_5^n{JFJan<9{v*}C@ALYu-fB5= zA|YzF8`kR#3IIunN>_8QOE}T(-FkiIA!_|vGUiQXxDD#(#QJ(r&5#H00u}Q%>_ft6 z_Sn&CU1ztQFB!wv-MrR@JOsAw{8sNL`Y@r=s3wl49*e{2z|)(;Dx|ja>aL7tlbX?x z<=+T)rOGRo6Ko<0lHc$t>Ls%HD%8;o9-je12WqOcp8lki_fQ8+w3nuzPb>^9e(n=| zxzsz=BMnz5hGStEbILO3jM?s;C^x&&BX7b3rmNcHMU2^%4y!tk`K(ZRe0$bxw@}|K zu%fx9+~hgrm_}7Z=?Ygh261dA0C^6n{s<>*R+ap zzgP(p+@5z|ydUVXEbrY{MQm~$IXxbaY$dMbxK?QdZ*EWJ7=44N)FdCRJ}7a zw&GJmIHrJlf@6G$TKR(LX(!GogN>KI-m!CA&kYO|8w9J;=DsZ1}fxF`)6J&vY{)TW{aF&$1n43wzn zDCm*3 z0WKk9U^?Q;zq*gH#g{ilZV;@zXm zha8ZPx4sP0JS9mjT2SN^otT2>j+70=QO^C(AC9&rNF`2Uh6Nr8f=cH%Q^`c7RW!5w zGK6KwC%@X?x9x|R?|rUu5$7*j+@f+vj%*LWn#I-`Yj<6PPp-aGezo}6WFPrSkQkXp zQ}eEZ{~Vo1o!Jn78||9 z&0oLvJe1$B?8{m*d^pKqBzs5n^<~;mFI)gO0*gNMdkUkuDDB~3cs9~Xgsh$dm4Ya@ zHbI6YRjhAXg~_GsW4X*9TCh!Xvs zjH7-U4BNKFscJQrKvq9kh3z(r`TKNz%~19C`;9^`Za;MSIB*oNnP!LU_4n*{CdwAH z8;Y^{8Qb@YqD!|>5IJ(Ej(E0f10I7XPC4mCADhJmiC)w=cJR{hBWY5tP^D&}i|hw} zYZGvc-7;+N9K2$upp)sOxPJmY}1pgFx{r_$>NGQ zQ51fyczcWrLS2__!u*sd@5sywq%~(&`clH!iynVi(M;p~Wz3fBPZWm=1M=LQ0mEvgB+;`=n#^w(TM5 zN$^Fc19f*tSuIn$Sn|?mvp)}>RY9D?V333UfFyTm2M8+w*?xO8q}|`FT66o`6hTDO z?;EsT-k29QospZnP z?6;-qcJY1*My8!mrUOP>k9zgn!n;m#_wM_RHwW(Xao??8;{f>JxxaSg>O-jB-WyzqfP|PxX{ovI!RePv ziEuUrlKbPl#HcE9b81<-z}n4}{$h<80CyK}Z2~&a9~`glD7NnxZ7l-r^)p*{9_(gk zv+C9Q6GuE~e~R#g_&DYs{G!k*(AtEJjg9uPKIr{6F#;fZ{j8cZVVJ4TX9m~e-FQ^& zPIJ!sI`LHlq=9H_aA#!D(~XOoUS3bm6#^_F-r3V%50lwyf8KpV$!gLl4ZIHr7b^b{ z9lMAH&CKs9T@l9)NOGYdQ2BueEyoaa$Jb{F@ELq?BS`FYSgFas#UJU{2Vw3fpQFrH z2gU*{#Fw`PmG(s~yA8$4Gu<+H;EAXwfvd6=-kq|-3`dYxxQ!=R?jtp|p;%GhQ zAV1iz>@Dqpe90-hVuhPwxW4paQ%2~!+2P+~X7dZ7OsSM7xQeVh3;|$E{&>BA@pGh2 zvLlj?8SnXP0xg$rUsn7HGL0coh=UO!50YOBs;Uv~<!Gc4 zYCv#d5c(UL1kIGqmw`pK`c;ukNs}TXB1`~W)p2el8!X_n2qN)zgF1;Hyg!0oAN!_8qP7*3M&VB+2|hwus7Eo^;6J@hiROh z7FWZw6fAoz9FPJtr~eB5pJYCKP1dPL)E2kF9!jT7G1wyUq z5Q*!s+2PlYF%rK5jtsz7Qzp{7b0oDC_qX;?rtv zTQj_@Tu-DrG@bgk@uKCJtx^T?32vt2_eB+OeTKCOI8MysUcK)f1wG{p@JB3%(r?2Z z3pJ#^qaR#0^!oJ^JpdaFW;qD2D__t%{&TwgJ_&$$B>S#6=cD$r0A;SPX3yBk_vSV~ z%W!C_x#*`nctNMc1$8}|Nx`vyN3@083fEjXtyAr-05$+Y zo&RSY0MihEhCxWYntjf&xAbQW?(t^7h6eG=FUlc=XUK~laKOq)ZkW$n z1A9aObPqlTV8!+*0b?{?a2>5fw4Sq!J~HooR=L7G67vgAZdZUw;E&x z_TrD;a~hdkuN7=TpO00QBeX#$0xX4`>~Vwzk9#Mr%v{O_(>pkIZ;f`Lsk| z`sw&*rEdv)XQsjDFRz+e^@}Pjz7k%s|SGu$XoHubqM>G`tqZ=4vxfG zc|loF)f%Kz>^kpM6i0$cGqio~%LWi$HG-UFEv* zLWB37v<9nVf>?e_K%-#)GzTv4`03mL0J|k!gqM3czq*1XNOOle_D2S}Fd`Dg<=S7* z=l{R7s_Fu485sQGFX{D4c@*Sqx*vJp|M#5*Bj*Tybc|v9a&0^_BS{WGBt^_Z`}3f- z?QzyzL5{W|4LPT99f0&#HjR^`Ze8B9|D(P4Gi_*ORW9bH_+LEvitdnud~Pqh_1m)o z-4|Mp>AO}=t!Ftjd3O!KOisxjIegyN>*ZfeUbGCqC(JXMG@6@f-0nH( z!(ukP@y327UTI?nu3csK7>l}O;~e}bnvFa;6W<|r{>Jm6&^duHj+dh~;?&XTm95?| zJ@VOOwlU1Oj!(f)x%PxKi#0_z%Z{I(2sofmq+9{r-^_oCMxL#6|4g14j?WMT)VDu< zhMJ^E{-nj&f$x2cYmi32gw}owj5fL~Qn9$D$AtIloDQ?k8Q~2jSa@z^TL_+4$acj~ z!DR`-g8jYRR}5s-@5$8_;$L2wIsKM0ds}SjAx-z6r(3@Z^zfNSxBg1mC|}42hukg~ z^Y3RS#@Je=FQO6A8hi!wYQGTwooiO%`XWeMl*8^}C2@JPZ|OS-euT*^@3kEAv)kx5 z=<4d??Fe;xw$NC8s?E@|=FN*o``d=kWQW=B$^UQjh-*0_av&yw`2ifPj8dLdhu^=R za^4wyd{@`Q44fzvJx&0`OPeOTNUb<^ZTl z?~aF>+P}#E$k(X8b7>l; zH7hGCeC&JtJ^?^6ah)!t8SdX2SYsh@|I4SnCW8dmU*D08+p|hy$*7a130dGCuEzlH z!l*seG2?x+Bm=G^GGXPWgFN(sn#%x;d7z{xf2|wl{&tehLO9lSs%B%)oV>cPbKFYO zT+a4R?fBJf{ix9u_!#t_=a|n`TwZ16UT_IM%Gf+}&0kB2@oY##Rq|b%fTx+~KdM=G zc_s7n==nCL5H~)wfA-96oO-gLpnImWUqv|D^JKr(weW?F#jVwCoU=OL7odtV^L}Id z0gTaN#L1F(Z!Y|;%|bxp+BmD&61Q;g#;00@gj$B|Nt`ZCS|SqZWJFvXpW}KRl4P7T zCU%WKCKsm*TX!3xB+?78WUWQV%AKMq@^ixGU2V~9%*Aq=1 zIME5rR<*6AJ_HnnY`0g_kCL~ef3oG9L8kVU=rAap zeNu%N^RU#XEIWWmN(v;Y;tY=TCYIa|Yu%G)f+fhHKq-t3klTI-URAB+O zRDU+ttk|KW{NhnEMp#(u%;PNBQOx-m{kXcTT#~oGz6Z{NOE+&6O@MXN1egZfD!@`y z0E$dz)N|^?sY?L$xDecZgKMfP#!t%2EPU2kqQ#i!xdL_4nt17E<d>5Sm564)P9cUmR-&3az?@ zk%~wFj_=6%zuOtsvbX3DEEwerVaGikaZ;6=i+ah(^#1p((MES5UN7&}evtjK1v4-4 z+?zStk1DTF>*Uem-vdy?7FlDnZC{I9V?;Q0c0y3v{MUhR?KL^l*!fdg)Z&4Gp&^jc zhK4h(4u>Op`uZM48=9Moer}C9GvTdhU}OZIp-?;{*K5si#BEj8_sV(y4|`u8PG!6H z-5^mZ6f#s2$&eu-L!}HELK!n^-qBc9xTbzP+>^2VEL%ex_=8;kdo>!g6vryIT>PdHZQgsW;c!apY;K!M znra16O?Eg!3fk4x-I&!S7z}S*Rk|0)&9DidO{{gE<8rFl+P%=6vTC85;btUqd)*AJY1>x3Gg3m z_**c<8M%+myi1lXP^eiFnOm&v{smQ>c-BuZi?|yyZo**BvE>Mi0Ja7=h<_TzeUh;m zvknxZwTmY{#Fp|!emS;X#(Fg*#QE9TSXCw1Dho?R@@J7Oa%+E`TP_ziEk=+xH9Os`s)xNu8w>v;Nc z&Eh+8X;r~j1F|J^R7$7?jQGna!WSE6iTD}>)Jd`@d;po`&Q=eT;}Fn ziab5oq5|Oy7ZvyL2_jsA02a_mR)Qnck3Qf&majL`VcKOE!_mjWeAr-VHcESb(&6IZ z6YJ{IB8=tAj8iH`FJSNC9HxW>)Fm>R`2g&xFv~U+Y|7E&rE-V6F#fl^_L<-**#JVh zYZbX=B@a1`tBQdd!*x7>tK=N!xU{BSqj)d2J`*j`%x{>d67;7nUJGIsxCR=dr7H;d zbn(;E@{8w`hh^N<4@veAA2(CNYrKI}ENn&!*bb{73)lu^H55$$mDSiBx{Hgn712A9 ziYDpL70vnk>$@;w8_w>#j}BLP;p;lvxivNA@tExvk24a^34kp`cWRzpD;TIh-$DYk zxc@&3(Er7^JqcptSaW_Ab|7le9Y0!6e)w$SsSv8f_x3fzn%x0&@!13{#A<-<&)oU| zS$eCLQ}%;Zms7%_J6DurKVPb`TFH|^F2yJH zmbn&>YHr_2%Jd>O0eC;larasb_LR3=oICc^ojCRFF%9HN>Mdh0aBa6j)G2TVDvL)p z!?I2XoILF|{3y{}#;wiB2|J#%%BNo-5QG=8Y+^wbTbv)dO0#D6Hz<(ep!LV%VAQVr z$#q>HNFz7x&bB~F2!Rf`5t5w^f%b;0T_wtkqhiag#XzcOFS>m2X0!?yhUR@uj3Ys>vcU| ztl2B@iqLGgvL%}kq2yZQKwJx{9HctWJMv>C@wnOCeZq=sD2uSm=w$@pkmsgzqgWMX zxo5T4%Ox_dgbpS*4dozpV;Z-=FDW^E1GIoTe_pH0A?8-2+DSE$TA{{QV|LvEVuj-e zP!gTB`r84!p?t;lIEnChOnx@DoOV~J*lR-$rr7N<0OQ?XLbRA*r>~cZ%h>Su%P5KF z^im7l0$&(tCFf>-EH!5_9nNKArp7xT;*za{!}KvhOLvF4G}E>(2KD65iH{gv`IwJz zI=bFPmZ|}cINxnCkD1)4oqN1b%xd3>JFfMS|aThNq%$*a7uMFr&Xe1viME0YqSkV=({G zG0YUAULQX!%YuvA;CDd?7qwe48n;s>Mc!kTyQ22!)AA!M?K(F)`s2}#H^YPF7LL^r znmLl9>Lbk}&9iG{*Iuy;zBeUY*Xno(m6gDIM=s{~k1Q-^3sJR?-_FtCqO8sMHXGp! z$wqcHwP953*_U1$Qu@@hjAhdLpYv>9ip(WUjCVi#c+c3zEqYwr3(YWJbRQ%cu$Z7I z0R5x20bKVA)s`2w5~;Sp0(;xkUK-=MD!hbE@!qlTtt3u`_yFd+!SAdPa;T%KEWyEA zhqW^?tRdHjk@~C0tRqhrF2jY=AT$1r_n&=dP#YcQ%_>VrZX%u^EA$J#4fLjDi8oMwihn#y< zs1w-emeST8X!BdGzoKC|r2`;Agn3>yY0dsuY%73F7CO(ao?o-6=l`Q^^hI|*9~bA_ zM>J57Z~-9W@Dm_&gOAx>Rf)zEowV*i2heEuf|3Yi=egBl%eM#|X&lSkcE*7oG4c!@ zEo=Q#iPLwAMwW*^mhR2qHA&{g1pS@EGKp1@gK1 zw|32tbb}l_Y{Q5t?s!2;qOfGAZSkRBu^ea#!$jJL@sJE#wNbpE=8&z& z&6tZoS(WJtxAflDFN@FO<)QceawN2ZoeQtR8qUuZBr*Y&mg^&Bqo8;+XMp?xk93p5 z#zf?mvLNJg(;{B5_9(D0h>PjQsmI92jRKtHEyD)0Fw{IaVlXv0yENgKq^2WD4r&*? zO5XGzD~Ue#NIFRBN)$x?oI-ITI7m}lgwOl6rH8g5B$sLXF$n(%bgn}cv#d|tQG-)T z8mv08G`^`_LuFRfPGumzsk=c+*$wHy)(1Mf9&83FO0R7IlCZ%K(DndTgn2MFYjl0YE$ zEP}lPV-<&M02X`XY0LU;m&I@f2@87DPsN_LBrmAfy$Z0eynOkx8G_u=`|5-ZuSgyd zVmI88ec|lEs0E#%26)lE06Laf9uShA&M`N?HvD)P&=fxzHn(qI`!yfIQGhSdyoI`s zWAnJVmd>vuqeaZ+GMqak=k3BEIWNF@K}URmxUHa1Zxw(1P=moXD3mRw-W@1%uiU5Q z2onZ{6_BUjKD8z^yh%~lw(r7VG}!U44HY7kuK{cmKp{%xpPA^CSiW;O#9ch`(=P6AxCdvuw_&Sz z)3+o-7@xtC%69xcD(1MB`4e0QSSWb}TdLZi}JnR9INpJ%rW1qsd29wnAQe zl$d)O{qj_D02zz%IhM`x+wlqE7k$v9w>mX}{Nm9kuN=!}&SMI}mEn9RHfBztGNl|oDZ(cROZus?mZP>6GhCe@Dkt>nXfpsXN+?MKE~Mcado8Go(d*=V?3jjoiN#ogGU2eU}+q1 zkVRxiqD~6$&LNdqN0DUtaK(>Kgs4nt8l0F`#zt%ztvHto2rw}DJC@Se4z%81^)a%S zr$wX*Z6Uj#lOoD0)IN3>tcC5*iyY1RZ1ezIxiOiM>jkn0=5L?B+6XIl`_;>lI!H%3 zFSG^4l_QC2iy@Nlzd(5K2wG`Uk6gt*u=__1JXJL2frjfYeb)lGBgv(?J0vM#zp3t{$^)KRjI0ZNt>dKc$TdKKi04wYpiwg4GxdQ=VAgO zAD`obe=%pGxgF)WCqSz5Pr^}V>CmMz2%)0lmF#+o`n>M4Ts`sS81n^YAaPb_70PzL z289e|M{fL>EmGplYD4B*P27XTm((O*_t_Hwl96e}t1{hBAYnb*%?dd*2a!Bpx(V{* z>n304HAT1Cea)FE;&Bd6-*~|ti~^CMJSoq(Qb;A|)=O*0ybsxunIv*kdeRFX{M!TU zVfVl30E331Xld+kj#~TfA<|JR`!9}KG_LJU%~@15i!t8$j__fwrAR0_7*;}|Y!gIm zJcF0pP}N4C8G7COAJM2+RV$RP;h>LRre#wm$fgR&S&bW+-b?b{NHvIy}&!agZS zG!A2#6mp*IMAJ0z-%qNB2e$r^b3r!Hp!)DD$pI?~W!L}q>Hq!2*8%4FpGBgO`oTr~ zzDSRpdM5796SNJkX5(Y%q{$&Qgd0YWGWmD4zxAd9iuNE_$9qAwApBYO`;tKKOE~faf=7Pzk z{VQL$mrRFIW`=%Jq)OQrv8s2)YB<0LTe)6k0$f9(kbM(1qV#GSjD`Rw6!hXAdbFYg z4Y5+s#O7U#Vg5_~s;6MajAS6J1KeyY)jTP2y}k2uBQEWW$%sR#XY(SPmRns*b2M|u z_|k{T!)g6m>HN>~czKqF8${{n3o-R2q1IuIjH2;RzCH9X-(DS6Nn3A3VeXEE;t;B( z^jB;|XDs%1d0FCr@CSNvX{!UbZ@TYYVeg@k&b`!=u&GnBT(J9M zo=NMIJL86Zar1;%TIX%foEItJ7~zh_R>F@A5d9>%sJK`>T;DSqeLdsFXD3O3$0}<6 zc^c7k_pdbKMiv2Mdtvrt1Anv2wKoGZt*GL~{2W{ElEKi!Egz%sj#^2m!miGo44&Q7 zFN<76Gr!Y9=hTkq$rkRB?H&kwnC4VZu3fP04smH1-;TjRq2dsu-9m5nd7+b<>v?Hc zgx@8KZCPn2GiRYk+^do|g~VDAxqX9mpcI`y%Kc97Vp*AX1e(D>$l*$JW#_VkQL|lf z6#nUz&t6taIJv_-OLb4(x5&NXdbThXSJlSPUoc5rTC^^!IeQ3L)@jK zg9nz7%A-!x35|Y6B!-CGkB-iVHDc&sUvnuaK9M>_zT~SU(;QN3VJ7>~#QF;P2kdAM zfKm-D8cry{*x(|#pp}||SW8LYGSbcxx74>9-vOMEr8zwaU#gYufD<}+=$!yCBSi#! z{$?I(VxI&eX4-nY0#)oIYq}JD(*8M~8Ka?X)1NgKIOyR4%$A@oi6r959A)@wQvLZ( zY_mu3!Ih3tE9=d<-5KGq&KpuG;4_k z7~?kFo+C(KH2nH&cIt=d&avgxlg_Bm&f3QpoRx>HiuG0>Ej{o4F2s2AIk)$@$JUtS zexN_kPc($x=xGX1Av>6oEMJmxjLClsQr`ioHvNIy&|>F9_Af5U$;s5U!%ABkuqH@x zNqIKt#uB!uNS9dVsTxl7mEyy@v8qAvp#6Mba-)zndwO#2#J<#e*-8u)!w+#OSp*cw z_e}5#Kq6FvoUIZ!qeJ~@EebqWVg)#75$AUQP{Crhrf{TT5pIBA)lK)Cy}^(#4-iSW znsMsSTt4;Wqwy9xT2S`FXfE7&5hqt|$W=dgW2!T^0GY&5SG{d+vkCq~&Jo|2IH4cU z-*65=jqUk%63V%cg3KJRnfVwq7rKLQscco~6L+|3QNibqPNjEw)`=HeKlf(;gEwN@ zi?iO==(K9<|40IxJR5=|wT*{K&ob%Ht(^_l4!QPTTPdlSw;k=u{)(Q~y;|zrz#5CEdQ1+)+3H#swDjpS}CCQ&oxY}vh zQ|=gZ+pW-i`t4lt(Dl0+(=++|N?jM9l&$csjQ6VYb*qi1yG?W#?7h84cZ_8!8BIKI zF?1|>dxn?~JP!4^NIEjj#M=3fy4c>D;ZigM{^%?Hd?aV)g+SUU>tq_^z_^&_oQ@{6N(J| zc>@{GpI@gZ;D*d?doMawu1spa;qbSOa#gRapj1j@Nz4-4|KT7?!Ya;xCbrz)+iUOB z^0;H@AP*!TVlnd|={s+IgYQRmTu_cY#2j&i1{I5<240t&SSAsk?Xr4x86S16o(rZ* z?0nQ9(+-0YKwp^9)*%<{?pQ9A=$Kjj&A_;w*EP#kN8^uJ{kH})=v!1cWpB4K{490sw~3J zx_mW%_1#l{z5H~;V_#DH+-u4gTqQ5gFFo7Dpt4%9I`e6$c%)b7_2}&#YPP}ta!>ga z&~Qy$-|&jo`9P<|OdPJ`Yl@jga;l{g!Ek)Dq)cCDVnX@=Cj>JL zEr9|U#MM~@L|hGADu?;5@N~QS`g%XP%>sue(Gm@*`rnqRN}CB<`B4&AW=m`@ALc0= z4rShQ?<~Km-hXlik^tT4Mo0TtKEa{6+ zz1WjI3DSdsxHDQEC()LnoY6Sug%hgyLKnV!NknnSt2PY4LjI#xfD!3e0aWH~AxLUR z84yHVtV>SpR(uBH7P~NrTl7YULn8q+3f)e=eYdLYpY~!=iyG9r?4;Kv8&7~A1+KC}JU(BB{9}sgWx8Efd-cq;Vko*xDxPjDz zyN=h+h}LyP@+jWaRqX?4p;t$B@w$^ z8XO^T4-Jp^-usbo@%K!-C{WU)b>neN{XnC4z%Xm9AU1EKxCv5qb}&G#BPD zoL@lcKLBLO|JCri*-j1t$HB2oiHj3Yi9zbuFIV~<(OLWQeq1oE%-=mpjY(!N$;m?F z;y?FuU6_eST;MIafR}tyewvlg_5_+P-s=)yhmC_?ft01F5k2+46Q~q4b>5T6dN05^ z+H@m+Bs#x0Dmd)(gy9&Eu94xQfWzIq#6#A4f@;aSSvEr$$(K0QOae)>wpgJj?%xc& z8lkd3ElR>qY$6d}B|88AEXqGx0{;JA6xLZ>FCS8gUe*ai3M93Q7j1O3jxy0f+2jLW zz5xr=$qj@H1CFEt3xR0UwJ$+z`k9_U-@yNwmgZ`FKtQ2Yi&Sd)K)UH$#gZsK_eQ<> z_=3LYx)naIXGa(~WDNWZmq@9y&Pfo(mVPyO$jBPGe29 zzyY@0P&A}ScJ9aK6k_T!(feOmb0;mgR0a((4Lgkl(tj(BHt^aarb0)2i0%f&#r<2> zd^mQ)dnV!+vC910F3#iUW%>79-2dA}nQ~fAjI#h7_^MH*N&d;}je2*{;rChad{OrpzK&%wXsC;|^zYj807J|sn(}s* zl30=$qKfJ#cKKgyS)D1|Z7NQRr%0Xq?;W;ZU*+HHZvD@z{Gq4#KO6L?PV4`y%70en zhpv339!yQ1^|zCq{bNg`Ma*o0wYS!9JeoA8)5@fr^fz9=Q(o~HNmx#%gv9G!*&pPS zf5Be*tvKIYG_zoD7D4SzHbD)P7(!6!YT{5f5M#=bEklP- zKfl|DFFW$9m{nN+(CWmedHqFg?r{KF>z1KC{~ExoyKLo=$qADe=?>T6(q?Z$_aK&+ zhsoasfeiBU^1{s9-@GA;b9m`{)2xB1)$p%v=H0zD?YKaYHttY~d!p z(9W`T(+r{@;^w)Uw^8`J7J!G?o=B7)#W#;38lO*H*$2KXXdxmWA|uiPs;yF_lkdF? z3Ywjdd?;xS%AF&Mlze=A;+6PLg~7KR_7|`_-(!QQZelw6k*uyzz47lyzhf1cnRszZCw~70aRXMg-%GZktsAX zs-Z3R-9_7PctUfZZPREDp>=YXZIJS>YAk>`ZG$xF_T-X8VjK1kxTEv0zlhT|yy@H# z{FFSV6WV3Vq8$t>12{W43=nYUnp^+#maRM*1jS>&_dtNW#HlCagKNlTg>KBr3t3%+ z=8H4*#`uJOir>2zh>8`iwC&=g+VvFmXVCN6X-*yHH|$TV1SE5M?8zM(JH_#n&3w9& zE7NzZ4d3cNy#$bZ$I>hel1=UpJFGWf%Fk@uI<-p(`Jc&!ez)dGdr1y`0|T^92gt^b zN688}OYWWQEq09DzNgm(d8=bqcmtN(`gG3qP-A?y)GBvvjPof=LWEsSoUcY8c z-}|>z)Aw=2>&Q;aupWZ($6pexx2{glCe5j~Xu5rtD!=G>IQd*2PhhInMl1|tz)CWk zKSf$&mIa{D0N85vh&;!8ppXt->#xK$M8(>X&vrgiy2tUb_TC^k&1&>gU~ zG~JYo8R;-#CCV!9i}o5H1D=E>AEaCe0(b_|z|cKdEqZQF%|iU4H!Md<26bmY^f-$c1-HFPPEE|YvGmdVvKM4bSLa}IpcXqhFU5TTT zub%wWLuGZ)M47YUX^Hb*=7j^Isle^Y-T#Vo@4OOcS!wh+6uu7WCDqHffu0h$&f0NJ zUp13@X+QrOwpW2j1^>kHtjF`cqxabhh4j$NpBkM;P6M07;Bq54{rq6{S~Kz`Z(`BL z@?({-2L5V)9}LtowvOBwPkFlLPtWSY9L}D2A3-bti7(U<1YJ3QwfuHLOP(Keq_AW$ zQU-UidhQJVMMhO<^b*(Lu@@Kh@J%2Eu^5e5;}tglsN7pqd3wCTNlYxhb6cv_$Uk}V zx|!lyS#&VfNLXWr-HsAwa(F~HU6|GO47$2)$=WX?H+L8E!GF!%y(Q&E#3RLi#3Moe zu2g@BFCJ&W?g{%ar&x(og7&1%D{~a6BZrqFw_ZdQ>yH`ZJ(Bg`uNCjC7Z6xgY5R|` z>YDs>>r?c?@=WssZQCeuhmWlZzC~`!In5{1ytyxUv`N%WHKBYzDgT(@CAQD6D-$q!Qk*1+)sfgViDr8k4Rs$#<-HoZk+WMht-cs!Rz ztyqA*M+S!=3@Pt6&?tnlRJCCWU%&Xr$a2I-AgM>)sUK1gK-<6f$=?Z;{^z^%k3q1k z)NKFk)7O-*EJWoiE^3#8=H6LtS-JQldCpWm`(#nP&OfR+*@KU-6Z67 zUbeQ*X$s<8FM;`##hX@A^44>v^0)I~e)_+09&`j@wwQ3x3rw#=Cje!qtABZ16XtMB zK_E6(kfz17p8Wh{5uhkgPilo>9kaImX&o)9x?rx9khp`s%NJQ2x4ymhr`TyB#MAux zWR<+fwLeWfI)N&#mXU!bI+iQsJf7P*5B?&(%`y4ZlQ%BLX`cc2ir`}!U+{zMz5+pD z)<&ZuXddD~ed2y5$^T-5F8y)Oc;t}Y&sQ6MKhCJ%k29F`>)%*=TP@gn9hyg* zAiW?BBmI7uyZ$?eIejWMG!M`PSem>A z^)3D~5($?PVa*#piSI;rVYrXL92B!VAG!JY^Lee|miJRpxA4y2WrjLe9SA*nrp37M zsGF(ym{TPR9W;D61Fw2n5;%MZdI&}f5|bz6QOTTxb++~7s#%E~keRy=xq@7*M5P^c^ZeOPiOfUZN42E_rxmN zn0!_*!%&&iZaG2t66cw4AN0Fwf4KI@u>7Xas*Ih3g993k?$DWLHzJO&3Jnkcdga8= zi;r|7eLy;qf+xAB&2jpi3K`F>t*z~p-*+y)zrKx!hi4^1pwk&#<>3Yxai^W(z072b zP#kmCIQ`MJrWFv46&|EzavOh^4?R?xX<8}M97J86rc_y8&AX`!yd%vz5Qk4_M0a5> zN>}4%LIfb>!3E z5CLLOUES~D3emL6OTf#3pSTtalk-k&Wouh&5p_bkv>ME-o}3KBoE}>$ zL)TSCMoX~~uo+wNM(u*(LY*w2k_Pb=q!w~XLe!AH#QPv}w-&3KUqXP2rPX=GUqcE8 z_7kIFkB20qH|N#1x8tmdWe+7R`%2ne>v!a#a`hjz)Esp7}Pu?^`nO z#KQ{np%d;%#7NM`aOrx0fFgz7ST=Di_&Z?ToRLt6IGNQ+COCQ zEp~V|d!~L98+B809k>71{7qD|-C*fekG2W>TS`xk%yr!=dzD;OUmCjd1*N|;DJ2P^hZ8vDTj)yxKd|uy&avM$UwmFqS((u2c3X;d-k|P7Em@`#8hQJk5$zUoje#v>iG9$PfUpf+cas34NZ@wl(pMi7M+M zn(DHBE=ZdjXj2NJVUG@V`(+)#%MJv%-a>IkCU@+^Muo}0zj_YW!16i?G~AcI9d94p zYgR1(nC1-q9ka%%s+3;2vPaIdFs7&Ge){#;NXJhf57gN4h11!@3=ob_UisXPNlo1~ z=~Rh-H|$PTlLy1UJ<$NPbefja(bK1Hg$XWBDMon_fedip5ESRCb99@iI^STO%ESLsckjR z`xqSlb#5EFw`9lhkhjk)Cuw->cupEFCOf{x^+bNYEb2CaJ=Hg8-PC^K2xr$Pzqe+3 zeP~PCkm1WO4I9Q@9c5pQh&4;P&-{*m5~}iDuSooyB?WTg{C+!e---znHu(7+mXN!&5*6Z?Gnhhr&wWs0lE@XCozzADvZJ#^AIR7eLMVowMu;yJ9r*C}i zjwx*!IiILS9^^}ir#$M)9ZHfbV_9z|;hv{uN@FE`z<2kjK#`a0F5guWO{AI%Cp3cHxU9PDPuU@mWaC#}i&>)CMA9@>?B7s}F}CKJ;O6Iq@t=PT%Qr0 z=xJ5ThK+K-jOfz3HD1MD@LjZ~dHlhG_>*#1J&uroueU@~cK&T)%Tb-*CgN!p`k4vk z*YSD7`*qyCcP~7lZ;7p}Fr(X#uVdqymR_a{3^d_fRjj-;@X~*Zp_`8_;0hwn0$tpd z2rz<5-L!14+}J?bZS(TXChLTsCxEM3Y``oBp=W3`74tkyp{ zG<#~9E-p}GpnB04HHvy4=eYKox9%Zs&*3+>2hS>ATHxL-c&NuswGSU%OxSiX?%?~E zUtSv-VSNG!W`VoD>|gb%mCxSkmSA-B$`JBghS77fj-+#C3M)=-{j8d;^`0EPVAlb( z*ZMaU;WlTPhxqZbUxjuJ&V5nv@uFnF7_rSUr!+;yRMrLh34qv zKvU-go;%&cx;`#;D{^!~2wLeE1f@!PVG{P<2T9tQ7vs29C8uO`baYOgx;-c>|Kzmj z3cIYv`ezEm$E42Se1*-x2~+NLGxg~lohcMtWy1?o9^6ebNflZ+8hJ(s&;lNHmpNL= z)84$S;S=s=cp4j)F=s?^V*Y*ehYMd6#18j5*O>75l&5$~`4= z{@F=bj9N@j+M!8^6nmA-B)oa&3~1cu3gxl1ZXCCF6FX^-Ec$WuBZRssQ z)?F+zvW3)xD+Q57rJ!{SKP#FdX}@bs?kRCKe`(?;Mfe_?qV858--HpoKzrpj<##ZufnY`7v4@Fq-x83=jg4cZ&gv)o!6EBgc`yWs+-(aeQ|)2hlTsba+(vFD(I^|@98y2|81Fr7@xL9n|L7nd{zyrMC?pjXsJXh(VzAZh!-pU;nr|U*s z-(2nUeS+91$uL;oz=Seb-xCZ9T0@!a0jEWY>)SM9@#CTSn`}r17A3g&|H_ep^{rLw zhxLu|W#^gFrj?InCa$lgosbL33@=d}JA~KVtFyY?m4#krj=A~l4OM2fqdgw${6XE4 zPq&mOiTzTWpM?D({X+_eSf?U7r<7#ovx&>so%5t+AJ*W&R{Zt1XiH{eq3vGf zjq9-5XP5J8GQV^Xzde@Moz&(a#YTNa1-DiIg2eN$i}BjwBB%z(_ZlEx4!N;Zf9w5; z1Eai#D;7%wHeAx-mfDN~mv2_FKP9(v-{y0AUp&?6qd{AUTdz>GC=OO-|Kx)3e!LFk zcYCHfdAXG4yvoC}WLs(x<7#4^e6j{9vr@ZlXsW{qdydY1n5&OvY82btR4(*9Qhf59 z6+s!&t(un;y$2_`Y5T7-RJGR0X||Fxe~z$K?0GGD;JPsU9{YV%_@hUKkSf9yZbf?< zZtlz9hR&Tk$C?^&2?JKCO@^Fh12}*NyjZ`NhC1xBH;InoXd$KN_ux!<>>!@YWAbFo zksFPLQt!X;e9^0M-e+(nUi^}lkE4pphZEN2i#H`%54a!>K8`ir)bQ&E3Fte5r- z&U*eDE1r?nXZhZPg}}dyE`8ZPt0c#FkBlXluq>vu*~PO-U($7U;I`_68-v4|U-{cF z+pPv?QhmPP=ae@%FaFKDlicZyO~KnM>8T9-7bUy1%q=Y$s?F0blo0OQ@RbshWmAx&__aQdq0Z5ANIeVv)uxv{~6V+vSLBtQMvIlbG^_iH39kvo7%E^?V6A8m-ybNcV$DI{rR{(Yg<-}DY{_B7)T6)$Sa(} zZGE8iiBz?0qkuj8;@dR(xJ>t=8$*;@NMK)EByLJ^E^w1;Nprbj*A>U8laAf2lds#I z{hM2D`pZ^A?-AOy4G%wPpr?4VofTO-_Ql%h{>ktG9zMQ1qCA?~+BFHHlu?T-dE(b# zcq5tN)vK|omszR3l(cEZ3#Ue2z<6}HfvED+ClsZpFDha$4O}7f-GR-7t7|n{0k)0|cX4kiw-EWyVrpFbEqw_qcl~H4+juG_*47=p4@KU}PvV#*FzGe#>gwx*Zkj(6d(X+0 zezgrv{H-|fh%^@J+AsSP&%W1%)9svZ5RBTmk;FzRY*4Agv={0z@ZR9(oK@es%HQu& zFR>gobK7TQ&h^BzOIfS=rW>8pJY8b+Bia`I(&@wAwuja-Te*Ar?SePiP&aae}=BO2K({t5I?|~5A zBtEk=H=ddbV`)BwaKwA(?(Yb%LW)y^PZpaXX5wlww8kHcPUG5sj^9l!Z~U4_<(@9G z0I44r_Bgp}#56^zx!6xmUrFjaU??%LwX8ygORVUI{p9u7S=5cZkkLIS)YbwJRxdjWF z`J6-=`L@PufJ47?{{7wDQ!;X4y~Kh%J+1%E4y=Lt!LY-%n6Q>dDEVb!%6eVlp-f?$ z5k1JRm})VRBIs!+NxRV|VO1%Oo!u&&hhMB+c0>L8z(5u%Ni=>8^`|rTFML@bAx=p) znbi5|B?#q|g|>bkojmhdW2~-sZY8%^4uN=59+eigbV}oVqaS6#CQ3M803zA=bg9t<@n^&SY_>PkYbQ?|%+v#u&`NSVC1nAR*C-A+vXtLqphNav-62FXf~{+gBELRrp#lr!AX z&F5nAoW2%=L_9A@uRaz7)?pWD>40Q>zI@?vBBU0NYRJ{j9&Y?~c?y(pdPVjhN{0xY z<*R^FTJ@Ke7SxwoHa!-+E{29>%kj@@Sr1{`x9by)o9TquWd<==Z9uDEK8E`^=lb;sQB@*cNZjQF|u2(NOrtCyo_-1211 z_7(H3MoT!_bY&U4Z_Lrh+M?V%E`J{Au;{ z!$p!)Kh{IhthiKFx+iXBAqI`#kFPpZ5V3N%E7=oexiLB=@uea09Ifgi;L`ZeBs9?< zpU2VhXg!Q||HDtf@5GrE0t{qse~`I|4}B#CWy#q#xWD_tOYPu&)DrDr=C6g?=)0S? zaWptU8UuDWRL@Tl)2jw#ugm?M$g^x~bs~@ETFJCiQrmDxB+$%2G!*Jq;=|W$5w8+Np z35zCfv9(IViw1dc+RxSk59SLctX4%%2bVpN`#RY_S>)?!X1Z(e)y>nWH*loZH*2U5 zWg?&(joUNCE*y}0S8j?TpOgeO5D#m~ughJafqTcv711Q$P^qB!BJo|I%_&?k0E7XH zY3tb*0v36~E!Ax^d;tegi`$_>%5G?(C>J&``EWs=+5SnbP@qVyY06}s0|F_odW4uk zF|NRB-3t!q*PMQQ2y*(Dyj!(NFU9r8YKOQ*3lBE#{o0b;(z5#1+4HNDyq2P*^+%bn z3SO0hSc7d(5k=gi z{XT2Pk_aXYtbqw?aS2q7(VMNLbG$xj9OC1{q@Zf}>qJT?n&b+8T?c{HDaYyeb>BGp zCJNr&hrwpc^ZDg;nhJ`Fr*Xj&o1d4`F)(a4FLt{bKl<(Q+_l_qtHuNB%j_OG=O6SD z?QGy4`z;hhnLf=#un0v9wWOqNUUWNb$p6)9DME(CE++hje=VHZp}NLvKxg@ zN;*(i9K8kkwkC)+OJi3HP^qcpfz=73#ZhD%)&n4U`VI;3)e*aC0naYP*QLR#})FFgV%XF7v5VA!zwZ3kDKph?4HjIw$FU#`ya^pkMv@S zKG2iy$GNo!N@Qh*!{YR<A1Vr#KJm2L3Cp*Yi>+2H#fF>h82B@J}_!aEe138$O_KIy`Vbr zTFk*yIvH}yd45f2rH3*Z6)_(RCOBiEOLcy-zx+&AW6a6^cT;}*PF_5B(ORTH=g4FB zlL~|KLuZnRramAC>ollDF$lN_wZGqnR&vH&{x=Hv&;^w@6*|Uxj-9`U;tUl3ac>Zs z!Dkte4VZ)Gqhi^XsJ!=q<;2^h?U2tQ=l!MO8YZas^YZb9Aw`*n=G@m6;@<*o0Y!j@hWux6r9ii&riO)t zyhN(CLq4<=WbDU|44!td4-R+PdVD`I!;``VBTIvgLNZ0D!j$^ZqnDiG?beof=laeD zOz72asCbDlqrwT!bHjSEGLuP;WS@>VZ(f%1h#e;zg&RUbSsb$$hBCfTziKr&x^MYr zd1@+O#16$?`mfH~c=w#Cb0K_+xd(``Y)iKa0+wN;5ag~F!*-+=(^P$igyt~NTq#9y z>QdF_1&h=Ur%cK9JXz1Sf)H&x>J*Wh0-WP%W4F!SO(&#Hcf2$-Jt3mxT`sa-1pn55 zD%{h|Af#4MV=XsggxpBDcqsLm)Q_28_&FOzIS98@G!Z4=CXzF-uD$?kgwaM z_XZG7LzO1I>`&A6L~o54E4%Ac-WZJ%0C2E(8zbxJ8sN#tb_><{i764c;l~qba5{mC zS=46MNpfbSai{;@ZWX9Xpi-w-h-vox{b*Ctxyib3>kcI7hdlrO+RpIW9v$3r67f`W z_NeeckuJF|Kli(e0D(pn>SpuHfg=Po^;fti!oM83_SeE9G1>Vsn6{`Yc`dPb{njmC zBCSI66Z$V4De};P{pnt8)HWa74OV>jbB6BS-F!iw%Lm|I=S1VZ-sQ#uCfKypkDzb5 z_A;{O-G{!?;sVK0DDDLrA4RL1NiZZ_*|yeyXR{all1oF_L6O#b2j$I} z{r`pex?_7YdvGfXF=rqjZ$5q;n-NcW+j7-cSAko%fBmxuNXKY7YVl+pdT+ z(@>EgOruzXMusxI&eq->t`BXvg9f3?4$03I5yIAF!{NR@J{p=UOXHc+eY7`{Qd1Q* z+n1M@$@W=Zazg6vh^Xh!Pg`yzD&0^4+3!C6QbPC-13FK>mr7V0fB+HQI^}fRk(mZg#(i_6}Xm;RmdWVX9En7 zT7%hZF$m0FrGt~OAA5b^f#mcPqw&|VFQOd#oZ%L+t@Zmp^_5=gGHxW_b|J^Yzv5I$BVf8xl5(*P@p`|0-vK=1%+->khw$Bn2ZCba z1-^Kw3a`2I3V%f;9Qxc}3x@#&Vv+2C?VTI%gf!q0cbA%)n&e(pknL<5PH8^*ZMo8Y zb7O0^0WhTNVsot4wvr(drz-CI?lNm z_G6Mek2O9zhO1v;N3u0e!DjuLc$OMpV;1>7RG%K$XgJD4?p|<3pLLsSqvX z`2NEF0aS)zq`vaZOgb-(9^~#PKX*VM%F_a;sUaZQ&rsr4SH51CjLtA9-co-iAt8a# zS1PgL6z>lBz_H7xRUYs7+13Edo6_DQw~>=rtzEsZZohW-F7+jZ-};H_{3Lb!#^PtZ zZTSjZ>Nhenf}~k!fklpPxO?ZBVfpIoSn0SK{~X9;*E!{!I+RHF%VK{2B_J5yq8ZvM z?yg1MTT;1TR@*vs{bl2+{CQ2X&h!{jAzt_*w3fV96UdHH7a;C$SY1JWmlgPO{;+Ry4^BN3l$8$Z-= z2Vv=(N2UJ>l~!0t-$yE$MWFKWrq`vxwBAF26?x_e4i{*Yx~hzW*A@vSOq74Ssayqv zV@F3vJKwxHidVXW6s204blrTI@QvVW^nmRUZ~zX{A-ncSpVO2hOfUpzam;SSk5@)y z1s=bSo}RwvmGLDKKU$yw{>D3O=l9>VDFJ44e?MGA*Q*gLWXmXMLWYf+^`*U5TMVf~ z#KbXX#mM_-iZ*qt09p8Av8MmqQs%cJgA!-SXsCF->L*KPngI3G*3`6WVl&wWvzCj`~-iLiY60^OL z(a|$4)fY9*B(5);;F-FcZe`{S{=kxZyDgWl%;OusosYL_tPAD@3)XHcD@{$kTpz-v zoPEYT`{cG6$bn?ikpl4nsX#pnXY#+A~N>-h5>a8sff$i>(-5EK+g}e4~Bxr z&w^X9A|fJmwDO^iNa(Vh2-D|)bSkIBi0OcIuCpWD5R%`Sm1->`gydWr-Pf>MjG#G- zUpZhrvfeDx#2cJ$N8U!V`Z?9*HgfeBv>K;zJ8uPA+%HFs&V0$(f&;kL+`?k7q|@it z1f@INu!gR)EoWZjl_bxD^O3l@>}0hVVRskR$+EwA7z!`SdwBrCyVC^s!aiJ|C>-5B zg}L5)klVI1qZjg+LOkC=_1GpZK*_s6|72Dixqsmu3lV9ka6t0;XKq6=A`h9up3q{W z*7+UHft)p}B`wtjZV)`f(Qd_k62?Ga$f-5;%!-q*=p_50EZ0XQ1NY zny{0lZ69H|RXTxn6c!#$w*giy#I@0X8GKDkAW~+!o0RVO(Uxw)J!nw-Tel_pe<^N1 zDvZyy$}w-C*Li2v@ql>}*R%AFi_LbuuzQ6vb7sjqoL{!aa85()>6IQpREvoC;AW-9v+_W zGWQW~SE5bn7Fv z{!evZ{s{H={hw6YP*jAdBq7vGvV~rRvW+E_wZ)Qc27|FrrN|zUC0ofl+1IfQ60&D+ zY-1Z^pX|#R^SKlHygz+D-#_5nPt#n_=iKMH_j%7bkMlU^43)dWzf}8dareL0`1ZsX z(J#TC|0m+Ea{hu@85^$MwrL_65{G`ak`>FOfEcE)d+~)yY;I%TBHqN0R<7czyk;dM@Nv4&r*N0U5Sf4kElH6X$B4^PhUnZsJ@_n)7uO3ax#Lm1u)zYuw9}> zEavk|>A7SK5h)4*gQnzc(AX6i7T~}sva@`t#_6>_;mTwH)- zkvzEqIPqmqoQ`crk2gjL)N>buq84O;FLoba2Mw75zUa80np?~C#Acl8S*2BKbz z?K=FY_8;NxKlmpMZ!46t?yNdHWV@Jk(f-MqPQ1!@SFodxu?StwDFxPmu}(KIh3IvQ zpHUp*LqppE|1Yg0>{laz^tV7mJy3h&Bs9RDz{&S;96#|j< z+*}4Ntzv>(KAUYWPiY3Zf^7+GcU%JQxw)-Dxr@ENeoRB|ly2EfR#{-E@>QpFo3)i* z6O~sdwDoqDG4;sBz3Tl;FK&Noa8};#u^&=m;Yerrs`(!@fu*KMU}xCs77v#>-GmL5 zcTGFv8&5CEuWWd<-C7ESZa%JaAy%wW!ysQ@9Wm#h>6rq)1X$V@Mi+3{mwGj`QG%W!!d&Y!}v){t1#4j@-35K^h zRMfO2;SLPb!_f5LK-w%Z3A()$0Qf_12KK(OWyvFRq=g=b#HMto;f15n}2@2gV6KZp#1=oAM zM6hq5ao{C_4wa+9jxJ3$59~~Zh>5gnoReaF1k44{-M-Hi0sQl`QqDHduC>g^-g0#S zLNgbi>^XbW<|k-K(Uq*iGN>g|2eOtyx^gkrzA@uOIVle?BHq_LARQU9WtlNH-C#@! z#pCgL9CdvVjUHhkp_19{Qds@nn#h`tg#6$Y}j89i; z9~+pN;hmWKYXexcwX~W&+9rDdqOT7e5ooCESb=4yYG47T5!h!`<7}x_RFn&xGlB+1 zj&prFPsNZwK}!v8rQj&8oR%0-Cs3SKAAtgC@&udUYL6uUu6D^R8&yV zg?$`Fl)ln``qZf?*r-j*qb(=r;}h<}yM)$e59TIO;2B>!bl7k=k_;3Lka#yoOn;M< zJ)xKWAEWcIZVlpagasRyw;M1D(vJh8aPV^nv!^j@emtpiBZ>TQMSn3**d%lofWAK>qw2?^r4U)s@T(wo24?mc z3ACNc<2=bdE&w=6i+^1E`5CZ<`-@>>B3&AB-gJzuxuy8=@w5y#5KV~)?N6Xcb}yfz z##8`Auc&Ld0r(rQ6?dxYS|8Zj{t<~5r7L*3!&@G>dVop2NGdNeWNl;Z7`v&|Z>sJ` z)Dm05OE>VUr{1s;u2|N3jTYqQmS0m)P|H7M)C3GoNSq{o#mz~jg%zkLc{q1wwvMi@ zbNe(kp$@DO3dQ(fP(A+E+3shyx(q|*s|4PUHk*D1OT+s4ptT89x^EWnZ*HG|)Ol|p zh7OjJmY(is5OPz>VbB8*L_S#9=Apkm$XG85TuBj<;cQ%Pl#Llxi_R6k)DH|>`s4jW zo@;|v%mxYywLrbMcm#pt09T1rR|hPck-W?O186vM=>zUnG269Ax8LbEQH_QtQ5_iv zQc*Y}Y}&s1<-w7p6_;Be>~Ezn*m_1G-RQ(Ow6@e>HzrC?bJpdJg@O0Ri8ipe1Wu$G zoruXMx~NTfPcj{V-H&ADw%ZNzfXK_G7#o6YzC#XTJ?2M~zg2K^$lHY&L%M`1K@kyn zS+`(Gk+|#P_+!+Ea1+KGu36Q3Pk@yg{e|cvI+V#gqf!OY`WAjo_TJ;?#SMredimP= zDZat&^?Tl`sfPWxF3Z(fPxn1~G@_uFWw;>+YXVisAP_EbyWup=Bmh^U^zZ@0nHGQ! zKEfbR0!kqs^yt)vNQ(ls1+W@nQ-ob=LBV~U?yxYX!Rt2Qm;?&hI2!?4X9Cb67aAwd zK1O+`;jI34-P$)kx(Jxw)L^Yku~Db^%Y!?P+pzeHJMZSY{uk-x#%B8MCY5(-Y{1`m zEzs8p0CuK;BAGm+f^VNPs2WMd{4JFgcX5^vyXYz6?ig2&`aCjW6PHDGd#|jkk2cGS(}`hq{8t2RDNO>7nQ~7rzl3Ht84ikxRZ7C*fA$e;q~2j_xz7nx4$+xTh)#n zOb2{A4q=`9l`!I$E};PmbGl2(Nb@> z6+KInb0Lnj-64>gpTCr)$9n6W0heATlmDl4h<*i{CM})OY#tkP_LIn#usr=X0G5}{ zP0Jsq>`I!+`}WI5=ZTRAMoJ33!37s2jWv5N+rD9X(A5o?RpU}Y4rqg%U_0a8!pne0GlyWrCLy`!`? z3;t%CWY*)Vx+g)1@PG5n!St57kLvDPTk?NHA}46mP6~mUfmEAsJmGEtUt+Sq_`gHt zzoR|!_s$OPPHOpY0Kt^GdlPV}!Ln5NFM^=fck`l_xa%y{}+P$ zKUuVZarJPz46qg8p{6{5N5kj%oBBo2&{EtZ6L6-ViB zma^d;KVTL!J*Kjh|HN7U#PTloPZ3lf>{3q{01t;*uwV}}e0%dd6*K%z;C4TaKgZqQ z@U#I)=l`?GWJS&`LsW{KCVzaqckf>H_`gN4jcsLRWkACOcJz2za8SK%e-TK5vF$71 zyE%_{KPLt?1fVS7EO_+hE<}Zg->@65`nmp|C@LZ%0(_)e|I>>`^>t&*Q=RX^!WI`7 zpNtt}dVRUPN&q{5kvtU6DQsBs7F=f5c&a#-3}C&u@bChQHqPSXF5naelklpi)IW)m?F6i@`gk)BKga5rGT&c3IST^oQ?=UQgSjBNJ*bcu&Y8sGzdvR%W6*X9Rj zveswL=420So*8Edp@vabHJnCNEV!%den|b;8LD^m zeQe?QImrTar*gPMZ!OLu-gTl)fTMT|tEzb_q`ouTr1B1Ws3qtrcqR}^ZV2OP(fPa! z`t5tMP9=ra0^o`I&I2CO`TmC$T`7G4`}t~`1W*)um%bEgq$3YRI!u{^ei2HksT%g= z9jx15cK3BZK#jhfzev5RFl?p+1a(o7efI&cK|9I@fI|5+kp5Fxb->^TIJnKHliP+= zips^TgjrfsDeRqvUC8z=72ZDeO(Eb6z8DXZg}#69JX}Si&B9H? zFKASHLr^gD^XE%6bx*7gCn<%*%OWwLfwaaH@Q*DmErFk@{5&^`?W+{A{2jP(Wm<>2 z6dhoc8V=Y;i$3WyytDy!=8zZ3wm7yKwCDo=3FefZeoq7T)ipsu!4ro|o>YMVEx4VK zTOHU^-T?TmHtD###rN@wGVrSa2Mg4AVong`-mSGYa0{Gz(0J>XojBf({kBUdrUIfR z)O;Chq0_Xx-OvAHi2AXF8c7_y)f*%7e~;VIQ>lr<5tPl`Ocmo8N&C^RNMrZ4AKe+| z?Bco~r$^i6U6Yj`P((3F{qI{;5+vd6(?$|JBRr2IIDTf9#;(kx@-J6jzgQ z&hB&KO6w5Xs=YbAlTfj;ojY>@E}tt;p%bz}S`PfIn?s*9XgyS)5{{oUB29lu@0_@b z4R?|_nc|}rgP5GGeG_`$ShB>vA=XmcqOu4IGk!RB=>&G{jzpit@a(`FF9vZju}jS~ zz68bCl*B-&mGDx`Ymv(p*Iet$PnTg-6NRytEm(fVZQUqNTR3)GCyuNtdiK%x^Zw{o z&lEZNPHg(EyseG8$!pHD>tZrw$-5E@quCo0!^;D2oEgNW#KK=T*N)ZjRv$w_y0T5~ z;F2$vwH|+GohM5d8_(|GI!wQ79x;HeS=W1y@26N9k`P~Gan;qLCIg*Ba`ZBtO@aGe z?qvmclsy{vStI=U1`J*jrvoFPeyzKLpUQ zzS!cPOn2*^Uz~B9s{L~)H8{UIX2UU3$*1)}>1Jl6;Cv4 zjP##XWLDFPo|720+D^FDpxR z4Y~V`3@s{ZUTzzfm0G{5j~ThE4;t}G@bS2 z*4+w%GKfoyeTt_IZVOtJ)-Gevk3rE>J`uG-jYNFMIUA#C)!XRNs(aBOJ4Rs4)L83y zK5|~m>Ri*kc|W5ern83hHTYX;f*hY@j$`BJd+*}em+ul3vFZ&t$=3cW*ZFIucvBq{ z3ULdhx$x0*!Y(y=N`;QSrm!_EU53D_I)KZqUbUF0)d&8?nnlOPGucKx z-D;yZZRF79k3S=-P`q0g-973u6u}-%VBemccrF5$Z{@Iafqt_*syvl4FN3;(k`oi} z^~7+xlaJXh3MGrosAmLMia2$AzQ^pdI)7@lc4i&ySh-J82JbX*#X;VBM{!6QvvsyP z7UauX9JuAqi_pAgJI0|wOXxWcaozTuvrltOwyytk zFhfAVT25J2XWjt9%WJHE=GN=J*j$w);4^OY?ITVGIYHn(y1x=!Y@Z{>eVT%CM?S5i z_)%LQA9n%b&AHrFxt0w?`~rjinN4@6;Vr3}3J4~8&f}G z0mbGl0w7V?^ICPkHFWZFK0n+W z|7k4ybnPbP3gLF)7@WIQLSt@nAV-3Fz~#of|3elK9l@C?kIbh_m#Po6ufHj6#@LYf z2Sw4~0a)y|M0g}GkfRL7CM}e2^z>E5A4-Q##;Yh8pd>-<37%sg`PB{vjvXGt{I=7oBBeLvVa(gJ_<50B#JG9)tEh=WJ z*2K=SSL%J` zx=UpENmxRbW|ocWl1%RS{kytf8e>C8)o`c^zU;FH!U9CY)Hdc>DniN~uPtjJYK)GU z?RUSc8gc6?Ey8@_b~4x~jS?DDzvamE49cqd;gvu}sl#wksI-=k5b4uug}GmeLdwh$ zk|(>5(5;Ef6Kk0n8UN2TpdH}_1L1*X0mAbPQ3UX51LF$oMyhQBhhz>Z?jZ!B!nr=( z?jU+$EW1MD?OiyxO-#%!<>)Qin-sM4JW6|PsQMyM?S-|2%3X~j(?XcNOErFH|h%mBGYIg2NzG7o{P*Me% z;&}B^K&_+rq1K2+R4QEflxSem#IpZ|I8w9J{V9;6^PzOz#oI`b^2}e%tPb-kY>rdgCGKBLrGp_5bH3eFQpVOZsYib$K@H=dcITNB?Mr9&%WPEWIv68M&W%#7E1 z1qAEzm~M%R(J_sXZe~cleFjg0F8l+G5uJ;5ChqX_CntP1Al#yRk52Vu#{wR1)Q0_Q zq-8N%{^OVL{jq8F_g1D-g`-uo@qF)Oz93Z`&cjwTi0@j-9hTf@lgF!KxA`E#;=|S& zlP}G-fv)?q!1s^`*}pDSVbb6bTQ=HX`DADj!sg{Fr_;2mI@kBKXS=aE8JS@^4j$FY+h0!tW0%T@E;?+bK9zZmPejYWw7uJ1uqtQux?Bye(D|a zSi>7YTzxCyGH>55^p11bc|h+-P%RtfsdlF&<9;Whg2Z&mTiLM4BV4BrF!P ze!(J?X_p5?uLjQbUyD6f*F#kM$8yd*75}F3QMX82fI;}K+S$@^m-J7Yp6(XO&S#4@ zZJs?oYjuVgr!Os(OnF)J(S$%xpLiLuF)S2P;gEPfk)KEDjO-vjx3)f}=crCdulfp0 zwrpsu5Po~MnhthDWUWwSpjVw{9?*=Ba$lC9-Ga78jVtNo)Ho0oQnPwYI8sN zSzCc|NZ><6in0z$*e32Ls(;DA8rO0qub$3o8D2GlKDokS=K%c~N88#OwBCGMqT&EX zU%HF5yx7@_M8!yOsg-6)ZbdWEKV*f+ZK?VlLS;0rP|YNFXKcG%WyT@pyk5xUplx$X zpI*V`CtIRYREcS}QEipsfxeSQZfZZ@8j$!$Vz#(dz|2JFlJ+aGTEuMy7ykas(U6Ng zJEq$U_7A{8XzvX0q&(YaM(NVT`BYwh%z$`qWp6*qBwMJ#Gv1wK`cQ75=2JKUs*cRFP929zmpXY} z!8a_opjT*7=$xexNXn(P$=+0J0%u!!{Ast)#9^k|p)V0OR-KLH03RpfKqfJ1PzrJG zhD96RE$Cm<5Hf3K3ylRq5l9Y=evD)gmk=AhPBC541Z7kFSIfR=za-B>#?V%sPC8Dj zBHiM7zoe6*W(F+yJzn*BRuZdbk~SUZ!#k4PBYmY-I5+xeOnx2oJ;I7?X`|sK_(V{* za2h6OCgP*Cq|)^)%|k@=$(mQFLh_ z4gSS8{6uVpzSiKiADeQ>sfbQ2*0q;;tX5ZfBO;dB;@Az@N>n(h)!ZThqo3kxg89zr zJaipfD7m}X785?e#_1Y()9@-Fv@_;qzFK9IL-yr5y?@`q8BTdRT_lCALM|{MQ(^-1 z&`~qZ78woK3J)P0@SRvR;TV5`Nv_{%WYPy(^%i;*ylM)qY2-N4G}{^JpK-(bKszG+ zdsdvGLkPZ^CUwHc@QjQ1j&ob`25guBp))&dkR6q_TW{sJNBfZK(O%VyS=#lG|MGb4 zs7XI8Mpu1yVbuS)l={&wAJjT1dzf{Du#tO7N9gGiCiKRlN5B5l)yG1Vc?lNo+ zQt%P^hL)|nAkJUozv+;Mj=8M-JE1<{g6~~Q{aDok7?|_s=#E(4y>a{VC$3b)E^VZe zWEvzFbTrjYk@-v#q)T|m)^(7lY?m|mYf~9#H`YHx+6BJtb&;n|lxiPkl^P!3?MAil z#T_0EayLo4)ZNR)Am9uxtzUm&u>v`B>#>S)L^@5c$IW>h6g~H`*k7&tj9$j}I5uHu zaZag6&mX0+|G&jN%tRFcTI2ZM1HL$LSz`&$9!Hsff2NpRBMoVJkOy5#DK5tJ>!Yz&n3WJC&V?6{gKC;!|VBkft9%T zIE<&N;=k)P>7pi>z6Cl#*hZvg!VP47+*PdljXS$l!hg?i9whM*FxGW%b`{r&HzF?< z;R$B5O+p&siz-SoeYpZlzao1Z*$8?vxCmcUK6ufvJ@z)RLG!UbH38qZJ|bBW$gZ~h6RluGnBOH^^ z{)~Yg|7WKA_OF6B20Nx?y|>As9{UTGv6;o&-3ZKDewK*Xxmyu%m!)tL1%Y~xn<-7v z(4=*Rdm*fwDm@*P;0Tmw-1Sk)VBe@PWhHdEo6FqX#%m?I%frNd`sZ_jHOsTQ^4M|jD{)AoE}!+_=!eP}m(L@Q z^^mQBQU=A__-{$uiNnrKl|iKDbwyEphc$&f_Z~;w>Pgm*$bt&UUYj6f8ju~oVWtlQ zUJID5-`hF=o6DQkg0hq4vvO(mRmu1Ue{CP;3X1@wEp55vsgHoiCJ_nJP$Xm1Vx8Kh?D zNi-$w(R@$b_1N#Ej1`l*%HaOIK(k2O12_=60WjWd{tk)IDm)|Mme@qClZ0p_%ivOr z!8Q)=d+}REww_~YW;c!zt9@?u?UxQ!wVLWzP0nVhcQYnQYeC;L@oU<}I_Xv`Q%>CT z8}*eo*im*t=te7LVe2F1RWZZn529n%#mj$Y^*d(bTh+Oni?wfm)`b)I8|U41^oq2} zsU5^;gNt+(I67A#TqY`9D_W;RH zRc);LRYiZ6gEkR}(~FYnLmW639xq#9i~VvvopFm~QVg}9fzV-0DC}p|+72H3?<47U zERay`S@FTWIODM7{yODow(kaZZN&y&sFqh>`V!m@_wRQ-MkJ%o6mN}gaEn^4@N!eo z-I;USQS5H*u^I0%y%ZSO*)POAlz$F7w{+j&R0Z(U`eMi&)Rx@DBEwi#-IkEgKezDj z(rToD!b6mC3|X-b|HE!Sfn|uqB1oB7U_5Sy$;p4ZL&p0}ay?JYhkkOLb?x_-*Y&fy zy>B0F#=SfL-lrnI@y~O$Qa}z+&u6L1!O{0zgR-vf#ubjK;S*4oiB@8f%?2%TvDD;a zTC3YUb;r+nFUe3!8Sb{!+RAT_83Tlq!Lt=IE*R$| zofe&L)qwG<+%|4HgIp-CRNa*KEt1_B5){O2bQ+^7Gu-10OKdEt6CTNn%g{~G-};3c z?D({TpiBiboRf0do;Ltn?}Kc!wDCi!@jUXFG!px%)?{l^HcZmlEr%@Zwcc{3c)Nxh z1#qUy0NMvTWhQnM-!;H)wYcNETPh1^*Tjq$Z~?j@IPtsS<7`iX{_9yagXBn$v)jxJ zqI!&3@f$Xj@ZhyUcbvD8wo;25K_p?Kr_jGV?pXb2H%eIznQ?_9Y`c|kkp5z{EMdh9 zfpD4k{=wLC)S8X44ryhdP)50iUO4S0+ACuuWBF(;c#T|KOdJON3J7A$ph4z>--?Lu z+PotLkWzZn*K(#{zAO%dduk6@6dXYN5Y~Af?b|yP|FVL9fO1itOe3s+)b0Nq4+fPC z;ag1C_U$dyF1LE`ZqL9%TKd@m=F0!PZg;$%dbW5SVFiNv%l_H1cc|p`f;)TVE&jg6 z^D!{YQF-9_U&hg&yXga4LH{DhZqmx%KT%~5hJ#J^ANoIk8vL~&FaQNl2LFe&{__^Y z;$XO5n1=R0?Xo{V4J;KZ$N&A|`aMznHG8{QFgzCdoaV3Z_wIIEWtc+ig5Wm41Btx1 Q5B$5QpnfMy?$OKt0-?Hzr~m)} literal 0 HcmV?d00001 From 5d68ec24940b089d3340044844b80eec23850aee Mon Sep 17 00:00:00 2001 From: janaobsteter Date: Tue, 12 May 2026 15:33:05 +0200 Subject: [PATCH 44/56] Updating variance calculation scripts on Gregor's visit to SLO --- vignettes/F2_Variance_calculations.Rmd | 5 ++- .../F2_Variance_calculations_functions.Rmd | 33 +++++++++++++++---- 2 files changed, 31 insertions(+), 7 deletions(-) diff --git a/vignettes/F2_Variance_calculations.Rmd b/vignettes/F2_Variance_calculations.Rmd index 206a2782..26a38d90 100644 --- a/vignettes/F2_Variance_calculations.Rmd +++ b/vignettes/F2_Variance_calculations.Rmd @@ -387,6 +387,7 @@ nW * nW (a <- nW * nW / nF) (b <- (nF - 1) * nW * nW / nF) a+b +#TODO define nDPQ ``` Looks like! @@ -397,7 +398,7 @@ Let's test this: ```{r check_workers_variances3} (varSumWorkers <- nW * varA[2]) # B1 -(covSumWorkersSuperSisters <- (nW * nW / nF) * 0.50 * varA[2]) # B2 in super-sisters ERROR: SHOULD BE 0.75 +(covSumWorkersSuperSisters <- (nW * nW / nF) * 0.75 * varA[2]) # B2 in super-sisters ERROR: SHOULD BE 0.75 (covSumWorkersHalfSisters <- ((nF - 1) * nW * nW / nF) * 0.25 * varA[2]) # B2 in half-sisters varSumWorkers + covSumWorkersSuperSisters + covSumWorkersHalfSisters # B @@ -464,6 +465,8 @@ print("Part B1") (varSumWorkers <- nW * varA[2]) # B1 print("Part B2 in super-sisters") (covSumWorkersSuperSisters <- (nW * nW / nF) * 0.75 * varA[2]) # B2 in super-sisters +print("Part B2 in full-sisters") +(covSumWorkersFullSisters <- ((nW * nW / nDPQ) - (nW * nW / nF)) * 0.50 * varA[2]) # B2 in full-sisters print("Part B2 in half-sisters") (covSumWorkersHalfSisters <- ((nF - 1) * nW * nW / nF) * 0.25 * varA[2]) # B2 in half-sisters print("Part B combined") diff --git a/vignettes/F2_Variance_calculations_functions.Rmd b/vignettes/F2_Variance_calculations_functions.Rmd index caeace0b..015f41a3 100644 --- a/vignettes/F2_Variance_calculations_functions.Rmd +++ b/vignettes/F2_Variance_calculations_functions.Rmd @@ -20,6 +20,21 @@ knitr::opts_chunk$set( ) ``` +```{r cor2cov, include = FALSE} +cor2cov <- function(corr, var) { + # Ensure inputs are matrices/vectors + corr <- as.matrix(corr) + var <- as.numeric(var) + + # Standard deviations + sd <- sqrt(var) + + # Covariance matrix + cov <- corr * (sd %o% sd) + + return(cov) +} +``` Let's again run the example from the quantitative genetic vignette. @@ -57,6 +72,7 @@ colonyPheno <- calcColonyPheno(apiary) How the expected and realised variances look like ```{r} +k <- 1 print("Expected genetic and phenotypic variance") covA[1, 1] + nW * covA[2, 2] + 2 * k * covA[1, 2] # variance can not be negative! covP[1, 1] + nW * covP[2, 2] + 2 * k * covP[1, 2] @@ -99,14 +115,16 @@ varA_w = 1 / SP$nWorkers corA_qw = corA[1,2] # Covariance due to super-sisters -covSumWorkersSuperSisters <- (nW * nW / nF) * 0.50 * varA_w +covSumWorkersSuperSisters <- (nW * nW / nF) * 0.75 * varA_w +# Covariance due to full-sisters +covSumWorkersFullSisters <- ((nW * nW / nDPQ) - (nW * nW / nF)) * 0.50 * varA_w # Covariance due to half-sisters covSumWorkersHalfSisters <- ((nF - 1) * nW * nW / nF) * 0.25 * varA_w -# Covariance due to full-sisters -mapIndToColonyVar <- function(varA_q, varA_w, corA_qw, nW, nF, workersFUN = "sum") { + +mapIndToColonyVar <- function(varA_q, varA_w, corA_qw, nW, nF, nDPQ, workersFUN = "sum") { if (workersFUN == "mean") { nW = 1 } @@ -127,13 +145,14 @@ mapIndToColonyVar <- function(varA_q, varA_w, corA_qw, nW, nF, workersFUN = "sum if (workersFUN == "sum") { varC <- A + B1 + B2_ss + B2_fs + B2_hs + C } else if (workersFUN == "mean") { - varC <- varA_q + (B2_ss + B2_fs + B2_hs) # This is equal as varA_w * average relatedness within a colony + stop("TODO: derive this equation properly") + #varC <- varA_q + varA_w + (B2_ss + B2_fs + B2_hs) + covA_qw # This is equal as varA_w * average relatedness within a colony } return(varC) } #This is the same as above, just simplified -mapIndToColonyVar <- function(varA_q, varA_w, corA_qw, nW, nF, workersFUN = "sum") { +mapIndToColonyVar <- function(varA_q, varA_w, corA_qw, nW, nF, nDPQ, workersFUN = "sum") { # Determina how many pairs of each you have p_SS = 1 / nF @@ -151,7 +170,7 @@ mapIndToColonyVar <- function(varA_q, varA_w, corA_qw, nW, nF, workersFUN = "sum if (workersFUN == "sum") { varC <- A + B1 + (B2_ss + B2_fs + B2_hs)*nW^2*varA_w + C } else if (workersFUN == "mean") { - varC <- varA_q + (B2_ss + B2_fs + B2_hs)*varA_w + covA_qw# This is equal as varA_w * average relatedness within a colony + varC <- A + varA_w + (B2_ss + B2_fs + B2_hs)*varA_w + covA_qw# This is equal as varA_w * average relatedness within a colony } return(varC) } @@ -164,6 +183,7 @@ mapIndToColonyVar(varA_q = varA_q, varA_w= varA_w, corA_qw = corA_qw, nW = nW, nF = nF, + nDPQ = nDPQ, workersFUN = "sum") colonyGv <- calcColonyGv(apiary, FUN = mapCasteToColonyGv, workersFUN = colSums) var(colonyGv) @@ -175,6 +195,7 @@ mapIndToColonyVar(varA_q = varA_q, varA_w = varA_w * SP$nWorkers, corA_qw = corA_qw, nW = nW, nF = nF, + nDPQ = nDPQ, workersFUN = "mean") colonyGv <- calcColonyGv(apiary, FUN = mapCasteToColonyGv, workersFUN = colMeans) var(colonyGv) From 67c6e813f147ded27c3b1b2b12a54e1ab77a6ffd Mon Sep 17 00:00:00 2001 From: Gregor Gorjanc Date: Tue, 12 May 2026 15:46:43 +0200 Subject: [PATCH 45/56] Add AGENT plan --- vignettes/colony_variance_theory_plan.md | 364 +++++++++++++++++++++++ 1 file changed, 364 insertions(+) create mode 100644 vignettes/colony_variance_theory_plan.md diff --git a/vignettes/colony_variance_theory_plan.md b/vignettes/colony_variance_theory_plan.md new file mode 100644 index 00000000..2e0a0e02 --- /dev/null +++ b/vignettes/colony_variance_theory_plan.md @@ -0,0 +1,364 @@ +# Colony Variance Theory Plan + +This note records the current plan for issue +[#49](https://github.com/HighlanderLab/SIMplyBee/issues/49) and the two draft +vignettes `F2_Variance_calculations.Rmd` and +`F2_Variance_calculations_functions.Rmd`. + +The goal is to turn published colony-level variance components into +individual-level queen and worker variance components that can be passed to +SIMplyBee/AlphaSimR. The forward direction is identifiable once the colony value +mapping and family structure are fixed. The reverse direction is usually +underdetermined, so the function must expose the missing assumptions rather than +pretend there is a unique solution. + +## Sources Studied + +- GitHub issue #49, including the 2025-12-10 meeting note on six individual + variance parameters and the underdetermined reverse problem. +- The linked historical commit `e135438f97c48ad7deabf10641a4c6f4a3f19fe8`, + which added the first `Colony_variance_calculus.Rmd` draft. +- `vignettes/F2_Variance_calculations.Rmd`, the derivation-heavy draft. +- `vignettes/F2_Variance_calculations_functions.Rmd`, the first function sketch. +- `vignettes/F_Quantitative_Genetics.Rmd`, which defines the default + individual-to-colony value mapping used in examples. +- `R/Class-SimParamBee.R` and `R/Functions_L0_auxilary.R`, especially + `mapCasteToColonyValue()`, `calcColonyGv()`, and `calcColonyPheno()`. + +## Model To Standardise + +For one colony trait, the current default mapping is + +```text +C = Q + W +``` + +where `Q` is the queen contribution and `W` is the aggregated worker +contribution. By default SIMplyBee uses `W = sum_i W_i`, but the theory should +also support `W = mean_i W_i` because some published worker-group estimates are +closer to mean worker effects than total worker production. + +For any aggregate with worker weights `a_i`, + +```text +W = sum_i a_i W_i +``` + +where `a_i = 1` for a worker sum and `a_i = 1 / n_w` for a worker mean. + +The core genetic variance equation is + +```text +Var(G_C) = + sigma_gq^2 + + K_w sigma_gw^2 + + L_qw sigma_gq,gw +``` + +with + +```text +K_w = sum_i a_i^2 + sum_{i != j} a_i a_j r_ij +L_qw = sum_i a_i +``` + +Here `r_ij` is the additive genetic relationship, or the corresponding +covariance multiplier, between workers `i` and `j`. For the default sum mapping, +`K_w = n_w + n_w (n_w - 1) rbar_w` and `L_qw = n_w`. For the mean mapping, +`K_w = (1 / n_w) * (1 + (n_w - 1) rbar_w)` and `L_qw = 1`. + +## Theory Patches + +1. Use distinct-worker pair counts. + + The current vignettes often use `n_w^2 / n_f` pair counts and then also add + the individual worker variance term. That double-counts the diagonal worker + terms. The clean formulation is: + + ```text + Var(sum_i W_i) = n_w sigma_w^2 + + n_w (n_w - 1) rbar_w sigma_w^2 + ``` + + This is clearer and avoids small but systematic over-counting. + +2. Standardise relationship classes. + + Use these default genetic relationship multipliers unless a source requires + different assumptions: + + ```text + same father / supersisters: 0.75 + same DPQ, different father: 0.50 + different DPQ / half-sisters through the colony queen only: 0.25 + unrelated workers: 0 + ``` + + Then compute `rbar_w` from probabilities or counts. For balanced groups with + `n_w` workers, `n_f` fathers, and `n_DPQ` drone-producing queens: + + ```text + n_SS = n_w^2 / n_f - n_w + n_FS = n_w^2 / n_DPQ - n_w^2 / n_f + n_HS = n_w (n_w - 1) - n_SS - n_FS + + rbar_w = (0.75 n_SS + 0.50 n_FS + 0.25 n_HS) / + (n_w (n_w - 1)) + ``` + + If `n_DPQ` is unavailable, start with the simpler father-only model: + same-father pairs have relationship 0.75 and different-father pairs have + relationship 0.25. + +3. Keep genetic and environmental aggregation separate. + + The phenotypic derivation in the draft currently mixes `covP` and genetic + relationship terms. Under the current SIMplyBee mapping, environmental + deviations are sampled on individuals. The environmental correlation between + queen and worker traits applies within an individual, but the colony phenotype + uses the queen's queen-trait phenotype and the workers' worker-trait + phenotypes from different individuals. Therefore the default colony + environmental variance should be: + + ```text + Var(E_C) = sigma_eq^2 + K_e sigma_ew^2 + ``` + + where `K_e = sum_i a_i^2`, because distinct individual environmental + deviations are independent by default. For a sum, `K_e = n_w`; for a mean, + `K_e = 1 / n_w`. + + Do not include worker-worker environmental covariance or queen-worker + environmental covariance unless we add an explicit common-colony environment + model. + +4. Treat `corE` carefully in examples. + + `corE` is still relevant for phenotypes of different traits measured on the + same individual, but it is not automatically a covariance between a queen's + environment and her workers' environments in the current colony value mapping. + The F2 vignettes should say this explicitly. + +5. Define reported colony covariance terms precisely. + + If literature reports a queen-worker colony covariance as + `Cov(G_Q, G_W)`, then for the sum mapping: + + ```text + Cov(G_Q, G_W) = 0.5 n_w sigma_gq,gw + ``` + + and the contribution to `Var(G_C)` is `2 Cov(G_Q, G_W)`. + + If literature reports the full variance contribution `2 Cov(G_Q, G_W)`, then + the inverse scaling differs by a factor of two. The function API should force + this distinction. + +## Reverse Mapping Policy + +The reverse function should not return a single "true" individual parameter set +unless enough constraints are supplied. + +### Case A: Literature Reports Colony Genetic Components + +Inputs: + +```text +V_gQ_colony = Var(G_Q) +V_gW_colony = Var(G_W) +C_gQW_colony = Cov(G_Q, G_W) +n_w, n_f, n_DPQ or rbar_w +workersFUN = "sum" or "mean" +``` + +Then the genetic inverse is identifiable: + +```text +sigma_gq^2 = V_gQ_colony +sigma_gw^2 = V_gW_colony / K_w +sigma_gq,gw = C_gQW_colony / (0.5 L_qw) +``` + +Validate the resulting genetic covariance matrix is positive semidefinite: + +```text +abs(sigma_gq,gw) <= sqrt(sigma_gq^2 sigma_gw^2) +``` + +### Case B: Literature Reports Only Total Colony Genetic Variance + +Input: + +```text +V_gC_colony = Var(G_C) +``` + +This is one equation with three genetic unknowns. Require user assumptions, for +example: + +```text +queen_share_g = target share of V_gC assigned to queen contribution +worker_share_g = target share assigned to worker aggregate contribution +cor_gq_gw = individual queen-worker genetic correlation +``` + +or accept fixed values for any two of `sigma_gq^2`, `sigma_gw^2`, and +`sigma_gq,gw`, then solve the third. + +### Case C: Literature Reports Colony Environmental Variance + +Under the current SIMplyBee mapping, use a default split between queen and +worker aggregate environmental variance: + +```text +V_eC_colony = sigma_eq^2 + K_e sigma_ew^2 +``` + +A reasonable API is: + +```text +env_share_queen = p +env_share_worker = 1 - p + +sigma_eq^2 = p V_eC_colony +sigma_ew^2 = (1 - p) V_eC_colony / K_e +sigma_eq,ew = 0 +``` + +Default proposal: `p = 0.5`, with a warning that this is an assumption. Also +allow `p` to be user supplied. + +Do not implement the three-way environmental split from the issue note as the +default unless we also implement an explicit common-colony environmental +covariance model. Otherwise we would estimate a parameter that SIMplyBee's +current phenotype mapping does not use. + +### Case D: User Wants Environmental Covariance + +Support this only as an optional future extension: + +```text +Var(E_C) = sigma_eq^2 + K_e sigma_ew^2 + L_e sigma_eq,ew +``` + +This needs a clear biological interpretation, for example shared apiary or +colony environment, and an implementation path for simulating that common +environment. It should not be conflated with AlphaSimR's within-individual +`corE`. + +## Proposed Functions + +1. `calcWorkerRelatedness()` + + Purpose: calculate `rbar_w` from either explicit worker pedigree/father + groups or summary assumptions. + + Initial arguments: + + ```text + nWorkers + nFathers = NULL + nDPQ = NULL + relationship = c(super = 0.75, full = 0.50, half = 0.25) + exact = TRUE + ``` + +2. `mapIndividualToColonyVar()` + + Purpose: forward-map individual variances to expected colony variances. + + Initial arguments: + + ```text + varGQueen, varGWorker, covGQueenWorker + varEQueen = 0, varEWorker = 0, covEQueenWorker = 0 + nWorkers + rbarWorkers = NULL + nFathers = NULL + nDPQ = NULL + workersFUN = c("sum", "mean") + envModel = c("independent", "common") + ``` + + Return a named list or data frame with: + + ```text + varGColony + varEColony + varPColony + queenGContribution + workerGContribution + queenWorkerGContribution + queenEContribution + workerEContribution + queenWorkerEContribution + K_w, K_e, L_qw, rbarWorkers + ``` + +3. `mapColonyToIndividualVar()` + + Purpose: reverse-map reported colony variances into individual simulation + parameters, with explicit assumptions. + + Initial modes: + + ```text + geneticMode = c("components", "shares", "fixed") + envMode = c("share", "fixed", "none") + ``` + + The function should return both estimates and an `assumptions` field. It + should error when the system is underdetermined and no policy is supplied. + +## Implementation Order + +1. Polish theory in the two F2 vignettes: + replace pair-count equations with `K_w`, `K_e`, and `L_qw`; correct the + phenotypic/environmental section; define `sum` versus `mean` worker mapping. + +2. Add a small internal helper for worker relationship multipliers and test it + with simple known cases: + one father, many fathers without DPQ, and fathers nested within DPQs. + +3. Add the forward function and tests comparing expected variance to simulated + variance under large `nColonies`, fixed `nWorkers`, fixed `nFathers`, and + simple additive traits. + +4. Add the reverse function in conservative modes: + `geneticMode = "components"` and `envMode = "share"` first. Add the more + flexible underdetermined policies only after the component mode is tested. + +5. Update `F_Quantitative_Genetics.Rmd` examples to call the helper rather than + hand-scaling worker variances by `SP$nWorkers` without explaining the + relationship multiplier. + +6. Add `NEWS.md` after user-facing functions are exported. + +## Open Decisions + +- Naming: decide whether these should be exported user-facing functions or + initially internal helpers used in vignettes. +- Default worker mapping: keep `workersFUN = "sum"` aligned with + `mapCasteToColonyValue()`, but document when `mean` better matches published + worker-group estimates. +- Literature convention: for each target paper, record whether reported + queen-worker covariance is `Cov(Q, W)` or `2 Cov(Q, W)`. +- DPQ availability: decide whether `nDPQ` should be required for the full model + or optional with a father-only fallback. +- Common environment: defer unless there is a concrete simulation design for + shared colony/apiary environmental deviations. + +## Recommended Starting Point + +Start with the forward mapping and the component-based inverse. That gives a +defensible, testable path: + +```text +published colony components -> individual genetic variances +published colony residual variance + explicit split -> individual environmental variances +``` + +For papers that report only total colony genetic or phenotypic variance, the +function should require shares, fixed parameters, or correlations supplied by +the user. This is the honest way to handle the underdetermined system and avoids +embedding arbitrary assumptions as hidden defaults. From 6b43d92859f766ca920c9ea198c65e469d4dd7fb Mon Sep 17 00:00:00 2001 From: Gregor Gorjanc Date: Wed, 13 May 2026 11:30:29 +0200 Subject: [PATCH 46/56] Adding AGENTS.md --- AGENTS.md | 297 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 297 insertions(+) create mode 100644 AGENTS.md diff --git a/AGENTS.md b/AGENTS.md new file mode 100644 index 00000000..fd44b0ac --- /dev/null +++ b/AGENTS.md @@ -0,0 +1,297 @@ +# AGENTS.md + +## Scope + +These notes apply to how we manage this git repository of the `SIMplyBee` package. +SIMplyBee aims to provide an easy to use simulation platform to simulate honeybee breeding programmes by building upon the AlphaSimR packages. So, we prioritise aligning the SIMplyBee R API with the underlying AlphaSimR R API where this is appropriate, and deviate or level-up where we need a honeybee specific approach. + +## The way of working + +* We strive for planned work so we have a plan of what we want to change. +* We strive for minimal changes, unless needed otherwise. +* We provide clear examples for new functionality so useRs can be quickly + onboarded. +* We add or update tests for every behavior change. +* We run R CMD check for every code change. +* We keep local quality gates green before handoff. +* We update `NEWS.md` for user-visible behavior or API changes. + +## Permissions and authorization + +Standing authorization for this repository: + +* All commands explicitly shown in this document are pre-authorized for + repository work (including inline commands and code-block commands, + with task-specific substitutions where placeholders are shown). +* Agents should run these documented commands directly without asking for + extra confirmation in chat. +* If sandboxing blocks an allowed command, agents should submit the required + unsandboxed/escalated tool request directly with a brief justification. +* Agents should ask in chat only if a required escalation is denied or a + platform policy still blocks execution after escalation. +* Agents may use `curl` (or equivalent read-only HTTP tools) for repository + and upstream references on: + `github.com`, `api.github.com`, `raw.githubusercontent.com`, + `github.com/HighlanderLab/SIMplyBee`, `SIMplyBee.info`, + `cran.r-project.org`, `cranchecks.info`, `badges.cranchecks.info`, + `r-pkg.org`, `cranlogs.r-pkg.org`, `img.shields.io`, + `codecov.io`, `app.codecov.io`, and `highlanderlab.r-universe.dev` + (including issues, pull requests, comments, events, metadata, and docs). +* For the above domains, agents should execute `curl` directly without asking + for extra confirmation in chat; if sandboxing requires escalation, submit the + escalated tool request immediately and continue. +* To minimise repeated platform permission prompts, prefer these canonical + command forms (same flags and flag order): + +```sh +curl -sS --max-time 15 +curl -I -sS --max-time 15 +``` + +* This standing authorization does not override explicit user instructions or + allow destructive commands that were not requested by the user. + +## Definition of done + +A task is done when all applicable items below are completed: + +* Added/updated user-facing examples and tests for new functionality. +* `pre-commit run --all-files` to pass basic code checks. +* `Rscript -e "setwd('SIMplyBee'); devtools::test()"` + for interactive "mode" testing. +* `Rscript -e "setwd('SIMplyBee'); devtools::check()"` + for non-interactive "mode" testing and full package checks. +* Updated `NEWS.md` for user-visible changes. + +### Task-class quality gates + +* For docs/config-only changes (for example `AGENTS.md`, README text, `NEWS.md` + text-only edits, comments, formatting-only), `devtools::test()` and + `devtools::check()` are not required unless package behavior is affected. +* For behavior-changing R/C++ work, run focused tests first (for example + `devtools::test(filter = '...')`), then run full package checks before + handoff (`pre-commit`, `devtools::test()`, and `devtools::check()`). +* If full checks are intentionally skipped, explicitly report what was skipped, + why, and which focused checks were run. + +## Worktree and file hygiene + +Default for non-trivial code tasks is to use a dedicated git worktree: + +```sh +git fetch origin --prune +git worktree add ../SIMplyBee_wt_ -b origin/main +``` + +Within this workflow, follow these rules: + +* In the shared root worktree, limit edits to small docs/meta/config work. +* For behavior-changing R/C++ tasks, use a dedicated worktree by default. +* A branch can be checked out in only one worktree at a time. +* If the shared root is dirty or conflicting edits appear, stop and move work + into a dedicated worktree. +* In a dedicated worktree, edit only task-related files and do not revert or + overwrite unrelated edits. +* If syncing an existing branch before substantial work, run: + +```sh +git fetch origin --prune +git rebase origin/main +``` + +* If there are local uncommitted edits, use `--autostash` or an explicit stash. +* If conflicts occur, preserve local edits, resolve conflicts carefully, and + report conflicted files plus the chosen resolution. +* By default, edit files freely but do not run `git add`, `git commit`, + or `git push` unless explicitly requested. +* If a command leaves files staged unintentionally, report that in handoff. + +Worktree cleanup after merge/finish: + +```sh +git worktree remove ../SIMplyBee_wt_ +git worktree prune +``` + +## Issue triage workflow + +For issue exploration, closure recommendations, or "what is left to do?" tasks: + +* Read issue body, comments, and events/timeline. +* Check linked commits/PRs and map issue checklist items to current files/tests. +* Report what is done, what is missing, and a concrete recommendation + (close, keep open, or split follow-up issue). +* Include direct references to supporting files/tests/commits. + +## Quality toolchain + +These checks mirror `README.md` guidance and enforce package quality. + +### Pre-commit hooks + +Install once per clone: + +```sh +pre-commit install +``` + +Run before committing: + +```sh +pre-commit run --all-files +``` + +Hook responsibilities: + +* `air format .`: format R, Rmd, and qmd files. +* `jarl check .`: lint R, Rmd, and qmd files. +* `clang-format -i --style=file`: format C/C++ sources and headers. +* `python tools/clang_tidy.py`: run clang-tidy checks for C/C++. +* Standard pre-commit hygiene hooks: + whitespace, line endings, YAML checks, + merge-conflict markers, and large-file checks. + +If a required tool is not found system-wide on `PATH`, +also check user-local bin directories +before assuming it is missing: + +```sh +which || PATH="$HOME/.local/bin:$HOME/bin:$PATH" which +``` + +Useful `clang-tidy` invocations: + +```sh +# Full hook set +pre-commit run --all-files + +# clang-tidy only +pre-commit run clang-tidy --all-files + +# clang-tidy for one file +pre-commit run clang-tidy --files src/SIMplyBee.cpp +``` + +If `clang-tidy` is not on `PATH` (for example Homebrew LLVM on macOS), set: + +```sh +export CLANG_TIDY="$(brew --prefix llvm)/bin/clang-tidy" +``` + +Then you can run the wrapper script directly: + +```sh +python tools/clang_tidy.py src/SIMplyBee.cpp +``` + +### Coverage with covr + +Use `covr` for test-coverage checks on behavior-changing work: + +```sh +Rscript -e "setwd('SIMplyBee'); cov <- covr::package_coverage(clean = TRUE); print(cov); covr::report(cov)" +``` + +### GitHub Actions (CI) + +CI runs on push and pull request and acts as the remote quality gate: + +* `.github/workflows/R-CMD-check.yaml`: multi-platform R CMD check matrix. +* `.github/workflows/test-coverage.yaml`: `covr` coverage run and Codecov upload. + +Local work should pass local checks before relying on CI feedback. + +## Generated files and source-of-truth rules + +Do not edit generated files by hand: + +* `R/RcppExports.R` +* `src/RcppExports.cpp` +* `NAMESPACE` +* Files in `man/` generated from roxygen comments + +Regenerate as needed: + +```sh +Rscript -e "setwd('SIMplyBee'); Rcpp::compileAttributes()" +Rscript -e "setwd('SIMplyBee'); devtools::document()" +``` +## R CMD Check + +### Preferred way to R CMD Check + +Run faster package checks from the package directory: + +```sh +Rscript -e "setwd('SIMplyBee'); devtools::check(vignette = FALSE)" +``` +Run this for every code change so changes are evaluated +in the same package context (build, docs, and tests). + +Run slower package checks from the package directory: + +```sh +Rscript -e "setwd('SIMplyBee'); devtools::check()" +``` + +### Codex runner caveat: build-tools detection + +In the sandboxed agent runner, `devtools::check()` may fail early with: + +- `Could not find tools necessary to compile a package` + +even when compilers are installed. This is caused by sandbox +restrictions around `callr`/`processx` compiler probing, +not by a missing local toolchain. + +Use unsandboxed/escalated execution for full package checks. + +### Quarto caveat (why it can work interactively but fail in agent runs) + +`which quarto` can return `quarto not found`, +yet `devtools::check()` may still work +in interactive Positron/R sessions. + +On a Mac, Positron bundles Quarto at: + +`/Applications/Positron.app/Contents/Resources/app/quarto/bin/quarto` + +Interactive IDE sessions may discover this automatically; +non-IDE agent runs usually do not. +For reliable agent checks, prepend this directory to `PATH`: + +```sh +Rscript -e "Sys.setenv(PATH=paste('/Applications/Positron.app/Contents/Resources/app/quarto/bin', Sys.getenv('PATH'), sep=':')); setwd('SIMplyBee'); devtools::check()" +``` + +### Current expected check outcome + +`devtools::check()` completes in this environment. + +## Testing + +We strive for very good testing with `testthat`. + +- Add or update `testthat` tests for every behavior change. +- Prefer focused regression tests for bug fixes. +- Keep tests runnable via package tests and checks. +- Guard environment-dependent tests with explicit skips + (for example Python availability, network availability, and CRAN restrictions). + +For testing use: +- `Rscript -e "setwd('SIMplyBee'); devtools::test()"` + for interactive "mode" testing, or variants of this one, such as + `Rscript -e "setwd('SIMplyBee'); devtools::test(filter = 'TableCollection')`. + +Tests are also run as part of R CMD check. + +## Proofreading + +If asked to proofread, act as an expert proofreader and editor +with a deep understanding of clear, engaging, and well-structured writing. +Work paragraph by paragraph, +always starting by making a TODO list +that includes individual items for each heading. +Fix spelling, grammar, and other minor problems without asking. Label any unclear, confusing, or ambiguous sentences with +a TODO comment. +Only report what you have changed. From 393b3989c17edc018f7732e478f6f6ce1183dd22 Mon Sep 17 00:00:00 2001 From: Gregor Gorjanc Date: Wed, 13 May 2026 11:40:36 +0200 Subject: [PATCH 47/56] Adding document.yaml GitHub Action --- .github/workflows/document.yaml | 46 +++++++++++++++++++++++++++++++++ 1 file changed, 46 insertions(+) create mode 100644 .github/workflows/document.yaml diff --git a/.github/workflows/document.yaml b/.github/workflows/document.yaml new file mode 100644 index 00000000..24934b79 --- /dev/null +++ b/.github/workflows/document.yaml @@ -0,0 +1,46 @@ +# Workflow derived from https://github.com/r-lib/actions/tree/v2/examples +# Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help +on: + push: + paths: ["R/**"] + +name: document.yaml + +permissions: read-all + +jobs: + document: + runs-on: ubuntu-latest + env: + GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} + permissions: + contents: write + steps: + - name: Checkout repo + uses: actions/checkout@v4 + with: + fetch-depth: 0 + + - name: Setup R + uses: r-lib/actions/setup-r@v2 + with: + use-public-rspm: true + + - name: Install dependencies + uses: r-lib/actions/setup-r-dependencies@v2 + with: + extra-packages: any::roxygen2 + needs: roxygen2 + + - name: Document + run: roxygen2::roxygenise() + shell: Rscript {0} + + - name: Commit and push changes + run: | + git config --local user.name "$GITHUB_ACTOR" + git config --local user.email "$GITHUB_ACTOR@users.noreply.github.com" + git add man/\* NAMESPACE DESCRIPTION + git commit -m "Update documentation" || echo "No changes to commit" + git pull --ff-only + git push origin From 43872ff34f5cd70e0772f4c305dbb5d1852b3aa8 Mon Sep 17 00:00:00 2001 From: Gregor Gorjanc Date: Wed, 13 May 2026 11:44:15 +0200 Subject: [PATCH 48/56] Adding test-coverage.yaml GitHub Action --- .github/workflows/test-coverage.yaml | 75 ++++++++++++++++++++++++++++ 1 file changed, 75 insertions(+) create mode 100644 .github/workflows/test-coverage.yaml diff --git a/.github/workflows/test-coverage.yaml b/.github/workflows/test-coverage.yaml new file mode 100644 index 00000000..61692019 --- /dev/null +++ b/.github/workflows/test-coverage.yaml @@ -0,0 +1,75 @@ +# Workflow derived from https://github.com/r-lib/actions/tree/v2/examples +# Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help +on: + push: + branches: [main, devel] + pull_request: + +name: test-coverage.yaml + +permissions: read-all + +jobs: + test-coverage: + runs-on: ${{ matrix.config.os }} + + name: ${{ matrix.config.os }} (${{ matrix.config.r }}) + + strategy: + fail-fast: false + matrix: + config: + - { os: ubuntu-latest, r: "release" } + # - { os: macos-latest, r: "release" } + + env: + GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} + + steps: + - uses: actions/checkout@v4 + + - uses: r-lib/actions/setup-r@v2 + with: + r-version: ${{ matrix.config.r }} + http-user-agent: ${{ matrix.config.http-user-agent }} + use-public-rspm: true + + - uses: r-lib/actions/setup-r-dependencies@v2 + with: + extra-packages: any::covr, any::xml2 + needs: coverage + + - name: Test coverage + run: | + cov <- covr::package_coverage( + quiet = FALSE, + clean = FALSE, + install_path = file.path(normalizePath(Sys.getenv("RUNNER_TEMP"), winslash = "/"), "package") + ) + print(cov) + covr::to_cobertura(cov) + shell: Rscript {0} + + - uses: codecov/codecov-action@v5 + with: + # Fail if error if not on PR, or if on PR and token is given + # fail_ci_if_error: ${{ github.event_name != 'pull_request' || secrets.CODECOV_TOKEN }} + fail_ci_if_error: false + files: cobertura.xml # generated during the process + plugins: noop + disable_search: true + token: ${{ secrets.CODECOV_TOKEN }} + + - name: Show testthat output + if: always() + run: | + ## -------------------------------------------------------------------- + find '${{ runner.temp }}/package' -name 'testthat.Rout*' -exec cat '{}' \; || true + shell: bash + + - name: Upload test results + if: failure() + uses: actions/upload-artifact@v4 + with: + name: coverage-test-failures + path: ${{ runner.temp }}/package From a470e85b774be6d8bcc0cd995fe00d36d14b0d43 Mon Sep 17 00:00:00 2001 From: Gregor Gorjanc Date: Wed, 13 May 2026 11:46:47 +0200 Subject: [PATCH 49/56] Updating R CMD check GitHub Action --- .github/workflows/R-CMD-check.yaml | 32 +++++++++++++++++++++++++----- 1 file changed, 27 insertions(+), 5 deletions(-) diff --git a/.github/workflows/R-CMD-check.yaml b/.github/workflows/R-CMD-check.yaml index 16c2d7c5..30efe874 100644 --- a/.github/workflows/R-CMD-check.yaml +++ b/.github/workflows/R-CMD-check.yaml @@ -2,23 +2,42 @@ # Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help on: push: - branches: [devel, master] + branches: [main, devel] pull_request: - branches: [devel, master] -name: R-CMD-check +name: R-CMD-check.yaml + +permissions: read-all jobs: R-CMD-check: - runs-on: ubuntu-latest + runs-on: ${{ matrix.config.os }} + + name: ${{ matrix.config.os }} (${{ matrix.config.r }}) + + strategy: + fail-fast: false + matrix: + config: + - { os: macos-latest, r: "release" } + - { os: windows-latest, r: "release" } + - { os: ubuntu-latest, r: "devel", http-user-agent: "release" } + - { os: ubuntu-latest, r: "release" } + - { os: ubuntu-latest, r: "oldrel-1" } + env: GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} R_KEEP_PKG_SOURCE: yes + steps: - - uses: actions/checkout@v3 + - uses: actions/checkout@v4 + + - uses: r-lib/actions/setup-pandoc@v2 - uses: r-lib/actions/setup-r@v2 with: + r-version: ${{ matrix.config.r }} + http-user-agent: ${{ matrix.config.http-user-agent }} use-public-rspm: true - uses: r-lib/actions/setup-r-dependencies@v2 @@ -27,3 +46,6 @@ jobs: needs: check - uses: r-lib/actions/check-r-package@v2 + with: + upload-snapshots: true + build_args: 'c("--no-manual","--compact-vignettes=gs+qpdf")' From ff159745c623699153420c7a86543de4c58c00fb Mon Sep 17 00:00:00 2001 From: Gregor Gorjanc Date: Wed, 13 May 2026 11:56:01 +0200 Subject: [PATCH 50/56] air and jarl specs --- .Rbuildignore | 24 ++++++++++++++++-------- air.toml | 11 +++++++++++ jarl.toml | 6 ++++++ 3 files changed, 33 insertions(+), 8 deletions(-) create mode 100644 air.toml create mode 100644 jarl.toml diff --git a/.Rbuildignore b/.Rbuildignore index 2e0fc2b0..679a4f13 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -1,11 +1,20 @@ -^\.Rhistory -^\.Rproj\.user -^\.git -^\.github +^.*\.Rproj$ +^\.Rproj\.user$ +^\.Rhistory$ +^\.git$ +^\.github$ ^\.gitignore +^[.]?air[.]toml$ +^[.]?jarl[.]toml$ ^_pkgdown\.yml -^SIMplyBee\.Rproj +^cran-comments\.html$ +^cran-comments\.md$ +^cran-comments_files$ +^covr$ ^docs +^notes_pkg_dev\.Rmd$ +^vignettes/*_files$ +^vignettes/\.quarto$ ^vignettes/*R ^vignettes/*RData ^vignettes/*pdf @@ -13,7 +22,6 @@ ^vignettes/SIMplyBee\_logo\_hex\.R ^vignettes/SIMplyBee\_logo\_hex\.png ^vignettes/SIMplyBee\_logo\_small\.png -^.*\.Rproj$ -^\.Rproj\.user$ -^doc$ ^Meta$ +^SIMplyBee\.Rproj + diff --git a/air.toml b/air.toml new file mode 100644 index 00000000..5ad7d175 --- /dev/null +++ b/air.toml @@ -0,0 +1,11 @@ +[format] +line-width = 80 +indent-width = 2 +indent-style = "space" +line-ending = "auto" +persistent-line-breaks = true +exclude = [] +default-exclude = true +skip = [] +table = [] +default-table = true diff --git a/jarl.toml b/jarl.toml new file mode 100644 index 00000000..57ea069b --- /dev/null +++ b/jarl.toml @@ -0,0 +1,6 @@ +[lint] +# Set the default assignment operator to report cases where "=" is used. +assignment = "<-" +# Use the default set of excluded files (mostly files that are automatically +# generated by other tools). +default-exclude = true From d557e6cfcbdf80eac41d038147cd2fddffdf13e6 Mon Sep 17 00:00:00 2001 From: janaobsteter Date: Fri, 15 May 2026 14:38:43 +0200 Subject: [PATCH 51/56] Mapping individual to colony variances --- NAMESPACE | 1 + R/Functions_L1_Pop.R | 28 +- .../F2_Variance_calculations_functions.Rmd | 868 +++++++++++++++--- vignettes/H_Parallelisation.Rmd | 84 +- vignettes/TestVarianceMapping.R | 427 +++++++++ 5 files changed, 1226 insertions(+), 182 deletions(-) create mode 100644 vignettes/TestVarianceMapping.R diff --git a/NAMESPACE b/NAMESPACE index 5222f2f6..9e20e95b 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -33,6 +33,7 @@ export(createMultiColony) export(createVirginQueens) export(createWorkers) export(cross) +export(crossVirginQueen) export(downsize) export(downsizePUnif) export(getCaste) diff --git a/R/Functions_L1_Pop.R b/R/Functions_L1_Pop.R index 77abab82..f69c365c 100644 --- a/R/Functions_L1_Pop.R +++ b/R/Functions_L1_Pop.R @@ -1734,7 +1734,6 @@ cross <- function(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@misc[["nWorkers"]] <- 0 @@ -1780,3 +1779,30 @@ cross <- function(x, return(ret) } + + +#' @rdname crossVirginQueen +#' @title Internal function to cross a virgin queen +#' +#' @description Internal function to cross a virgin queen +#' +#' @param virginQueen \code{\link[AlphaSimR]{Pop-class}} +#' @param virginQueenDrones, list with drones +#' @param simParamBee, SimParamBee object +#' +#' @export +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)) { #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/vignettes/F2_Variance_calculations_functions.Rmd b/vignettes/F2_Variance_calculations_functions.Rmd index 015f41a3..d49037dd 100644 --- a/vignettes/F2_Variance_calculations_functions.Rmd +++ b/vignettes/F2_Variance_calculations_functions.Rmd @@ -1,15 +1,15 @@ --- - title: "Variance calculations between individual and colony level values" +title: "Variance calculations between individual and colony level values" date: "`r Sys.Date()`" output: rmarkdown::html_vignette vignette: > -%\VignetteIndexEntry{VarianceCalculations} -%\VignetteEngine{knitr::rmarkdown} -%\VignetteEncoding{UTF-8} + %\VignetteIndexEntry{VarianceCalculations} + %\VignetteEngine{knitr::rmarkdown} + %\VignetteEncoding{UTF-8} editor_options: markdown: - wrap: 80 -canonical: true + wrap: 80 + canonical: true --- ```{r setup, include = FALSE} @@ -20,37 +20,19 @@ knitr::opts_chunk$set( ) ``` -```{r cor2cov, include = FALSE} -cor2cov <- function(corr, var) { - # Ensure inputs are matrices/vectors - corr <- as.matrix(corr) - var <- as.numeric(var) - - # Standard deviations - sd <- sqrt(var) - - # Covariance matrix - cov <- corr * (sd %o% sd) - - return(cov) -} -``` - -Let's again run the example from the quantitative genetic vignette. - ```{r FirstExampleFromQuanGenVignette} -# Run the example from the quantitative genetic vignette +library(package = "SIMplyBee") founderGenomes <- quickHaplo(nInd = 20, nChr = 16, segSites = 1000) SP <- SimParamBee$new(founderGenomes) nQtlPerChr <- 100 mean <- c(10, 10 / SP$nWorkers) varA <- c(1, 1 / SP$nWorkers) -corA <- matrix(data = c( 1.0, -0.5, - -0.5, 1.0), nrow = 2, byrow = TRUE) +corA <- matrix(data = c( 1.0, -0.5, + -0.5, 1.0), nrow = 2, byrow = TRUE) SP$addTraitA(nQtlPerChr = nQtlPerChr, mean = mean, var = varA, corA = corA, name = c("queenTrait", "workersTrait")) varE <- c(3, 3 / SP$nWorkers) -corE <- matrix(data = c(1.0, 0.3, +corE <- matrix(data = c(1.0, 0.3, 0.3, 1.0), nrow = 2, byrow = TRUE) SP$setVarE(varE = varE, corE = corE) basePop <- createVirginQueens(founderGenomes, n = 20) @@ -67,145 +49,755 @@ apiary <- cross(x = apiary, drones = drones, crossPlan = "create", checkCross = apiary <- buildUp(apiary) colonyGv <- calcColonyGv(apiary) colonyPheno <- calcColonyPheno(apiary) - ``` -How the expected and realised variances look like -```{r} -k <- 1 -print("Expected genetic and phenotypic variance") +The idea of this work is: + +1) We want to do honey bee simulations with individual queens, drones, and + workers + +2) To do the above, we require individual variances and covariances + +3) Literature reports only variances and covariances at the colony level + +4) The aim of this paper is to show how to use variances and covariances at the + colony level to do simulations at the individual level. + +# Introduction WORK IN PROGRESS + +This document develops theory for the variance of genetic and phenotypic values +between colonies with the aim to understand how to fine tune a SIMplyBee +simulation where we need variance components for queen and workers effects at an +individual honeybee level. The challenge here is that in reality we do not +observe such variances, but only on a colony level. + +For example, in the vignette we assumed that phenotypic variance on the +individual level is about 1/4 due to genetic variation and about 3/4 due to +environmental variation, but looking at colony genetic and phenotypic variances +the ratio was about 1/2! + +TODO: What do we do about this? It feels like we need a full paper on all of +this;) :( + +INTRODUCTION + +TODO: Topic 1 + +TODO: cite this paper that does honeybee simulations, but without actually doing +honeybee colony stuff etc. Heritability in honeybees paper: + + +TOOD: cite some classic papers on variances in honeybees + +TODO: cite recent papers from German and Dutch colleagues on variances in +honeybees + +Brascamp and Bijma (2014): Methods to estimate breeding values in honey bees + + +Brascamp and Bijma (2019): A note on genetic parameters and accuracy of +estimated breeding values in honey bees + + +Andonov et al.: Modeling honey yield, defensive and swarming behaviors of +Italian honey bees (Apis mellifera ligustica) using linear-threshold approaches + + +To make use of the material in this document you should run the quantitative +genetics vignette - the first example. Then you can continue here! + +Having multiple colonies and their values, we can now return to the "about" +point mentioned at the start of this section, when we defined quantitative +genetic parameters. Recall that our starting quantitative genetic parameters for +the queen and workers effects were: + +We will follow the example from Brascamp and Bijma (2019) they have: + +$\sigma_{g_q}^2=0.5$ - this is their $\sigma_{A_q}^2=0.5$ + +$\sigma_{g_w}^2=1.0$ - this is their $\sigma_{A_w}^2=1.0$ among nominally +unrelated groups of workers + +$\sigma_{\bar{g}_w}^2=0.32$ - this is their $\sigma_{\bar{A}_w}^2=0.32$ among +base related groups of workers + +Where the relationship between the two is +$\sigma_{\bar{g}_w}^2 = a_{ii} * \sigma_{g_w}^2$ where $a_{ii}$ is average +additive genetic relationship between workers in a colony as can be defined (in +a non-inbred population) as +$a_{ii} = 1/4 + 1/2p_1 + 1/4(p_2 - p_1) + 1/4(1 - p_2)a_{ss}$; where $p_1$ is +the probability that two workers descend from the same drone, $p_2$ is the +probability that they descend from the same DPQ, and $a_{ss}$ is the relatedness +between two DPQs. We are ignore the $a_{ss}$ part (TODO?). + +$\sigma_{{g_q},{g_w}}=-0.35$ + +$\sigma_{P}^2 = \sigma_{\bar{g}_w^w}^2 + \sigma_{g_q^q}^2 + 2*\sigma_{\bar{g}_w^w g_q^q} + \sigma_{E}^2$ + +$\sigma_e^2=2.0$ + +$h^2=(a_{base}\sigma_{g,w}^2 + \sigma_{{g,w},{g,q}} + \sigma_{g,q}^2)/\sigma_{p,c}^2=???$ + +$h_w^2=a_{base}\sigma_{g,w}^2/\sigma_{p,c}^2=0.13$ + +$h_q^2=\sigma_{g,q}^2/\sigma_{p,c}^2=0.20$ + +$T^2=(\sigma_{g,w}^2 + 2\sigma_{{g,w},{g,q}} \sigma_{g,q}^2)/\sigma_{p,c}^2=0.32$ + +$T_w^2=\sigma_{g,w}^2/\sigma_{p,c}^2=0.41$ + +$T_q^2=\sigma_{g,q}^2/\sigma_{p,c}^2=0.20$ + +$r_g = cor(g_w, g_q) = -0.50$ + +TODO: equation 3 in Brascamp and Bijma (2019) is highly relevant to our work +here - that equation shows connection between the variance of the sum (or +average) of worker genetic values for worker effect AND variance of worker +genetic values for worker effect - THIS IS NOT TRUE they always work with the +worker group effect, never individuals! + +TODO: show sensitivity to the number of workers - the larger the number of +workers, the smaller the variance between workers + +covA[1, 1] + nW \* covA[2, 2] + 2 \* k \* covA[1, 2] + +```{r quan_gen_param_revision} +# Trait means +mean + +# Trait genetic variation - on a per honeybee level +varA +corA +(covA <- corA * outer(X = sqrt(varA), Y = sqrt(varA), FUN = "*")) + +# Trait environmental variation - on a per honeybee level +varE +corE +(covE <- corE * outer(X = sqrt(varE), Y = sqrt(varE), FUN = "*")) + +# Trait phenotypic variation - on a per honeybee level +(covP <- covA + covE) +(corP <- cov2cor(covP)) +(varP <- diag(covP)) + +# Expected phenotypic variation - on a per colony level +# TODO: there is in fact more stuff happening here - see below! +nW <- SP$nWorkers # TODO: this is not correct - we have queen-workers pairs and workers-workers (see below!) +# Var(z)=Var(x+y)=Var(x)+Var(sum(y))=Var(x)+Var(y_1)+Var(y_2)+... +# this is all wrong likely ... + +k <- 1 # just adding this so vignette can run, but I don't know what this k should be + covA[1, 1] + nW * covA[2, 2] + 2 * k * covA[1, 2] # variance can not be negative! covP[1, 1] + nW * covP[2, 2] + 2 * k * covP[1, 2] -print("Realised genetic and phenotypic variance") +# Observed variation - on a per colony level var(colonyGv) var(colonyPheno) +var(colonyGv) / var(colonyPheno) ``` -Now, in theory, how we go from the individual to colony level variances? -The queen trait variance remains the same, since there is only one queen. The worker -individual variance needs to be adjusted due to covariances between workers. +Hmm, we have much higher genetic and phenotypic variances in simulation than +based simply looking at queen and n\*workers variances, as well as much higher +ratio between the two than the initial value of \~1/4! Why? Let's see. For +genetic value of a colony $g_c$ we add up the queen's genetic value for the +queen effect $g_{q,q}$ and workers' genetic values for the workers effect +$\Sigma_{i=1}^{n_w}(g_{i,w})$: + +$g_c = g_{q,q} + \Sigma_{i=1}^{n_w}(g_{i,w}).$ + +Expectation of colony genetic value is then: + +$E(g_c) = E(g_{q,q} + \Sigma_{i=1}^{n_w}(g_{i,w}))$ + +$E(g_c) = E(g_{q,q}) + E(\Sigma_{i=1}^{n_w}(g_{i,w}))$ + +$E(g_c) = \mu_{g_{q}} + n_w E(g_{w,w})$ + +$E(g_c) = \mu_{g_{q}} + n_w \mu_{g_{w}}$ + +we are assuming here that $n_w$ is a fixed value, but if it is a random variable +then we would have + +$E(g_c) = \mu_{g_{q}} + E(n_w) E(g_{w,w})$ using + + +$E(g_c) = \mu_{g_{q}} + \lambda_{n_w} \mu_{g_{w}}$ + +where $\lambda_{n_w}$ is average number of workers. So, in our case this turns +out the same as above. So in our case we have: ```{r} -a_ii = 0.40 -varA_colony <- c(varA[1], varA[2] * a_ii) -corA = cov2cor(covA) -covA_colony = cor2cov(corA, var = varA_colony) +nW <- SP$nWorkers +mean[1] + nW * mean[2] +mean(colonyGv) +mean(colonyPheno) +``` -covA[1, 1] + nW * covA[2, 2] + 2 * k * covA[1, 2] -covA_colony[1, 1] + covA_colony[2, 2] + 2 * k * covA_colony[1, 2] +Variance of colony genetic value is then: + +$Var(g_c) = Var(g_{q,q} + \Sigma_{i=1}^{n_w}(g_{i,w}))$ + +$Var(g_c) = Var(g_{q,q}) + Var(\Sigma_{i=1}^{n_w}(g_{i,w})) + 2Cov(g_{q,q}, \Sigma_{i=1}^{n_w}(g_{i,w}))$ + +$Var(g_c) = \sigma^2_{g_{q}} + Var(\Sigma_{i=1}^{n_w}(g_{i,w})) + 2Cov(g_{q,q}, \Sigma_{i=1}^{n_w}(g_{i,w}))$ + +So, we have three parts: + +A) the variance of the queen effect in queens $\sigma^2_{g_{q}}$, + +B) variance of a sum of workers effect in workers + $Var(\Sigma_{i=1}^{n_w}(g_{i,w}))$, and + +C) covariance between the two $2Cov(g_{q,q}, \Sigma_{i=1}^{n_w}(g_{i,w}))$. + +# A) Variance of the queen effect in queens $\sigma^2_{g_{q}}$ - in our case this is: + +```{r check_queen_variances} +varA[1] +x = getQueenGv(apiary, collapse = TRUE)[, "queenTrait"] +var(x) +# ... note that R's var() divides by n-1, which matters with small n +popVar(x) +sum((x - mean[1])^2) / nColonies(apiary) -var(colonyGv) -var(colonyPheno) ``` -We need to add the covariance due to different types of workers in the colony -```{r} -# Get the real number of fathers and DPQs -nFathers(apiary) -median(sapply(getFathers(apiary), FUN = function(x) length(unique(x@father)))) +Anyway, quite close! + +# B) Variance of a sum of workers effect in workers $Var(\Sigma_{i=1}^{n_w}(g_{i,w}))$ + +Given that this is a sum, we need to look at: + +B1) variance of each of worker genetic values $Var(g_{i,w})$ and + +B2) covariance between each pair of the values $Cov(g_{i,w}, g_{j,w})$. + +This means, that family structure will start to matter because it induces +covariance between family members (workers). The simplest case is when all +workers come from the same father. Then we have: + +$g_{1,w} = \frac{1}{2}g_{q,w} + g_{f,w} + r_{1,w}$ + +$g_{2,w} = \frac{1}{2}g_{q,w} + g_{f,w} + r_{2,w}$ + +... + +$g_{n_w,w} = \frac{1}{2}g_{q,w} + g_{f,w} + r_{n_w,w}$ + +## B1) variance of each of worker genetic values $Var(g_{i,w})$ + +As stated initially, we have $Var(g_{i,w}) = \sigma^2_{g_{w}}$ and we have $n_w$ +such terms, $n_w \sigma^2_{g_{w}}$. In our case this would be: + +```{r check_workers_variances} +nW * varA[2] +g <- calcColonyGv(apiary, mapCasteToColonyGv, queenTrait = NULL, workersTrait = "workersTrait") +var(g) +# ... note that R's var() divides by n-1, which matters with small n +sum((g - nW * mean[2])^2) / nColonies(apiary) +popVar(g) +``` + +So, a huge discrepancy between the variance of a sum of genetic values for the +workers effect `nW * varA[2]` (assuming independence) and a realised sum of +genetic values for the workers effect. As we have seen above, this is due to +family structure and associated B2) covariance between each pair of the values +$Cov(g_{i,w}, g_{j,w})$. + +## B2) covariance between each pair of the values $Cov(g_{i,w}, g_{j,w})$ + +Clearly, these covariances matter a lot - there is lots of worker pairs in a +colony! How do these covariances look like? + +$Cov(g_{1,w}, g_{2,w}) = Cov(\frac{1}{2}g_{q,w} + g_{f,w}, \frac{1}{2}g_{q,w} + g_{f,w})$ + +$Cov(g_{1,w}, g_{2,w}) = Var(\frac{1}{2}g_{q,w}) + Var(g_{f,w})$ + +assuming that mother and father are not related; further genetic variance +between drones is in fact half the genetic variance between queens because they +are haploid, so we get: + +$Cov(g_{1,w}, g_{2,w}) = \frac{1}{4}\sigma^2_{g_w} + \frac{1}{4}\sigma^2_{g_w}$ + +$Cov(g_{1,w}, g_{2,w}) = \frac{1}{2}\sigma^2_{g_w}$. + +Every pair of super-sister workers adds $\frac{1}{2}\sigma^2_{g_w}$ to B - note +that pair A-B adds this value, but so does the pair B-A, hence total is +$2\frac{1}{2}\sigma^2_{g_w} = \sigma^2_{g_w}$. With $n_w$ workers we get +$n_w n_w$ pairs (including with itself) or $n_w n_w - n_w$ pairs between +different workers. The total covariance contribution is then +$(n_w n_w - n_w)\frac{1}{2}\sigma^2_{g_w}$). In our case this would be: + +```{r check_workers_variances2} +(varSumWorkers <- nW * varA[2]) # B1 +(covSumWorkers <- (nW * nW - nW) * 1/2 * varA[2]) # B2 +varSumWorkers + covSumWorkers # B + +g <- calcColonyGv(apiary, mapCasteToColonyGv, queenTrait = NULL, workersTrait = "workersTrait") +var(g) # B +# ... note that R's var() divides by n-1, which matters with small n +sum((g - nW * mean[2])^2) / nColonies(apiary) # B +popVar(g) +``` + +If we would only have super-sisters we would have \~1 for B1, \~49.5 for B2, and +\~50.5 for B, but with a mix of half-sisters and super-sisters we would have a +lower value, which is what we see above, \~26.8 for B. + +TODO: Define the setting above in intro or start of M&M - We also can have +full-sisters, where the mother is obviously the same, but the fathers are +different, yet they come from the same mother, which is equivalent to a +full-sibs case in diploid species. We will assume in this work that we have +unrelated queens and unrelated drones (=base pop) - our aim is to set variances +in such a base population - to get the scale or the variances right. In +simulation of our base population we generated drones from virgin queens, which +means that our drones can in fact be brothers, so our realised variances might +be a bit off compared to this theory. But this is fine, we are mostly trying to +get the order of variances correct. + +So, now we need to work out B2 with a mix of half-sisters and super-sisters :( +Sister workers are related only due to having the same mother, assuming that +drones the queen mated with are unrelated: + +$g_{1,w} = \frac{1}{2}g_{q,w} + g_{f1,w} + r_{1,w}$ + +$g_{2,w} = \frac{1}{2}g_{q,w} + g_{f2,w} + r_{2,w}$ + +$Cov(g_{1,w}, g_{2,w}) = Cov(\frac{1}{2}g_{q,w} + g_{f1,w}, \frac{1}{2}g_{q,w} + g_{f2,w})$ + +$Cov(g_{1,w}, g_{2,w}) = Var(\frac{1}{2}g_{q,w})$ + +$Cov(g_{1,w}, g_{2,w}) = \frac{1}{4}Var(g_{q,w})$ + +Hence every pair of half-sister workers adds $\frac{1}{4}\sigma^2_{g_w}$ to B +(note, this is $2\frac{1}{4}\sigma^2_{g_w}$ for A-B and B-A pairs!). With $n_w$ +workers and $n_f$ fathers we have $\frac{n_w}{n_f}$ workers per father. Further, +we have $n_f$ groups of super-sisters and $n_f n_f - n_f$ pairs of sister +groups. Assuming that half-sister groups are the same size, we have +$n_f \frac{n_w}{n_f} \frac{n_w}{n_f} = n_w \frac{n_w}{n_f} = \frac{n^2_w}{n_f}$ +pairs of super-sisters and $(n_f n_f - n_f) \frac{n_w}{n_f} \frac{n_w}{n_f}$ - +this is +$n_f (n_f - 1) \frac{n_w}{n_f} \frac{n_w}{n_f} = (n_f - 1) n_w \frac{n_w}{n_f} = \frac{ (n_f - 1) n^2_w}{n_f}$. +Is this correct? + +```{r pairs_of_workers} +(nF <- nFathers(colony)) +nW * nW +(a <- nW * nW / nF) +(b <- (nF - 1) * nW * nW / nF) +a+b +#TODO define nDPQ +``` + +Looks like! + +So, super-sister pairs add $\frac{n^2_w}{n_f} \frac{1}{2}\sigma^2_{g_w}$ and +half-sister pairs add $\frac{ (n_f - 1) n^2_w}{n_f} \frac{1}{4}\sigma^2_{g_w}$. +Let's test this: + +```{r check_workers_variances3} +(varSumWorkers <- nW * varA[2]) # B1 +(covSumWorkersSuperSisters <- (nW * nW / nF) * 0.75 * varA[2]) # B2 in super-sisters ERROR: SHOULD BE 0.75 +(covSumWorkersHalfSisters <- ((nF - 1) * nW * nW / nF) * 0.25 * varA[2]) # B2 in half-sisters +varSumWorkers + covSumWorkersSuperSisters + covSumWorkersHalfSisters # B + +g <- calcColonyGv(apiary, mapCasteToColonyGv, queenTrait = NULL, workersTrait = "workersTrait") +var(g) # B +# ... note that R's var() divides by n-1, which matters with small n +sum((g - SP$nWorkers * mean[2])^2) / nColonies(apiary) # B +``` + +Cool - very close!!! There can be some difference because the formulae above +assume that we have fixed sizes of half-sister and super-sister groups. Also, +there can be full-sisters in there as well!!! + +TODO: We could also add full-sisters: To do this, we would have to assume how +many brother drones we use to figure out the grups + +TODO: What if $n_w$ is a random variable? Following + +we would use: + +$Var(XY) = (Var(X) + E(X)^2) (Var(Y) + E(Y)^2) - E(X)^2 E(Y)^2$ + +but this is for two variables, while I have $n_w$ genetic values, so this +reference result is not that useful in our case! Well, if $n_w$ varies between +colonies, this must boost variance of colony-level genetic values significantly, +because kind of start calculating variance between apples (small colonies) and +oranges (large colonies). -# Genetic values -nW = SP$nWorkers #100 #BB assumes mean - so calculate as if this is 1 -nF = SP$nFathers +# C) Covariance between the two $2Cov(g_{q,q}, \Sigma_{i-1}^{n_w}(g_{i,w}))$. + +Let's repeat: + +$g_{1,w} = \frac{1}{2}g_{q,w} + g_{f1,w} + r_{1,w}$ + +$g_{2,w} = \frac{1}{2}g_{q,w} + g_{f2,w} + r_{2,w}$ ... + +The essential bit here is: + +$Cov(g_{q,q}, g_{i,w}) = Cov(g_{q,q}, \frac{1}{2} g_{q,w})$ + +assuming that the queen and fathers are unrelated. Then: + +$Cov(g_{q,q}, g_{i,w}) = Cov(g_{q}, \frac{1}{2} g_{w})$ + +$Cov(g_{q,q}, g_{i,w}) = \frac{1}{2} Cov(g_{q}, g_{w})$ + +$Cov(g_{q,q}, g_{i,w}) = \frac{1}{2} \sigma_{g_{q},g_{w}}$ + +So: + +$2Cov(g_{q,q}, \Sigma_{i=1}^{n_w}(g_{i,w})) = 2Cov(g_{q,q}, n_w \frac{1}{2} g_{q,w})$ + +$2Cov(g_{q,q}, \Sigma_{i=1}^{n_w}(g_{i,w})) = 2 n_w \frac{1}{2}Cov(g_{q,q}, g_{q,w})$ + +$2Cov(g_{q,q}, \Sigma_{i=1}^{n_w}(g_{i,w})) = n_w \sigma_{g_{q},g_{w}}$ + +```{r check_workers_variances4} nDPQ = 5 +n_SS = (nW * nW / nF) - nW +n_FS = (nW * nW / nDPQ) - (nW * nW / nF) +n_HS = (nW * nW / nDPQ) * (nDPQ - 1) + +(n_SS + n_FS + n_HS + nW) == nW * nW -varA_q <- 1 -varA_w = 1 / SP$nWorkers -corA_qw = corA[1,2] - -# Covariance due to super-sisters -covSumWorkersSuperSisters <- (nW * nW / nF) * 0.75 * varA_w -# Covariance due to full-sisters -covSumWorkersFullSisters <- ((nW * nW / nDPQ) - (nW * nW / nF)) * 0.50 * varA_w -# Covariance due to half-sisters -covSumWorkersHalfSisters <- ((nF - 1) * nW * nW / nF) * 0.25 * varA_w - - - - -mapIndToColonyVar <- function(varA_q, varA_w, corA_qw, nW, nF, nDPQ, workersFUN = "sum") { - if (workersFUN == "mean") { - nW = 1 - } - - # Determine how many pairs of each you have - n_SS = nW * nW / nF - n_FS = (nW * nW / nDPQ) - (nW * nW / nF) - n_HS = (nW * nW / nDPQ) * (nDPQ - 1) - A <- varA_q - B1 <- nW * varA_w - B2_ss <- n_SS * 0.75 * varA_w - B2_fs <- n_FS * 0.50 * varA_w - B2_hs <- n_HS * 0.25 * varA_w - - covA_qw = corA_qw * sqrt(varA_q) * sqrt(varA_w) - C <- nW * covA_qw - - if (workersFUN == "sum") { - varC <- A + B1 + B2_ss + B2_fs + B2_hs + C - } else if (workersFUN == "mean") { - stop("TODO: derive this equation properly") - #varC <- varA_q + varA_w + (B2_ss + B2_fs + B2_hs) + covA_qw # This is equal as varA_w * average relatedness within a colony - } - return(varC) -} - -#This is the same as above, just simplified -mapIndToColonyVar <- function(varA_q, varA_w, corA_qw, nW, nF, nDPQ, workersFUN = "sum") { - - # Determina how many pairs of each you have - p_SS = 1 / nF - p_FS = (1 / nDPQ) - (1 / nF) - p_HS = (1 / nDPQ) * (nDPQ - 1) - A <- varA_q - B1 <- nW * varA_w - B2_ss <- p_SS * 0.75 - B2_fs <- p_FS * 0.50 - B2_hs <- p_HS * 0.25 - - covA_qw = corA_qw * sqrt(varA_q) * sqrt(varA_w) - C <- nW * covA_qw - - if (workersFUN == "sum") { - varC <- A + B1 + (B2_ss + B2_fs + B2_hs)*nW^2*varA_w + C - } else if (workersFUN == "mean") { - varC <- A + varA_w + (B2_ss + B2_fs + B2_hs)*varA_w + covA_qw# This is equal as varA_w * average relatedness within a colony - } - return(varC) -} +print("Genetic variances") +print("Part A") +(varQueen_A <- varA[1]) # A +print("Part B1") +(varSumWorkers_A <- nW * varA[2]) # B1 +print("Part B2 in super-sisters") +(covSumWorkersSuperSisters_A <- n_SS * 0.75 * varA[2]) # B2 in super-sisters +print("Part B2 in full-sisters") +(covSumWorkersFullSisters_A <- n_FS * 0.50 * varA[2]) # B2 in full-sisters +print("Part B2 in half-sisters") +(covSumWorkersHalfSisters_A <- n_HS * 0.25 * varA[2]) # B2 in half-sisters +print("Part B combined") +(varCovSumWorkers_A <- varSumWorkers_A + covSumWorkersSuperSisters_A + covSumWorkersFullSisters_A + covSumWorkersHalfSisters_A) # B +print("Part C") +(covQueenSumWorkers_A <- nW * covA[1, 2]) # C + +print("Part A + B + C") +varQueen_A + varCovSumWorkers_A + 2*covQueenSumWorkers_A + +print("ColonyGv variance") +g <- colonyGv +var(g) +popVar(g) +sum((g - (mean(g)))^2) / nColonies(apiary) ``` +Bingo for genetic variance. + ```{r} -# When the function to summarise worker effects is SUM -mapIndToColonyVar(varA_q = varA_q, - varA_w= varA_w, - corA_qw = corA_qw, - nW = nW, nF = nF, - nDPQ = nDPQ, - workersFUN = "sum") -colonyGv <- calcColonyGv(apiary, FUN = mapCasteToColonyGv, workersFUN = colSums) -var(colonyGv) + + +print("Environmental variance") +print("Part A") +(varQueen_E <- varE[1]) # A +print("Part B1") +(varSumWorkers_E <- nW * varE[2]) # B1, there is not environmental covariance between workers, so no B2 +print("Part C") +(covQueenSumWorkers_E <- nW * covE[1, 2]) # C - both genetic and env cove here? TODO + +print("Part A + B + C f") +varQueen_A + varCovSumWorkers_A + covQueenSumWorkers_A + varQueen_E + varSumWorkers_E + covQueenSumWorkers_E + +p <- colonyPheno +var(p) +popVar(p) +sum((p - (mean(p)))^2) / nColonies(apiary) ``` -```{r} -# When the function to summarise worker effects is MEAN -mapIndToColonyVar(varA_q = varA_q, - varA_w = varA_w * SP$nWorkers, - corA_qw = corA_qw, - nW = nW, nF = nF, - nDPQ = nDPQ, - workersFUN = "mean") -colonyGv <- calcColonyGv(apiary, FUN = mapCasteToColonyGv, workersFUN = colMeans) +And very close for phenotypic too, but we need to check some part above! + +# What now? + +Alright, what can we now do with this? We now have a system of expected genetic +and phenotypic variances for colony values as a function of number of workers, +fathers, and genetic and phenotypic covariances between the queen and worker +effects. So, it should be possible, in principle, to solve for what kind of +covariance values for the queen and workers effects should we use, to get the +desired colony genetic and phenotypic variances! + +TODO: develop such estimating equations! + +So, we have genetic part: + +$A_g = \sigma^2_{g_q}$ + +$B1_g = n_w \sigma^2_{g_w}$ + +$B2ss_g = (\frac{n^2_w}{n_f} - {n_w}) \frac{1}{2} \sigma^2_{g_w}$ + +$B2fs = (\frac{n^2_w}{n_{DPQ}} - \frac{n^2_w}{n_f}) \frac{1}{4} \sigma^2_{g_w}$ + +$B2hs_g = \frac{(n_f - 1) n^2_w}{n_f} \frac{1}{4} \sigma^2_{g_w}$ + +$C_g = n_w \sigma^2_{{g_q},{g_w}}$ + +here are 3 unknowns: $\sigma^2_{g_q}$, $\sigma^2_{g_w}$, and +$\sigma^2_{{g_q},{g_w}}$ + +we can add phenotypic part: + +$A_p = \sigma^2_{p_q}$ + +$B1_p = n_w \sigma^2_{p_w}$ + +$B2_p = \frac{n^2_w}{n_f} \frac{1}{2} \sigma^2_{g_w}$ TODO: check if its only +genetic + +$B3_p = \frac{(n_f - 1) n^2_w}{n_f} \frac{1}{4} \sigma^2_{g_w}$ TODO: check if +its only genetic + +$C_p = n_w \sigma^2_{{p_q},{p_w}}$ + +here are additional 3 unknowns: $\sigma^2_{p_q}$, $\sigma^2_{p_w}$, and +$\sigma^2_{{p_q},{p_w}}$ + +while we could provide as guidance 2, maybe 3, inputs: $\sigma^2_{g_c}$, +$\sigma^2_{p_c}$, and $\frac{\sigma^2_{g_c}}{\sigma^2_{p_c}}$. + +TODO: are there any additional inputs that we could get from literature? How do +we connect all this with variance estimates for the queen and the workers effect +in the honeybee genetics and breeding literature? I think that those estimates +are essentially this: +$\sigma^2_{g_c} = \sigma^2_{g_{c,q}} + \sigma^2_{g_{c,w}} + 2\sigma_{g_{c,q},g_{c,w}}$ +where $\sigma^2_{g_{c,q}}$ is the queen part of $\sigma^2_{g_c}$, but not +necessarily the same as $\sigma^2_{g_w}$, or is it? Maybe that is the same, and +$\sigma^2_{g_{c,w}}$ is a counterpart to +$n_w \sigma^2_{g_w} + \frac{n^2_w}{n_f} \frac{1}{2} \sigma^2_{g_w}, \frac{(n_f - 1) n^2_w}{n_f} \frac{1}{4} \sigma^2_{g_w}$ +(TODO: should we add full-sisters?), while $\sigma_{g_{c,q},g_{c,w}}$ is a +counterpart to $n_w \sigma_{{g_q},{g_w}}$. If this is so, then it fells that we +should have 3 more inputs for genetic part, so 4 inputs to estimate 3 unknowns +of which some are very simple transformations!!! + +Additional input could be $\sigma^2_{p_c}$. For sure we don't get estimates of +$\sigma^2_{p_c} = \sigma^2_{p_{c,q}} + \sigma^2_{p_{c,w}} + 2\sigma_{p_{c,q},p_{c,w}}$, +but, having sorted the genetic part and if $B2_p$ and $B3_p$ depend only on +genetic covariance, then maybe, we have some maneuvering space to estimate also +$\sigma^2_{p_q}$, $\sigma^2_{p_w}$, and $\sigma^2_{{p_q},{p_w}}$?! + +Furthermore, we have some constraints, so this is not just any system of +equations. For example, we know that variances must be positive. Futhermore, we +might know that come covariances are either positive or negative. + +TODO: Develop and polish all this further and create a Shiny application where +we can change these individual-level parameters and study how that will change +colony-level parameters and then how we could go the other way around based on +literature and solving the above systems of equations. We could host such a +Shiny app on SIMplyBee.info!? Can we? + +NEXT STEPS: + +1) read the above, check derivations, missing bits, etc. + +2) write a function that takes individual variances, nw, nf, etc. and returns + colony variances and h2, t2, T2, ... + +3) develop a system of equations (using A, Bs, and C) linking individual and + colony values for two types of colony values (for different models beepeople + run!) - then find a way to optimize/solve for individual values (output) + with colony values as input + + +NOW - do the same, but for when the aggregate of the workers is a mean +```{r FirstExampleFromQuanGenVignette} +library(package = "SIMplyBee") +founderGenomes <- quickHaplo(nInd = 20, nChr = 16, segSites = 1000) +SP <- SimParamBee$new(founderGenomes) +nQtlPerChr <- 100 +mean <- c(10, 10) +varA <- c(1, 1) +corA <- matrix(data = c( 1.0, -0.5, + -0.5, 1.0), nrow = 2, byrow = TRUE) +SP$addTraitA(nQtlPerChr = nQtlPerChr, mean = mean, var = varA, corA = corA, + name = c("queenTrait", "workersTrait")) +varE <- c(3, 3) +corE <- matrix(data = c(1.0, 0.3, + 0.3, 1.0), nrow = 2, byrow = TRUE) +SP$setVarE(varE = varE, corE = corE) +basePop <- createVirginQueens(founderGenomes, n = 20) +head(basePop@gv) +head(basePop@pheno) +drones <- createDrones(x = basePop[1:5], nInd = 3) +colony <- createColony(x = basePop[6]) +colony <- cross(x = colony, drones = drones, checkCross = "warning") +colony <- addWorkers(x = colony, nInd = 50) +colony <- buildUp(colony) +apiary <- createMultiColony(basePop[7:20]) +drones <- createDrones(basePop[1:5], nInd = 100) +apiary <- cross(x = apiary, drones = drones, crossPlan = "create", checkCross = "warning") +apiary <- buildUp(apiary) +colonyGv <- unlist(mapCasteToColonyGv(x = apiary, queenTrait = 1, workersTrait = 2, workersFUN = colMeans)) +colonyPheno <- unlist(mapCasteToColonyPheno(x = apiary, queenTrait = 1, workersTrait = 2, workersFUN = colMeans)) +``` + + +```{r quan_gen_param_revision} +# Trait means +mean + +# Trait genetic variation - on a per honeybee level +varA +corA +(covA <- corA * outer(X = sqrt(varA), Y = sqrt(varA), FUN = "*")) + +# Trait environmental variation - on a per honeybee level +varE +corE +(covE <- corE * outer(X = sqrt(varE), Y = sqrt(varE), FUN = "*")) + +# Trait phenotypic variation - on a per honeybee level +(covP <- covA + covE) +(corP <- cov2cor(covP)) +(varP <- diag(covP)) + +# Expected phenotypic variation - on a per colony level +# TODO: there is in fact more stuff happening here - see below! +nW <- SP$nWorkers # TODO: this is not correct - we have queen-workers pairs and workers-workers (see below!) +# Var(z)=Var(x+y)=Var(x)+Var(sum(y))=Var(x)+Var(y_1)+Var(y_2)+... +# this is all wrong likely ... + +k <- 1 # just adding this so vignette can run, but I don't know what this k should be + + +# Observed variation - on a per colony level var(colonyGv) +var(colonyPheno) +var(colonyGv) / var(colonyPheno) ``` + + + +# A) Variance of the queen effect in queens $\sigma^2_{g_{q}}$ - in our case this is: + +```{r check_queen_variances} +varA[1] +x = getQueenGv(apiary, collapse = TRUE)[, "queenTrait"] +var(x) +# ... note that R's var() divides by n-1, which matters with small n +popVar(x) +sum((x - mean[1])^2) / nColonies(apiary) + ``` -```{r} -# Try to frame something for the other way around -# At best, we would have varA_q (colony), varA_w (colony), +Anyway, quite close! +# B) Variance of a sum of workers effect in workers $Var(\Sigma_{i=1}^{n_w}(g_{i,w}))$ + +Given that this is a sum, we need to look at: + +B1) variance of each of worker genetic values $Var(g_{i,w})$ and + +B2) covariance between each pair of the values $Cov(g_{i,w}, g_{j,w})$. + +This means, that family structure will start to matter because it induces +covariance between family members (workers). The simplest case is when all +workers come from the same father. Then we have: + +$g_{1,w} = \frac{1}{2}g_{q,w} + g_{f,w} + r_{1,w}$ + +$g_{2,w} = \frac{1}{2}g_{q,w} + g_{f,w} + r_{2,w}$ + +... + +$g_{n_w,w} = \frac{1}{2}g_{q,w} + g_{f,w} + r_{n_w,w}$ + +## B1) variance of each of worker genetic values $Var(g_{i,w})$ + +As stated initially, we have $Var(g_{i,w}) = \sigma^2_{g_{w}}$ and we have $n_w$ +such terms, $n_w \sigma^2_{g_{w}}$. In our case this would be: + +```{r check_workers_variances} +nW * varA[2] +g <- calcColonyGv(apiary, mapCasteToColonyGv, queenTrait = NULL, workersTrait = "workersTrait", workersFUN = colMeans) +var(g) +# ... note that R's var() divides by n-1, which matters with small n +#sum((g - 1/nW^2 * mean[2])^2) / nColonies(apiary) ? +popVar(g) +``` + +So, a huge discrepancy between the variance of a sum of genetic values for the +workers effect `nW * varA[2]` (assuming independence) and a realised sum of +genetic values for the workers effect. As we have seen above, this is due to +family structure and associated B2) covariance between each pair of the values +$Cov(g_{i,w}, g_{j,w})$. + +## B2) covariance between each pair of the values $Cov(g_{i,w}, g_{j,w})$ + +```{r pairs_of_workers} +(nF <- round(mean(nFathers(apiary)), 0)) +(nDPQ <- round(mean(sapply(getFathers(apiary), function(x) length(unique(x@mother)))), 0)) +nW * nW +(a <- nW * nW / nF) +(b <- (nF - 1) * nW * nW / nF) +a+b ``` +Looks like! + +So, super-sister pairs add $\frac{n^2_w}{n_f} \frac{1}{2}\sigma^2_{g_w}$ and +half-sister pairs add $\frac{ (n_f - 1) n^2_w}{n_f} \frac{1}{4}\sigma^2_{g_w}$. +Let's test this: + + +```{r check_workers_variances4} +n_SS = (nW * nW / nF) - nW +n_FS = (nW * nW / nDPQ) - (nW * nW / nF) +n_HS = (nW * nW / nDPQ) * (nDPQ - 1) + +(n_SS + n_FS + n_HS + nW) == nW * nW + +print("Genetic variances") +print("Part A") +(varQueen_A <- varA[1]) # A + +print("Part B1") +(varSumWorkers_A <- (1 / nW^2) * varA[2]) # B1 +print("Part B2 in super-sisters") +(covSumWorkersSuperSisters_A <- n_SS * 0.75 * varA[2]) # B2 in super-sisters +print("Part B2 in full-sisters") +(covSumWorkersFullSisters_A <- n_FS * 0.50 * varA[2]) # B2 in full-sisters +print("Part B2 in half-sisters") +(covSumWorkersHalfSisters_A <- n_HS * 0.25 * varA[2]) # B2 in half-sisters +print("Part B combined") +(varCovSumWorkers_A <- (1 / nW^2) * (varSumWorkers_A + covSumWorkersSuperSisters_A + covSumWorkersFullSisters_A + covSumWorkersHalfSisters_A)) #B +print("Part C") +(covQueenSumWorkers_A <- (1 / nW^2) * covA[1, 2]) # C + +print("Part A + B + C") +varQueen_A + varCovSumWorkers_A + covQueenSumWorkers_A + +print("ColonyGv variance") +g <- colonyGv +var(g) +popVar(g) +sum((g - (mean(g)))^2) / nColonies(apiary) +``` + +Bingo for genetic variance. + +```{r} +print("Environmental variance") +print("Part A") +(varQueen_E <- varE[1]) # A +print("Part B1") +(varSumWorkers_E <- (1 / nW^2) * varE[2]) # B1, there is not environmental covariance between workers, so no B2 +print("Part C") +(covQueenSumWorkers_E <- (1 / nW^2) * covE[1, 2]) # C - both genetic and env cove here? TODO + +print("Part A + B + C f") +varQueen_A + varCovSumWorkers_A + covQueenSumWorkers_A + varQueen_E + varSumWorkers_E + covQueenSumWorkers_E + +p <- colonyPheno +var(p) +popVar(p) +sum((p - (mean(p)))^2) / nColonies(apiary) +``` +And very close for phenotypic too, but we need to check some part above! diff --git a/vignettes/H_Parallelisation.Rmd b/vignettes/H_Parallelisation.Rmd index d967704b..2f7cde27 100644 --- a/vignettes/H_Parallelisation.Rmd +++ b/vignettes/H_Parallelisation.Rmd @@ -23,27 +23,28 @@ knitr::opts_chunk$set( # 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`. +environments. We recommend running these lines at the beginning of the +simulation. We do recommend reading the remaining of this vignette. ```{r quick_setup, eval=F, echo=T} library(SIMplyBee) -library(parallel) -library(doParallel) +library(future) -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() +NCORES = # e.g., 8 + +# Use function plan to set up parallel environment +# There are three options +# First one is no parallelisation, the default +plan(sequential) +# Second one is forking - it's quick but only works on Linux/MACOS on local machines (not HPCs!) +plan(multicore, workers = NCORES) +# Third one is PSOCK - works on all systems, including HPCs +plan(multisession, workers = NCORES) +# Fourth one is clust that runs separate R processes on multiple machines +plan(cluster, workers = c("machine1", "machine2", ...)) + +# At the end of everything you run to stop parallelisation back-end +plan(sequential) ``` # Introduction @@ -52,23 +53,27 @@ 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. +with `future` and `future.apply` R packages. Nothing changed in terms of running +the functions, but to parallelise your simulation, you need to set up a parallel +back-end with the function `plan` from the package `future` before starting the +simulation. You can set that to a desired number or make the simulation use all +available cores. As metioned in the quick set-up, there are three different +options to the `plan` function: no parallelisation (`sequential`), forking +(`multicore`), PSOCK (`multisession`), and running R processes on multiple +machines (`cluster`). You can read more about these options in the `future` +documentation (). ```{r nThread_setup} library(package = "SIMplyBee") -library(package = "parallel") +library(package = "future") + +# Set to the desired number of cores +plan(multisession, workers = 8) +# Or use all available cores +plan(multisession, workers = availableCores()) 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`. @@ -101,28 +106,22 @@ create_bee_colonies <- function() { ``` We set up different parallelisation back-ends with the following code, where -`ncores` was either 1 or 8. +`ncores` was either 1, 8, or 16. All options were tested on an HPC cluster. ```{r parallelisation_options, eval=F, echo=T} -# First one - ??? -SP$nThreads = ncores -registerDoParallel(cores = SP$nThreads) +# First one - sequential +plan(sequential) create_bee_colonies() -# Second one - create a FORK cluster -SP$nThreads = ncores -cl <- makeCluster(SP$nThreads, type="FORK") -registerDoParallel(cl) +# Second one - use forking +plan(multicore, workers = nCores) create_bee_colonies() -stopImplicitCluster() -# Third one - create a PSOCK cluster -SP$nThreads = ncores -cl <- makeCluster(SP$nThreads, type="PSOCK") -registerDoParallel(cl) + +# Third one - use PSOCK parallelisation +plan(multisession, workers = nCores) create_bee_colonies() -stopImplicitCluster() ``` Here are the results of running these different options. You can see that the @@ -159,4 +158,3 @@ replicates. ```{r functions_time, echo=FALSE, out.width='100%'} knitr::include_graphics("Profiling_parallelised_functions_Unix.png") ``` - diff --git a/vignettes/TestVarianceMapping.R b/vignettes/TestVarianceMapping.R new file mode 100644 index 00000000..e0b5805d --- /dev/null +++ b/vignettes/TestVarianceMapping.R @@ -0,0 +1,427 @@ +library(SIMplyBee) +library(tidyr) +library(ggplot2) + +# Create a function that maps individual to colony variance +mapIndToColonyVar <- function(varA_q, varA_w, corA_qw, + varE_q, varE_w, corE_qw, + nW, nF, nDPQ, workersFUN = "sum") { + + # First handle the genetic part + # Determine how many pairs of each you have + nW = nW + n_SS = (nW * nW / nF) - nW + n_FS = (nW * nW / nDPQ) - (nW * nW / nF) + n_HS = (nW * nW / nDPQ) * (nDPQ - 1) + + varA_q <- varA_q + if (workersFUN == "mean") { + B1 = 1 / nW * varA_w + } else if (workersFUN == "sum") { + B1 = nW * varA_w + } + + B2_ss <- n_SS * 0.75 * varA_w + B2_fs <- n_FS * 0.50 * varA_w + B2_hs <- n_HS * 0.25 * varA_w + + if (workersFUN == "mean") { + varA_wbar = B1 + 1/nW^2 * (B2_ss + B2_fs + B2_hs) + } else if (workersFUN == "sum") { + varA_wbar = B1 + B2_ss + B2_fs + B2_hs + } + + covA_qw = corA_qw * sqrt(varA_q) * sqrt(varA_w) + + if (workersFUN == "mean") { + covA_qwbar <- covA_qw + } else if (workersFUN == "sum") { + covA_qwbar <- nW * covA_qw + } + corA_qwbar <- covA_qwbar / (sqrt(varA_q) * sqrt(varA_wbar)) + + varA_c <- varA_q + varA_wbar + 2*covA_qwbar + + # Next handle the environmental part + if (workersFUN == "mean") { + varE_wbar = 1 / nW * varE_w + } else if (workersFUN == "sum") { + varE_wbar = nW * varE_w + } + + covE_qw = corE_qw * sqrt(varE_q) * sqrt(varE_w) + + if (workersFUN == "mean") { + covE_qwbar <- covE_qw + } else if (workersFUN == "sum") { + covE_qwbar <- nW * covE_qw + } + corE_qwbar <- covE_qwbar / (sqrt(varE_q) * sqrt(varE_wbar)) + + varE_c <- varE_q + varE_wbar + 2*covE_qwbar + + return(list(varA_q = varA_q, varA_wbar = varA_wbar, covA_qwbar = covA_qwbar, corA_qwbar = corA_qwbar, varA_c = varA_c, + varE_q = varE_q, varE_wbar = varE_wbar, covE_qwbar = covE_qwbar, corE_qwbar = corE_qwbar, varE_c = varE_c)) +} + +# Test the function through reps +nRep = 10 +variances0 = data.frame() + +for (rep in 1:nRep) { + print(paste0("Mean, rep ", rep)) + founderGenomes <- quickHaplo(nInd = 20, nChr = 16, segSites = 1000) + SP <- SimParamBee$new(founderGenomes) + nQtlPerChr <- 100 + mean <- c(0, 0) + varA <- c(1, 1) + corA <- matrix(data = c( 1.0, -0.5, + -0.5, 1.0), nrow = 2, byrow = TRUE) + SP$addTraitA(nQtlPerChr = nQtlPerChr, mean = mean, var = varA, corA = corA, + name = c("queenTrait", "workersTrait")) + varE <- c(3, 3) + corE <- matrix(data = c(1.0, 0.3, + 0.3, 1.0), nrow = 2, byrow = TRUE) + SP$setVarE(varE = varE, corE = corE) + basePop <- createVirginQueens(founderGenomes, n = 20) + head(basePop@gv) + head(basePop@pheno) + drones <- createDrones(x = basePop[1:5], nInd = 3) + colony <- createColony(x = basePop[6]) + colony <- cross(x = colony, drones = drones, checkCross = "warning") + colony <- addWorkers(x = colony, nInd = 50) + colony <- buildUp(colony) + apiary <- createMultiColony(basePop[7:20]) + drones <- createDrones(basePop[1:5], nInd = 100) + apiary <- cross(x = apiary, drones = drones, crossPlan = "create", checkCross = "warning") + apiary <- buildUp(apiary) + colonyGv <- calcColonyGv(apiary) + + # Get the real number of fathers and DPQs + nW = round(mean(nWorkers(apiary)), 0) + nF = round(mean(nFathers(apiary)), 0) + nDPQ <- round(mean(sapply(getFathers(apiary), function(x) length(unique(x@mother)))), 0) + + + # When the function to summarise worker effects is SUM + calcVar <- mapIndToColonyVar(varA_q = varA[1], + varA_w= varA[2], + corA_qw = corA[1,2], + varE_q = varE[1], + varE_w = varE[2], + corE_qw = corE[1,2], + nW = nW, nF = nF, + nDPQ = nDPQ, + workersFUN = "mean") + + real_gv_q <- calcColonyGv(apiary, FUN = mapCasteToColonyGv, queenTrait = 1, workersTrait = NULL) + real_gv_wbar <- calcColonyGv(apiary, FUN = mapCasteToColonyGv, queenTrait = NULL, workersTrait = 2, workersFUN = colMeans) + real_covA_qwbar <- cov(real_gv_q, real_gv_wbar) + real_corA_qwbar <- cor(real_gv_q, real_gv_wbar) + real_varA_q <- var(real_gv_q) + real_varA_wbar <- var(real_gv_wbar) + real_varA_c <- var(calcColonyGv(apiary, FUN = mapCasteToColonyGv, workersFUN = colMeans)) + real_varP_c <- var(calcColonyPheno(apiary, FUN = mapCasteToColonyPheno, workersFUN = colMeans)) + + variances0 <- rbind(variances0, data.frame(rep = rep, + calc_varA_q = calcVar$varA_q, calc_varA_wbar = calcVar$varA_wbar, calc_varA_c = calcVar$varA_c, calc_varE_c = calcVar$varE_c, + real_varA_q = real_varA_q[1,1], real_varA_wbar = real_varA_wbar[1,1], real_varA_c = real_varA_c[1,1], + real_covA_qwbar = real_covA_qwbar[1,1], real_corA_qwbar = real_corA_qwbar[1,1], + real_varP_c = real_varP_c[1,1], + fun = "mean")) + + print(paste0("Sum, rep ", rep)) + # Run the example from the quantitative genetic vignette + founderGenomes <- quickHaplo(nInd = 20, nChr = 16, segSites = 1000) + SP <- SimParamBee$new(founderGenomes) + SP$nWorkers <- 100 + SP$nFathers <- 15 + nQtlPerChr <- 100 + mean <- c(0, 0) + varA <- c(1, 1 / SP$nWorkers) + corA <- matrix(data = c( 1.0, -0.5, + -0.5, 1.0), nrow = 2, byrow = TRUE) + SP$addTraitA(nQtlPerChr = nQtlPerChr, mean = mean, var = varA, corA = corA, + name = c("queenTrait", "workersTrait")) + varE <- c(3, 3 / SP$nWorkers) + corE <- matrix(data = c(1.0, 0.3, + 0.3, 1.0), nrow = 2, byrow = TRUE) + SP$setVarE(varE = varE, corE = corE) + + basePop <- createVirginQueens(founderGenomes, n = 20) + head(basePop@gv) + head(basePop@pheno) + drones <- createDrones(x = basePop[1:5], nInd = 3) + colony <- createColony(x = basePop[6]) + colony <- cross(x = colony, drones = drones, checkCross = "warning") + colony <- addWorkers(x = colony, nInd = 50) + colony <- buildUp(colony) + apiary <- createMultiColony(basePop[7:20]) + drones <- createDrones(basePop[1:5], nInd = 100) + apiary <- cross(x = apiary, drones = drones, crossPlan = "create", checkCross = "warning") + apiary <- buildUp(apiary) + colonyGv <- calcColonyGv(apiary) + colonyPheno <- calcColonyPheno(apiary) + + nW = round(mean(nWorkers(apiary)), 0) + nF = round(mean(nFathers(apiary)), 0) + nDPQ <- round(mean(sapply(getFathers(apiary), function(x) length(unique(x@mother)))), 0) + + + # When the function to summarise worker effects is SUM + calcVar <- mapIndToColonyVar(varA_q = varA[1], + varA_w= varA[2], + corA_qw = corA[1,2], + varE_q = varE[1], + varE_w = varE[2], + corE_qw = corE[1,2], + nW = nW, nF = nF, + nDPQ = nDPQ, + workersFUN = "sum") + + real_gv_q <- calcColonyGv(apiary, FUN = mapCasteToColonyGv, queenTrait = 1, workersTrait = NULL) + real_gv_wbar <- calcColonyGv(apiary, FUN = mapCasteToColonyGv, queenTrait = NULL, workersTrait = 2, workersFUN = colSums) + real_covA_qwbar <- cov(real_gv_q, real_gv_wbar) + real_corA_qwbar <- cor(real_gv_q, real_gv_wbar) + real_varA_q <- var(real_gv_q) + real_varA_wbar <- var(real_gv_wbar) + real_varA_c <- var(calcColonyGv(apiary, FUN = mapCasteToColonyGv, workersFUN = colSums)) + real_varP_c <- var(calcColonyPheno(apiary, FUN = mapCasteToColonyPheno, workersFUN = colMeans)) + + + variances0 <- rbind(variances0, data.frame(rep = rep, + calc_varA_q = calcVar$varA_q, calc_varA_wbar = calcVar$varA_wbar, calc_varA_c = calcVar$varA_c, calc_varE_c = calcVar$varE_c, + real_varA_q = real_varA_q[1,1], real_varA_wbar = real_varA_wbar[1,1], real_varA_c = real_varA_c[1,1], + real_covA_qwbar = real_covA_qwbar[1,1], real_corA_qwbar = real_corA_qwbar[1,1], + real_varP_c = real_varP_c[1,1], + fun = "sum")) + + +} + +variances0Long <- pivot_longer(variances0 |> select(-c(real_covA_qwbar, real_corA_qwbar)), + cols = c("calc_varA_q", "calc_varA_wbar", "calc_varA_c", "calc_varE_c", + "real_varA_q", "real_varA_c", "real_varA_wbar", "real_varP_c"), names_to = "VarType", values_to = "Var") +meanRealVar = variances0Long %>% group_by(fun, VarType) %>% summarise(meanVar = mean(Var)) + +variances0Long %>% + mutate(rep = as.factor(rep)) %>% + mutate(VarType = factor(VarType, levels = c("calc_varA_q", "calc_varA_wbar", "calc_varA_c", "calc_varE_c", + "real_varA_q", "real_varA_wbar", "real_varA_c", "real_varP_c"))) %>% + ggplot(aes(x = rep, y = Var, color = VarType)) + + geom_point(size = 3) + + geom_hline(data = meanRealVar, aes(yintercept = meanVar, colour = VarType), linewidth = 3) + + facet_wrap(. ~fun, scales = "free") + + theme_bw(base_size = 20) + + scale_colour_manual(values = c( + "#D55E00", # vermillion + "#084159", # blue + "#32c237", + "#b560b4", + "#a80805", # reddish purple + "#0f77a3", # bluish green + "#1a5e1d", + "#610b60" + )) + +variances0 |> filter(rep == 1) + +pivot_longer(variances0 |> select(c(rep, fun, real_covA_qwbar, real_corA_qwbar)), cols = c("real_covA_qwbar", "real_corA_qwbar"), names_to = "CovType", values_to = "Cov") |> + mutate(rep = as.factor(rep)) %>% + ggplot(aes(x = rep, y = Cov, color = CovType)) + + geom_point(size = 3) + + facet_wrap(. ~fun+CovType, scales = "free") + + theme_bw(base_size = 20) + +########################################################################################3 +# The other way around +# Create a function that maps colony level variance to individual level variance +######################################################################################## +mapColonyToIndVar <- function(varA_q, + varA_wbar, + corA_qwbar, + varE_q, + varE_wbar, + corE_qwbar, + nW, + nF, + nDPQ, + workersFUN = "sum") { + + # First handle the genetic part + covA_qwbar <- corA_qwbar * sqrt(varA_q) * sqrt(varA_wbar) + + # scaling factor + if (workersFUN == "sum") { + covA_qw <- covA_qwbar / nW + } else if (workersFUN == "mean") { + covA_qw <- covA_qwbar + } + + # pair counts + n_SS <- (nW * nW / nF) - nW + n_FS <- (nW * nW / nDPQ) - (nW * nW / nF) + n_HS <- (nW * nW / nDPQ) * (nDPQ - 1) + + # worker variance coefficient + if (workersFUN == "sum") { + K <- nW + + n_SS * 0.75 + + n_FS * 0.50 + + n_HS * 0.25 + } else if (workersFUN == "mean") { + K <- 1 / nW + ((n_SS * 0.75 + + n_FS * 0.50 + + n_HS * 0.25) / nW^2) + } + + varA_w <- varA_wbar / K + + corA_qw <- covA_qw / (sqrt(varA_q) * sqrt(varA_w)) + + # Next handle the environmental part + covE_qwbar <- corE_qwbar * sqrt(varE_q) * sqrt(varE_wbar) + + if (workersFUN == "sum") { + varE_w <- varE_wbar / nW + covE_qw <- covE_qwbar / nW + } else if (workersFUN == "mean") { + varE_w <- varE_wbar * nW + covE_qw <- covE_qwbar + } + + corE_qw <- covE_qw / (sqrt(varE_q) * sqrt(varE_w)) + + + return(list(varA_q = varA_q, varA_wbar = varA_wbar, varA_w = varA_w, + covA_qwbar = covA_qwbar, covA_qw = covA_qw, corA_qw = corA_qw, + varE_q = varE_q, varE_wbar = varE_wbar, varE_w = varE_w, + covE_qwbar = covE_qwbar, covE_qw = covE_qw, corE_qw = corE_qw)) +} + +# Test the function through reps +nRep = 50 +variances = data.frame() + +for (rep in 1:nRep) { + varA_q <- 5 + varA_wbar <- 10 + corA_qwbar <- -0.5 + + varE_q <- 10 + varE_wbar <- 20 + corE_qwbar <- 0.3 + + nW <- 100 + nF <- 15 + nDPQ <- 5 + + for (fun in c("mean", "sum")) { + indVarComp <- mapColonyToIndVar(varA_q = varA_q, varA_wbar = varA_wbar, corA_qwbar = corA_qwbar, + varE_q = varE_q, varE_wbar = varE_wbar, corE_qwbar = corE_qwbar, + nW = nW, nF = nF, nDPQ = nDPQ, workersFUN = fun) + calc_var_c <- mapIndToColonyVar(varA_q = indVarComp$varA_q, varA_w = indVarComp$varA_w, corA_qw = indVarComp$corA_qw, + varE_q = indVarComp$varE_q, varE_w = indVarComp$varE_w, corE_qw = indVarComp$corE_qw, + nW = nW, nF = nF, nDPQ = nDPQ, workersFUN = fun) + + print(paste0("Sum, rep ", rep)) + founderGenomes <- quickHaplo(nInd = 20, nChr = 16, segSites = 1000) + SP <- SimParamBee$new(founderGenomes) + SP$nWorkers = nW + SP$nFathers = nF + nQtlPerChr <- 100 + mean <- c(0, 0) + varA <- c(indVarComp$varA_q, indVarComp$varA_w) + corA <- matrix(data = c( 1.0, indVarComp$corA_qw, + indVarComp$corA_qw, 1.0), nrow = 2, byrow = TRUE) + SP$addTraitA(nQtlPerChr = nQtlPerChr, mean = mean, var = varA, corA = corA, + name = c("queenTrait", "workersTrait")) + varE <- c(indVarComp$varE_q, indVarComp$varE_w) + corE <- matrix(data = c(1.0, indVarComp$corE_qw, + indVarComp$corE_qw, 1.0), nrow = 2, byrow = TRUE) + SP$setVarE(varE = varE, corE = corE) + basePop <- createVirginQueens(founderGenomes, n = 20) + + drones <- createDrones(x = basePop[1:nDPQ], nInd = 3) + colony <- createColony(x = basePop[nDPQ+1]) + colony <- cross(x = colony, drones = drones, checkCross = "warning") + colony <- addWorkers(x = colony, nInd = 50) + colony <- buildUp(colony) + apiary <- createMultiColony(basePop[7:20]) + drones <- createDrones(basePop[1:nDPQ], nInd = 100) + apiary <- cross(x = apiary, drones = drones, crossPlan = "create", checkCross = "warning") + apiary <- buildUp(apiary) + + if (fun == "sum") { + workersFUN <- colSums + } else if (fun == "mean") { + workersFUN <- colMeans + } + + # Get the real number of fathers and DPQs + real_A_wbar <- calcColonyGv(apiary, mapCasteToColonyGv, queenTrait = NULL, workersTrait = 2, workersFUN = workersFUN) + real_varA_wbar <- popVar(real_A_wbar) + real_A_c <- calcColonyGv(apiary, mapCasteToColonyGv, queenTrait = 1, workersTrait = 2, workersFUN = workersFUN) + real_varA_c <- popVar(real_A_c) + real_P_wbar <- calcColonyPheno(apiary, mapCasteToColonyPheno, queenTrait = NULL, workersTrait = 2, workersFUN = workersFUN) + real_E_wbar <- real_P_wbar - real_A_wbar + real_varE_wbar <- popVar(real_E_wbar) + real_P_c <- calcColonyPheno(apiary, mapCasteToColonyPheno, queenTrait = 1, workersTrait = 2, workersFUN = workersFUN) + real_E_c <- real_P_c - real_A_c + real_varE_c <- popVar(real_E_c) + + variances <- rbind(variances, data.frame(rep = rep, + set_var_wbar = varA_wbar, + + calc_var_wbar = calc_var_c$varA_wbar, calc_var_c = calc_var_c$varA_c, + real_var_wbar = real_varA_wbar[1,1], real_var_c = real_varA_c, + + component = "A", + + fun = fun)) + + variances <- rbind(variances, data.frame(rep = rep, + set_var_wbar = varE_wbar, + + calc_var_wbar = calc_var_c$varE_wbar, calc_var_c = calc_var_c$varE_c, + real_var_wbar = real_varE_wbar[1,1], real_var_c = real_varE_c, + + component = "E", + fun = fun)) + + + + } +} + + + +variancesLong <- variances |> + #select(rep, fun, real_varA_wbar, set_varA_wbar, real_varA_c, calc_varA_c, calc_varA_wbar) |> + pivot_longer(cols = c("set_var_wbar", + "calc_var_wbar", "calc_var_c", + "real_var_wbar", "real_var_c"), + names_to = "VarType", values_to = "Var") + +meanRealVar = variancesLong %>% group_by(fun, component, VarType) %>% summarise(meanVar = mean(Var)) + +library(viridis) +variancesLong %>% + mutate(rep = as.factor(rep)) %>% + mutate(VarType = factor(VarType, levels = c("set_var_wbar", "calc_var_wbar", "real_var_wbar", "calc_var_c", "real_var_c"))) %>% + ggplot(aes(x = rep, y = Var, color = VarType)) + + geom_point(size = 3, alpha = 0.7) + + geom_hline(data = meanRealVar, aes(yintercept = meanVar, colour = VarType), linewidth = 3) + + facet_wrap(. ~fun + component, scales = "free") + + theme_bw(base_size = 20) + + scale_colour_manual(values = c( + # Cool tones + "#1B4965", # deep blue + "#048BA8", # cyan-blue + "#16DB93", # green-teal + + # Warm tones + "#F4A261", # sand orange + "#D62828", # red + "#9D4EDD" # purple +)) From 0fad5dad46e40190003ca75df629f228ba6b2d70 Mon Sep 17 00:00:00 2001 From: janaobsteter Date: Fri, 15 May 2026 12:42:14 +0000 Subject: [PATCH 52/56] Update documentation --- DESCRIPTION | 2 +- man/MultiColony-class.Rd | 8 +- man/SIMplyBee-package.Rd | 1 + man/SimParamBee.Rd | 514 +++++++++++++++++++-------------------- man/crossVirginQueen.Rd | 18 ++ 5 files changed, 270 insertions(+), 273 deletions(-) create mode 100644 man/crossVirginQueen.Rd diff --git a/DESCRIPTION b/DESCRIPTION index 79503518..2f7b3eb1 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -29,7 +29,6 @@ LazyData: true Imports: methods, R6, stats, utils, extraDistr (>= 1.9.1), RANN, Rcpp (>= 0.12.7), future.apply Depends: R (>= 3.3.0), AlphaSimR (>= 2.0.0) LinkingTo: Rcpp, RcppArmadillo (>= 0.7.500.0.0), BH -RoxygenNote: 7.3.2 Suggests: rmarkdown, knitr, @@ -39,3 +38,4 @@ Suggests: Config/testthat/edition: 3 Config/Needs/website: tidyverse/tidytemplate VignetteBuilder: knitr +Config/roxygen2/version: 8.0.0 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/SIMplyBee-package.Rd b/man/SIMplyBee-package.Rd index 71d90a18..a22788f0 100644 --- a/man/SIMplyBee-package.Rd +++ b/man/SIMplyBee-package.Rd @@ -33,6 +33,7 @@ Useful links: Authors: \itemize{ + \item Jana Obšteter \email{obsteter.jana@gmail.com} (\href{https://orcid.org/0000-0003-1511-3916}{ORCID}) \item Laura Strachan (\href{https://orcid.org/0000-0002-2569-0250}{ORCID}) \item Jernej Bubnič (\href{https://orcid.org/0000-0003-1362-3736}{ORCID}) \item Gregor Gorjanc (\href{https://orcid.org/0000-0001-8008-2787}{ORCID}) diff --git a/man/SimParamBee.Rd b/man/SimParamBee.Rd index 00f6e5f5..555e3730 100644 --- a/man/SimParamBee.Rd +++ b/man/SimParamBee.Rd @@ -25,7 +25,7 @@ See also \code{vignette(package = "SIMplyBee")} for descriptions of how \examples{ ## ------------------------------------------------ -## Method `SimParamBee$new` +## Method `SimParamBee$new()` ## ------------------------------------------------ founderGenomes <- quickHaplo(nInd = 10, nChr = 3, segSites = 10) @@ -45,7 +45,7 @@ SP <- SimParamBee$new(founderGenomes, nCsdAlleles = 100) \dontshow{SP$nThreads = 1L} ## ------------------------------------------------ -## Method `SimParamBee$addToCaste` +## Method `SimParamBee$addToCaste()` ## ------------------------------------------------ founderGenomes <- quickHaplo(nInd = 2, nChr = 1, segSites = 100) @@ -65,7 +65,7 @@ SP$pedigree SP$caste ## ------------------------------------------------ -## Method `SimParamBee$changeCaste` +## Method `SimParamBee$changeCaste()` ## ------------------------------------------------ founderGenomes <- quickHaplo(nInd = 2, nChr = 1, segSites = 100) @@ -105,9 +105,9 @@ Zareba et al. (2017) Uneven distribution of complementary sex determiner \code{\link[AlphaSimR:SimParam]{AlphaSimR::SimParam}} -> \code{SimParamBee} } \section{Public fields}{ -\if{html}{\out{
    }} -\describe{ -\item{\code{nWorkers}}{numeric or function, a number of workers generated in a + \if{html}{\out{
    }} + \describe{ + \item{\code{nWorkers}}{numeric or function, a number of workers generated in a colony - used in \code{\link[SIMplyBee]{createWorkers}}, \code{\link[SIMplyBee]{addWorkers}}, \code{\link[SIMplyBee]{buildUp}}. @@ -129,7 +129,7 @@ Zareba et al. (2017) Uneven distribution of complementary sex determiner You can provide your own functions that satisfy your needs!} -\item{\code{nDrones}}{numeric or function, a number of drones generated in a + \item{\code{nDrones}}{numeric or function, a number of drones generated in a colony - used in \code{\link[SIMplyBee]{createDrones}}, \code{\link[SIMplyBee]{addDrones}}, \code{\link[SIMplyBee]{buildUp}}. @@ -151,7 +151,7 @@ Zareba et al. (2017) Uneven distribution of complementary sex determiner You can provide your own functions that satisfy your needs!} -\item{\code{nVirginQueens}}{numeric or function, a number of virgin queens + \item{\code{nVirginQueens}}{numeric or function, a number of virgin queens generated when a queen dies or other situations - used in \code{\link[SIMplyBee]{createVirginQueens}} and \code{\link[SIMplyBee]{addVirginQueens}}. @@ -173,7 +173,7 @@ Zareba et al. (2017) Uneven distribution of complementary sex determiner You can provide your own functions that satisfy your needs!} -\item{\code{nFathers}}{numeric or function, a number of drones a queen mates + \item{\code{nFathers}}{numeric or function, a number of drones a queen mates with - used in \code{\link[SIMplyBee]{pullDroneGroupsFromDCA}}, \code{\link[SIMplyBee]{cross}}. @@ -195,7 +195,7 @@ Zareba et al. (2017) Uneven distribution of complementary sex determiner You can provide your own functions that satisfy your needs!} -\item{\code{swarmP}}{numeric or a function, the swarm proportion - the proportion + \item{\code{swarmP}}{numeric or a function, the swarm proportion - the proportion of workers that leave with the old queen when the colony swarms - used in \code{\link[SIMplyBee]{swarm}}. @@ -216,7 +216,7 @@ Zareba et al. (2017) Uneven distribution of complementary sex determiner You can provide your own functions that satisfy your needs!} -\item{\code{swarmRadius}}{numeric, radius within which to sample a location of + \item{\code{swarmRadius}}{numeric, radius within which to sample a location of of the swarm - used in \code{\link[SIMplyBee]{swarm}} - see its \code{radius} argument. @@ -225,7 +225,7 @@ Zareba et al. (2017) Uneven distribution of complementary sex determiner You can change this setting to your needs!} -\item{\code{splitP}}{numeric or a function, the split proportion - the + \item{\code{splitP}}{numeric or a function, the split proportion - the proportion of workers removed in a managed split - used in \code{\link[SIMplyBee]{split}}. @@ -246,7 +246,7 @@ Zareba et al. (2017) Uneven distribution of complementary sex determiner You can provide your own functions that satisfy your needs!} -\item{\code{downsizeP}}{numeric or a function, the downsize proportion - the + \item{\code{downsizeP}}{numeric or a function, the downsize proportion - the proportion of workers removed from the colony when downsizing, usually in autumn - used in \code{\link[SIMplyBee]{downsize}}. @@ -267,7 +267,7 @@ Zareba et al. (2017) Uneven distribution of complementary sex determiner You can provide your own functions that satisfy your needs!} -\item{\code{colonyValueFUN}}{function, to calculate colony values - used + \item{\code{colonyValueFUN}}{function, to calculate colony values - used in \code{\link[SIMplyBee]{calcColonyValue}} - see also \code{\link[SIMplyBee]{calcColonyPheno}} and \code{\link[SIMplyBee]{calcColonyGv}}. @@ -279,100 +279,99 @@ Zareba et al. (2017) Uneven distribution of complementary sex determiner See \code{\link[SIMplyBee]{mapCasteToColonyValue}} for an example. You can provide your own functions that satisfy your needs!} -} -\if{html}{\out{
    }} + } + \if{html}{\out{
    }} } \section{Active bindings}{ -\if{html}{\out{
    }} -\describe{ -\item{\code{caste}}{character, caste information for every individual ever + \if{html}{\out{
    }} + \describe{ + \item{\code{caste}}{character, caste information for every individual ever created} -\item{\code{lastColonyId}}{integer, ID of the last Colony object + \item{\code{lastColonyId}}{integer, ID of the last Colony object created with \code{\link[SIMplyBee]{createColony}}} -\item{\code{csdChr}}{integer, chromosome of the csd locus} + \item{\code{csdChr}}{integer, chromosome of the csd locus} -\item{\code{csdPos}}{numeric, starting position of the csd locus on the + \item{\code{csdPos}}{numeric, starting position of the csd locus on the \code{csdChr} chromosome (relative at the moment, but could be in base pairs in the future)} -\item{\code{nCsdAlleles}}{integer, number of possible csd alleles} + \item{\code{nCsdAlleles}}{integer, number of possible csd alleles} -\item{\code{nCsdSites}}{integer, number of segregating sites representing the + \item{\code{nCsdSites}}{integer, number of segregating sites representing the csd locus} -\item{\code{csdPosStart}}{integer, starting position of the csd locus} + \item{\code{csdPosStart}}{integer, starting position of the csd locus} -\item{\code{csdPosStop}}{integer, ending position of the csd locus} + \item{\code{csdPosStop}}{integer, ending position of the csd locus} -\item{\code{version}}{list, versions of AlphaSimR and SIMplyBee packages used to + \item{\code{version}}{list, versions of AlphaSimR and SIMplyBee packages used to generate this object} -} -\if{html}{\out{
    }} + } + \if{html}{\out{
    }} } \section{Methods}{ \subsection{Public methods}{ -\itemize{ -\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-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()}} -\item \href{#method-SimParamBee-clone}{\code{SimParamBee$clone()}} -} -} -\if{html}{\out{ -
    Inherited methods + \itemize{ + \item \href{#method-SimParamBee-initialize}{\code{SimParamBee$new()}} + \item \href{#method-SimParamBee-addToCaste}{\code{SimParamBee$addToCaste()}} + \item \href{#method-SimParamBee-changeCaste}{\code{SimParamBee$changeCaste()}} + \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()}} + \item \href{#method-SimParamBee-clone}{\code{SimParamBee$clone()}} + } +} +\if{html}{\out{
    Inherited methods -
    -}} +
    }} \if{html}{\out{
    }} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-SimParamBee-new}{}}} -\subsection{Method \code{new()}}{ -Starts the process of building a new simulation by creating +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-SimParamBee-initialize}{}}} +\subsection{\code{SimParamBee$new()}}{ + Starts the process of building a new simulation by creating a new SimParamBee object and assigning a founder population of genomes to the this object. -\subsection{Usage}{ -\if{html}{\out{
    }}\preformatted{SimParamBee$new( + \subsection{Usage}{ + \if{html}{\out{
    }} + \preformatted{SimParamBee$new( founderPop, nWorkers = 100, nDrones = 100, @@ -386,99 +385,81 @@ Starts the process of building a new simulation by creating csdPos = 0.865, nCsdAlleles = 128, colonyValueFUN = NULL -)}\if{html}{\out{
    }} -} - -\subsection{Arguments}{ -\if{html}{\out{
    }} -\describe{ -\item{\code{founderPop}}{\code{\link[AlphaSimR]{MapPop-class}}, founder population of +)} + \if{html}{\out{
    }} + } + \subsection{Arguments}{ + \if{html}{\out{
    }} + \describe{ + \item{\code{founderPop}}{\code{\link[AlphaSimR]{MapPop-class}}, founder population of genomes} - -\item{\code{nWorkers}}{see \code{\link[SIMplyBee]{SimParamBee}} field \code{nWorkers}} - -\item{\code{nDrones}}{see \code{\link[SIMplyBee]{SimParamBee}} field \code{nDrones}} - -\item{\code{nVirginQueens}}{see \code{\link[SIMplyBee]{SimParamBee}} field \code{nVirginQueens}} - -\item{\code{nFathers}}{see \code{\link[SIMplyBee]{SimParamBee}} field \code{nFathers}} - -\item{\code{swarmP}}{see \code{\link[SIMplyBee]{SimParamBee}} field \code{swarmP}} - -\item{\code{swarmRadius}}{see \code{\link[SIMplyBee]{SimParamBee}} field \code{swarmRadius}} - -\item{\code{splitP}}{see \code{\link[SIMplyBee]{SimParamBee}} field \code{splitP}} - -\item{\code{downsizeP}}{see \code{\link[SIMplyBee]{SimParamBee}} field \code{downsizeP}} - -\item{\code{csdChr}}{integer, chromosome that will carry the csd locus, by + \item{\code{nWorkers}}{see \code{\link[SIMplyBee]{SimParamBee}} field \code{nWorkers}} + \item{\code{nDrones}}{see \code{\link[SIMplyBee]{SimParamBee}} field \code{nDrones}} + \item{\code{nVirginQueens}}{see \code{\link[SIMplyBee]{SimParamBee}} field \code{nVirginQueens}} + \item{\code{nFathers}}{see \code{\link[SIMplyBee]{SimParamBee}} field \code{nFathers}} + \item{\code{swarmP}}{see \code{\link[SIMplyBee]{SimParamBee}} field \code{swarmP}} + \item{\code{swarmRadius}}{see \code{\link[SIMplyBee]{SimParamBee}} field \code{swarmRadius}} + \item{\code{splitP}}{see \code{\link[SIMplyBee]{SimParamBee}} field \code{splitP}} + \item{\code{downsizeP}}{see \code{\link[SIMplyBee]{SimParamBee}} field \code{downsizeP}} + \item{\code{csdChr}}{integer, chromosome that will carry the csd locus, by default 3, but if there are less chromosomes (for a simplified simulation), the locus is put on the last available chromosome (1 or 2); if \code{NULL} then csd locus is ignored in the simulation} - -\item{\code{csdPos}}{numeric, starting position of the csd locus on the + \item{\code{csdPos}}{numeric, starting position of the csd locus on the \code{csdChr} chromosome (relative at the moment, but could be in base pairs in future)} - -\item{\code{nCsdAlleles}}{integer, number of possible csd alleles (this + \item{\code{nCsdAlleles}}{integer, number of possible csd alleles (this determines how many segregating sites will be needed to represent the csd locus from the underlying bi-allelic SNP; the minimum number of bi-allelic SNP needed is \code{log2(nCsdAlleles)}); if set to \code{0} then \code{csdChr=NULL} is triggered. By default we set \code{nCsdAlleles} to 128, which is at the upper end of the reported number of csd alleles (Lechner et al., 2014; Zareba et al., 2017; Bovo et al., 2021).} - -\item{\code{colonyValueFUN}}{see \code{\link[SIMplyBee]{SimParamBee}} field \code{colonyValueFUN}} -} -\if{html}{\out{
    }} -} -\subsection{Examples}{ -\if{html}{\out{
    }} -\preformatted{founderGenomes <- quickHaplo(nInd = 10, nChr = 3, segSites = 10) + \item{\code{colonyValueFUN}}{see \code{\link[SIMplyBee]{SimParamBee}} field \code{colonyValueFUN}} + } + \if{html}{\out{
    }} + } + \subsection{Examples}{ + \if{html}{\out{
    }} + \preformatted{founderGenomes <- quickHaplo(nInd = 10, nChr = 3, segSites = 10) SP <- SimParamBee$new(founderGenomes, nCsdAlleles = 2) -\dontshow{SP$nThreads = 1L} # We need enough segregating sites try(SP <- SimParamBee$new(founderGenomes, nCsdAlleles = 100)) -\dontshow{SP$nThreads = 1L} founderGenomes <- quickHaplo(nInd = 10, nChr = 3, segSites = 100) SP <- SimParamBee$new(founderGenomes, nCsdAlleles = 100) -\dontshow{SP$nThreads = 1L} # We can save the csd locus on chromosome 1 or 2, too, for quick simulations founderGenomes <- quickHaplo(nInd = 10, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, nCsdAlleles = 100) -\dontshow{SP$nThreads = 1L} } -\if{html}{\out{
    }} - + \if{html}{\out{
    }} + } } -} \if{html}{\out{
    }} \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-SimParamBee-addToCaste}{}}} -\subsection{Method \code{addToCaste()}}{ -Store caste information (for internal use only!) -\subsection{Usage}{ -\if{html}{\out{
    }}\preformatted{SimParamBee$addToCaste(id, caste)}\if{html}{\out{
    }} -} - -\subsection{Arguments}{ -\if{html}{\out{
    }} -\describe{ -\item{\code{id}}{character, individuals whose caste will be stored} - -\item{\code{caste}}{character, single "Q" for queens, "W" for workers, "D" for +\subsection{\code{SimParamBee$addToCaste()}}{ + Store caste information (for internal use only!) + \subsection{Usage}{ + \if{html}{\out{
    }} + \preformatted{SimParamBee$addToCaste(id, caste)} + \if{html}{\out{
    }} + } + \subsection{Arguments}{ + \if{html}{\out{
    }} + \describe{ + \item{\code{id}}{character, individuals whose caste will be stored} + \item{\code{caste}}{character, single "Q" for queens, "W" for workers, "D" for drones, "V" for virgin queens, and "F" for fathers} -} -\if{html}{\out{
    }} -} -\subsection{Examples}{ -\if{html}{\out{
    }} -\preformatted{founderGenomes <- quickHaplo(nInd = 2, nChr = 1, segSites = 100) + } + \if{html}{\out{
    }} + } + \subsection{Examples}{ + \if{html}{\out{
    }} + \preformatted{founderGenomes <- quickHaplo(nInd = 2, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes) -\dontshow{SP$nThreads = 1L} SP$setTrackPed(isTrackPed = TRUE) basePop <- createVirginQueens(founderGenomes) @@ -492,35 +473,33 @@ colony <- addVirginQueens(colony, nInd = 2) SP$pedigree SP$caste } -\if{html}{\out{
    }} - + \if{html}{\out{
    }} + } } -} \if{html}{\out{
    }} \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-SimParamBee-changeCaste}{}}} -\subsection{Method \code{changeCaste()}}{ -Change caste information (for internal use only!) -\subsection{Usage}{ -\if{html}{\out{
    }}\preformatted{SimParamBee$changeCaste(id, caste)}\if{html}{\out{
    }} -} - -\subsection{Arguments}{ -\if{html}{\out{
    }} -\describe{ -\item{\code{id}}{character, individuals whose caste will be changed} - -\item{\code{caste}}{character, single "Q" for queens, "W" for workers, "D" for +\subsection{\code{SimParamBee$changeCaste()}}{ + Change caste information (for internal use only!) + \subsection{Usage}{ + \if{html}{\out{
    }} + \preformatted{SimParamBee$changeCaste(id, caste)} + \if{html}{\out{
    }} + } + \subsection{Arguments}{ + \if{html}{\out{
    }} + \describe{ + \item{\code{id}}{character, individuals whose caste will be changed} + \item{\code{caste}}{character, single "Q" for queens, "W" for workers, "D" for drones, "V" for virgin queens, and "F" for fathers} -} -\if{html}{\out{
    }} -} -\subsection{Examples}{ -\if{html}{\out{
    }} -\preformatted{founderGenomes <- quickHaplo(nInd = 2, nChr = 1, segSites = 100) + } + \if{html}{\out{
    }} + } + \subsection{Examples}{ + \if{html}{\out{
    }} + \preformatted{founderGenomes <- quickHaplo(nInd = 2, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes) -\dontshow{SP$nThreads = 1L} SP$setTrackPed(isTrackPed = TRUE) basePop <- createVirginQueens(founderGenomes) SP$pedigree @@ -532,140 +511,139 @@ colony <- cross(colony, drones = drones) SP$pedigree SP$caste } -\if{html}{\out{
    }} - + \if{html}{\out{
    }} + } } -} \if{html}{\out{
    }} \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$addToBeePed(nNewInd, id, mother, father, isDH)}\if{html}{\out{
    }} +\subsection{\code{SimParamBee$addToBeePed()}}{ + For internal use only. + \subsection{Usage}{ + \if{html}{\out{
    }} + \preformatted{SimParamBee$addToBeePed(nNewInd, id, mother, father, isDH)} + \if{html}{\out{
    }} + } + \subsection{Arguments}{ + \if{html}{\out{
    }} + \describe{ + \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{
    }} + } } -\subsection{Arguments}{ -\if{html}{\out{
    }} -\describe{ -\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-addToBeeRec}{}}} -\subsection{Method \code{addToBeeRec()}}{ -For internal use only. -\subsection{Usage}{ -\if{html}{\out{
    }}\preformatted{SimParamBee$addToBeeRec(nNewInd, id, mother, father, isDH, hist, ploidy)}\if{html}{\out{
    }} +\subsection{\code{SimParamBee$addToBeeRec()}}{ + For internal use only. + \subsection{Usage}{ + \if{html}{\out{
    }} + \preformatted{SimParamBee$addToBeeRec(nNewInd, id, mother, father, isDH, hist, ploidy)} + \if{html}{\out{
    }} + } + \subsection{Arguments}{ + \if{html}{\out{
    }} + \describe{ + \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{
    }} + } } -\subsection{Arguments}{ -\if{html}{\out{
    }} -\describe{ -\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{
    }} -} -} \if{html}{\out{
    }} \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-SimParamBee-updateCaste}{}}} -\subsection{Method \code{updateCaste()}}{ -A function to update the caste +\subsection{\code{SimParamBee$updateCaste()}}{ + A function to update the caste For internal use only. -\subsection{Usage}{ -\if{html}{\out{
    }}\preformatted{SimParamBee$updateCaste(caste)}\if{html}{\out{
    }} + \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{
    }} + } } -\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-updateLastBeeId}{}}} -\subsection{Method \code{updateLastBeeId()}}{ -A function to update the last +\subsection{\code{SimParamBee$updateLastBeeId()}}{ + A function to update the last ID everytime we create an individual For internal use in SIMplyBee only. -\subsection{Usage}{ -\if{html}{\out{
    }}\preformatted{SimParamBee$updateLastBeeId(n = 1L)}\if{html}{\out{
    }} + \subsection{Usage}{ + \if{html}{\out{
    }} + \preformatted{SimParamBee$updateLastBeeId(n = 1L)} + \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{
    }} + } } -\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{}} \if{latex}{\out{\hypertarget{method-SimParamBee-updateLastColonyId}{}}} -\subsection{Method \code{updateLastColonyId()}}{ -A function to update the colony last +\subsection{\code{SimParamBee$updateLastColonyId()}}{ + 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(n = 1)}\if{html}{\out{
    }} + \subsection{Usage}{ + \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{
    }} + } } -\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{
    }} -} -} \if{html}{\out{
    }} \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-SimParamBee-clone}{}}} -\subsection{Method \code{clone()}}{ -The objects of this class are cloneable with this method. -\subsection{Usage}{ -\if{html}{\out{
    }}\preformatted{SimParamBee$clone(deep = FALSE)}\if{html}{\out{
    }} +\subsection{\code{SimParamBee$clone()}}{ + The objects of this class are cloneable with this method. + \subsection{Usage}{ + \if{html}{\out{
    }} + \preformatted{SimParamBee$clone(deep = FALSE)} + \if{html}{\out{
    }} + } + \subsection{Arguments}{ + \if{html}{\out{
    }} + \describe{ + \item{\code{deep}}{Whether to make a deep clone.} + } + \if{html}{\out{
    }} + } } -\subsection{Arguments}{ -\if{html}{\out{
    }} -\describe{ -\item{\code{deep}}{Whether to make a deep clone.} -} -\if{html}{\out{
    }} -} -} } diff --git a/man/crossVirginQueen.Rd b/man/crossVirginQueen.Rd new file mode 100644 index 00000000..f28bd134 --- /dev/null +++ b/man/crossVirginQueen.Rd @@ -0,0 +1,18 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/Functions_L1_Pop.R +\name{crossVirginQueen} +\alias{crossVirginQueen} +\title{Internal function to cross a virgin queen} +\usage{ +crossVirginQueen(virginQueen, virginQueenDrones, simParamBee = NULL) +} +\arguments{ +\item{virginQueen}{\code{\link[AlphaSimR]{Pop-class}}} + +\item{virginQueenDrones, }{list with drones} + +\item{simParamBee, }{SimParamBee object} +} +\description{ +Internal function to cross a virgin queen +} From d342130b219d2075eba2db52e540f9943bf89d16 Mon Sep 17 00:00:00 2001 From: janaobsteter Date: Fri, 15 May 2026 14:42:35 +0200 Subject: [PATCH 53/56] Resolving --- vignettes/F2_Variance_calculations.Rmd | 600 ----------- .../F2_Variance_calculations_functions.Rmd | 944 +++++------------- 2 files changed, 259 insertions(+), 1285 deletions(-) delete mode 100644 vignettes/F2_Variance_calculations.Rmd diff --git a/vignettes/F2_Variance_calculations.Rmd b/vignettes/F2_Variance_calculations.Rmd deleted file mode 100644 index 26a38d90..00000000 --- a/vignettes/F2_Variance_calculations.Rmd +++ /dev/null @@ -1,600 +0,0 @@ ---- -title: "Variance calculations between individual and colony level values" -date: "`r Sys.Date()`" -output: rmarkdown::html_vignette -vignette: > - %\VignetteIndexEntry{VarianceCalculations} - %\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 -) -``` - -```{r FirstExampleFromQuanGenVignette} -library(package = "SIMplyBee") -founderGenomes <- quickHaplo(nInd = 20, nChr = 16, segSites = 1000) -SP <- SimParamBee$new(founderGenomes) -nQtlPerChr <- 100 -mean <- c(10, 10 / SP$nWorkers) -varA <- c(1, 1 / SP$nWorkers) -corA <- matrix(data = c( 1.0, -0.5, - -0.5, 1.0), nrow = 2, byrow = TRUE) -SP$addTraitA(nQtlPerChr = nQtlPerChr, mean = mean, var = varA, corA = corA, - name = c("queenTrait", "workersTrait")) -varE <- c(3, 3 / SP$nWorkers) -corE <- matrix(data = c(1.0, 0.3, - 0.3, 1.0), nrow = 2, byrow = TRUE) -SP$setVarE(varE = varE, corE = corE) -basePop <- createVirginQueens(founderGenomes, n = 20) -head(basePop@gv) -head(basePop@pheno) -drones <- createDrones(x = basePop[1:5], nInd = 3) -colony <- createColony(x = basePop[6]) -colony <- cross(x = colony, drones = drones, checkCross = "warning") -colony <- addWorkers(x = colony, nInd = 50) -colony <- buildUp(colony) -apiary <- createMultiColony(basePop[7:20]) -drones <- createDrones(basePop[1:5], nInd = 100) -apiary <- cross(x = apiary, drones = drones, crossPlan = "create", checkCross = "warning") -apiary <- buildUp(apiary) -colonyGv <- calcColonyGv(apiary) -colonyPheno <- calcColonyPheno(apiary) -``` - -The idea of this work is: - -1) We want to do honey bee simulations with individual queens, drones, and - workers - -2) To do the above, we require individual variances and covariances - -3) Literature reports only variances and covariances at the colony level - -4) The aim of this paper is to show how to use variances and covariances at the - colony level to do simulations at the individual level. - -# Introduction WORK IN PROGRESS - -This document develops theory for the variance of genetic and phenotypic values -between colonies with the aim to understand how to fine tune a SIMplyBee -simulation where we need variance components for queen and workers effects at an -individual honeybee level. The challenge here is that in reality we do not -observe such variances, but only on a colony level. - -For example, in the vignette we assumed that phenotypic variance on the -individual level is about 1/4 due to genetic variation and about 3/4 due to -environmental variation, but looking at colony genetic and phenotypic variances -the ratio was about 1/2! - -TODO: What do we do about this? It feels like we need a full paper on all of -this;) :( - -INTRODUCTION - -TODO: Topic 1 - -TODO: cite this paper that does honeybee simulations, but without actually doing -honeybee colony stuff etc. Heritability in honeybees paper: - - -TOOD: cite some classic papers on variances in honeybees - -TODO: cite recent papers from German and Dutch colleagues on variances in -honeybees - -Brascamp and Bijma (2014): Methods to estimate breeding values in honey bees - - -Brascamp and Bijma (2019): A note on genetic parameters and accuracy of -estimated breeding values in honey bees - - -Andonov et al.: Modeling honey yield, defensive and swarming behaviors of -Italian honey bees (Apis mellifera ligustica) using linear-threshold approaches - - -To make use of the material in this document you should run the quantitative -genetics vignette - the first example. Then you can continue here! - -Having multiple colonies and their values, we can now return to the "about" -point mentioned at the start of this section, when we defined quantitative -genetic parameters. Recall that our starting quantitative genetic parameters for -the queen and workers effects were: - -We will follow the example from Brascamp and Bijma (2019) they have: - -$\sigma_{g_q}^2=0.5$ - this is their $\sigma_{A_q}^2=0.5$ - -$\sigma_{g_w}^2=1.0$ - this is their $\sigma_{A_w}^2=1.0$ among nominally -unrelated groups of workers - -$\sigma_{\bar{g}_w}^2=0.32$ - this is their $\sigma_{\bar{A}_w}^2=0.32$ among -base related groups of workers - -Where the relationship between the two is -$\sigma_{\bar{g}_w}^2 = a_{ii} * \sigma_{g_w}^2$ where $a_{ii}$ is average -additive genetic relationship between workers in a colony as can be defined (in -a non-inbred population) as -$a_{ii} = 1/4 + 1/2p_1 + 1/4(p_2 - p_1) + 1/4(1 - p_2)a_{ss}$; where $p_1$ is -the probability that two workers descend from the same drone, $p_2$ is the -probability that they descend from the same DPQ, and $a_{ss}$ is the relatedness -between two DPQs. We are ignore the $a_{ss}$ part (TODO?). - -$\sigma_{{g_q},{g_w}}=-0.35$ - -$\sigma_{P}^2 = \sigma_{\bar{g}_w^w}^2 + \sigma_{g_q^q}^2 + 2*\sigma_{\bar{g}_w^w g_q^q} + \sigma_{E}^2$ - -$\sigma_e^2=2.0$ - -$h^2=(a_{base}\sigma_{g,w}^2 + \sigma_{{g,w},{g,q}} + \sigma_{g,q}^2)/\sigma_{p,c}^2=???$ - -$h_w^2=a_{base}\sigma_{g,w}^2/\sigma_{p,c}^2=0.13$ - -$h_q^2=\sigma_{g,q}^2/\sigma_{p,c}^2=0.20$ - -$T^2=(\sigma_{g,w}^2 + 2\sigma_{{g,w},{g,q}} \sigma_{g,q}^2)/\sigma_{p,c}^2=0.32$ - -$T_w^2=\sigma_{g,w}^2/\sigma_{p,c}^2=0.41$ - -$T_q^2=\sigma_{g,q}^2/\sigma_{p,c}^2=0.20$ - -$r_g = cor(g_w, g_q) = -0.50$ - -TODO: equation 3 in Brascamp and Bijma (2019) is highly relevant to our work -here - that equation shows connection between the variance of the sum (or -average) of worker genetic values for worker effect AND variance of worker -genetic values for worker effect - THIS IS NOT TRUE they always work with the -worker group effect, never individuals! - -TODO: show sensitivity to the number of workers - the larger the number of -workers, the smaller the variance between workers - -covA[1, 1] + nW \* covA[2, 2] + 2 \* k \* covA[1, 2] - -```{r quan_gen_param_revision} -# Trait means -mean - -# Trait genetic variation - on a per honeybee level -varA -corA -(covA <- corA * outer(X = sqrt(varA), Y = sqrt(varA), FUN = "*")) - -# Trait environmental variation - on a per honeybee level -varE -corE -(covE <- corE * outer(X = sqrt(varE), Y = sqrt(varE), FUN = "*")) - -# Trait phenotypic variation - on a per honeybee level -(covP <- covA + covE) -(corP <- cov2cor(covP)) -(varP <- diag(covP)) - -# Expected phenotypic variation - on a per colony level -# TODO: there is in fact more stuff happening here - see below! -nW <- SP$nWorkers # TODO: this is not correct - we have queen-workers pairs and workers-workers (see below!) -# Var(z)=Var(x+y)=Var(x)+Var(sum(y))=Var(x)+Var(y_1)+Var(y_2)+... -# this is all wrong likely ... - -k <- 1 # just adding this so vignette can run, but I don't know what this k should be - -covA[1, 1] + nW * covA[2, 2] + 2 * k * covA[1, 2] # variance can not be negative! -covP[1, 1] + nW * covP[2, 2] + 2 * k * covP[1, 2] - -# Observed variation - on a per colony level -var(colonyGv) -var(colonyPheno) -var(colonyGv) / var(colonyPheno) -``` - -Hmm, we have much higher genetic and phenotypic variances in simulation than -based simply looking at queen and n\*workers variances, as well as much higher -ratio between the two than the initial value of \~1/4! Why? Let's see. For -genetic value of a colony $g_c$ we add up the queen's genetic value for the -queen effect $g_{q,q}$ and workers' genetic values for the workers effect -$\Sigma_{i=1}^{n_w}(g_{i,w})$: - -$g_c = g_{q,q} + \Sigma_{i=1}^{n_w}(g_{i,w}).$ - -Expectation of colony genetic value is then: - -$E(g_c) = E(g_{q,q} + \Sigma_{i=1}^{n_w}(g_{i,w}))$ - -$E(g_c) = E(g_{q,q}) + E(\Sigma_{i=1}^{n_w}(g_{i,w}))$ - -$E(g_c) = \mu_{g_{q}} + n_w E(g_{w,w})$ - -$E(g_c) = \mu_{g_{q}} + n_w \mu_{g_{w}}$ - -we are assuming here that $n_w$ is a fixed value, but if it is a random variable -then we would have - -$E(g_c) = \mu_{g_{q}} + E(n_w) E(g_{w,w})$ using - - -$E(g_c) = \mu_{g_{q}} + \lambda_{n_w} \mu_{g_{w}}$ - -where $\lambda_{n_w}$ is average number of workers. So, in our case this turns -out the same as above. So in our case we have: - -```{r} -nW <- SP$nWorkers -mean[1] + nW * mean[2] -mean(colonyGv) -mean(colonyPheno) -``` - -Variance of colony genetic value is then: - -$Var(g_c) = Var(g_{q,q} + \Sigma_{i=1}^{n_w}(g_{i,w}))$ - -$Var(g_c) = Var(g_{q,q}) + Var(\Sigma_{i=1}^{n_w}(g_{i,w})) + 2Cov(g_{q,q}, \Sigma_{i=1}^{n_w}(g_{i,w}))$ - -$Var(g_c) = \sigma^2_{g_{q}} + Var(\Sigma_{i=1}^{n_w}(g_{i,w})) + 2Cov(g_{q,q}, \Sigma_{i=1}^{n_w}(g_{i,w}))$ - -So, we have three parts: - -A) the variance of the queen effect in queens $\sigma^2_{g_{q}}$, - -B) variance of a sum of workers effect in workers - $Var(\Sigma_{i=1}^{n_w}(g_{i,w}))$, and - -C) covariance between the two $2Cov(g_{q,q}, \Sigma_{i=1}^{n_w}(g_{i,w}))$. - -# A) Variance of the queen effect in queens $\sigma^2_{g_{q}}$ - in our case this is: - -```{r check_queen_variances} -varA[1] -x = getQueenGv(apiary, collapse = TRUE)[, "queenTrait"] -var(x) -# ... note that R's var() divides by n-1, which matters with small n -popVar(x) -sum((x - mean[1])^2) / nColonies(apiary) - -``` - -Anyway, quite close! - -# B) Variance of a sum of workers effect in workers $Var(\Sigma_{i=1}^{n_w}(g_{i,w}))$ - -Given that this is a sum, we need to look at: - -B1) variance of each of worker genetic values $Var(g_{i,w})$ and - -B2) covariance between each pair of the values $Cov(g_{i,w}, g_{j,w})$. - -This means, that family structure will start to matter because it induces -covariance between family members (workers). The simplest case is when all -workers come from the same father. Then we have: - -$g_{1,w} = \frac{1}{2}g_{q,w} + g_{f,w} + r_{1,w}$ - -$g_{2,w} = \frac{1}{2}g_{q,w} + g_{f,w} + r_{2,w}$ - -... - -$g_{n_w,w} = \frac{1}{2}g_{q,w} + g_{f,w} + r_{n_w,w}$ - -## B1) variance of each of worker genetic values $Var(g_{i,w})$ - -As stated initially, we have $Var(g_{i,w}) = \sigma^2_{g_{w}}$ and we have $n_w$ -such terms, $n_w \sigma^2_{g_{w}}$. In our case this would be: - -```{r check_workers_variances} -nW * varA[2] -g <- calcColonyGv(apiary, mapCasteToColonyGv, queenTrait = NULL, workersTrait = "workersTrait") -var(g) -# ... note that R's var() divides by n-1, which matters with small n -sum((g - nW * mean[2])^2) / nColonies(apiary) -popVar(g) -``` - -So, a huge discrepancy between the variance of a sum of genetic values for the -workers effect `nW * varA[2]` (assuming independence) and a realised sum of -genetic values for the workers effect. As we have seen above, this is due to -family structure and associated B2) covariance between each pair of the values -$Cov(g_{i,w}, g_{j,w})$. - -## B2) covariance between each pair of the values $Cov(g_{i,w}, g_{j,w})$ - -Clearly, these covariances matter a lot - there is lots of worker pairs in a -colony! How do these covariances look like? - -$Cov(g_{1,w}, g_{2,w}) = Cov(\frac{1}{2}g_{q,w} + g_{f,w}, \frac{1}{2}g_{q,w} + g_{f,w})$ - -$Cov(g_{1,w}, g_{2,w}) = Var(\frac{1}{2}g_{q,w}) + Var(g_{f,w})$ - -assuming that mother and father are not related; further genetic variance -between drones is in fact half the genetic variance between queens because they -are haploid, so we get: - -$Cov(g_{1,w}, g_{2,w}) = \frac{1}{4}\sigma^2_{g_w} + \frac{1}{4}\sigma^2_{g_w}$ - -$Cov(g_{1,w}, g_{2,w}) = \frac{1}{2}\sigma^2_{g_w}$. - -Every pair of super-sister workers adds $\frac{1}{2}\sigma^2_{g_w}$ to B - note -that pair A-B adds this value, but so does the pair B-A, hence total is -$2\frac{1}{2}\sigma^2_{g_w} = \sigma^2_{g_w}$. With $n_w$ workers we get -$n_w n_w$ pairs (including with itself) or $n_w n_w - n_w$ pairs between -different workers. The total covariance contribution is then -$(n_w n_w - n_w)\frac{1}{2}\sigma^2_{g_w}$). In our case this would be: - -```{r check_workers_variances2} -(varSumWorkers <- nW * varA[2]) # B1 -(covSumWorkers <- (nW * nW - nW) * 1/2 * varA[2]) # B2 -varSumWorkers + covSumWorkers # B - -g <- calcColonyGv(apiary, mapCasteToColonyGv, queenTrait = NULL, workersTrait = "workersTrait") -var(g) # B -# ... note that R's var() divides by n-1, which matters with small n -sum((g - nW * mean[2])^2) / nColonies(apiary) # B -popVar(g) -``` - -If we would only have super-sisters we would have \~1 for B1, \~49.5 for B2, and -\~50.5 for B, but with a mix of half-sisters and super-sisters we would have a -lower value, which is what we see above, \~26.8 for B. - -TODO: Define the setting above in intro or start of M&M - We also can have -full-sisters, where the mother is obviously the same, but the fathers are -different, yet they come from the same mother, which is equivalent to a -full-sibs case in diploid species. We will assume in this work that we have -unrelated queens and unrelated drones (=base pop) - our aim is to set variances -in such a base population - to get the scale or the variances right. In -simulation of our base population we generated drones from virgin queens, which -means that our drones can in fact be brothers, so our realised variances might -be a bit off compared to this theory. But this is fine, we are mostly trying to -get the order of variances correct. - -So, now we need to work out B2 with a mix of half-sisters and super-sisters :( -Sister workers are related only due to having the same mother, assuming that -drones the queen mated with are unrelated: - -$g_{1,w} = \frac{1}{2}g_{q,w} + g_{f1,w} + r_{1,w}$ - -$g_{2,w} = \frac{1}{2}g_{q,w} + g_{f2,w} + r_{2,w}$ - -$Cov(g_{1,w}, g_{2,w}) = Cov(\frac{1}{2}g_{q,w} + g_{f1,w}, \frac{1}{2}g_{q,w} + g_{f2,w})$ - -$Cov(g_{1,w}, g_{2,w}) = Var(\frac{1}{2}g_{q,w})$ - -$Cov(g_{1,w}, g_{2,w}) = \frac{1}{4}Var(g_{q,w})$ - -Hence every pair of half-sister workers adds $\frac{1}{4}\sigma^2_{g_w}$ to B -(note, this is $2\frac{1}{4}\sigma^2_{g_w}$ for A-B and B-A pairs!). With $n_w$ -workers and $n_f$ fathers we have $\frac{n_w}{n_f}$ workers per father. Further, -we have $n_f$ groups of super-sisters and $n_f n_f - n_f$ pairs of sister -groups. Assuming that half-sister groups are the same size, we have -$n_f \frac{n_w}{n_f} \frac{n_w}{n_f} = n_w \frac{n_w}{n_f} = \frac{n^2_w}{n_f}$ -pairs of super-sisters and $(n_f n_f - n_f) \frac{n_w}{n_f} \frac{n_w}{n_f}$ - -this is -$n_f (n_f - 1) \frac{n_w}{n_f} \frac{n_w}{n_f} = (n_f - 1) n_w \frac{n_w}{n_f} = \frac{ (n_f - 1) n^2_w}{n_f}$. -Is this correct? - -```{r pairs_of_workers} -(nF <- nFathers(colony)) -nW * nW -(a <- nW * nW / nF) -(b <- (nF - 1) * nW * nW / nF) -a+b -#TODO define nDPQ -``` - -Looks like! - -So, super-sister pairs add $\frac{n^2_w}{n_f} \frac{1}{2}\sigma^2_{g_w}$ and -half-sister pairs add $\frac{ (n_f - 1) n^2_w}{n_f} \frac{1}{4}\sigma^2_{g_w}$. -Let's test this: - -```{r check_workers_variances3} -(varSumWorkers <- nW * varA[2]) # B1 -(covSumWorkersSuperSisters <- (nW * nW / nF) * 0.75 * varA[2]) # B2 in super-sisters ERROR: SHOULD BE 0.75 -(covSumWorkersHalfSisters <- ((nF - 1) * nW * nW / nF) * 0.25 * varA[2]) # B2 in half-sisters -varSumWorkers + covSumWorkersSuperSisters + covSumWorkersHalfSisters # B - -g <- calcColonyGv(apiary, mapCasteToColonyGv, queenTrait = NULL, workersTrait = "workersTrait") -var(g) # B -# ... note that R's var() divides by n-1, which matters with small n -sum((g - SP$nWorkers * mean[2])^2) / nColonies(apiary) # B -``` - -Cool - very close!!! There can be some difference because the formulae above -assume that we have fixed sizes of half-sister and super-sister groups. Also, -there can be full-sisters in there as well!!! - -TODO: We could also add full-sisters: To do this, we would have to assume how -many brother drones we use to figure out the grups - -TODO: What if $n_w$ is a random variable? Following - -we would use: - -$Var(XY) = (Var(X) + E(X)^2) (Var(Y) + E(Y)^2) - E(X)^2 E(Y)^2$ - -but this is for two variables, while I have $n_w$ genetic values, so this -reference result is not that useful in our case! Well, if $n_w$ varies between -colonies, this must boost variance of colony-level genetic values significantly, -because kind of start calculating variance between apples (small colonies) and -oranges (large colonies). - -# C) Covariance between the two $2Cov(g_{q,q}, \Sigma_{i-1}^{n_w}(g_{i,w}))$. - -Let's repeat: - -$g_{1,w} = \frac{1}{2}g_{q,w} + g_{f1,w} + r_{1,w}$ - -$g_{2,w} = \frac{1}{2}g_{q,w} + g_{f2,w} + r_{2,w}$ ... - -The essential bit here is: - -$Cov(g_{q,q}, g_{i,w}) = Cov(g_{q,q}, \frac{1}{2} g_{q,w})$ - -assuming that the queen and fathers are unrelated. Then: - -$Cov(g_{q,q}, g_{i,w}) = Cov(g_{q}, \frac{1}{2} g_{w})$ - -$Cov(g_{q,q}, g_{i,w}) = \frac{1}{2} Cov(g_{q}, g_{w})$ - -$Cov(g_{q,q}, g_{i,w}) = \frac{1}{2} \sigma_{g_{q},g_{w}}$ - -So: - -$2Cov(g_{q,q}, \Sigma_{i=1}^{n_w}(g_{i,w})) = 2Cov(g_{q,q}, n_w \frac{1}{2} g_{q,w})$ - -$2Cov(g_{q,q}, \Sigma_{i=1}^{n_w}(g_{i,w})) = 2 n_w \frac{1}{2}Cov(g_{q,q}, g_{q,w})$ - -$2Cov(g_{q,q}, \Sigma_{i=1}^{n_w}(g_{i,w})) = n_w \sigma_{g_{q},g_{w}}$ - -```{r check_workers_variances4} - -print("Genetic variances") -print("Part A") -(varQueen <- varA[1]) # A - -print("Part B1") -(varSumWorkers <- nW * varA[2]) # B1 -print("Part B2 in super-sisters") -(covSumWorkersSuperSisters <- (nW * nW / nF) * 0.75 * varA[2]) # B2 in super-sisters -print("Part B2 in full-sisters") -(covSumWorkersFullSisters <- ((nW * nW / nDPQ) - (nW * nW / nF)) * 0.50 * varA[2]) # B2 in full-sisters -print("Part B2 in half-sisters") -(covSumWorkersHalfSisters <- ((nF - 1) * nW * nW / nF) * 0.25 * varA[2]) # B2 in half-sisters -print("Part B combined") -(varSumWorkers <- varSumWorkers + covSumWorkersSuperSisters + covSumWorkersHalfSisters) # B -print("Part C") -(covQueenSumWorkers <- nW * covA[1, 2]) # C - -print("Part A + B + C") -varQueen + varSumWorkers + covQueenSumWorkers - -print("ColonyGv variance") -g <- colonyGv -var(g) -popVar(g) -sum((g - 20)^2) / nColonies(apiary) - - -``` - -Bingo for genetic variance. - -```{r} - -print("Phenotypic variance") -print("Part A") -(varQueen <- varP[1]) # A -print("Part B1") -(varSumWorkers <- nW * varP[2]) # B1 -(covSumWorkersSuperSisters <- (nW * nW / nF) * 0.75 * varA[2]) # B2 in super-sisters - only genetic cov here -(covSumWorkersSisters <- ((nF - 1) * nW * nW / nF) * 0.25 * varA[2]) # B2 in sisters - only genetic cov here -(varSumWorkers <- varSumWorkers + covSumWorkersSuperSisters + covSumWorkersSisters) # B - -(covQueenSumWorkers <- nW * covP[1, 2]) # C - both genetic and env cove here? TODO - -varQueen + varSumWorkers + covQueenSumWorkers - -p <- colonyPheno -var(p) -popVar(p) -sum((p - 20)^2) / nColonies(apiary) -``` - -And very close for phenotypic too, but we need to check some part above! - -# What now? - -Alright, what can we now do with this? We now have a system of expected genetic -and phenotypic variances for colony values as a function of number of workers, -fathers, and genetic and phenotypic covariances between the queen and worker -effects. So, it should be possible, in principle, to solve for what kind of -covariance values for the queen and workers effects should we use, to get the -desired colony genetic and phenotypic variances! - -TODO: develop such estimating equations! - -So, we have genetic part: - -$A_g = \sigma^2_{g_q}$ - -$B1_g = n_w \sigma^2_{g_w}$ - -$B2_g = \frac{n^2_w}{n_f} \frac{1}{2} \sigma^2_{g_w}$ - -$B3_g = \frac{(n_f - 1) n^2_w}{n_f} \frac{1}{4} \sigma^2_{g_w}$ - -$C_g = n_w \sigma^2_{{g_q},{g_w}}$ - -here are 3 unknowns: $\sigma^2_{g_q}$, $\sigma^2_{g_w}$, and -$\sigma^2_{{g_q},{g_w}}$ - -we can add phenotypic part: - -$A_p = \sigma^2_{p_q}$ - -$B1_p = n_w \sigma^2_{p_w}$ - -$B2_p = \frac{n^2_w}{n_f} \frac{1}{2} \sigma^2_{g_w}$ TODO: check if its only -genetic - -$B3_p = \frac{(n_f - 1) n^2_w}{n_f} \frac{1}{4} \sigma^2_{g_w}$ TODO: check if -its only genetic - -$C_p = n_w \sigma^2_{{p_q},{p_w}}$ - -here are additional 3 unknowns: $\sigma^2_{p_q}$, $\sigma^2_{p_w}$, and -$\sigma^2_{{p_q},{p_w}}$ - -while we could provide as guidance 2, maybe 3, inputs: $\sigma^2_{g_c}$, -$\sigma^2_{p_c}$, and $\frac{\sigma^2_{g_c}}{\sigma^2_{p_c}}$. - -TODO: are there any additional inputs that we could get from literature? How do -we connect all this with variance estimates for the queen and the workers effect -in the honeybee genetics and breeding literature? I think that those estimates -are essentially this: -$\sigma^2_{g_c} = \sigma^2_{g_{c,q}} + \sigma^2_{g_{c,w}} + 2\sigma_{g_{c,q},g_{c,w}}$ -where $\sigma^2_{g_{c,q}}$ is the queen part of $\sigma^2_{g_c}$, but not -necessarily the same as $\sigma^2_{g_w}$, or is it? Maybe that is the same, and -$\sigma^2_{g_{c,w}}$ is a counterpart to -$n_w \sigma^2_{g_w} + \frac{n^2_w}{n_f} \frac{1}{2} \sigma^2_{g_w}, \frac{(n_f - 1) n^2_w}{n_f} \frac{1}{4} \sigma^2_{g_w}$ -(TODO: should we add full-sisters?), while $\sigma_{g_{c,q},g_{c,w}}$ is a -counterpart to $n_w \sigma_{{g_q},{g_w}}$. If this is so, then it fells that we -should have 3 more inputs for genetic part, so 4 inputs to estimate 3 unknowns -of which some are very simple transformations!!! - -Additional input could be $\sigma^2_{p_c}$. For sure we don't get estimates of -$\sigma^2_{p_c} = \sigma^2_{p_{c,q}} + \sigma^2_{p_{c,w}} + 2\sigma_{p_{c,q},p_{c,w}}$, -but, having sorted the genetic part and if $B2_p$ and $B3_p$ depend only on -genetic covariance, then maybe, we have some maneuvering space to estimate also -$\sigma^2_{p_q}$, $\sigma^2_{p_w}$, and $\sigma^2_{{p_q},{p_w}}$?! - -Furthermore, we have some constraints, so this is not just any system of -equations. For example, we know that variances must be positive. Futhermore, we -might know that come covariances are either positive or negative. - -TODO: Develop and polish all this further and create a Shiny application where -we can change these individual-level parameters and study how that will change -colony-level parameters and then how we could go the other way around based on -literature and solving the above systems of equations. We could host such a -Shiny app on SIMplyBee.info!? Can we? - -NEXT STEPS: - -1) read the above, check derivations, missing bits, etc. - -2) write a function that takes individual variances, nw, nf, etc. and returns - colony variances and h2, t2, T2, ... - -3) develop a system of equations (using A, Bs, and C) linking individual and - colony values for two types of colony values (for different models beepeople - run!) - then find a way to optimize/solve for individual values (output) - with colony values as input diff --git a/vignettes/F2_Variance_calculations_functions.Rmd b/vignettes/F2_Variance_calculations_functions.Rmd index d49037dd..5ef02f1f 100644 --- a/vignettes/F2_Variance_calculations_functions.Rmd +++ b/vignettes/F2_Variance_calculations_functions.Rmd @@ -12,6 +12,7 @@ editor_options: canonical: true --- + ```{r setup, include = FALSE} knitr::opts_chunk$set( collapse = TRUE, @@ -20,19 +21,38 @@ knitr::opts_chunk$set( ) ``` -```{r FirstExampleFromQuanGenVignette} +```{r cor2cov, include = FALSE} library(package = "SIMplyBee") +cor2cov <- function(corr, var) { + # Ensure inputs are matrices/vectors + corr <- as.matrix(corr) + var <- as.numeric(var) + + # Standard deviations + sd <- sqrt(var) + + # Covariance matrix + cov <- corr * (sd %o% sd) + + return(cov) +} +``` + +Let's again run the example from the quantitative genetic vignette. + +```{r FirstExampleFromQuanGenVignette} +# Run the example from the quantitative genetic vignette founderGenomes <- quickHaplo(nInd = 20, nChr = 16, segSites = 1000) SP <- SimParamBee$new(founderGenomes) nQtlPerChr <- 100 mean <- c(10, 10 / SP$nWorkers) varA <- c(1, 1 / SP$nWorkers) -corA <- matrix(data = c( 1.0, -0.5, - -0.5, 1.0), nrow = 2, byrow = TRUE) +corA <- matrix(data = c( 1.0, -0.5, + -0.5, 1.0), nrow = 2, byrow = TRUE) SP$addTraitA(nQtlPerChr = nQtlPerChr, mean = mean, var = varA, corA = corA, name = c("queenTrait", "workersTrait")) varE <- c(3, 3 / SP$nWorkers) -corE <- matrix(data = c(1.0, 0.3, +corE <- matrix(data = c(1.0, 0.3, 0.3, 1.0), nrow = 2, byrow = TRUE) SP$setVarE(varE = varE, corE = corE) basePop <- createVirginQueens(founderGenomes, n = 20) @@ -49,576 +69,153 @@ apiary <- cross(x = apiary, drones = drones, crossPlan = "create", checkCross = apiary <- buildUp(apiary) colonyGv <- calcColonyGv(apiary) colonyPheno <- calcColonyPheno(apiary) -``` - -The idea of this work is: - -1) We want to do honey bee simulations with individual queens, drones, and - workers - -2) To do the above, we require individual variances and covariances - -3) Literature reports only variances and covariances at the colony level - -4) The aim of this paper is to show how to use variances and covariances at the - colony level to do simulations at the individual level. - -# Introduction WORK IN PROGRESS - -This document develops theory for the variance of genetic and phenotypic values -between colonies with the aim to understand how to fine tune a SIMplyBee -simulation where we need variance components for queen and workers effects at an -individual honeybee level. The challenge here is that in reality we do not -observe such variances, but only on a colony level. - -For example, in the vignette we assumed that phenotypic variance on the -individual level is about 1/4 due to genetic variation and about 3/4 due to -environmental variation, but looking at colony genetic and phenotypic variances -the ratio was about 1/2! - -TODO: What do we do about this? It feels like we need a full paper on all of -this;) :( - -INTRODUCTION - -TODO: Topic 1 - -TODO: cite this paper that does honeybee simulations, but without actually doing -honeybee colony stuff etc. Heritability in honeybees paper: - - -TOOD: cite some classic papers on variances in honeybees - -TODO: cite recent papers from German and Dutch colleagues on variances in -honeybees - -Brascamp and Bijma (2014): Methods to estimate breeding values in honey bees - - -Brascamp and Bijma (2019): A note on genetic parameters and accuracy of -estimated breeding values in honey bees - - -Andonov et al.: Modeling honey yield, defensive and swarming behaviors of -Italian honey bees (Apis mellifera ligustica) using linear-threshold approaches - - -To make use of the material in this document you should run the quantitative -genetics vignette - the first example. Then you can continue here! - -Having multiple colonies and their values, we can now return to the "about" -point mentioned at the start of this section, when we defined quantitative -genetic parameters. Recall that our starting quantitative genetic parameters for -the queen and workers effects were: - -We will follow the example from Brascamp and Bijma (2019) they have: - -$\sigma_{g_q}^2=0.5$ - this is their $\sigma_{A_q}^2=0.5$ -$\sigma_{g_w}^2=1.0$ - this is their $\sigma_{A_w}^2=1.0$ among nominally -unrelated groups of workers - -$\sigma_{\bar{g}_w}^2=0.32$ - this is their $\sigma_{\bar{A}_w}^2=0.32$ among -base related groups of workers - -Where the relationship between the two is -$\sigma_{\bar{g}_w}^2 = a_{ii} * \sigma_{g_w}^2$ where $a_{ii}$ is average -additive genetic relationship between workers in a colony as can be defined (in -a non-inbred population) as -$a_{ii} = 1/4 + 1/2p_1 + 1/4(p_2 - p_1) + 1/4(1 - p_2)a_{ss}$; where $p_1$ is -the probability that two workers descend from the same drone, $p_2$ is the -probability that they descend from the same DPQ, and $a_{ss}$ is the relatedness -between two DPQs. We are ignore the $a_{ss}$ part (TODO?). - -$\sigma_{{g_q},{g_w}}=-0.35$ - -$\sigma_{P}^2 = \sigma_{\bar{g}_w^w}^2 + \sigma_{g_q^q}^2 + 2*\sigma_{\bar{g}_w^w g_q^q} + \sigma_{E}^2$ - -$\sigma_e^2=2.0$ - -$h^2=(a_{base}\sigma_{g,w}^2 + \sigma_{{g,w},{g,q}} + \sigma_{g,q}^2)/\sigma_{p,c}^2=???$ - -$h_w^2=a_{base}\sigma_{g,w}^2/\sigma_{p,c}^2=0.13$ - -$h_q^2=\sigma_{g,q}^2/\sigma_{p,c}^2=0.20$ - -$T^2=(\sigma_{g,w}^2 + 2\sigma_{{g,w},{g,q}} \sigma_{g,q}^2)/\sigma_{p,c}^2=0.32$ - -$T_w^2=\sigma_{g,w}^2/\sigma_{p,c}^2=0.41$ - -$T_q^2=\sigma_{g,q}^2/\sigma_{p,c}^2=0.20$ - -$r_g = cor(g_w, g_q) = -0.50$ - -TODO: equation 3 in Brascamp and Bijma (2019) is highly relevant to our work -here - that equation shows connection between the variance of the sum (or -average) of worker genetic values for worker effect AND variance of worker -genetic values for worker effect - THIS IS NOT TRUE they always work with the -worker group effect, never individuals! - -TODO: show sensitivity to the number of workers - the larger the number of -workers, the smaller the variance between workers - -covA[1, 1] + nW \* covA[2, 2] + 2 \* k \* covA[1, 2] - -```{r quan_gen_param_revision} -# Trait means -mean +``` -# Trait genetic variation - on a per honeybee level -varA +How the expected and realised variances look like +```{r ExpectedAndRealisedVariances} corA (covA <- corA * outer(X = sqrt(varA), Y = sqrt(varA), FUN = "*")) # Trait environmental variation - on a per honeybee level -varE -corE (covE <- corE * outer(X = sqrt(varE), Y = sqrt(varE), FUN = "*")) # Trait phenotypic variation - on a per honeybee level (covP <- covA + covE) (corP <- cov2cor(covP)) (varP <- diag(covP)) +nW <- SP$nWorkers -# Expected phenotypic variation - on a per colony level -# TODO: there is in fact more stuff happening here - see below! -nW <- SP$nWorkers # TODO: this is not correct - we have queen-workers pairs and workers-workers (see below!) -# Var(z)=Var(x+y)=Var(x)+Var(sum(y))=Var(x)+Var(y_1)+Var(y_2)+... -# this is all wrong likely ... - -k <- 1 # just adding this so vignette can run, but I don't know what this k should be +k <- 1 +print("Expected genetic and phenotypic variance") covA[1, 1] + nW * covA[2, 2] + 2 * k * covA[1, 2] # variance can not be negative! covP[1, 1] + nW * covP[2, 2] + 2 * k * covP[1, 2] -# Observed variation - on a per colony level +print("Realised genetic and phenotypic variance") var(colonyGv) var(colonyPheno) -var(colonyGv) / var(colonyPheno) -``` - -Hmm, we have much higher genetic and phenotypic variances in simulation than -based simply looking at queen and n\*workers variances, as well as much higher -ratio between the two than the initial value of \~1/4! Why? Let's see. For -genetic value of a colony $g_c$ we add up the queen's genetic value for the -queen effect $g_{q,q}$ and workers' genetic values for the workers effect -$\Sigma_{i=1}^{n_w}(g_{i,w})$: - -$g_c = g_{q,q} + \Sigma_{i=1}^{n_w}(g_{i,w}).$ - -Expectation of colony genetic value is then: - -$E(g_c) = E(g_{q,q} + \Sigma_{i=1}^{n_w}(g_{i,w}))$ - -$E(g_c) = E(g_{q,q}) + E(\Sigma_{i=1}^{n_w}(g_{i,w}))$ - -$E(g_c) = \mu_{g_{q}} + n_w E(g_{w,w})$ - -$E(g_c) = \mu_{g_{q}} + n_w \mu_{g_{w}}$ - -we are assuming here that $n_w$ is a fixed value, but if it is a random variable -then we would have - -$E(g_c) = \mu_{g_{q}} + E(n_w) E(g_{w,w})$ using - - -$E(g_c) = \mu_{g_{q}} + \lambda_{n_w} \mu_{g_{w}}$ - -where $\lambda_{n_w}$ is average number of workers. So, in our case this turns -out the same as above. So in our case we have: - -```{r} -nW <- SP$nWorkers -mean[1] + nW * mean[2] -mean(colonyGv) -mean(colonyPheno) -``` - -Variance of colony genetic value is then: - -$Var(g_c) = Var(g_{q,q} + \Sigma_{i=1}^{n_w}(g_{i,w}))$ - -$Var(g_c) = Var(g_{q,q}) + Var(\Sigma_{i=1}^{n_w}(g_{i,w})) + 2Cov(g_{q,q}, \Sigma_{i=1}^{n_w}(g_{i,w}))$ - -$Var(g_c) = \sigma^2_{g_{q}} + Var(\Sigma_{i=1}^{n_w}(g_{i,w})) + 2Cov(g_{q,q}, \Sigma_{i=1}^{n_w}(g_{i,w}))$ - -So, we have three parts: - -A) the variance of the queen effect in queens $\sigma^2_{g_{q}}$, - -B) variance of a sum of workers effect in workers - $Var(\Sigma_{i=1}^{n_w}(g_{i,w}))$, and - -C) covariance between the two $2Cov(g_{q,q}, \Sigma_{i=1}^{n_w}(g_{i,w}))$. - -# A) Variance of the queen effect in queens $\sigma^2_{g_{q}}$ - in our case this is: - -```{r check_queen_variances} -varA[1] -x = getQueenGv(apiary, collapse = TRUE)[, "queenTrait"] -var(x) -# ... note that R's var() divides by n-1, which matters with small n -popVar(x) -sum((x - mean[1])^2) / nColonies(apiary) - ``` -Anyway, quite close! - -# B) Variance of a sum of workers effect in workers $Var(\Sigma_{i=1}^{n_w}(g_{i,w}))$ - -Given that this is a sum, we need to look at: - -B1) variance of each of worker genetic values $Var(g_{i,w})$ and - -B2) covariance between each pair of the values $Cov(g_{i,w}, g_{j,w})$. - -This means, that family structure will start to matter because it induces -covariance between family members (workers). The simplest case is when all -workers come from the same father. Then we have: - -$g_{1,w} = \frac{1}{2}g_{q,w} + g_{f,w} + r_{1,w}$ - -$g_{2,w} = \frac{1}{2}g_{q,w} + g_{f,w} + r_{2,w}$ - -... - -$g_{n_w,w} = \frac{1}{2}g_{q,w} + g_{f,w} + r_{n_w,w}$ - -## B1) variance of each of worker genetic values $Var(g_{i,w})$ - -As stated initially, we have $Var(g_{i,w}) = \sigma^2_{g_{w}}$ and we have $n_w$ -such terms, $n_w \sigma^2_{g_{w}}$. In our case this would be: - -```{r check_workers_variances} -nW * varA[2] -g <- calcColonyGv(apiary, mapCasteToColonyGv, queenTrait = NULL, workersTrait = "workersTrait") -var(g) -# ... note that R's var() divides by n-1, which matters with small n -sum((g - nW * mean[2])^2) / nColonies(apiary) -popVar(g) -``` - -So, a huge discrepancy between the variance of a sum of genetic values for the -workers effect `nW * varA[2]` (assuming independence) and a realised sum of -genetic values for the workers effect. As we have seen above, this is due to -family structure and associated B2) covariance between each pair of the values -$Cov(g_{i,w}, g_{j,w})$. - -## B2) covariance between each pair of the values $Cov(g_{i,w}, g_{j,w})$ - -Clearly, these covariances matter a lot - there is lots of worker pairs in a -colony! How do these covariances look like? +Now, in theory, how we go from the individual to colony level variances? +The queen trait variance remains the same, since there is only one queen. The worker +individual variance needs to be adjusted due to covariances between workers. -$Cov(g_{1,w}, g_{2,w}) = Cov(\frac{1}{2}g_{q,w} + g_{f,w}, \frac{1}{2}g_{q,w} + g_{f,w})$ +```{r AdjustingWorkerVariance} +a_ii = 0.40 +varA_colony <- c(varA[1], varA[2] * a_ii) +corA = cov2cor(covA) +covA_colony = cor2cov(corA, var = varA_colony) -$Cov(g_{1,w}, g_{2,w}) = Var(\frac{1}{2}g_{q,w}) + Var(g_{f,w})$ +covA[1, 1] + nW * covA[2, 2] + 2 * k * covA[1, 2] +covA_colony[1, 1] + covA_colony[2, 2] + 2 * k * covA_colony[1, 2] -assuming that mother and father are not related; further genetic variance -between drones is in fact half the genetic variance between queens because they -are haploid, so we get: - -$Cov(g_{1,w}, g_{2,w}) = \frac{1}{4}\sigma^2_{g_w} + \frac{1}{4}\sigma^2_{g_w}$ - -$Cov(g_{1,w}, g_{2,w}) = \frac{1}{2}\sigma^2_{g_w}$. - -Every pair of super-sister workers adds $\frac{1}{2}\sigma^2_{g_w}$ to B - note -that pair A-B adds this value, but so does the pair B-A, hence total is -$2\frac{1}{2}\sigma^2_{g_w} = \sigma^2_{g_w}$. With $n_w$ workers we get -$n_w n_w$ pairs (including with itself) or $n_w n_w - n_w$ pairs between -different workers. The total covariance contribution is then -$(n_w n_w - n_w)\frac{1}{2}\sigma^2_{g_w}$). In our case this would be: - -```{r check_workers_variances2} -(varSumWorkers <- nW * varA[2]) # B1 -(covSumWorkers <- (nW * nW - nW) * 1/2 * varA[2]) # B2 -varSumWorkers + covSumWorkers # B - -g <- calcColonyGv(apiary, mapCasteToColonyGv, queenTrait = NULL, workersTrait = "workersTrait") -var(g) # B -# ... note that R's var() divides by n-1, which matters with small n -sum((g - nW * mean[2])^2) / nColonies(apiary) # B -popVar(g) -``` - -If we would only have super-sisters we would have \~1 for B1, \~49.5 for B2, and -\~50.5 for B, but with a mix of half-sisters and super-sisters we would have a -lower value, which is what we see above, \~26.8 for B. - -TODO: Define the setting above in intro or start of M&M - We also can have -full-sisters, where the mother is obviously the same, but the fathers are -different, yet they come from the same mother, which is equivalent to a -full-sibs case in diploid species. We will assume in this work that we have -unrelated queens and unrelated drones (=base pop) - our aim is to set variances -in such a base population - to get the scale or the variances right. In -simulation of our base population we generated drones from virgin queens, which -means that our drones can in fact be brothers, so our realised variances might -be a bit off compared to this theory. But this is fine, we are mostly trying to -get the order of variances correct. - -So, now we need to work out B2 with a mix of half-sisters and super-sisters :( -Sister workers are related only due to having the same mother, assuming that -drones the queen mated with are unrelated: - -$g_{1,w} = \frac{1}{2}g_{q,w} + g_{f1,w} + r_{1,w}$ - -$g_{2,w} = \frac{1}{2}g_{q,w} + g_{f2,w} + r_{2,w}$ - -$Cov(g_{1,w}, g_{2,w}) = Cov(\frac{1}{2}g_{q,w} + g_{f1,w}, \frac{1}{2}g_{q,w} + g_{f2,w})$ - -$Cov(g_{1,w}, g_{2,w}) = Var(\frac{1}{2}g_{q,w})$ - -$Cov(g_{1,w}, g_{2,w}) = \frac{1}{4}Var(g_{q,w})$ - -Hence every pair of half-sister workers adds $\frac{1}{4}\sigma^2_{g_w}$ to B -(note, this is $2\frac{1}{4}\sigma^2_{g_w}$ for A-B and B-A pairs!). With $n_w$ -workers and $n_f$ fathers we have $\frac{n_w}{n_f}$ workers per father. Further, -we have $n_f$ groups of super-sisters and $n_f n_f - n_f$ pairs of sister -groups. Assuming that half-sister groups are the same size, we have -$n_f \frac{n_w}{n_f} \frac{n_w}{n_f} = n_w \frac{n_w}{n_f} = \frac{n^2_w}{n_f}$ -pairs of super-sisters and $(n_f n_f - n_f) \frac{n_w}{n_f} \frac{n_w}{n_f}$ - -this is -$n_f (n_f - 1) \frac{n_w}{n_f} \frac{n_w}{n_f} = (n_f - 1) n_w \frac{n_w}{n_f} = \frac{ (n_f - 1) n^2_w}{n_f}$. -Is this correct? - -```{r pairs_of_workers} -(nF <- nFathers(colony)) -nW * nW -(a <- nW * nW / nF) -(b <- (nF - 1) * nW * nW / nF) -a+b -#TODO define nDPQ -``` - -Looks like! - -So, super-sister pairs add $\frac{n^2_w}{n_f} \frac{1}{2}\sigma^2_{g_w}$ and -half-sister pairs add $\frac{ (n_f - 1) n^2_w}{n_f} \frac{1}{4}\sigma^2_{g_w}$. -Let's test this: - -```{r check_workers_variances3} -(varSumWorkers <- nW * varA[2]) # B1 -(covSumWorkersSuperSisters <- (nW * nW / nF) * 0.75 * varA[2]) # B2 in super-sisters ERROR: SHOULD BE 0.75 -(covSumWorkersHalfSisters <- ((nF - 1) * nW * nW / nF) * 0.25 * varA[2]) # B2 in half-sisters -varSumWorkers + covSumWorkersSuperSisters + covSumWorkersHalfSisters # B - -g <- calcColonyGv(apiary, mapCasteToColonyGv, queenTrait = NULL, workersTrait = "workersTrait") -var(g) # B -# ... note that R's var() divides by n-1, which matters with small n -sum((g - SP$nWorkers * mean[2])^2) / nColonies(apiary) # B +var(colonyGv) +var(colonyPheno) ``` -Cool - very close!!! There can be some difference because the formulae above -assume that we have fixed sizes of half-sister and super-sister groups. Also, -there can be full-sisters in there as well!!! - -TODO: We could also add full-sisters: To do this, we would have to assume how -many brother drones we use to figure out the grups - -TODO: What if $n_w$ is a random variable? Following - -we would use: - -$Var(XY) = (Var(X) + E(X)^2) (Var(Y) + E(Y)^2) - E(X)^2 E(Y)^2$ - -but this is for two variables, while I have $n_w$ genetic values, so this -reference result is not that useful in our case! Well, if $n_w$ varies between -colonies, this must boost variance of colony-level genetic values significantly, -because kind of start calculating variance between apples (small colonies) and -oranges (large colonies). - -# C) Covariance between the two $2Cov(g_{q,q}, \Sigma_{i-1}^{n_w}(g_{i,w}))$. - -Let's repeat: - -$g_{1,w} = \frac{1}{2}g_{q,w} + g_{f1,w} + r_{1,w}$ - -$g_{2,w} = \frac{1}{2}g_{q,w} + g_{f2,w} + r_{2,w}$ ... - -The essential bit here is: - -$Cov(g_{q,q}, g_{i,w}) = Cov(g_{q,q}, \frac{1}{2} g_{q,w})$ - -assuming that the queen and fathers are unrelated. Then: - -$Cov(g_{q,q}, g_{i,w}) = Cov(g_{q}, \frac{1}{2} g_{w})$ - -$Cov(g_{q,q}, g_{i,w}) = \frac{1}{2} Cov(g_{q}, g_{w})$ - -$Cov(g_{q,q}, g_{i,w}) = \frac{1}{2} \sigma_{g_{q},g_{w}}$ - -So: - -$2Cov(g_{q,q}, \Sigma_{i=1}^{n_w}(g_{i,w})) = 2Cov(g_{q,q}, n_w \frac{1}{2} g_{q,w})$ +We need to add the covariance due to different types of workers in the colony +```{r CovariancesBetweenWorkers} +mapIndToColonyVar <- function(varA_q, varA_w, corA_qw, nW, nF, nDPQ, workersFUN = "sum") { + if (workersFUN == "mean") { + factor = 1 / nW^2 + } else if (workersFUN == "sum") { + factor = nW + } + + # Determine how many pairs of each you have + nW = nW + n_SS = (nW * nW / nF) - nW + n_FS = (nW * nW / nDPQ) - (nW * nW / nF) + n_HS = (nW * nW / nDPQ) * (nDPQ - 1) + + A <- varA_q + if (workersFUN == "mean") { + B1 = 1 / nW * varA_w + } else if (workersFUN == "sum") { + B1 = nW * varA_w + } + + B2_ss <- n_SS * 0.75 * varA_w + B2_fs <- n_FS * 0.50 * varA_w + B2_hs <- n_HS * 0.25 * varA_w + if (workersFUN == "mean") { + B = B1 + 1/nW^2 * (B2_ss + B2_fs + B2_hs) + } else if (workersFUN == "sum") { + B = B1 + B2_ss + B2_fs + B2_hs + } + + covA_qw = corA_qw * sqrt(varA_q) * sqrt(varA_w) + + if (workersFUN == "mean") { + C <- covA_qw + } else if (workersFUN == "sum") { + C <- nW * covA_qw + } + + varC <- A + B + C + + return(list(A = A, B = B, C = C, colonyVar = varC)) +} + +#This is the same as above, just simplified +# mapIndToColonyVar <- function(varA_q, varA_w, corA_qw, nW, nF, nDPQ, workersFUN = "sum") { + +# # Determine how many pairs of each you have +# p_SS = 1 / nF - 1 / nW +# p_FS = (1 / nDPQ) - (1 / nF) +# p_HS = (1 / nDPQ) * (nDPQ - 1) +# A <- varA_q +# B1 <- nW * varA_w +# B2_ss <- p_SS * 0.75 +# B2_fs <- p_FS * 0.50 +# B2_hs <- p_HS * 0.25 + +# covA_qw = corA_qw * sqrt(varA_q) * sqrt(varA_w) +# C <- nW * covA_qw + +# if (workersFUN == "sum") { +# varC <- A + B1 + (B2_ss + B2_fs + B2_hs)*nW^2*varA_w + C +# } else if (workersFUN == "mean") { +# varC <- A + varA_w + (B2_ss + B2_fs + B2_hs)*varA_w + covA_qw# This is equal as varA_w * average relatedness within a colony +# } +# return(varC) +# } -$2Cov(g_{q,q}, \Sigma_{i=1}^{n_w}(g_{i,w})) = 2 n_w \frac{1}{2}Cov(g_{q,q}, g_{q,w})$ - -$2Cov(g_{q,q}, \Sigma_{i=1}^{n_w}(g_{i,w})) = n_w \sigma_{g_{q},g_{w}}$ - -```{r check_workers_variances4} -nDPQ = 5 -n_SS = (nW * nW / nF) - nW -n_FS = (nW * nW / nDPQ) - (nW * nW / nF) -n_HS = (nW * nW / nDPQ) * (nDPQ - 1) - -(n_SS + n_FS + n_HS + nW) == nW * nW - -print("Genetic variances") -print("Part A") -(varQueen_A <- varA[1]) # A - -print("Part B1") -(varSumWorkers_A <- nW * varA[2]) # B1 -print("Part B2 in super-sisters") -(covSumWorkersSuperSisters_A <- n_SS * 0.75 * varA[2]) # B2 in super-sisters -print("Part B2 in full-sisters") -(covSumWorkersFullSisters_A <- n_FS * 0.50 * varA[2]) # B2 in full-sisters -print("Part B2 in half-sisters") -(covSumWorkersHalfSisters_A <- n_HS * 0.25 * varA[2]) # B2 in half-sisters -print("Part B combined") -(varCovSumWorkers_A <- varSumWorkers_A + covSumWorkersSuperSisters_A + covSumWorkersFullSisters_A + covSumWorkersHalfSisters_A) # B -print("Part C") -(covQueenSumWorkers_A <- nW * covA[1, 2]) # C - -print("Part A + B + C") -varQueen_A + varCovSumWorkers_A + 2*covQueenSumWorkers_A - -print("ColonyGv variance") -g <- colonyGv -var(g) -popVar(g) -sum((g - (mean(g)))^2) / nColonies(apiary) ``` -Bingo for genetic variance. - -```{r} - - -print("Environmental variance") -print("Part A") -(varQueen_E <- varE[1]) # A -print("Part B1") -(varSumWorkers_E <- nW * varE[2]) # B1, there is not environmental covariance between workers, so no B2 -print("Part C") -(covQueenSumWorkers_E <- nW * covE[1, 2]) # C - both genetic and env cove here? TODO - -print("Part A + B + C f") -varQueen_A + varCovSumWorkers_A + covQueenSumWorkers_A + varQueen_E + varSumWorkers_E + covQueenSumWorkers_E - -p <- colonyPheno -var(p) -popVar(p) -sum((p - (mean(p)))^2) / nColonies(apiary) +```{r testingMapIndToColonyVar} +# Get the real number of fathers and DPQs +nW = round(mean(nWorkers(apiary)), 0) +nF = round(mean(nFathers(apiary)), 0) +nDPQ <- round(mean(sapply(getFathers(apiary), function(x) length(unique(x@mother)))), 0) + + +# When the function to summarise worker effects is SUM +mapIndToColonyVar(varA_q = varA[1], + varA_w= varA[2], + corA_qw = corA[1,2], + nW = nW, nF = nF, + nDPQ = nDPQ, + workersFUN = "sum") +colonyGv <- calcColonyGv(apiary, FUN = mapCasteToColonyGv, workersFUN = colSums) +var(colonyGv) ``` -And very close for phenotypic too, but we need to check some part above! - -# What now? - -Alright, what can we now do with this? We now have a system of expected genetic -and phenotypic variances for colony values as a function of number of workers, -fathers, and genetic and phenotypic covariances between the queen and worker -effects. So, it should be possible, in principle, to solve for what kind of -covariance values for the queen and workers effects should we use, to get the -desired colony genetic and phenotypic variances! - -TODO: develop such estimating equations! - -So, we have genetic part: - -$A_g = \sigma^2_{g_q}$ - -$B1_g = n_w \sigma^2_{g_w}$ - -$B2ss_g = (\frac{n^2_w}{n_f} - {n_w}) \frac{1}{2} \sigma^2_{g_w}$ - -$B2fs = (\frac{n^2_w}{n_{DPQ}} - \frac{n^2_w}{n_f}) \frac{1}{4} \sigma^2_{g_w}$ - -$B2hs_g = \frac{(n_f - 1) n^2_w}{n_f} \frac{1}{4} \sigma^2_{g_w}$ - -$C_g = n_w \sigma^2_{{g_q},{g_w}}$ - -here are 3 unknowns: $\sigma^2_{g_q}$, $\sigma^2_{g_w}$, and -$\sigma^2_{{g_q},{g_w}}$ - -we can add phenotypic part: - -$A_p = \sigma^2_{p_q}$ - -$B1_p = n_w \sigma^2_{p_w}$ - -$B2_p = \frac{n^2_w}{n_f} \frac{1}{2} \sigma^2_{g_w}$ TODO: check if its only -genetic - -$B3_p = \frac{(n_f - 1) n^2_w}{n_f} \frac{1}{4} \sigma^2_{g_w}$ TODO: check if -its only genetic - -$C_p = n_w \sigma^2_{{p_q},{p_w}}$ - -here are additional 3 unknowns: $\sigma^2_{p_q}$, $\sigma^2_{p_w}$, and -$\sigma^2_{{p_q},{p_w}}$ -while we could provide as guidance 2, maybe 3, inputs: $\sigma^2_{g_c}$, -$\sigma^2_{p_c}$, and $\frac{\sigma^2_{g_c}}{\sigma^2_{p_c}}$. - -TODO: are there any additional inputs that we could get from literature? How do -we connect all this with variance estimates for the queen and the workers effect -in the honeybee genetics and breeding literature? I think that those estimates -are essentially this: -$\sigma^2_{g_c} = \sigma^2_{g_{c,q}} + \sigma^2_{g_{c,w}} + 2\sigma_{g_{c,q},g_{c,w}}$ -where $\sigma^2_{g_{c,q}}$ is the queen part of $\sigma^2_{g_c}$, but not -necessarily the same as $\sigma^2_{g_w}$, or is it? Maybe that is the same, and -$\sigma^2_{g_{c,w}}$ is a counterpart to -$n_w \sigma^2_{g_w} + \frac{n^2_w}{n_f} \frac{1}{2} \sigma^2_{g_w}, \frac{(n_f - 1) n^2_w}{n_f} \frac{1}{4} \sigma^2_{g_w}$ -(TODO: should we add full-sisters?), while $\sigma_{g_{c,q},g_{c,w}}$ is a -counterpart to $n_w \sigma_{{g_q},{g_w}}$. If this is so, then it fells that we -should have 3 more inputs for genetic part, so 4 inputs to estimate 3 unknowns -of which some are very simple transformations!!! - -Additional input could be $\sigma^2_{p_c}$. For sure we don't get estimates of -$\sigma^2_{p_c} = \sigma^2_{p_{c,q}} + \sigma^2_{p_{c,w}} + 2\sigma_{p_{c,q},p_{c,w}}$, -but, having sorted the genetic part and if $B2_p$ and $B3_p$ depend only on -genetic covariance, then maybe, we have some maneuvering space to estimate also -$\sigma^2_{p_q}$, $\sigma^2_{p_w}$, and $\sigma^2_{{p_q},{p_w}}$?! - -Furthermore, we have some constraints, so this is not just any system of -equations. For example, we know that variances must be positive. Futhermore, we -might know that come covariances are either positive or negative. - -TODO: Develop and polish all this further and create a Shiny application where -we can change these individual-level parameters and study how that will change -colony-level parameters and then how we could go the other way around based on -literature and solving the above systems of equations. We could host such a -Shiny app on SIMplyBee.info!? Can we? - -NEXT STEPS: - -1) read the above, check derivations, missing bits, etc. - -2) write a function that takes individual variances, nw, nf, etc. and returns - colony variances and h2, t2, T2, ... - -3) develop a system of equations (using A, Bs, and C) linking individual and - colony values for two types of colony values (for different models beepeople - run!) - then find a way to optimize/solve for individual values (output) - with colony values as input - - -NOW - do the same, but for when the aggregate of the workers is a mean ```{r FirstExampleFromQuanGenVignette} -library(package = "SIMplyBee") +# Run the example from the quantitative genetic vignette founderGenomes <- quickHaplo(nInd = 20, nChr = 16, segSites = 1000) SP <- SimParamBee$new(founderGenomes) nQtlPerChr <- 100 mean <- c(10, 10) varA <- c(1, 1) -corA <- matrix(data = c( 1.0, -0.5, - -0.5, 1.0), nrow = 2, byrow = TRUE) +corA <- matrix(data = c( 1.0, -0.5, + -0.5, 1.0), nrow = 2, byrow = TRUE) SP$addTraitA(nQtlPerChr = nQtlPerChr, mean = mean, var = varA, corA = corA, name = c("queenTrait", "workersTrait")) varE <- c(3, 3) -corE <- matrix(data = c(1.0, 0.3, +corE <- matrix(data = c(1.0, 0.3, 0.3, 1.0), nrow = 2, byrow = TRUE) SP$setVarE(varE = varE, corE = corE) basePop <- createVirginQueens(founderGenomes, n = 20) @@ -633,171 +230,148 @@ apiary <- createMultiColony(basePop[7:20]) drones <- createDrones(basePop[1:5], nInd = 100) apiary <- cross(x = apiary, drones = drones, crossPlan = "create", checkCross = "warning") apiary <- buildUp(apiary) -colonyGv <- unlist(mapCasteToColonyGv(x = apiary, queenTrait = 1, workersTrait = 2, workersFUN = colMeans)) -colonyPheno <- unlist(mapCasteToColonyPheno(x = apiary, queenTrait = 1, workersTrait = 2, workersFUN = colMeans)) -``` - - -```{r quan_gen_param_revision} -# Trait means -mean - -# Trait genetic variation - on a per honeybee level -varA -corA -(covA <- corA * outer(X = sqrt(varA), Y = sqrt(varA), FUN = "*")) - -# Trait environmental variation - on a per honeybee level -varE -corE -(covE <- corE * outer(X = sqrt(varE), Y = sqrt(varE), FUN = "*")) - -# Trait phenotypic variation - on a per honeybee level -(covP <- covA + covE) -(corP <- cov2cor(covP)) -(varP <- diag(covP)) - -# Expected phenotypic variation - on a per colony level -# TODO: there is in fact more stuff happening here - see below! -nW <- SP$nWorkers # TODO: this is not correct - we have queen-workers pairs and workers-workers (see below!) -# Var(z)=Var(x+y)=Var(x)+Var(sum(y))=Var(x)+Var(y_1)+Var(y_2)+... -# this is all wrong likely ... - -k <- 1 # just adding this so vignette can run, but I don't know what this k should be +colonyGv <- calcColonyGv(apiary) +colonyPheno <- calcColonyPheno(apiary) +``` -# Observed variation - on a per colony level +```{r testingMapIndToColonyVarMean} +# Get the real number of fathers and DPQs +nW = round(mean(nWorkers(apiary)), 0) +nF = round(mean(nFathers(apiary)), 0) +nDPQ <- round(mean(sapply(getFathers(apiary), function(x) length(unique(x@mother)))), 0) + + +# When the function to summarise worker effects is MEAN +mapIndToColonyVar(varA_q = varA[1], + varA_w= varA[2], + corA_qw = corA[1,2], + nW = nW, nF = nF, + nDPQ = nDPQ, + workersFUN = "mean") +colonyGv <- calcColonyGv(apiary, FUN = mapCasteToColonyGv, workersFUN = colMeans) var(colonyGv) -var(colonyPheno) -var(colonyGv) / var(colonyPheno) ``` - -# A) Variance of the queen effect in queens $\sigma^2_{g_{q}}$ - in our case this is: - -```{r check_queen_variances} -varA[1] -x = getQueenGv(apiary, collapse = TRUE)[, "queenTrait"] -var(x) -# ... note that R's var() divides by n-1, which matters with small n -popVar(x) -sum((x - mean[1])^2) / nColonies(apiary) - +```{r mapColonyToIndVar} +# First option, we know the varA_q, varA_wbar and cor, and one varE +mapColonyToIndVar <- function(varA_q, + varA_wbar, + corA_qwbar = NULL, + varE, + nW, + nF, + nDPQ, + workersFUN = "sum") { + + # scaling factor + if (workersFUN == "sum") { + covA_qwbar <- corA_qwbar * sqrt(varA_q) * sqrt(varA_wbar) + covA_qw <- covA_qwbar / nW + } else if (workersFUN == "mean") { + covA_qw <- covA_qwbar + } + + # pair counts + n_SS <- (nW * nW / nF) - nW + n_FS <- (nW * nW / nDPQ) - (nW * nW / nF) + n_HS <- (nW * nW / nDPQ) * (nDPQ - 1) + + # worker variance coefficient + if (workersFUN == "sum") { + K <- nW + + n_SS * 0.75 + + n_FS * 0.50 + + n_HS * 0.25 + } else if (workersFUN == "mean") { + K <- 1 / nW + ((n_SS * 0.75 + + n_FS * 0.50 + + n_HS * 0.25) / nW^2) + } + + varA_w <- varA_wbar / K + + corA_qw <- covA_qw / (sqrt(varA_q) * sqrt(varA_w)) + + return(list(varA_q = varA_q, varA_wbar = varA_wbar, varA_w = varA_w, covA_qwbar = covA_qwbar, covA_qw = covA_qw, corA_qw = corA_qw)) +} ``` -Anyway, quite close! - -# B) Variance of a sum of workers effect in workers $Var(\Sigma_{i=1}^{n_w}(g_{i,w}))$ - -Given that this is a sum, we need to look at: - -B1) variance of each of worker genetic values $Var(g_{i,w})$ and - -B2) covariance between each pair of the values $Cov(g_{i,w}, g_{j,w})$. +```{r testMapColonyToIndFunction} +mapColonyToIndVar(varA_q = 10, varA_wbar = 10, corA_qwbar = -0.5, varE = 30, nW = 100, nF = 5, nDPQ = 5, workersFUN = "sum") -This means, that family structure will start to matter because it induces -covariance between family members (workers). The simplest case is when all -workers come from the same father. Then we have: - -$g_{1,w} = \frac{1}{2}g_{q,w} + g_{f,w} + r_{1,w}$ - -$g_{2,w} = \frac{1}{2}g_{q,w} + g_{f,w} + r_{2,w}$ - -... - -$g_{n_w,w} = \frac{1}{2}g_{q,w} + g_{f,w} + r_{n_w,w}$ - -## B1) variance of each of worker genetic values $Var(g_{i,w})$ - -As stated initially, we have $Var(g_{i,w}) = \sigma^2_{g_{w}}$ and we have $n_w$ -such terms, $n_w \sigma^2_{g_{w}}$. In our case this would be: - -```{r check_workers_variances} -nW * varA[2] -g <- calcColonyGv(apiary, mapCasteToColonyGv, queenTrait = NULL, workersTrait = "workersTrait", workersFUN = colMeans) -var(g) -# ... note that R's var() divides by n-1, which matters with small n -#sum((g - 1/nW^2 * mean[2])^2) / nColonies(apiary) ? -popVar(g) -``` +# Run the example from the quantitative genetic vignette +founderGenomes <- quickHaplo(nInd = 20, nChr = 16, segSites = 1000) +SP <- SimParamBee$new(founderGenomes) +SP$nWorkers <- 100 +nQtlPerChr <- 100 +mean <- c(0, 0) +varA <- c(10, 0.002836879) +corA <- matrix(data = c( 1.0, -0.2968586, + -0.2968586, 1.0), nrow = 2, byrow = TRUE) +SP$addTraitA(nQtlPerChr = nQtlPerChr, mean = mean, var = varA, corA = corA, + name = c("queenTrait", "workersTrait")) +varE <- c(3, 3) +corE <- matrix(data = c(1.0, 0.3, + 0.3, 1.0), nrow = 2, byrow = TRUE) +SP$setVarE(varE = varE, corE = corE) +basePop <- createVirginQueens(founderGenomes, n = 20) +head(basePop@gv) +head(basePop@pheno) +drones <- createDrones(x = basePop[1:5], nInd = 3) +colony <- createColony(x = basePop[6]) +colony <- cross(x = colony, drones = drones, checkCross = "warning") +colony <- addWorkers(x = colony, nInd = 50) +colony <- buildUp(colony) +apiary <- createMultiColony(basePop[7:20]) +drones <- createDrones(basePop[1:5], nInd = 100) +apiary <- cross(x = apiary, drones = drones, crossPlan = "create", checkCross = "warning") +apiary <- buildUp(apiary) -So, a huge discrepancy between the variance of a sum of genetic values for the -workers effect `nW * varA[2]` (assuming independence) and a realised sum of -genetic values for the workers effect. As we have seen above, this is due to -family structure and associated B2) covariance between each pair of the values -$Cov(g_{i,w}, g_{j,w})$. - -## B2) covariance between each pair of the values $Cov(g_{i,w}, g_{j,w})$ - -```{r pairs_of_workers} -(nF <- round(mean(nFathers(apiary)), 0)) -(nDPQ <- round(mean(sapply(getFathers(apiary), function(x) length(unique(x@mother)))), 0)) -nW * nW -(a <- nW * nW / nF) -(b <- (nF - 1) * nW * nW / nF) -a+b -``` +workerGroupGv <- calcColonyGv(apiary, mapCasteToColonyGv, queenTrait = NULL, workersFUN = colSums) +colonyGv <- calcColonyGv(apiary) # sum is the default -Looks like! - -So, super-sister pairs add $\frac{n^2_w}{n_f} \frac{1}{2}\sigma^2_{g_w}$ and -half-sister pairs add $\frac{ (n_f - 1) n^2_w}{n_f} \frac{1}{4}\sigma^2_{g_w}$. -Let's test this: - - -```{r check_workers_variances4} -n_SS = (nW * nW / nF) - nW -n_FS = (nW * nW / nDPQ) - (nW * nW / nF) -n_HS = (nW * nW / nDPQ) * (nDPQ - 1) - -(n_SS + n_FS + n_HS + nW) == nW * nW - -print("Genetic variances") -print("Part A") -(varQueen_A <- varA[1]) # A - -print("Part B1") -(varSumWorkers_A <- (1 / nW^2) * varA[2]) # B1 -print("Part B2 in super-sisters") -(covSumWorkersSuperSisters_A <- n_SS * 0.75 * varA[2]) # B2 in super-sisters -print("Part B2 in full-sisters") -(covSumWorkersFullSisters_A <- n_FS * 0.50 * varA[2]) # B2 in full-sisters -print("Part B2 in half-sisters") -(covSumWorkersHalfSisters_A <- n_HS * 0.25 * varA[2]) # B2 in half-sisters -print("Part B combined") -(varCovSumWorkers_A <- (1 / nW^2) * (varSumWorkers_A + covSumWorkersSuperSisters_A + covSumWorkersFullSisters_A + covSumWorkersHalfSisters_A)) #B -print("Part C") -(covQueenSumWorkers_A <- (1 / nW^2) * covA[1, 2]) # C - -print("Part A + B + C") -varQueen_A + varCovSumWorkers_A + covQueenSumWorkers_A - -print("ColonyGv variance") -g <- colonyGv -var(g) -popVar(g) -sum((g - (mean(g)))^2) / nColonies(apiary) +print("Worker group variance") +var(workerGroupGv) +print("Colony variance") +var(colonyGv) ``` -Bingo for genetic variance. - -```{r} -print("Environmental variance") -print("Part A") -(varQueen_E <- varE[1]) # A -print("Part B1") -(varSumWorkers_E <- (1 / nW^2) * varE[2]) # B1, there is not environmental covariance between workers, so no B2 -print("Part C") -(covQueenSumWorkers_E <- (1 / nW^2) * covE[1, 2]) # C - both genetic and env cove here? TODO +```{r testMapColonyToIndFunction} +mapColonyToIndVar(varA_q = 10, varA_wbar = 10, corA_qwbar = -0.5, varE = 30, nW = 100, nF = 5, nDPQ = 5, workersFUN = "mean") -print("Part A + B + C f") -varQueen_A + varCovSumWorkers_A + covQueenSumWorkers_A + varQueen_E + varSumWorkers_E + covQueenSumWorkers_E +# Run the example from the quantitative genetic vignette +founderGenomes <- quickHaplo(nInd = 20, nChr = 16, segSites = 1000) +SP <- SimParamBee$new(founderGenomes) +SP$nWorkers <- 100 +nQtlPerChr <- 100 +mean <- c(0, 0) +varA <- c(10, 28.36879) +corA <- matrix(data = c( 1.0, -0.2968586, + -0.2968586, 1.0), nrow = 2, byrow = TRUE) +SP$addTraitA(nQtlPerChr = nQtlPerChr, mean = mean, var = varA, corA = corA, + name = c("queenTrait", "workersTrait")) +varE <- c(3, 3) +corE <- matrix(data = c(1.0, 0.3, + 0.3, 1.0), nrow = 2, byrow = TRUE) +SP$setVarE(varE = varE, corE = corE) +basePop <- createVirginQueens(founderGenomes, n = 20) +head(basePop@gv) +head(basePop@pheno) +drones <- createDrones(x = basePop[1:5], nInd = 3) +colony <- createColony(x = basePop[6]) +colony <- cross(x = colony, drones = drones, checkCross = "warning") +colony <- addWorkers(x = colony, nInd = 50) +colony <- buildUp(colony) +apiary <- createMultiColony(basePop[7:20]) +drones <- createDrones(basePop[1:5], nInd = 100) +apiary <- cross(x = apiary, drones = drones, crossPlan = "create", checkCross = "warning") +apiary <- buildUp(apiary) -p <- colonyPheno -var(p) -popVar(p) -sum((p - (mean(p)))^2) / nColonies(apiary) -``` +workerGroupGv <- calcColonyGv(apiary, mapCasteToColonyGv, queenTrait = NULL, workersFUN = colSums) +colonyGv <- calcColonyGv(apiary) # sum is the default -And very close for phenotypic too, but we need to check some part above! +var(workerGroupGv) +var(colonyGv) +``` \ No newline at end of file From 69739a5ca4cf4d4f0e2e94313f08e7bcbe995ab4 Mon Sep 17 00:00:00 2001 From: janaobsteter Date: Fri, 15 May 2026 14:46:32 +0200 Subject: [PATCH 54/56] Sup files changed --- man/MultiColony-class.Rd | 8 ++++---- man/crossVirginQueen.Rd | 18 ++++++++++++++++++ vignettes/.gitignore | 3 +++ 3 files changed, 25 insertions(+), 4 deletions(-) create mode 100644 man/crossVirginQueen.Rd 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/crossVirginQueen.Rd b/man/crossVirginQueen.Rd new file mode 100644 index 00000000..f28bd134 --- /dev/null +++ b/man/crossVirginQueen.Rd @@ -0,0 +1,18 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/Functions_L1_Pop.R +\name{crossVirginQueen} +\alias{crossVirginQueen} +\title{Internal function to cross a virgin queen} +\usage{ +crossVirginQueen(virginQueen, virginQueenDrones, simParamBee = NULL) +} +\arguments{ +\item{virginQueen}{\code{\link[AlphaSimR]{Pop-class}}} + +\item{virginQueenDrones, }{list with drones} + +\item{simParamBee, }{SimParamBee object} +} +\description{ +Internal function to cross a virgin queen +} diff --git a/vignettes/.gitignore b/vignettes/.gitignore index cc78fe5d..cf04f8e0 100644 --- a/vignettes/.gitignore +++ b/vignettes/.gitignore @@ -1 +1,4 @@ FounderGenomes2_3chr.RData + +/.quarto/ +**/*.quarto_ipynb From 7d6a3a4d93cf296d8e922cb73fb75249aa1b1b83 Mon Sep 17 00:00:00 2001 From: janaobsteter Date: Fri, 15 May 2026 14:48:38 +0200 Subject: [PATCH 55/56] Adding back the F2 vignetet --- vignettes/F2_Variance_calculations.Rmd | 803 +++++++++++++++++++++++++ 1 file changed, 803 insertions(+) create mode 100644 vignettes/F2_Variance_calculations.Rmd diff --git a/vignettes/F2_Variance_calculations.Rmd b/vignettes/F2_Variance_calculations.Rmd new file mode 100644 index 00000000..d49037dd --- /dev/null +++ b/vignettes/F2_Variance_calculations.Rmd @@ -0,0 +1,803 @@ +--- +title: "Variance calculations between individual and colony level values" +date: "`r Sys.Date()`" +output: rmarkdown::html_vignette +vignette: > + %\VignetteIndexEntry{VarianceCalculations} + %\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 +) +``` + +```{r FirstExampleFromQuanGenVignette} +library(package = "SIMplyBee") +founderGenomes <- quickHaplo(nInd = 20, nChr = 16, segSites = 1000) +SP <- SimParamBee$new(founderGenomes) +nQtlPerChr <- 100 +mean <- c(10, 10 / SP$nWorkers) +varA <- c(1, 1 / SP$nWorkers) +corA <- matrix(data = c( 1.0, -0.5, + -0.5, 1.0), nrow = 2, byrow = TRUE) +SP$addTraitA(nQtlPerChr = nQtlPerChr, mean = mean, var = varA, corA = corA, + name = c("queenTrait", "workersTrait")) +varE <- c(3, 3 / SP$nWorkers) +corE <- matrix(data = c(1.0, 0.3, + 0.3, 1.0), nrow = 2, byrow = TRUE) +SP$setVarE(varE = varE, corE = corE) +basePop <- createVirginQueens(founderGenomes, n = 20) +head(basePop@gv) +head(basePop@pheno) +drones <- createDrones(x = basePop[1:5], nInd = 3) +colony <- createColony(x = basePop[6]) +colony <- cross(x = colony, drones = drones, checkCross = "warning") +colony <- addWorkers(x = colony, nInd = 50) +colony <- buildUp(colony) +apiary <- createMultiColony(basePop[7:20]) +drones <- createDrones(basePop[1:5], nInd = 100) +apiary <- cross(x = apiary, drones = drones, crossPlan = "create", checkCross = "warning") +apiary <- buildUp(apiary) +colonyGv <- calcColonyGv(apiary) +colonyPheno <- calcColonyPheno(apiary) +``` + +The idea of this work is: + +1) We want to do honey bee simulations with individual queens, drones, and + workers + +2) To do the above, we require individual variances and covariances + +3) Literature reports only variances and covariances at the colony level + +4) The aim of this paper is to show how to use variances and covariances at the + colony level to do simulations at the individual level. + +# Introduction WORK IN PROGRESS + +This document develops theory for the variance of genetic and phenotypic values +between colonies with the aim to understand how to fine tune a SIMplyBee +simulation where we need variance components for queen and workers effects at an +individual honeybee level. The challenge here is that in reality we do not +observe such variances, but only on a colony level. + +For example, in the vignette we assumed that phenotypic variance on the +individual level is about 1/4 due to genetic variation and about 3/4 due to +environmental variation, but looking at colony genetic and phenotypic variances +the ratio was about 1/2! + +TODO: What do we do about this? It feels like we need a full paper on all of +this;) :( + +INTRODUCTION + +TODO: Topic 1 + +TODO: cite this paper that does honeybee simulations, but without actually doing +honeybee colony stuff etc. Heritability in honeybees paper: + + +TOOD: cite some classic papers on variances in honeybees + +TODO: cite recent papers from German and Dutch colleagues on variances in +honeybees + +Brascamp and Bijma (2014): Methods to estimate breeding values in honey bees + + +Brascamp and Bijma (2019): A note on genetic parameters and accuracy of +estimated breeding values in honey bees + + +Andonov et al.: Modeling honey yield, defensive and swarming behaviors of +Italian honey bees (Apis mellifera ligustica) using linear-threshold approaches + + +To make use of the material in this document you should run the quantitative +genetics vignette - the first example. Then you can continue here! + +Having multiple colonies and their values, we can now return to the "about" +point mentioned at the start of this section, when we defined quantitative +genetic parameters. Recall that our starting quantitative genetic parameters for +the queen and workers effects were: + +We will follow the example from Brascamp and Bijma (2019) they have: + +$\sigma_{g_q}^2=0.5$ - this is their $\sigma_{A_q}^2=0.5$ + +$\sigma_{g_w}^2=1.0$ - this is their $\sigma_{A_w}^2=1.0$ among nominally +unrelated groups of workers + +$\sigma_{\bar{g}_w}^2=0.32$ - this is their $\sigma_{\bar{A}_w}^2=0.32$ among +base related groups of workers + +Where the relationship between the two is +$\sigma_{\bar{g}_w}^2 = a_{ii} * \sigma_{g_w}^2$ where $a_{ii}$ is average +additive genetic relationship between workers in a colony as can be defined (in +a non-inbred population) as +$a_{ii} = 1/4 + 1/2p_1 + 1/4(p_2 - p_1) + 1/4(1 - p_2)a_{ss}$; where $p_1$ is +the probability that two workers descend from the same drone, $p_2$ is the +probability that they descend from the same DPQ, and $a_{ss}$ is the relatedness +between two DPQs. We are ignore the $a_{ss}$ part (TODO?). + +$\sigma_{{g_q},{g_w}}=-0.35$ + +$\sigma_{P}^2 = \sigma_{\bar{g}_w^w}^2 + \sigma_{g_q^q}^2 + 2*\sigma_{\bar{g}_w^w g_q^q} + \sigma_{E}^2$ + +$\sigma_e^2=2.0$ + +$h^2=(a_{base}\sigma_{g,w}^2 + \sigma_{{g,w},{g,q}} + \sigma_{g,q}^2)/\sigma_{p,c}^2=???$ + +$h_w^2=a_{base}\sigma_{g,w}^2/\sigma_{p,c}^2=0.13$ + +$h_q^2=\sigma_{g,q}^2/\sigma_{p,c}^2=0.20$ + +$T^2=(\sigma_{g,w}^2 + 2\sigma_{{g,w},{g,q}} \sigma_{g,q}^2)/\sigma_{p,c}^2=0.32$ + +$T_w^2=\sigma_{g,w}^2/\sigma_{p,c}^2=0.41$ + +$T_q^2=\sigma_{g,q}^2/\sigma_{p,c}^2=0.20$ + +$r_g = cor(g_w, g_q) = -0.50$ + +TODO: equation 3 in Brascamp and Bijma (2019) is highly relevant to our work +here - that equation shows connection between the variance of the sum (or +average) of worker genetic values for worker effect AND variance of worker +genetic values for worker effect - THIS IS NOT TRUE they always work with the +worker group effect, never individuals! + +TODO: show sensitivity to the number of workers - the larger the number of +workers, the smaller the variance between workers + +covA[1, 1] + nW \* covA[2, 2] + 2 \* k \* covA[1, 2] + +```{r quan_gen_param_revision} +# Trait means +mean + +# Trait genetic variation - on a per honeybee level +varA +corA +(covA <- corA * outer(X = sqrt(varA), Y = sqrt(varA), FUN = "*")) + +# Trait environmental variation - on a per honeybee level +varE +corE +(covE <- corE * outer(X = sqrt(varE), Y = sqrt(varE), FUN = "*")) + +# Trait phenotypic variation - on a per honeybee level +(covP <- covA + covE) +(corP <- cov2cor(covP)) +(varP <- diag(covP)) + +# Expected phenotypic variation - on a per colony level +# TODO: there is in fact more stuff happening here - see below! +nW <- SP$nWorkers # TODO: this is not correct - we have queen-workers pairs and workers-workers (see below!) +# Var(z)=Var(x+y)=Var(x)+Var(sum(y))=Var(x)+Var(y_1)+Var(y_2)+... +# this is all wrong likely ... + +k <- 1 # just adding this so vignette can run, but I don't know what this k should be + +covA[1, 1] + nW * covA[2, 2] + 2 * k * covA[1, 2] # variance can not be negative! +covP[1, 1] + nW * covP[2, 2] + 2 * k * covP[1, 2] + +# Observed variation - on a per colony level +var(colonyGv) +var(colonyPheno) +var(colonyGv) / var(colonyPheno) +``` + +Hmm, we have much higher genetic and phenotypic variances in simulation than +based simply looking at queen and n\*workers variances, as well as much higher +ratio between the two than the initial value of \~1/4! Why? Let's see. For +genetic value of a colony $g_c$ we add up the queen's genetic value for the +queen effect $g_{q,q}$ and workers' genetic values for the workers effect +$\Sigma_{i=1}^{n_w}(g_{i,w})$: + +$g_c = g_{q,q} + \Sigma_{i=1}^{n_w}(g_{i,w}).$ + +Expectation of colony genetic value is then: + +$E(g_c) = E(g_{q,q} + \Sigma_{i=1}^{n_w}(g_{i,w}))$ + +$E(g_c) = E(g_{q,q}) + E(\Sigma_{i=1}^{n_w}(g_{i,w}))$ + +$E(g_c) = \mu_{g_{q}} + n_w E(g_{w,w})$ + +$E(g_c) = \mu_{g_{q}} + n_w \mu_{g_{w}}$ + +we are assuming here that $n_w$ is a fixed value, but if it is a random variable +then we would have + +$E(g_c) = \mu_{g_{q}} + E(n_w) E(g_{w,w})$ using + + +$E(g_c) = \mu_{g_{q}} + \lambda_{n_w} \mu_{g_{w}}$ + +where $\lambda_{n_w}$ is average number of workers. So, in our case this turns +out the same as above. So in our case we have: + +```{r} +nW <- SP$nWorkers +mean[1] + nW * mean[2] +mean(colonyGv) +mean(colonyPheno) +``` + +Variance of colony genetic value is then: + +$Var(g_c) = Var(g_{q,q} + \Sigma_{i=1}^{n_w}(g_{i,w}))$ + +$Var(g_c) = Var(g_{q,q}) + Var(\Sigma_{i=1}^{n_w}(g_{i,w})) + 2Cov(g_{q,q}, \Sigma_{i=1}^{n_w}(g_{i,w}))$ + +$Var(g_c) = \sigma^2_{g_{q}} + Var(\Sigma_{i=1}^{n_w}(g_{i,w})) + 2Cov(g_{q,q}, \Sigma_{i=1}^{n_w}(g_{i,w}))$ + +So, we have three parts: + +A) the variance of the queen effect in queens $\sigma^2_{g_{q}}$, + +B) variance of a sum of workers effect in workers + $Var(\Sigma_{i=1}^{n_w}(g_{i,w}))$, and + +C) covariance between the two $2Cov(g_{q,q}, \Sigma_{i=1}^{n_w}(g_{i,w}))$. + +# A) Variance of the queen effect in queens $\sigma^2_{g_{q}}$ - in our case this is: + +```{r check_queen_variances} +varA[1] +x = getQueenGv(apiary, collapse = TRUE)[, "queenTrait"] +var(x) +# ... note that R's var() divides by n-1, which matters with small n +popVar(x) +sum((x - mean[1])^2) / nColonies(apiary) + +``` + +Anyway, quite close! + +# B) Variance of a sum of workers effect in workers $Var(\Sigma_{i=1}^{n_w}(g_{i,w}))$ + +Given that this is a sum, we need to look at: + +B1) variance of each of worker genetic values $Var(g_{i,w})$ and + +B2) covariance between each pair of the values $Cov(g_{i,w}, g_{j,w})$. + +This means, that family structure will start to matter because it induces +covariance between family members (workers). The simplest case is when all +workers come from the same father. Then we have: + +$g_{1,w} = \frac{1}{2}g_{q,w} + g_{f,w} + r_{1,w}$ + +$g_{2,w} = \frac{1}{2}g_{q,w} + g_{f,w} + r_{2,w}$ + +... + +$g_{n_w,w} = \frac{1}{2}g_{q,w} + g_{f,w} + r_{n_w,w}$ + +## B1) variance of each of worker genetic values $Var(g_{i,w})$ + +As stated initially, we have $Var(g_{i,w}) = \sigma^2_{g_{w}}$ and we have $n_w$ +such terms, $n_w \sigma^2_{g_{w}}$. In our case this would be: + +```{r check_workers_variances} +nW * varA[2] +g <- calcColonyGv(apiary, mapCasteToColonyGv, queenTrait = NULL, workersTrait = "workersTrait") +var(g) +# ... note that R's var() divides by n-1, which matters with small n +sum((g - nW * mean[2])^2) / nColonies(apiary) +popVar(g) +``` + +So, a huge discrepancy between the variance of a sum of genetic values for the +workers effect `nW * varA[2]` (assuming independence) and a realised sum of +genetic values for the workers effect. As we have seen above, this is due to +family structure and associated B2) covariance between each pair of the values +$Cov(g_{i,w}, g_{j,w})$. + +## B2) covariance between each pair of the values $Cov(g_{i,w}, g_{j,w})$ + +Clearly, these covariances matter a lot - there is lots of worker pairs in a +colony! How do these covariances look like? + +$Cov(g_{1,w}, g_{2,w}) = Cov(\frac{1}{2}g_{q,w} + g_{f,w}, \frac{1}{2}g_{q,w} + g_{f,w})$ + +$Cov(g_{1,w}, g_{2,w}) = Var(\frac{1}{2}g_{q,w}) + Var(g_{f,w})$ + +assuming that mother and father are not related; further genetic variance +between drones is in fact half the genetic variance between queens because they +are haploid, so we get: + +$Cov(g_{1,w}, g_{2,w}) = \frac{1}{4}\sigma^2_{g_w} + \frac{1}{4}\sigma^2_{g_w}$ + +$Cov(g_{1,w}, g_{2,w}) = \frac{1}{2}\sigma^2_{g_w}$. + +Every pair of super-sister workers adds $\frac{1}{2}\sigma^2_{g_w}$ to B - note +that pair A-B adds this value, but so does the pair B-A, hence total is +$2\frac{1}{2}\sigma^2_{g_w} = \sigma^2_{g_w}$. With $n_w$ workers we get +$n_w n_w$ pairs (including with itself) or $n_w n_w - n_w$ pairs between +different workers. The total covariance contribution is then +$(n_w n_w - n_w)\frac{1}{2}\sigma^2_{g_w}$). In our case this would be: + +```{r check_workers_variances2} +(varSumWorkers <- nW * varA[2]) # B1 +(covSumWorkers <- (nW * nW - nW) * 1/2 * varA[2]) # B2 +varSumWorkers + covSumWorkers # B + +g <- calcColonyGv(apiary, mapCasteToColonyGv, queenTrait = NULL, workersTrait = "workersTrait") +var(g) # B +# ... note that R's var() divides by n-1, which matters with small n +sum((g - nW * mean[2])^2) / nColonies(apiary) # B +popVar(g) +``` + +If we would only have super-sisters we would have \~1 for B1, \~49.5 for B2, and +\~50.5 for B, but with a mix of half-sisters and super-sisters we would have a +lower value, which is what we see above, \~26.8 for B. + +TODO: Define the setting above in intro or start of M&M - We also can have +full-sisters, where the mother is obviously the same, but the fathers are +different, yet they come from the same mother, which is equivalent to a +full-sibs case in diploid species. We will assume in this work that we have +unrelated queens and unrelated drones (=base pop) - our aim is to set variances +in such a base population - to get the scale or the variances right. In +simulation of our base population we generated drones from virgin queens, which +means that our drones can in fact be brothers, so our realised variances might +be a bit off compared to this theory. But this is fine, we are mostly trying to +get the order of variances correct. + +So, now we need to work out B2 with a mix of half-sisters and super-sisters :( +Sister workers are related only due to having the same mother, assuming that +drones the queen mated with are unrelated: + +$g_{1,w} = \frac{1}{2}g_{q,w} + g_{f1,w} + r_{1,w}$ + +$g_{2,w} = \frac{1}{2}g_{q,w} + g_{f2,w} + r_{2,w}$ + +$Cov(g_{1,w}, g_{2,w}) = Cov(\frac{1}{2}g_{q,w} + g_{f1,w}, \frac{1}{2}g_{q,w} + g_{f2,w})$ + +$Cov(g_{1,w}, g_{2,w}) = Var(\frac{1}{2}g_{q,w})$ + +$Cov(g_{1,w}, g_{2,w}) = \frac{1}{4}Var(g_{q,w})$ + +Hence every pair of half-sister workers adds $\frac{1}{4}\sigma^2_{g_w}$ to B +(note, this is $2\frac{1}{4}\sigma^2_{g_w}$ for A-B and B-A pairs!). With $n_w$ +workers and $n_f$ fathers we have $\frac{n_w}{n_f}$ workers per father. Further, +we have $n_f$ groups of super-sisters and $n_f n_f - n_f$ pairs of sister +groups. Assuming that half-sister groups are the same size, we have +$n_f \frac{n_w}{n_f} \frac{n_w}{n_f} = n_w \frac{n_w}{n_f} = \frac{n^2_w}{n_f}$ +pairs of super-sisters and $(n_f n_f - n_f) \frac{n_w}{n_f} \frac{n_w}{n_f}$ - +this is +$n_f (n_f - 1) \frac{n_w}{n_f} \frac{n_w}{n_f} = (n_f - 1) n_w \frac{n_w}{n_f} = \frac{ (n_f - 1) n^2_w}{n_f}$. +Is this correct? + +```{r pairs_of_workers} +(nF <- nFathers(colony)) +nW * nW +(a <- nW * nW / nF) +(b <- (nF - 1) * nW * nW / nF) +a+b +#TODO define nDPQ +``` + +Looks like! + +So, super-sister pairs add $\frac{n^2_w}{n_f} \frac{1}{2}\sigma^2_{g_w}$ and +half-sister pairs add $\frac{ (n_f - 1) n^2_w}{n_f} \frac{1}{4}\sigma^2_{g_w}$. +Let's test this: + +```{r check_workers_variances3} +(varSumWorkers <- nW * varA[2]) # B1 +(covSumWorkersSuperSisters <- (nW * nW / nF) * 0.75 * varA[2]) # B2 in super-sisters ERROR: SHOULD BE 0.75 +(covSumWorkersHalfSisters <- ((nF - 1) * nW * nW / nF) * 0.25 * varA[2]) # B2 in half-sisters +varSumWorkers + covSumWorkersSuperSisters + covSumWorkersHalfSisters # B + +g <- calcColonyGv(apiary, mapCasteToColonyGv, queenTrait = NULL, workersTrait = "workersTrait") +var(g) # B +# ... note that R's var() divides by n-1, which matters with small n +sum((g - SP$nWorkers * mean[2])^2) / nColonies(apiary) # B +``` + +Cool - very close!!! There can be some difference because the formulae above +assume that we have fixed sizes of half-sister and super-sister groups. Also, +there can be full-sisters in there as well!!! + +TODO: We could also add full-sisters: To do this, we would have to assume how +many brother drones we use to figure out the grups + +TODO: What if $n_w$ is a random variable? Following + +we would use: + +$Var(XY) = (Var(X) + E(X)^2) (Var(Y) + E(Y)^2) - E(X)^2 E(Y)^2$ + +but this is for two variables, while I have $n_w$ genetic values, so this +reference result is not that useful in our case! Well, if $n_w$ varies between +colonies, this must boost variance of colony-level genetic values significantly, +because kind of start calculating variance between apples (small colonies) and +oranges (large colonies). + +# C) Covariance between the two $2Cov(g_{q,q}, \Sigma_{i-1}^{n_w}(g_{i,w}))$. + +Let's repeat: + +$g_{1,w} = \frac{1}{2}g_{q,w} + g_{f1,w} + r_{1,w}$ + +$g_{2,w} = \frac{1}{2}g_{q,w} + g_{f2,w} + r_{2,w}$ ... + +The essential bit here is: + +$Cov(g_{q,q}, g_{i,w}) = Cov(g_{q,q}, \frac{1}{2} g_{q,w})$ + +assuming that the queen and fathers are unrelated. Then: + +$Cov(g_{q,q}, g_{i,w}) = Cov(g_{q}, \frac{1}{2} g_{w})$ + +$Cov(g_{q,q}, g_{i,w}) = \frac{1}{2} Cov(g_{q}, g_{w})$ + +$Cov(g_{q,q}, g_{i,w}) = \frac{1}{2} \sigma_{g_{q},g_{w}}$ + +So: + +$2Cov(g_{q,q}, \Sigma_{i=1}^{n_w}(g_{i,w})) = 2Cov(g_{q,q}, n_w \frac{1}{2} g_{q,w})$ + +$2Cov(g_{q,q}, \Sigma_{i=1}^{n_w}(g_{i,w})) = 2 n_w \frac{1}{2}Cov(g_{q,q}, g_{q,w})$ + +$2Cov(g_{q,q}, \Sigma_{i=1}^{n_w}(g_{i,w})) = n_w \sigma_{g_{q},g_{w}}$ + +```{r check_workers_variances4} +nDPQ = 5 +n_SS = (nW * nW / nF) - nW +n_FS = (nW * nW / nDPQ) - (nW * nW / nF) +n_HS = (nW * nW / nDPQ) * (nDPQ - 1) + +(n_SS + n_FS + n_HS + nW) == nW * nW + +print("Genetic variances") +print("Part A") +(varQueen_A <- varA[1]) # A + +print("Part B1") +(varSumWorkers_A <- nW * varA[2]) # B1 +print("Part B2 in super-sisters") +(covSumWorkersSuperSisters_A <- n_SS * 0.75 * varA[2]) # B2 in super-sisters +print("Part B2 in full-sisters") +(covSumWorkersFullSisters_A <- n_FS * 0.50 * varA[2]) # B2 in full-sisters +print("Part B2 in half-sisters") +(covSumWorkersHalfSisters_A <- n_HS * 0.25 * varA[2]) # B2 in half-sisters +print("Part B combined") +(varCovSumWorkers_A <- varSumWorkers_A + covSumWorkersSuperSisters_A + covSumWorkersFullSisters_A + covSumWorkersHalfSisters_A) # B +print("Part C") +(covQueenSumWorkers_A <- nW * covA[1, 2]) # C + +print("Part A + B + C") +varQueen_A + varCovSumWorkers_A + 2*covQueenSumWorkers_A + +print("ColonyGv variance") +g <- colonyGv +var(g) +popVar(g) +sum((g - (mean(g)))^2) / nColonies(apiary) +``` + +Bingo for genetic variance. + +```{r} + + +print("Environmental variance") +print("Part A") +(varQueen_E <- varE[1]) # A +print("Part B1") +(varSumWorkers_E <- nW * varE[2]) # B1, there is not environmental covariance between workers, so no B2 +print("Part C") +(covQueenSumWorkers_E <- nW * covE[1, 2]) # C - both genetic and env cove here? TODO + +print("Part A + B + C f") +varQueen_A + varCovSumWorkers_A + covQueenSumWorkers_A + varQueen_E + varSumWorkers_E + covQueenSumWorkers_E + +p <- colonyPheno +var(p) +popVar(p) +sum((p - (mean(p)))^2) / nColonies(apiary) +``` + +And very close for phenotypic too, but we need to check some part above! + +# What now? + +Alright, what can we now do with this? We now have a system of expected genetic +and phenotypic variances for colony values as a function of number of workers, +fathers, and genetic and phenotypic covariances between the queen and worker +effects. So, it should be possible, in principle, to solve for what kind of +covariance values for the queen and workers effects should we use, to get the +desired colony genetic and phenotypic variances! + +TODO: develop such estimating equations! + +So, we have genetic part: + +$A_g = \sigma^2_{g_q}$ + +$B1_g = n_w \sigma^2_{g_w}$ + +$B2ss_g = (\frac{n^2_w}{n_f} - {n_w}) \frac{1}{2} \sigma^2_{g_w}$ + +$B2fs = (\frac{n^2_w}{n_{DPQ}} - \frac{n^2_w}{n_f}) \frac{1}{4} \sigma^2_{g_w}$ + +$B2hs_g = \frac{(n_f - 1) n^2_w}{n_f} \frac{1}{4} \sigma^2_{g_w}$ + +$C_g = n_w \sigma^2_{{g_q},{g_w}}$ + +here are 3 unknowns: $\sigma^2_{g_q}$, $\sigma^2_{g_w}$, and +$\sigma^2_{{g_q},{g_w}}$ + +we can add phenotypic part: + +$A_p = \sigma^2_{p_q}$ + +$B1_p = n_w \sigma^2_{p_w}$ + +$B2_p = \frac{n^2_w}{n_f} \frac{1}{2} \sigma^2_{g_w}$ TODO: check if its only +genetic + +$B3_p = \frac{(n_f - 1) n^2_w}{n_f} \frac{1}{4} \sigma^2_{g_w}$ TODO: check if +its only genetic + +$C_p = n_w \sigma^2_{{p_q},{p_w}}$ + +here are additional 3 unknowns: $\sigma^2_{p_q}$, $\sigma^2_{p_w}$, and +$\sigma^2_{{p_q},{p_w}}$ + +while we could provide as guidance 2, maybe 3, inputs: $\sigma^2_{g_c}$, +$\sigma^2_{p_c}$, and $\frac{\sigma^2_{g_c}}{\sigma^2_{p_c}}$. + +TODO: are there any additional inputs that we could get from literature? How do +we connect all this with variance estimates for the queen and the workers effect +in the honeybee genetics and breeding literature? I think that those estimates +are essentially this: +$\sigma^2_{g_c} = \sigma^2_{g_{c,q}} + \sigma^2_{g_{c,w}} + 2\sigma_{g_{c,q},g_{c,w}}$ +where $\sigma^2_{g_{c,q}}$ is the queen part of $\sigma^2_{g_c}$, but not +necessarily the same as $\sigma^2_{g_w}$, or is it? Maybe that is the same, and +$\sigma^2_{g_{c,w}}$ is a counterpart to +$n_w \sigma^2_{g_w} + \frac{n^2_w}{n_f} \frac{1}{2} \sigma^2_{g_w}, \frac{(n_f - 1) n^2_w}{n_f} \frac{1}{4} \sigma^2_{g_w}$ +(TODO: should we add full-sisters?), while $\sigma_{g_{c,q},g_{c,w}}$ is a +counterpart to $n_w \sigma_{{g_q},{g_w}}$. If this is so, then it fells that we +should have 3 more inputs for genetic part, so 4 inputs to estimate 3 unknowns +of which some are very simple transformations!!! + +Additional input could be $\sigma^2_{p_c}$. For sure we don't get estimates of +$\sigma^2_{p_c} = \sigma^2_{p_{c,q}} + \sigma^2_{p_{c,w}} + 2\sigma_{p_{c,q},p_{c,w}}$, +but, having sorted the genetic part and if $B2_p$ and $B3_p$ depend only on +genetic covariance, then maybe, we have some maneuvering space to estimate also +$\sigma^2_{p_q}$, $\sigma^2_{p_w}$, and $\sigma^2_{{p_q},{p_w}}$?! + +Furthermore, we have some constraints, so this is not just any system of +equations. For example, we know that variances must be positive. Futhermore, we +might know that come covariances are either positive or negative. + +TODO: Develop and polish all this further and create a Shiny application where +we can change these individual-level parameters and study how that will change +colony-level parameters and then how we could go the other way around based on +literature and solving the above systems of equations. We could host such a +Shiny app on SIMplyBee.info!? Can we? + +NEXT STEPS: + +1) read the above, check derivations, missing bits, etc. + +2) write a function that takes individual variances, nw, nf, etc. and returns + colony variances and h2, t2, T2, ... + +3) develop a system of equations (using A, Bs, and C) linking individual and + colony values for two types of colony values (for different models beepeople + run!) - then find a way to optimize/solve for individual values (output) + with colony values as input + + +NOW - do the same, but for when the aggregate of the workers is a mean +```{r FirstExampleFromQuanGenVignette} +library(package = "SIMplyBee") +founderGenomes <- quickHaplo(nInd = 20, nChr = 16, segSites = 1000) +SP <- SimParamBee$new(founderGenomes) +nQtlPerChr <- 100 +mean <- c(10, 10) +varA <- c(1, 1) +corA <- matrix(data = c( 1.0, -0.5, + -0.5, 1.0), nrow = 2, byrow = TRUE) +SP$addTraitA(nQtlPerChr = nQtlPerChr, mean = mean, var = varA, corA = corA, + name = c("queenTrait", "workersTrait")) +varE <- c(3, 3) +corE <- matrix(data = c(1.0, 0.3, + 0.3, 1.0), nrow = 2, byrow = TRUE) +SP$setVarE(varE = varE, corE = corE) +basePop <- createVirginQueens(founderGenomes, n = 20) +head(basePop@gv) +head(basePop@pheno) +drones <- createDrones(x = basePop[1:5], nInd = 3) +colony <- createColony(x = basePop[6]) +colony <- cross(x = colony, drones = drones, checkCross = "warning") +colony <- addWorkers(x = colony, nInd = 50) +colony <- buildUp(colony) +apiary <- createMultiColony(basePop[7:20]) +drones <- createDrones(basePop[1:5], nInd = 100) +apiary <- cross(x = apiary, drones = drones, crossPlan = "create", checkCross = "warning") +apiary <- buildUp(apiary) +colonyGv <- unlist(mapCasteToColonyGv(x = apiary, queenTrait = 1, workersTrait = 2, workersFUN = colMeans)) +colonyPheno <- unlist(mapCasteToColonyPheno(x = apiary, queenTrait = 1, workersTrait = 2, workersFUN = colMeans)) +``` + + +```{r quan_gen_param_revision} +# Trait means +mean + +# Trait genetic variation - on a per honeybee level +varA +corA +(covA <- corA * outer(X = sqrt(varA), Y = sqrt(varA), FUN = "*")) + +# Trait environmental variation - on a per honeybee level +varE +corE +(covE <- corE * outer(X = sqrt(varE), Y = sqrt(varE), FUN = "*")) + +# Trait phenotypic variation - on a per honeybee level +(covP <- covA + covE) +(corP <- cov2cor(covP)) +(varP <- diag(covP)) + +# Expected phenotypic variation - on a per colony level +# TODO: there is in fact more stuff happening here - see below! +nW <- SP$nWorkers # TODO: this is not correct - we have queen-workers pairs and workers-workers (see below!) +# Var(z)=Var(x+y)=Var(x)+Var(sum(y))=Var(x)+Var(y_1)+Var(y_2)+... +# this is all wrong likely ... + +k <- 1 # just adding this so vignette can run, but I don't know what this k should be + + +# Observed variation - on a per colony level +var(colonyGv) +var(colonyPheno) +var(colonyGv) / var(colonyPheno) +``` + + + +# A) Variance of the queen effect in queens $\sigma^2_{g_{q}}$ - in our case this is: + +```{r check_queen_variances} +varA[1] +x = getQueenGv(apiary, collapse = TRUE)[, "queenTrait"] +var(x) +# ... note that R's var() divides by n-1, which matters with small n +popVar(x) +sum((x - mean[1])^2) / nColonies(apiary) + +``` + +Anyway, quite close! + +# B) Variance of a sum of workers effect in workers $Var(\Sigma_{i=1}^{n_w}(g_{i,w}))$ + +Given that this is a sum, we need to look at: + +B1) variance of each of worker genetic values $Var(g_{i,w})$ and + +B2) covariance between each pair of the values $Cov(g_{i,w}, g_{j,w})$. + +This means, that family structure will start to matter because it induces +covariance between family members (workers). The simplest case is when all +workers come from the same father. Then we have: + +$g_{1,w} = \frac{1}{2}g_{q,w} + g_{f,w} + r_{1,w}$ + +$g_{2,w} = \frac{1}{2}g_{q,w} + g_{f,w} + r_{2,w}$ + +... + +$g_{n_w,w} = \frac{1}{2}g_{q,w} + g_{f,w} + r_{n_w,w}$ + +## B1) variance of each of worker genetic values $Var(g_{i,w})$ + +As stated initially, we have $Var(g_{i,w}) = \sigma^2_{g_{w}}$ and we have $n_w$ +such terms, $n_w \sigma^2_{g_{w}}$. In our case this would be: + +```{r check_workers_variances} +nW * varA[2] +g <- calcColonyGv(apiary, mapCasteToColonyGv, queenTrait = NULL, workersTrait = "workersTrait", workersFUN = colMeans) +var(g) +# ... note that R's var() divides by n-1, which matters with small n +#sum((g - 1/nW^2 * mean[2])^2) / nColonies(apiary) ? +popVar(g) +``` + +So, a huge discrepancy between the variance of a sum of genetic values for the +workers effect `nW * varA[2]` (assuming independence) and a realised sum of +genetic values for the workers effect. As we have seen above, this is due to +family structure and associated B2) covariance between each pair of the values +$Cov(g_{i,w}, g_{j,w})$. + +## B2) covariance between each pair of the values $Cov(g_{i,w}, g_{j,w})$ + +```{r pairs_of_workers} +(nF <- round(mean(nFathers(apiary)), 0)) +(nDPQ <- round(mean(sapply(getFathers(apiary), function(x) length(unique(x@mother)))), 0)) +nW * nW +(a <- nW * nW / nF) +(b <- (nF - 1) * nW * nW / nF) +a+b +``` + +Looks like! + +So, super-sister pairs add $\frac{n^2_w}{n_f} \frac{1}{2}\sigma^2_{g_w}$ and +half-sister pairs add $\frac{ (n_f - 1) n^2_w}{n_f} \frac{1}{4}\sigma^2_{g_w}$. +Let's test this: + + +```{r check_workers_variances4} +n_SS = (nW * nW / nF) - nW +n_FS = (nW * nW / nDPQ) - (nW * nW / nF) +n_HS = (nW * nW / nDPQ) * (nDPQ - 1) + +(n_SS + n_FS + n_HS + nW) == nW * nW + +print("Genetic variances") +print("Part A") +(varQueen_A <- varA[1]) # A + +print("Part B1") +(varSumWorkers_A <- (1 / nW^2) * varA[2]) # B1 +print("Part B2 in super-sisters") +(covSumWorkersSuperSisters_A <- n_SS * 0.75 * varA[2]) # B2 in super-sisters +print("Part B2 in full-sisters") +(covSumWorkersFullSisters_A <- n_FS * 0.50 * varA[2]) # B2 in full-sisters +print("Part B2 in half-sisters") +(covSumWorkersHalfSisters_A <- n_HS * 0.25 * varA[2]) # B2 in half-sisters +print("Part B combined") +(varCovSumWorkers_A <- (1 / nW^2) * (varSumWorkers_A + covSumWorkersSuperSisters_A + covSumWorkersFullSisters_A + covSumWorkersHalfSisters_A)) #B +print("Part C") +(covQueenSumWorkers_A <- (1 / nW^2) * covA[1, 2]) # C + +print("Part A + B + C") +varQueen_A + varCovSumWorkers_A + covQueenSumWorkers_A + +print("ColonyGv variance") +g <- colonyGv +var(g) +popVar(g) +sum((g - (mean(g)))^2) / nColonies(apiary) +``` + +Bingo for genetic variance. + +```{r} +print("Environmental variance") +print("Part A") +(varQueen_E <- varE[1]) # A +print("Part B1") +(varSumWorkers_E <- (1 / nW^2) * varE[2]) # B1, there is not environmental covariance between workers, so no B2 +print("Part C") +(covQueenSumWorkers_E <- (1 / nW^2) * covE[1, 2]) # C - both genetic and env cove here? TODO + +print("Part A + B + C f") +varQueen_A + varCovSumWorkers_A + covQueenSumWorkers_A + varQueen_E + varSumWorkers_E + covQueenSumWorkers_E + +p <- colonyPheno +var(p) +popVar(p) +sum((p - (mean(p)))^2) / nColonies(apiary) +``` + +And very close for phenotypic too, but we need to check some part above! From 1a49e1733f82cf75a2de6c913a3288ec4af777f4 Mon Sep 17 00:00:00 2001 From: janaobsteter Date: Fri, 15 May 2026 15:18:19 +0200 Subject: [PATCH 56/56] Cleaning up variance vignetets --- .../F2_Variance_calculations_functions.Rmd | 341 +++++++++----- vignettes/TestVarianceMapping.R | 427 ------------------ 2 files changed, 231 insertions(+), 537 deletions(-) delete mode 100644 vignettes/TestVarianceMapping.R diff --git a/vignettes/F2_Variance_calculations_functions.Rmd b/vignettes/F2_Variance_calculations_functions.Rmd index 5ef02f1f..63668904 100644 --- a/vignettes/F2_Variance_calculations_functions.Rmd +++ b/vignettes/F2_Variance_calculations_functions.Rmd @@ -1,5 +1,5 @@ --- -title: "Variance calculations between individual and colony level values" +title: "Variance calculations between individual and colony level values - functions" date: "`r Sys.Date()`" output: rmarkdown::html_vignette vignette: > @@ -116,20 +116,18 @@ var(colonyPheno) We need to add the covariance due to different types of workers in the colony ```{r CovariancesBetweenWorkers} -mapIndToColonyVar <- function(varA_q, varA_w, corA_qw, nW, nF, nDPQ, workersFUN = "sum") { - if (workersFUN == "mean") { - factor = 1 / nW^2 - } else if (workersFUN == "sum") { - factor = nW - } - +mapIndToColonyVar <- function(varA_q, varA_w, corA_qw, + varE_q, varE_w, corE_qw, + nW, nF, nDPQ, workersFUN = "sum") { + + # First handle the genetic part # Determine how many pairs of each you have nW = nW n_SS = (nW * nW / nF) - nW n_FS = (nW * nW / nDPQ) - (nW * nW / nF) n_HS = (nW * nW / nDPQ) * (nDPQ - 1) - A <- varA_q + varA_q <- varA_q if (workersFUN == "mean") { B1 = 1 / nW * varA_w } else if (workersFUN == "sum") { @@ -139,52 +137,76 @@ mapIndToColonyVar <- function(varA_q, varA_w, corA_qw, nW, nF, nDPQ, workersFUN B2_ss <- n_SS * 0.75 * varA_w B2_fs <- n_FS * 0.50 * varA_w B2_hs <- n_HS * 0.25 * varA_w + if (workersFUN == "mean") { - B = B1 + 1/nW^2 * (B2_ss + B2_fs + B2_hs) + varA_wbar = B1 + 1/nW^2 * (B2_ss + B2_fs + B2_hs) } else if (workersFUN == "sum") { - B = B1 + B2_ss + B2_fs + B2_hs + varA_wbar = B1 + B2_ss + B2_fs + B2_hs } covA_qw = corA_qw * sqrt(varA_q) * sqrt(varA_w) if (workersFUN == "mean") { - C <- covA_qw + covA_qwbar <- covA_qw } else if (workersFUN == "sum") { - C <- nW * covA_qw + covA_qwbar <- nW * covA_qw } - - varC <- A + B + C + corA_qwbar <- covA_qwbar / (sqrt(varA_q) * sqrt(varA_wbar)) - return(list(A = A, B = B, C = C, colonyVar = varC)) -} + varA_c <- varA_q + varA_wbar + 2*covA_qwbar -#This is the same as above, just simplified -# mapIndToColonyVar <- function(varA_q, varA_w, corA_qw, nW, nF, nDPQ, workersFUN = "sum") { - -# # Determine how many pairs of each you have -# p_SS = 1 / nF - 1 / nW -# p_FS = (1 / nDPQ) - (1 / nF) -# p_HS = (1 / nDPQ) * (nDPQ - 1) -# A <- varA_q -# B1 <- nW * varA_w -# B2_ss <- p_SS * 0.75 -# B2_fs <- p_FS * 0.50 -# B2_hs <- p_HS * 0.25 - -# covA_qw = corA_qw * sqrt(varA_q) * sqrt(varA_w) -# C <- nW * covA_qw - -# if (workersFUN == "sum") { -# varC <- A + B1 + (B2_ss + B2_fs + B2_hs)*nW^2*varA_w + C -# } else if (workersFUN == "mean") { -# varC <- A + varA_w + (B2_ss + B2_fs + B2_hs)*varA_w + covA_qw# This is equal as varA_w * average relatedness within a colony -# } -# return(varC) -# } + # Next handle the environmental part + if (workersFUN == "mean") { + varE_wbar = 1 / nW * varE_w + } else if (workersFUN == "sum") { + varE_wbar = nW * varE_w + } + + covE_qw = corE_qw * sqrt(varE_q) * sqrt(varE_w) + if (workersFUN == "mean") { + covE_qwbar <- covE_qw + } else if (workersFUN == "sum") { + covE_qwbar <- nW * covE_qw + } + corE_qwbar <- covE_qwbar / (sqrt(varE_q) * sqrt(varE_wbar)) + + varE_c <- varE_q + varE_wbar + 2*covE_qwbar + + return(list(varA_q = varA_q, varA_wbar = varA_wbar, covA_qwbar = covA_qwbar, corA_qwbar = corA_qwbar, varA_c = varA_c, + varE_q = varE_q, varE_wbar = varE_wbar, covE_qwbar = covE_qwbar, corE_qwbar = corE_qwbar, varE_c = varE_c)) +} ``` ```{r testingMapIndToColonyVar} +print("Workers aggregate is a mean") +founderGenomes <- quickHaplo(nInd = 20, nChr = 16, segSites = 1000) +SP <- SimParamBee$new(founderGenomes) +nQtlPerChr <- 100 +mean <- c(0, 0) +varA <- c(1, 1) +corA <- matrix(data = c( 1.0, -0.5, + -0.5, 1.0), nrow = 2, byrow = TRUE) +SP$addTraitA(nQtlPerChr = nQtlPerChr, mean = mean, var = varA, corA = corA, + name = c("queenTrait", "workersTrait")) +varE <- c(3, 3) +corE <- matrix(data = c(1.0, 0.3, + 0.3, 1.0), nrow = 2, byrow = TRUE) +SP$setVarE(varE = varE, corE = corE) +basePop <- createVirginQueens(founderGenomes, n = 20) +head(basePop@gv) +head(basePop@pheno) +drones <- createDrones(x = basePop[1:5], nInd = 3) +colony <- createColony(x = basePop[6]) +colony <- cross(x = colony, drones = drones, checkCross = "warning") +colony <- addWorkers(x = colony, nInd = 50) +colony <- buildUp(colony) +apiary <- createMultiColony(basePop[7:20]) +drones <- createDrones(basePop[1:5], nInd = 100) +apiary <- cross(x = apiary, drones = drones, crossPlan = "create", checkCross = "warning") +apiary <- buildUp(apiary) +colonyGv <- calcColonyGv(apiary) + # Get the real number of fathers and DPQs nW = round(mean(nWorkers(apiary)), 0) nF = round(mean(nFathers(apiary)), 0) @@ -192,32 +214,50 @@ nDPQ <- round(mean(sapply(getFathers(apiary), function(x) length(unique(x@mother # When the function to summarise worker effects is SUM -mapIndToColonyVar(varA_q = varA[1], +calcVar <- mapIndToColonyVar(varA_q = varA[1], varA_w= varA[2], corA_qw = corA[1,2], + varE_q = varE[1], + varE_w = varE[2], + corE_qw = corE[1,2], nW = nW, nF = nF, nDPQ = nDPQ, - workersFUN = "sum") -colonyGv <- calcColonyGv(apiary, FUN = mapCasteToColonyGv, workersFUN = colSums) -var(colonyGv) -``` - + workersFUN = "mean") -```{r FirstExampleFromQuanGenVignette} +real_gv_q <- calcColonyGv(apiary, FUN = mapCasteToColonyGv, queenTrait = 1, workersTrait = NULL) +real_gv_wbar <- calcColonyGv(apiary, FUN = mapCasteToColonyGv, queenTrait = NULL, workersTrait = 2, workersFUN = colMeans) +real_covA_qwbar <- cov(real_gv_q, real_gv_wbar) +real_corA_qwbar <- cor(real_gv_q, real_gv_wbar) +real_varA_q <- var(real_gv_q) +real_varA_wbar <- var(real_gv_wbar) +real_varA_c <- var(calcColonyGv(apiary, FUN = mapCasteToColonyGv, workersFUN = colMeans)) +real_varP_c <- var(calcColonyPheno(apiary, FUN = mapCasteToColonyPheno, workersFUN = colMeans)) + +variances0 <- rbind(variances0, data.frame(rep = rep, + calc_varA_q = calcVar$varA_q, calc_varA_wbar = calcVar$varA_wbar, calc_varA_c = calcVar$varA_c, calc_varE_c = calcVar$varE_c, + real_varA_q = real_varA_q[1,1], real_varA_wbar = real_varA_wbar[1,1], real_varA_c = real_varA_c[1,1], + real_covA_qwbar = real_covA_qwbar[1,1], real_corA_qwbar = real_corA_qwbar[1,1], + real_varP_c = real_varP_c[1,1], + fun = "mean")) + +print("Workers aggregate is a sum") # Run the example from the quantitative genetic vignette founderGenomes <- quickHaplo(nInd = 20, nChr = 16, segSites = 1000) SP <- SimParamBee$new(founderGenomes) +SP$nWorkers <- 100 +SP$nFathers <- 15 nQtlPerChr <- 100 -mean <- c(10, 10) -varA <- c(1, 1) +mean <- c(0, 0) +varA <- c(1, 1 / SP$nWorkers) corA <- matrix(data = c( 1.0, -0.5, - -0.5, 1.0), nrow = 2, byrow = TRUE) + -0.5, 1.0), nrow = 2, byrow = TRUE) SP$addTraitA(nQtlPerChr = nQtlPerChr, mean = mean, var = varA, corA = corA, - name = c("queenTrait", "workersTrait")) -varE <- c(3, 3) + name = c("queenTrait", "workersTrait")) +varE <- c(3, 3 / SP$nWorkers) corE <- matrix(data = c(1.0, 0.3, 0.3, 1.0), nrow = 2, byrow = TRUE) SP$setVarE(varE = varE, corE = corE) + basePop <- createVirginQueens(founderGenomes, n = 20) head(basePop@gv) head(basePop@pheno) @@ -231,43 +271,62 @@ drones <- createDrones(basePop[1:5], nInd = 100) apiary <- cross(x = apiary, drones = drones, crossPlan = "create", checkCross = "warning") apiary <- buildUp(apiary) colonyGv <- calcColonyGv(apiary) -colonyPheno <- calcColonyPheno(apiary) - -``` +colonyPheno <- calcColonyPheno(apiary) -```{r testingMapIndToColonyVarMean} -# Get the real number of fathers and DPQs nW = round(mean(nWorkers(apiary)), 0) nF = round(mean(nFathers(apiary)), 0) nDPQ <- round(mean(sapply(getFathers(apiary), function(x) length(unique(x@mother)))), 0) -# When the function to summarise worker effects is MEAN -mapIndToColonyVar(varA_q = varA[1], +# When the function to summarise worker effects is SUM +calcVar <- mapIndToColonyVar(varA_q = varA[1], varA_w= varA[2], corA_qw = corA[1,2], + varE_q = varE[1], + varE_w = varE[2], + corE_qw = corE[1,2], nW = nW, nF = nF, nDPQ = nDPQ, - workersFUN = "mean") -colonyGv <- calcColonyGv(apiary, FUN = mapCasteToColonyGv, workersFUN = colMeans) -var(colonyGv) + workersFUN = "sum") + +real_gv_q <- calcColonyGv(apiary, FUN = mapCasteToColonyGv, queenTrait = 1, workersTrait = NULL) +real_gv_wbar <- calcColonyGv(apiary, FUN = mapCasteToColonyGv, queenTrait = NULL, workersTrait = 2, workersFUN = colSums) +real_covA_qwbar <- cov(real_gv_q, real_gv_wbar) +real_corA_qwbar <- cor(real_gv_q, real_gv_wbar) +real_varA_q <- var(real_gv_q) +real_varA_wbar <- var(real_gv_wbar) +real_varA_c <- var(calcColonyGv(apiary, FUN = mapCasteToColonyGv, workersFUN = colSums)) +real_varP_c <- var(calcColonyPheno(apiary, FUN = mapCasteToColonyPheno, workersFUN = colMeans)) + + +variances0 <- rbind(variances0, data.frame(rep = rep, + calc_varA_q = calcVar$varA_q, calc_varA_wbar = calcVar$varA_wbar, calc_varA_c = calcVar$varA_c, calc_varE_c = calcVar$varE_c, + real_varA_q = real_varA_q[1,1], real_varA_wbar = real_varA_wbar[1,1], real_varA_c = real_varA_c[1,1], + real_covA_qwbar = real_covA_qwbar[1,1], real_corA_qwbar = real_corA_qwbar[1,1], + real_varP_c = real_varP_c[1,1], + fun = "sum")) ``` +Now the other way around. Let's say you have a colony-level estimate of variance components - this is what you would get out of a paper. ```{r mapColonyToIndVar} # First option, we know the varA_q, varA_wbar and cor, and one varE mapColonyToIndVar <- function(varA_q, varA_wbar, - corA_qwbar = NULL, - varE, + corA_qwbar, + varE_q, + varE_wbar, + corE_qwbar, nW, nF, nDPQ, workersFUN = "sum") { + + # First handle the genetic part + covA_qwbar <- corA_qwbar * sqrt(varA_q) * sqrt(varA_wbar) # scaling factor if (workersFUN == "sum") { - covA_qwbar <- corA_qwbar * sqrt(varA_q) * sqrt(varA_wbar) covA_qw <- covA_qwbar / nW } else if (workersFUN == "mean") { covA_qw <- covA_qwbar @@ -294,84 +353,146 @@ mapColonyToIndVar <- function(varA_q, corA_qw <- covA_qw / (sqrt(varA_q) * sqrt(varA_w)) - return(list(varA_q = varA_q, varA_wbar = varA_wbar, varA_w = varA_w, covA_qwbar = covA_qwbar, covA_qw = covA_qw, corA_qw = corA_qw)) + # Next handle the environmental part + covE_qwbar <- corE_qwbar * sqrt(varE_q) * sqrt(varE_wbar) + + if (workersFUN == "sum") { + varE_w <- varE_wbar / nW + covE_qw <- covE_qwbar / nW + } else if (workersFUN == "mean") { + varE_w <- varE_wbar * nW + covE_qw <- covE_qwbar + } + + corE_qw <- covE_qw / (sqrt(varE_q) * sqrt(varE_w)) + + + return(list(varA_q = varA_q, varA_wbar = varA_wbar, varA_w = varA_w, + covA_qwbar = covA_qwbar, covA_qw = covA_qw, corA_qw = corA_qw, + varE_q = varE_q, varE_wbar = varE_wbar, varE_w = varE_w, + covE_qwbar = covE_qwbar, covE_qw = covE_qw, corE_qw = corE_qw)) } ``` ```{r testMapColonyToIndFunction} -mapColonyToIndVar(varA_q = 10, varA_wbar = 10, corA_qwbar = -0.5, varE = 30, nW = 100, nF = 5, nDPQ = 5, workersFUN = "sum") +varA_q <- 5 +varA_wbar <- 10 +corA_qwbar <- -0.5 + +varE_q <- 10 +varE_wbar <- 20 +corE_qwbar <- 0.3 + +nW <- 100 +nF <- 15 +nDPQ <- 5 + +print("Workers aggregate is a mean") +indVarComp <- mapColonyToIndVar(varA_q = varA_q, varA_wbar = varA_wbar, corA_qwbar = corA_qwbar, + varE_q = varE_q, varE_wbar = varE_wbar, corE_qwbar = corE_qwbar, + nW = nW, nF = nF, nDPQ = nDPQ, workersFUN = fun) +calc_var_c <- mapIndToColonyVar(varA_q = indVarComp$varA_q, varA_w = indVarComp$varA_w, corA_qw = indVarComp$corA_qw, + varE_q = indVarComp$varE_q, varE_w = indVarComp$varE_w, corE_qw = indVarComp$corE_qw, + nW = nW, nF = nF, nDPQ = nDPQ, workersFUN = fun) + -# Run the example from the quantitative genetic vignette founderGenomes <- quickHaplo(nInd = 20, nChr = 16, segSites = 1000) SP <- SimParamBee$new(founderGenomes) -SP$nWorkers <- 100 +SP$nWorkers = nW +SP$nFathers = nF nQtlPerChr <- 100 mean <- c(0, 0) -varA <- c(10, 0.002836879) -corA <- matrix(data = c( 1.0, -0.2968586, - -0.2968586, 1.0), nrow = 2, byrow = TRUE) +varA <- c(indVarComp$varA_q, indVarComp$varA_w) +corA <- matrix(data = c( 1.0, indVarComp$corA_qw, + indVarComp$corA_qw, 1.0), nrow = 2, byrow = TRUE) SP$addTraitA(nQtlPerChr = nQtlPerChr, mean = mean, var = varA, corA = corA, - name = c("queenTrait", "workersTrait")) -varE <- c(3, 3) -corE <- matrix(data = c(1.0, 0.3, - 0.3, 1.0), nrow = 2, byrow = TRUE) + name = c("queenTrait", "workersTrait")) +varE <- c(indVarComp$varE_q, indVarComp$varE_w) +corE <- matrix(data = c(1.0, indVarComp$corE_qw, + indVarComp$corE_qw, 1.0), nrow = 2, byrow = TRUE) SP$setVarE(varE = varE, corE = corE) basePop <- createVirginQueens(founderGenomes, n = 20) -head(basePop@gv) -head(basePop@pheno) -drones <- createDrones(x = basePop[1:5], nInd = 3) -colony <- createColony(x = basePop[6]) + +drones <- createDrones(x = basePop[1:nDPQ], nInd = 3) +colony <- createColony(x = basePop[nDPQ+1]) colony <- cross(x = colony, drones = drones, checkCross = "warning") colony <- addWorkers(x = colony, nInd = 50) colony <- buildUp(colony) apiary <- createMultiColony(basePop[7:20]) -drones <- createDrones(basePop[1:5], nInd = 100) +drones <- createDrones(basePop[1:nDPQ], nInd = 100) apiary <- cross(x = apiary, drones = drones, crossPlan = "create", checkCross = "warning") apiary <- buildUp(apiary) -workerGroupGv <- calcColonyGv(apiary, mapCasteToColonyGv, queenTrait = NULL, workersFUN = colSums) -colonyGv <- calcColonyGv(apiary) # sum is the default - -print("Worker group variance") -var(workerGroupGv) -print("Colony variance") -var(colonyGv) -``` +if (fun == "sum") { + workersFUN <- colSums +} else if (fun == "mean") { + workersFUN <- colMeans +} -```{r testMapColonyToIndFunction} -mapColonyToIndVar(varA_q = 10, varA_wbar = 10, corA_qwbar = -0.5, varE = 30, nW = 100, nF = 5, nDPQ = 5, workersFUN = "mean") +# Get the real number of fathers and DPQs +real_A_wbar <- calcColonyGv(apiary, mapCasteToColonyGv, queenTrait = NULL, workersTrait = 2, workersFUN = workersFUN) +real_varA_wbar <- popVar(real_A_wbar) +real_A_c <- calcColonyGv(apiary, mapCasteToColonyGv, queenTrait = 1, workersTrait = 2, workersFUN = workersFUN) +real_varA_c <- popVar(real_A_c) +real_P_wbar <- calcColonyPheno(apiary, mapCasteToColonyPheno, queenTrait = NULL, workersTrait = 2, workersFUN = workersFUN) +real_E_wbar <- real_P_wbar - real_A_wbar +real_varE_wbar <- popVar(real_E_wbar) +real_P_c <- calcColonyPheno(apiary, mapCasteToColonyPheno, queenTrait = 1, workersTrait = 2, workersFUN = workersFUN) +real_E_c <- real_P_c - real_A_c +real_varE_c <- popVar(real_E_c) + + +print("Workers aggregate is a sum") +fun = "sum" +indVarComp <- mapColonyToIndVar(varA_q = varA_q, varA_wbar = varA_wbar, corA_qwbar = corA_qwbar, + varE_q = varE_q, varE_wbar = varE_wbar, corE_qwbar = corE_qwbar, + nW = nW, nF = nF, nDPQ = nDPQ, workersFUN = fun) +calc_var_c <- mapIndToColonyVar(varA_q = indVarComp$varA_q, varA_w = indVarComp$varA_w, corA_qw = indVarComp$corA_qw, + varE_q = indVarComp$varE_q, varE_w = indVarComp$varE_w, corE_qw = indVarComp$corE_qw, + nW = nW, nF = nF, nDPQ = nDPQ, workersFUN = fun) -# Run the example from the quantitative genetic vignette founderGenomes <- quickHaplo(nInd = 20, nChr = 16, segSites = 1000) SP <- SimParamBee$new(founderGenomes) -SP$nWorkers <- 100 +SP$nWorkers = nW +SP$nFathers = nF nQtlPerChr <- 100 mean <- c(0, 0) -varA <- c(10, 28.36879) -corA <- matrix(data = c( 1.0, -0.2968586, - -0.2968586, 1.0), nrow = 2, byrow = TRUE) +varA <- c(indVarComp$varA_q, indVarComp$varA_w) +corA <- matrix(data = c( 1.0, indVarComp$corA_qw, + indVarComp$corA_qw, 1.0), nrow = 2, byrow = TRUE) SP$addTraitA(nQtlPerChr = nQtlPerChr, mean = mean, var = varA, corA = corA, - name = c("queenTrait", "workersTrait")) -varE <- c(3, 3) -corE <- matrix(data = c(1.0, 0.3, - 0.3, 1.0), nrow = 2, byrow = TRUE) + name = c("queenTrait", "workersTrait")) +varE <- c(indVarComp$varE_q, indVarComp$varE_w) +corE <- matrix(data = c(1.0, indVarComp$corE_qw, + indVarComp$corE_qw, 1.0), nrow = 2, byrow = TRUE) SP$setVarE(varE = varE, corE = corE) basePop <- createVirginQueens(founderGenomes, n = 20) -head(basePop@gv) -head(basePop@pheno) -drones <- createDrones(x = basePop[1:5], nInd = 3) -colony <- createColony(x = basePop[6]) + +drones <- createDrones(x = basePop[1:nDPQ], nInd = 3) +colony <- createColony(x = basePop[nDPQ+1]) colony <- cross(x = colony, drones = drones, checkCross = "warning") colony <- addWorkers(x = colony, nInd = 50) colony <- buildUp(colony) apiary <- createMultiColony(basePop[7:20]) -drones <- createDrones(basePop[1:5], nInd = 100) +drones <- createDrones(basePop[1:nDPQ], nInd = 100) apiary <- cross(x = apiary, drones = drones, crossPlan = "create", checkCross = "warning") apiary <- buildUp(apiary) -workerGroupGv <- calcColonyGv(apiary, mapCasteToColonyGv, queenTrait = NULL, workersFUN = colSums) -colonyGv <- calcColonyGv(apiary) # sum is the default +if (fun == "sum") { + workersFUN <- colSums +} else if (fun == "mean") { + workersFUN <- colMeans +} -var(workerGroupGv) -var(colonyGv) -``` \ No newline at end of file +# Get the real number of fathers and DPQs +real_A_wbar <- calcColonyGv(apiary, mapCasteToColonyGv, queenTrait = NULL, workersTrait = 2, workersFUN = workersFUN) +real_varA_wbar <- popVar(real_A_wbar) +real_A_c <- calcColonyGv(apiary, mapCasteToColonyGv, queenTrait = 1, workersTrait = 2, workersFUN = workersFUN) +real_varA_c <- popVar(real_A_c) +real_P_wbar <- calcColonyPheno(apiary, mapCasteToColonyPheno, queenTrait = NULL, workersTrait = 2, workersFUN = workersFUN) +real_E_wbar <- real_P_wbar - real_A_wbar +real_varE_wbar <- popVar(real_E_wbar) +real_P_c <- calcColonyPheno(apiary, mapCasteToColonyPheno, queenTrait = 1, workersTrait = 2, workersFUN = workersFUN) +real_E_c <- real_P_c - real_A_c +real_varE_c <- popVar(real_E_c) +``` diff --git a/vignettes/TestVarianceMapping.R b/vignettes/TestVarianceMapping.R deleted file mode 100644 index e0b5805d..00000000 --- a/vignettes/TestVarianceMapping.R +++ /dev/null @@ -1,427 +0,0 @@ -library(SIMplyBee) -library(tidyr) -library(ggplot2) - -# Create a function that maps individual to colony variance -mapIndToColonyVar <- function(varA_q, varA_w, corA_qw, - varE_q, varE_w, corE_qw, - nW, nF, nDPQ, workersFUN = "sum") { - - # First handle the genetic part - # Determine how many pairs of each you have - nW = nW - n_SS = (nW * nW / nF) - nW - n_FS = (nW * nW / nDPQ) - (nW * nW / nF) - n_HS = (nW * nW / nDPQ) * (nDPQ - 1) - - varA_q <- varA_q - if (workersFUN == "mean") { - B1 = 1 / nW * varA_w - } else if (workersFUN == "sum") { - B1 = nW * varA_w - } - - B2_ss <- n_SS * 0.75 * varA_w - B2_fs <- n_FS * 0.50 * varA_w - B2_hs <- n_HS * 0.25 * varA_w - - if (workersFUN == "mean") { - varA_wbar = B1 + 1/nW^2 * (B2_ss + B2_fs + B2_hs) - } else if (workersFUN == "sum") { - varA_wbar = B1 + B2_ss + B2_fs + B2_hs - } - - covA_qw = corA_qw * sqrt(varA_q) * sqrt(varA_w) - - if (workersFUN == "mean") { - covA_qwbar <- covA_qw - } else if (workersFUN == "sum") { - covA_qwbar <- nW * covA_qw - } - corA_qwbar <- covA_qwbar / (sqrt(varA_q) * sqrt(varA_wbar)) - - varA_c <- varA_q + varA_wbar + 2*covA_qwbar - - # Next handle the environmental part - if (workersFUN == "mean") { - varE_wbar = 1 / nW * varE_w - } else if (workersFUN == "sum") { - varE_wbar = nW * varE_w - } - - covE_qw = corE_qw * sqrt(varE_q) * sqrt(varE_w) - - if (workersFUN == "mean") { - covE_qwbar <- covE_qw - } else if (workersFUN == "sum") { - covE_qwbar <- nW * covE_qw - } - corE_qwbar <- covE_qwbar / (sqrt(varE_q) * sqrt(varE_wbar)) - - varE_c <- varE_q + varE_wbar + 2*covE_qwbar - - return(list(varA_q = varA_q, varA_wbar = varA_wbar, covA_qwbar = covA_qwbar, corA_qwbar = corA_qwbar, varA_c = varA_c, - varE_q = varE_q, varE_wbar = varE_wbar, covE_qwbar = covE_qwbar, corE_qwbar = corE_qwbar, varE_c = varE_c)) -} - -# Test the function through reps -nRep = 10 -variances0 = data.frame() - -for (rep in 1:nRep) { - print(paste0("Mean, rep ", rep)) - founderGenomes <- quickHaplo(nInd = 20, nChr = 16, segSites = 1000) - SP <- SimParamBee$new(founderGenomes) - nQtlPerChr <- 100 - mean <- c(0, 0) - varA <- c(1, 1) - corA <- matrix(data = c( 1.0, -0.5, - -0.5, 1.0), nrow = 2, byrow = TRUE) - SP$addTraitA(nQtlPerChr = nQtlPerChr, mean = mean, var = varA, corA = corA, - name = c("queenTrait", "workersTrait")) - varE <- c(3, 3) - corE <- matrix(data = c(1.0, 0.3, - 0.3, 1.0), nrow = 2, byrow = TRUE) - SP$setVarE(varE = varE, corE = corE) - basePop <- createVirginQueens(founderGenomes, n = 20) - head(basePop@gv) - head(basePop@pheno) - drones <- createDrones(x = basePop[1:5], nInd = 3) - colony <- createColony(x = basePop[6]) - colony <- cross(x = colony, drones = drones, checkCross = "warning") - colony <- addWorkers(x = colony, nInd = 50) - colony <- buildUp(colony) - apiary <- createMultiColony(basePop[7:20]) - drones <- createDrones(basePop[1:5], nInd = 100) - apiary <- cross(x = apiary, drones = drones, crossPlan = "create", checkCross = "warning") - apiary <- buildUp(apiary) - colonyGv <- calcColonyGv(apiary) - - # Get the real number of fathers and DPQs - nW = round(mean(nWorkers(apiary)), 0) - nF = round(mean(nFathers(apiary)), 0) - nDPQ <- round(mean(sapply(getFathers(apiary), function(x) length(unique(x@mother)))), 0) - - - # When the function to summarise worker effects is SUM - calcVar <- mapIndToColonyVar(varA_q = varA[1], - varA_w= varA[2], - corA_qw = corA[1,2], - varE_q = varE[1], - varE_w = varE[2], - corE_qw = corE[1,2], - nW = nW, nF = nF, - nDPQ = nDPQ, - workersFUN = "mean") - - real_gv_q <- calcColonyGv(apiary, FUN = mapCasteToColonyGv, queenTrait = 1, workersTrait = NULL) - real_gv_wbar <- calcColonyGv(apiary, FUN = mapCasteToColonyGv, queenTrait = NULL, workersTrait = 2, workersFUN = colMeans) - real_covA_qwbar <- cov(real_gv_q, real_gv_wbar) - real_corA_qwbar <- cor(real_gv_q, real_gv_wbar) - real_varA_q <- var(real_gv_q) - real_varA_wbar <- var(real_gv_wbar) - real_varA_c <- var(calcColonyGv(apiary, FUN = mapCasteToColonyGv, workersFUN = colMeans)) - real_varP_c <- var(calcColonyPheno(apiary, FUN = mapCasteToColonyPheno, workersFUN = colMeans)) - - variances0 <- rbind(variances0, data.frame(rep = rep, - calc_varA_q = calcVar$varA_q, calc_varA_wbar = calcVar$varA_wbar, calc_varA_c = calcVar$varA_c, calc_varE_c = calcVar$varE_c, - real_varA_q = real_varA_q[1,1], real_varA_wbar = real_varA_wbar[1,1], real_varA_c = real_varA_c[1,1], - real_covA_qwbar = real_covA_qwbar[1,1], real_corA_qwbar = real_corA_qwbar[1,1], - real_varP_c = real_varP_c[1,1], - fun = "mean")) - - print(paste0("Sum, rep ", rep)) - # Run the example from the quantitative genetic vignette - founderGenomes <- quickHaplo(nInd = 20, nChr = 16, segSites = 1000) - SP <- SimParamBee$new(founderGenomes) - SP$nWorkers <- 100 - SP$nFathers <- 15 - nQtlPerChr <- 100 - mean <- c(0, 0) - varA <- c(1, 1 / SP$nWorkers) - corA <- matrix(data = c( 1.0, -0.5, - -0.5, 1.0), nrow = 2, byrow = TRUE) - SP$addTraitA(nQtlPerChr = nQtlPerChr, mean = mean, var = varA, corA = corA, - name = c("queenTrait", "workersTrait")) - varE <- c(3, 3 / SP$nWorkers) - corE <- matrix(data = c(1.0, 0.3, - 0.3, 1.0), nrow = 2, byrow = TRUE) - SP$setVarE(varE = varE, corE = corE) - - basePop <- createVirginQueens(founderGenomes, n = 20) - head(basePop@gv) - head(basePop@pheno) - drones <- createDrones(x = basePop[1:5], nInd = 3) - colony <- createColony(x = basePop[6]) - colony <- cross(x = colony, drones = drones, checkCross = "warning") - colony <- addWorkers(x = colony, nInd = 50) - colony <- buildUp(colony) - apiary <- createMultiColony(basePop[7:20]) - drones <- createDrones(basePop[1:5], nInd = 100) - apiary <- cross(x = apiary, drones = drones, crossPlan = "create", checkCross = "warning") - apiary <- buildUp(apiary) - colonyGv <- calcColonyGv(apiary) - colonyPheno <- calcColonyPheno(apiary) - - nW = round(mean(nWorkers(apiary)), 0) - nF = round(mean(nFathers(apiary)), 0) - nDPQ <- round(mean(sapply(getFathers(apiary), function(x) length(unique(x@mother)))), 0) - - - # When the function to summarise worker effects is SUM - calcVar <- mapIndToColonyVar(varA_q = varA[1], - varA_w= varA[2], - corA_qw = corA[1,2], - varE_q = varE[1], - varE_w = varE[2], - corE_qw = corE[1,2], - nW = nW, nF = nF, - nDPQ = nDPQ, - workersFUN = "sum") - - real_gv_q <- calcColonyGv(apiary, FUN = mapCasteToColonyGv, queenTrait = 1, workersTrait = NULL) - real_gv_wbar <- calcColonyGv(apiary, FUN = mapCasteToColonyGv, queenTrait = NULL, workersTrait = 2, workersFUN = colSums) - real_covA_qwbar <- cov(real_gv_q, real_gv_wbar) - real_corA_qwbar <- cor(real_gv_q, real_gv_wbar) - real_varA_q <- var(real_gv_q) - real_varA_wbar <- var(real_gv_wbar) - real_varA_c <- var(calcColonyGv(apiary, FUN = mapCasteToColonyGv, workersFUN = colSums)) - real_varP_c <- var(calcColonyPheno(apiary, FUN = mapCasteToColonyPheno, workersFUN = colMeans)) - - - variances0 <- rbind(variances0, data.frame(rep = rep, - calc_varA_q = calcVar$varA_q, calc_varA_wbar = calcVar$varA_wbar, calc_varA_c = calcVar$varA_c, calc_varE_c = calcVar$varE_c, - real_varA_q = real_varA_q[1,1], real_varA_wbar = real_varA_wbar[1,1], real_varA_c = real_varA_c[1,1], - real_covA_qwbar = real_covA_qwbar[1,1], real_corA_qwbar = real_corA_qwbar[1,1], - real_varP_c = real_varP_c[1,1], - fun = "sum")) - - -} - -variances0Long <- pivot_longer(variances0 |> select(-c(real_covA_qwbar, real_corA_qwbar)), - cols = c("calc_varA_q", "calc_varA_wbar", "calc_varA_c", "calc_varE_c", - "real_varA_q", "real_varA_c", "real_varA_wbar", "real_varP_c"), names_to = "VarType", values_to = "Var") -meanRealVar = variances0Long %>% group_by(fun, VarType) %>% summarise(meanVar = mean(Var)) - -variances0Long %>% - mutate(rep = as.factor(rep)) %>% - mutate(VarType = factor(VarType, levels = c("calc_varA_q", "calc_varA_wbar", "calc_varA_c", "calc_varE_c", - "real_varA_q", "real_varA_wbar", "real_varA_c", "real_varP_c"))) %>% - ggplot(aes(x = rep, y = Var, color = VarType)) + - geom_point(size = 3) + - geom_hline(data = meanRealVar, aes(yintercept = meanVar, colour = VarType), linewidth = 3) + - facet_wrap(. ~fun, scales = "free") + - theme_bw(base_size = 20) + - scale_colour_manual(values = c( - "#D55E00", # vermillion - "#084159", # blue - "#32c237", - "#b560b4", - "#a80805", # reddish purple - "#0f77a3", # bluish green - "#1a5e1d", - "#610b60" - )) - -variances0 |> filter(rep == 1) - -pivot_longer(variances0 |> select(c(rep, fun, real_covA_qwbar, real_corA_qwbar)), cols = c("real_covA_qwbar", "real_corA_qwbar"), names_to = "CovType", values_to = "Cov") |> - mutate(rep = as.factor(rep)) %>% - ggplot(aes(x = rep, y = Cov, color = CovType)) + - geom_point(size = 3) + - facet_wrap(. ~fun+CovType, scales = "free") + - theme_bw(base_size = 20) - -########################################################################################3 -# The other way around -# Create a function that maps colony level variance to individual level variance -######################################################################################## -mapColonyToIndVar <- function(varA_q, - varA_wbar, - corA_qwbar, - varE_q, - varE_wbar, - corE_qwbar, - nW, - nF, - nDPQ, - workersFUN = "sum") { - - # First handle the genetic part - covA_qwbar <- corA_qwbar * sqrt(varA_q) * sqrt(varA_wbar) - - # scaling factor - if (workersFUN == "sum") { - covA_qw <- covA_qwbar / nW - } else if (workersFUN == "mean") { - covA_qw <- covA_qwbar - } - - # pair counts - n_SS <- (nW * nW / nF) - nW - n_FS <- (nW * nW / nDPQ) - (nW * nW / nF) - n_HS <- (nW * nW / nDPQ) * (nDPQ - 1) - - # worker variance coefficient - if (workersFUN == "sum") { - K <- nW + - n_SS * 0.75 + - n_FS * 0.50 + - n_HS * 0.25 - } else if (workersFUN == "mean") { - K <- 1 / nW + ((n_SS * 0.75 + - n_FS * 0.50 + - n_HS * 0.25) / nW^2) - } - - varA_w <- varA_wbar / K - - corA_qw <- covA_qw / (sqrt(varA_q) * sqrt(varA_w)) - - # Next handle the environmental part - covE_qwbar <- corE_qwbar * sqrt(varE_q) * sqrt(varE_wbar) - - if (workersFUN == "sum") { - varE_w <- varE_wbar / nW - covE_qw <- covE_qwbar / nW - } else if (workersFUN == "mean") { - varE_w <- varE_wbar * nW - covE_qw <- covE_qwbar - } - - corE_qw <- covE_qw / (sqrt(varE_q) * sqrt(varE_w)) - - - return(list(varA_q = varA_q, varA_wbar = varA_wbar, varA_w = varA_w, - covA_qwbar = covA_qwbar, covA_qw = covA_qw, corA_qw = corA_qw, - varE_q = varE_q, varE_wbar = varE_wbar, varE_w = varE_w, - covE_qwbar = covE_qwbar, covE_qw = covE_qw, corE_qw = corE_qw)) -} - -# Test the function through reps -nRep = 50 -variances = data.frame() - -for (rep in 1:nRep) { - varA_q <- 5 - varA_wbar <- 10 - corA_qwbar <- -0.5 - - varE_q <- 10 - varE_wbar <- 20 - corE_qwbar <- 0.3 - - nW <- 100 - nF <- 15 - nDPQ <- 5 - - for (fun in c("mean", "sum")) { - indVarComp <- mapColonyToIndVar(varA_q = varA_q, varA_wbar = varA_wbar, corA_qwbar = corA_qwbar, - varE_q = varE_q, varE_wbar = varE_wbar, corE_qwbar = corE_qwbar, - nW = nW, nF = nF, nDPQ = nDPQ, workersFUN = fun) - calc_var_c <- mapIndToColonyVar(varA_q = indVarComp$varA_q, varA_w = indVarComp$varA_w, corA_qw = indVarComp$corA_qw, - varE_q = indVarComp$varE_q, varE_w = indVarComp$varE_w, corE_qw = indVarComp$corE_qw, - nW = nW, nF = nF, nDPQ = nDPQ, workersFUN = fun) - - print(paste0("Sum, rep ", rep)) - founderGenomes <- quickHaplo(nInd = 20, nChr = 16, segSites = 1000) - SP <- SimParamBee$new(founderGenomes) - SP$nWorkers = nW - SP$nFathers = nF - nQtlPerChr <- 100 - mean <- c(0, 0) - varA <- c(indVarComp$varA_q, indVarComp$varA_w) - corA <- matrix(data = c( 1.0, indVarComp$corA_qw, - indVarComp$corA_qw, 1.0), nrow = 2, byrow = TRUE) - SP$addTraitA(nQtlPerChr = nQtlPerChr, mean = mean, var = varA, corA = corA, - name = c("queenTrait", "workersTrait")) - varE <- c(indVarComp$varE_q, indVarComp$varE_w) - corE <- matrix(data = c(1.0, indVarComp$corE_qw, - indVarComp$corE_qw, 1.0), nrow = 2, byrow = TRUE) - SP$setVarE(varE = varE, corE = corE) - basePop <- createVirginQueens(founderGenomes, n = 20) - - drones <- createDrones(x = basePop[1:nDPQ], nInd = 3) - colony <- createColony(x = basePop[nDPQ+1]) - colony <- cross(x = colony, drones = drones, checkCross = "warning") - colony <- addWorkers(x = colony, nInd = 50) - colony <- buildUp(colony) - apiary <- createMultiColony(basePop[7:20]) - drones <- createDrones(basePop[1:nDPQ], nInd = 100) - apiary <- cross(x = apiary, drones = drones, crossPlan = "create", checkCross = "warning") - apiary <- buildUp(apiary) - - if (fun == "sum") { - workersFUN <- colSums - } else if (fun == "mean") { - workersFUN <- colMeans - } - - # Get the real number of fathers and DPQs - real_A_wbar <- calcColonyGv(apiary, mapCasteToColonyGv, queenTrait = NULL, workersTrait = 2, workersFUN = workersFUN) - real_varA_wbar <- popVar(real_A_wbar) - real_A_c <- calcColonyGv(apiary, mapCasteToColonyGv, queenTrait = 1, workersTrait = 2, workersFUN = workersFUN) - real_varA_c <- popVar(real_A_c) - real_P_wbar <- calcColonyPheno(apiary, mapCasteToColonyPheno, queenTrait = NULL, workersTrait = 2, workersFUN = workersFUN) - real_E_wbar <- real_P_wbar - real_A_wbar - real_varE_wbar <- popVar(real_E_wbar) - real_P_c <- calcColonyPheno(apiary, mapCasteToColonyPheno, queenTrait = 1, workersTrait = 2, workersFUN = workersFUN) - real_E_c <- real_P_c - real_A_c - real_varE_c <- popVar(real_E_c) - - variances <- rbind(variances, data.frame(rep = rep, - set_var_wbar = varA_wbar, - - calc_var_wbar = calc_var_c$varA_wbar, calc_var_c = calc_var_c$varA_c, - real_var_wbar = real_varA_wbar[1,1], real_var_c = real_varA_c, - - component = "A", - - fun = fun)) - - variances <- rbind(variances, data.frame(rep = rep, - set_var_wbar = varE_wbar, - - calc_var_wbar = calc_var_c$varE_wbar, calc_var_c = calc_var_c$varE_c, - real_var_wbar = real_varE_wbar[1,1], real_var_c = real_varE_c, - - component = "E", - fun = fun)) - - - - } -} - - - -variancesLong <- variances |> - #select(rep, fun, real_varA_wbar, set_varA_wbar, real_varA_c, calc_varA_c, calc_varA_wbar) |> - pivot_longer(cols = c("set_var_wbar", - "calc_var_wbar", "calc_var_c", - "real_var_wbar", "real_var_c"), - names_to = "VarType", values_to = "Var") - -meanRealVar = variancesLong %>% group_by(fun, component, VarType) %>% summarise(meanVar = mean(Var)) - -library(viridis) -variancesLong %>% - mutate(rep = as.factor(rep)) %>% - mutate(VarType = factor(VarType, levels = c("set_var_wbar", "calc_var_wbar", "real_var_wbar", "calc_var_c", "real_var_c"))) %>% - ggplot(aes(x = rep, y = Var, color = VarType)) + - geom_point(size = 3, alpha = 0.7) + - geom_hline(data = meanRealVar, aes(yintercept = meanVar, colour = VarType), linewidth = 3) + - facet_wrap(. ~fun + component, scales = "free") + - theme_bw(base_size = 20) + - scale_colour_manual(values = c( - # Cool tones - "#1B4965", # deep blue - "#048BA8", # cyan-blue - "#16DB93", # green-teal - - # Warm tones - "#F4A261", # sand orange - "#D62828", # red - "#9D4EDD" # purple -))