From d1939bf5cb669d651006cacf234c75d44d1950cc Mon Sep 17 00:00:00 2001 From: janaobsteter Date: Tue, 8 Apr 2025 16:47:41 +0200 Subject: [PATCH 01/98] 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/98] 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/98] 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/98] 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/98] 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/98] 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/98] 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/98] 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/98] 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/98] 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/98] 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/98] 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/98] 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/98] 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/98] 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/98] 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/98] 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/98] 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/98] 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/98] 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/98] 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/98] 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/98] 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/98] 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/98] .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/98] 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/98] 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/98] 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/98] 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/98] 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/98] 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/98] 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/98] 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/98] 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/98] 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/98] 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/98] 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/98] 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/98] 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/98] 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/98] 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/98] 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/98] 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/98] 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/98] 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/98] 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/98] 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/98] 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/98] 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/98] 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/98] 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/98] 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/98] 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/98] 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/98] 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/98] 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 -)) From cdbc58bf44752ccdc94b5515445ad8abff4111f7 Mon Sep 17 00:00:00 2001 From: janaobsteter Date: Mon, 31 Aug 2026 11:14:03 +0200 Subject: [PATCH 57/98] Adding variance component calculations functions and vignette --- DESCRIPTION | 1 + NAMESPACE | 2 + R/Functions_L0_auxilary.R | 179 +++++++ man/SimParamBee.Rd | 514 +++++++++--------- man/mapColonyToIndVar.Rd | 46 ++ man/mapIndToColonyVar.Rd | 46 ++ vignettes/F2_Variance_calculations.Rmd | 704 ++++++++++++------------- 7 files changed, 877 insertions(+), 615 deletions(-) create mode 100644 man/mapColonyToIndVar.Rd create mode 100644 man/mapIndToColonyVar.Rd diff --git a/DESCRIPTION b/DESCRIPTION index 2f7b3eb1..0ff973df 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -39,3 +39,4 @@ Config/testthat/edition: 3 Config/Needs/website: tidyverse/tidytemplate VignetteBuilder: knitr Config/roxygen2/version: 8.0.0 +RoxygenNote: 7.3.2 diff --git a/NAMESPACE b/NAMESPACE index 9e20e95b..45670887 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -143,6 +143,8 @@ export(isWorkersPresent) export(mapCasteToColonyGv) export(mapCasteToColonyPheno) export(mapCasteToColonyValue) +export(mapColonyToIndVar) +export(mapIndToColonyVar) export(nCaste) export(nCasteColonyPhenotype) export(nCastePoisson) diff --git a/R/Functions_L0_auxilary.R b/R/Functions_L0_auxilary.R index fbbb20b5..6008ebf4 100644 --- a/R/Functions_L0_auxilary.R +++ b/R/Functions_L0_auxilary.R @@ -6438,3 +6438,182 @@ mapLoci = function(markers, genMap){ return(list(lociPerChr=lociPerChr, lociLoc=lociLoc)) } + + +#' @rdname cor2cov +#' @title Convert correlation matrix to covariance matrix +#' +#' @description Convert correlation matrix to covariance matrix +#' This function is adopted from AlphaSimR (Gaynor et al., 2021) +#' +#' @param corr correlation matrix +#' @param var vector of variances +#' @return covariance matrix +cor2cov <- function(corr, var) { + corr <- as.matrix(corr) + var <- as.numeric(var) + sd <- sqrt(var) + cov <- corr * (sd %o% sd) + return(cov) +} + +#' @rdname mapIndToColonyVar +#' @title Map individual-level variance components to colony-level variance components +#' +#' @description Map individual-level variance components to colony-level variance components +#' +#' @param varA_q numeric, additive genetic variance of the queen +#' @param varA_w numeric, additive genetic variance of the workers +#' @param corA_qw numeric, correlation between queen and workers +#' @param varE_q numeric, environmental variance of the queen +#' @param varE_w numeric, environmental variance of the workers +#' @param corE_qw numeric, correlation between queen and workers +#' @param nW numeric, number of workers in the colony +#' @param nF numeric, number of fathers of the workers +#' @param nDPQ numeric, number of drone producing queens in the colony +#' @param workersFUN character, either "sum" or "mean", indicating whether the workers' contributions are summed or averaged +#' +#' @return list with colony-level variance components +#' +#' @export +mapIndToColonyVar <- function(varA_q, varA_w, corA_qw, + varE_q, varE_w, corE_qw, + nW, nF, nDPQ, workersFUN = "sum") { + + if (!workersFUN %in% c("sum", "mean")) { + stop("Invalid value for workersFUN. We currently only support either 'sum' or 'mean'.") + } + + # Pair counts + n_SS <- (nW * nW / nF) - nW + n_FS <- (nW * nW / nDPQ) - (nW * nW / nF) + n_HS <- (nW * nW / nDPQ) * (nDPQ - 1) + + 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 + + # 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)) +} + +#' @rdname mapColonyToIndVar +#' @title Map colony-level variance components to individual-level variance components +#' +#' @description Map colony-level variance components to individual-level variance components +#' +#' @param varA_q numeric, additive genetic variance of the queen +#' @param varA_wbar numeric, additive genetic variance of the average worker +#' @param corA_qwbar numeric, correlation between queen and average worker +#' @param varE_q numeric, environmental variance of the queen +#' @param varE_wbar numeric, environmental variance of the average worker +#' @param corE_qwbar numeric, correlation between queen and average worker +#' @param nW numeric, number of workers in the colony +#' @param nF numeric, number of fathers of the workers +#' @param nDPQ numeric, number of drone producing queens in the colony +#' @param workersFUN character, either "sum" or "mean", indicating whether the workers' contributions are summed or averaged +#' +#' @return list with individual-level variance components +#' +#' @export +mapColonyToIndVar <- function(varA_q, + varA_wbar, + corA_qwbar, + varE_q, + varE_wbar, + corE_qwbar, + nW, + nF, + nDPQ, + workersFUN = "sum") { + + if (!workersFUN %in% c("sum", "mean")) { + stop("Invalid value for workersFUN. We currently only support either 'sum' or 'mean'.") + } + + covA_qwbar <- corA_qwbar * sqrt(varA_q) * sqrt(varA_wbar) + + if (workersFUN == "sum") { + covA_qw <- covA_qwbar / nW + } else if (workersFUN == "mean") { + covA_qw <- covA_qwbar + } + + n_SS <- (nW * nW / nF) - nW + n_FS <- (nW * nW / nDPQ) - (nW * nW / nF) + n_HS <- (nW * nW / nDPQ) * (nDPQ - 1) + + 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)) + + # 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)) +} \ No newline at end of file diff --git a/man/SimParamBee.Rd b/man/SimParamBee.Rd index 555e3730..00f6e5f5 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,99 +279,100 @@ 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-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 +\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 -
    }} +
    +}} \if{html}{\out{
    }} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-SimParamBee-initialize}{}}} -\subsection{\code{SimParamBee$new()}}{ - Starts the process of building a new simulation by creating +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-SimParamBee-new}{}}} +\subsection{Method \code{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, @@ -385,81 +386,99 @@ generate this object} 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{\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 +\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 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) @@ -473,33 +492,35 @@ 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{\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 +\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 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 @@ -511,139 +532,140 @@ 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{\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{Method \code{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{
    }} +} +} \if{html}{\out{
    }} \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-SimParamBee-addToBeeRec}{}}} -\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{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{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{\code{SimParamBee$updateCaste()}}{ - A function to update the caste +\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{
    }} - } +\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-updateLastBeeId}{}}} -\subsection{\code{SimParamBee$updateLastBeeId()}}{ - A function to update the last +\subsection{Method \code{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{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{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{
    }} +} +} \if{html}{\out{
    }} \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-SimParamBee-updateLastColonyId}{}}} -\subsection{\code{SimParamBee$updateLastColonyId()}}{ - A function to update the colony last +\subsection{Method \code{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{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{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{
    }} +} +} \if{html}{\out{
    }} \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-SimParamBee-clone}{}}} -\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{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{Arguments}{ +\if{html}{\out{
    }} +\describe{ +\item{\code{deep}}{Whether to make a deep clone.} +} +\if{html}{\out{
    }} +} +} } diff --git a/man/mapColonyToIndVar.Rd b/man/mapColonyToIndVar.Rd new file mode 100644 index 00000000..d5de8977 --- /dev/null +++ b/man/mapColonyToIndVar.Rd @@ -0,0 +1,46 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/Functions_L0_auxilary.R +\name{mapColonyToIndVar} +\alias{mapColonyToIndVar} +\title{Map colony-level variance components to individual-level variance components} +\usage{ +mapColonyToIndVar( + varA_q, + varA_wbar, + corA_qwbar, + varE_q, + varE_wbar, + corE_qwbar, + nW, + nF, + nDPQ, + workersFUN = "sum" +) +} +\arguments{ +\item{varA_q}{numeric, additive genetic variance of the queen} + +\item{varA_wbar}{numeric, additive genetic variance of the average worker} + +\item{corA_qwbar}{numeric, correlation between queen and average worker} + +\item{varE_q}{numeric, environmental variance of the queen} + +\item{varE_wbar}{numeric, environmental variance of the average worker} + +\item{corE_qwbar}{numeric, correlation between queen and average worker} + +\item{nW}{numeric, number of workers in the colony} + +\item{nF}{numeric, number of fathers of the workers} + +\item{nDPQ}{numeric, number of drone producing queens in the colony} + +\item{workersFUN}{character, either "sum" or "mean", indicating whether the workers' contributions are summed or averaged} +} +\value{ +list with individual-level variance components +} +\description{ +Map colony-level variance components to individual-level variance components +} diff --git a/man/mapIndToColonyVar.Rd b/man/mapIndToColonyVar.Rd new file mode 100644 index 00000000..aa3b35cd --- /dev/null +++ b/man/mapIndToColonyVar.Rd @@ -0,0 +1,46 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/Functions_L0_auxilary.R +\name{mapIndToColonyVar} +\alias{mapIndToColonyVar} +\title{Map individual-level variance components to colony-level variance components} +\usage{ +mapIndToColonyVar( + varA_q, + varA_w, + corA_qw, + varE_q, + varE_w, + corE_qw, + nW, + nF, + nDPQ, + workersFUN = "sum" +) +} +\arguments{ +\item{varA_q}{numeric, additive genetic variance of the queen} + +\item{varA_w}{numeric, additive genetic variance of the workers} + +\item{corA_qw}{numeric, correlation between queen and workers} + +\item{varE_q}{numeric, environmental variance of the queen} + +\item{varE_w}{numeric, environmental variance of the workers} + +\item{corE_qw}{numeric, correlation between queen and workers} + +\item{nW}{numeric, number of workers in the colony} + +\item{nF}{numeric, number of fathers of the workers} + +\item{nDPQ}{numeric, number of drone producing queens in the colony} + +\item{workersFUN}{character, either "sum" or "mean", indicating whether the workers' contributions are summed or averaged} +} +\value{ +list with colony-level variance components +} +\description{ +Map individual-level variance components to colony-level variance components +} diff --git a/vignettes/F2_Variance_calculations.Rmd b/vignettes/F2_Variance_calculations.Rmd index d49037dd..0d540d5c 100644 --- a/vignettes/F2_Variance_calculations.Rmd +++ b/vignettes/F2_Variance_calculations.Rmd @@ -19,99 +19,33 @@ knitr::opts_chunk$set( 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: +# Introduction of the problem +As seen in the quantitative genetics vignette, in SIMplyBee, traits are defined +and simulated at the individual (queen, worker, drone) level and mapped to +colony-level values. This requires specification of individual-level variances +and covariances for the queen and workers effects. However, in practice and +literature, we can obtain only colony-level values, and we would like to be able +to use these to inform the individual-level trait definitions. This requires +understanding how colony-level variances and covariances translate to +individual-level variances and covariances, as well as vice-versa. + +This vignettes presents: +- the theory behind the relationship between individual-level and colony-level variances and covariances, +- the implementation of this theory in SIMplyBee, and +- examples of implementation for when the workers's values are combined as a mean or a sum. + +# Theory: colony-level variance components +As seen in the quantitative genetics vignette, in SIMplyBee, traits are defined +and simulated at the individual (queen, worker, drone) level and mapped to +colony-level values. This requires specification of individual-level variances +and covariances for the queen and workers effects. However, in practice and +literature, we can obtain only colony-level values, and we would like to be able +to use these to inform the individual-level trait definitions. This requires +understanding how colony-level variances and covariances translate to +individual-level variances and covariances, as well as vice-versa. + + +We will follow the example from Brascamp and Bijma (2019): $\sigma_{g_q}^2=0.5$ - this is their $\sigma_{A_q}^2=0.5$ @@ -128,7 +62,7 @@ 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?). +between two DPQs. We are ignore the $a_{ss}$ part. $\sigma_{{g_q},{g_w}}=-0.35$ @@ -150,57 +84,84 @@ $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] +$covA[1, 1] + nW * covA[2, 2] + 2 * k * covA[1, 2]$ -```{r quan_gen_param_revision} -# Trait means -mean +Let's run again the example from the quantitative genetics vignette to have some +data to work with. In this example, we assumed that the contribution of workers +was summed up to obtain the combined colony-level worker contribution. +Accordingly, the variance for the worker trait was naively scaled by +$1/nWorkers$, which assumed that workers' contributions were independent. What +does this give us? -# Trait genetic variation - on a per honeybee level -varA -corA +```{r load_variance_scripts, include = FALSE} +# load shared variance helper functions for this vignette +library("SIMplyBee") +library("dplyr") +library("ggplot2") +``` + +```{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(3.0, 0.3, + 0.3, 3.0), nrow = 2, byrow = TRUE) +SP$setVarE(varE = varE, corE = corE) +basePop <- createVirginQueens(founderGenomes, n = 20) +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) + +(popVar(colonyGv)) +(popVar(colonyPheno)) +``` + +In this example, 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! + +Also, if we naively compute the expected colony-level variances based on our assumptions of worker-independence when +setting individual-level variances, we get: +```{r variance_expectation} (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] + SP$nWorkers * covA[2, 2] + 2 * covA[1, 2]) +(covP[1, 1] + SP$nWorkers * covP[2, 2] + 2 * covP[1, 2]) +``` +Here, we see an even larger discrepancy between the assumed and realised colony-level genetic variance, +where the realised values greatly exceed the assumed values. -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] +So, let's have a look at how we can improve the simulation to get the desired +colony-level variances and covariances. -# Observed variation - on a per colony level -var(colonyGv) -var(colonyPheno) -var(colonyGv) / var(colonyPheno) -``` +# Theory: Breaking down colony-level variance components -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 +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})$: @@ -514,116 +475,37 @@ 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}}$?! +# SIMplyBee implementation -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. +We have developed a set of functions that use the theory explained above to: +(i) calculate expected colony-level variances +and covariances based on the provided individual-level variances and covariances: `mapIndToColonyVar()` +(ii) calculate the required individual-level variances and covariances to achieve the desired +colony-level variances and covariances: `mapColonyToIndVar()` -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? +# Example: summarising worker effects as a sum -NEXT STEPS: +Let's see how these work in practice. We will use the same example as above, so let's just recall what values we've set. +Note again, that we are summarising the workers' effects as a sum, so we naively set the individual-level variance for the worker effect +to be $1/nWorkers$ of the desired colony-level variance for the worker effect. -1) read the above, check derivations, missing bits, etc. +Let's start off with a fresh simulation. -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") +```{r} founderGenomes <- quickHaplo(nInd = 20, nChr = 16, segSites = 1000) SP <- SimParamBee$new(founderGenomes) nQtlPerChr <- 100 -mean <- c(10, 10) -varA <- c(1, 1) +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) -corE <- matrix(data = c(1.0, 0.3, - 0.3, 1.0), nrow = 2, byrow = TRUE) +varE <- c(3, 3 / SP$nWorkers) +corE <- matrix(data = c(3.0, 0.3, + 0.3, 3.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") @@ -633,171 +515,255 @@ 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 +Now, let's compute the corresponding colony-level variances and covariances using the `mapIndToColonyVar()` function. +```{r mapIndToColonyVar_sum} +# When the function to summarise worker effects is SUM +calcColonyValues <- 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") + +calcColonyValues$varA_c +colonyGv <- calcColonyGv(apiary, FUN = mapCasteToColonyGv, workersFUN = colSums) 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) - +We see that the realised and calculated colony-level variances match quite closely. + +Now, let's do it the other way around. This is a more realistic scenario since you would normally obtain +the colony-level variances and covariances from the literature and would want to recreate them using simulation. +Here, we assume, you obtain a separate estimate for the queen and for the worker trait. +Let's say we want to achieve the following colony-level variances and covariances: +```{r mapColonyToIndVar_sum} +varA_q <- 1 +varA_wbar <- 1 +corA_qwbar <- -0.5 + +varE_q <- 3 +varE_wbar <- 3 +corE_qwbar <- 0.3 + +nW <- 100 +nF <- 15 +nDPQ <- 5 + +calcIndValues <- 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 = "sum") ``` +Now, let's use these calculated individual-level variances and covariances to simulate a new population and check if we achieve the desired colony-level variances and covariances. -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: +```{r example_sum} +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(calcIndValues$varA_q, calcIndValues$varA_w) +corA <- matrix(data = c( 1.0, calcIndValues$corA_qw, + calcIndValues$corA_qw, 1.0), nrow = 2, byrow = TRUE) +SP$addTraitA(nQtlPerChr = nQtlPerChr, mean = mean, var = varA, corA = corA, + name = c("queenTrait", "workersTrait")) +varE <- c(calcIndValues$varE_q, calcIndValues$varE_w) +corE <- matrix(data = c(1.0, calcIndValues$corE_qw, + calcIndValues$corE_qw, 1.0), nrow = 2, byrow = TRUE) +SP$setVarE(varE = varE, corE = corE) +basePop <- createVirginQueens(founderGenomes, n = 20) -$g_{1,w} = \frac{1}{2}g_{q,w} + g_{f,w} + r_{1,w}$ +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) -$g_{2,w} = \frac{1}{2}g_{q,w} + g_{f,w} + r_{2,w}$ +# Get the realised numbers +real_A_q <- calcColonyGv(apiary, mapCasteToColonyGv, queenTrait = 1, workersTrait = NULL) +real_varA_q <- popVar(real_A_q) +real_A_wbar <- calcColonyGv(apiary, mapCasteToColonyGv, queenTrait = NULL, workersTrait = 2, workersFUN = colSums) +real_varA_wbar <- popVar(real_A_wbar) +real_A_c <- calcColonyGv(apiary, mapCasteToColonyGv, queenTrait = 1, workersTrait = 2, workersFUN = colSums) +real_varA_c <- popVar(real_A_c) + +real_P_q <- calcColonyPheno(apiary, mapCasteToColonyPheno, queenTrait = 1, workersTrait = NULL) +real_E_q <- real_P_q - real_A_q +real_varE_q <- popVar(real_E_q) +real_P_wbar <- calcColonyPheno(apiary, mapCasteToColonyPheno, queenTrait = NULL, workersTrait = 2, workersFUN = colSums) +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 = colSums) +real_E_c <- real_P_c - real_A_c +real_varE_c <- popVar(real_E_c) + +variances <- data.frame(set_varA_q = varA_q, real_varA_q = real_varA_q[1,1], + set_varA_wbar = varA_wbar, real_varA_wbar = real_varA_wbar[1,1], + real_varA_c = real_varA_c[1,1], + set_varE_q = varE_q, real_varE_q = real_varE_q[1,1], + set_varE_wbar = varE_wbar, real_varE_wbar = real_varE_wbar[1,1], + real_varE_c = real_varE_c[1,1], + fun = "sum") + +# Plot the results +variancesLong <- variances %>% + tidyr::pivot_longer(cols = -c(fun), names_to = "VarType", values_to = "Var") +variancesLong$RealCalc <- sapply(strsplit(as.character(variancesLong$VarType), "_"), "[", 1) +# Extract the second and third elements and paste them together to get the variance type for plotting +variancesLong$VarTypePlot <- paste0(sapply(strsplit(as.character(variancesLong$VarType), "_"), "[", 2), "_", sapply(strsplit(as.character(variancesLong$VarType), "_"), "[", 3)) + +variancesLong$VarTypePlot <- factor(variancesLong$VarTypePlot, levels = c("varA_q", "varA_wbar", "varA_c", + "varE_q", "varE_wbar", "varE_c")) + +variancesLong |> filter(VarTypePlot %in% c("varA_q", "varA_wbar", "varE_q", "varE_wbar")) |> + ggplot(aes(x = VarTypePlot, y = Var, fill = RealCalc)) + + geom_col(position = "dodge") + + facet_wrap(. ~fun, scales = "free") + + theme_bw(base_size = 20) + + scale_fill_manual(values = c("#D55E00", "#084159")) # one color per RealCalc level (set/real) +``` -... +As we see, we are pretty much on point with matching the desired values! There is of course the element of stochasticity and +the limited samples size. -$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})$ +# Example: summarising worker effects as a mean +Let's repeat all of the above using a mean to summarise workers' values. +For this, we set the individual-level variance for the worker effect the same as the desired colony-level variance. +For this, we need to resimulate our apiary. -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) +```{r simulation_mean} +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 / SP$nWorkers) +corE <- matrix(data = c(3.0, 0.3, + 0.3, 3.0), nrow = 2, byrow = TRUE) +SP$setVarE(varE = varE, corE = corE) +basePop <- createVirginQueens(founderGenomes, n = 20) +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 +Let's again compute the corresponding colony-level variances and covariances using the `mapIndToColonyVar()` function. +```{r mapIndToColonyVar_mean} +# When the function to summarise worker effects is MEAN +calcColonyValues <- 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") + +calcColonyValues$varA_c +colonyGv <- calcColonyGv(apiary, FUN = mapCasteToColonyGv, workersFUN = colMeans) +var(colonyGv) ``` +We again see that the realised and calculated colony-level variances match very closely. -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) +And for the other way around: +```{r mapColonyToIndVar_mean} +calcIndValues <- 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 = "sum") ``` +Now, let's use these calculated individual-level variances and covariances to simulate a new population and check if we achieve the desired colony-level variances and covariances. -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 example_mean} +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(calcIndValues$varA_q, calcIndValues$varA_w) +corA <- matrix(data = c( 1.0, calcIndValues$corA_qw, + calcIndValues$corA_qw, 1.0), nrow = 2, byrow = TRUE) +SP$addTraitA(nQtlPerChr = nQtlPerChr, mean = mean, var = varA, corA = corA, + name = c("queenTrait", "workersTrait")) +varE <- c(calcIndValues$varE_q, calcIndValues$varE_w) +corE <- matrix(data = c(1.0, calcIndValues$corE_qw, + calcIndValues$corE_qw, 1.0), nrow = 2, byrow = TRUE) +SP$setVarE(varE = varE, corE = corE) +basePop <- createVirginQueens(founderGenomes, n = 20) -print("Part A + B + C f") -varQueen_A + varCovSumWorkers_A + covQueenSumWorkers_A + varQueen_E + varSumWorkers_E + covQueenSumWorkers_E +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) -p <- colonyPheno -var(p) -popVar(p) -sum((p - (mean(p)))^2) / nColonies(apiary) +# Get the realised numbers +real_A_q <- calcColonyGv(apiary, mapCasteToColonyGv, queenTrait = 1, workersTrait = NULL) +real_varA_q <- popVar(real_A_q) +real_A_wbar <- calcColonyGv(apiary, mapCasteToColonyGv, queenTrait = NULL, workersTrait = 2, workersFUN = colSums) +real_varA_wbar <- popVar(real_A_wbar) +real_A_c <- calcColonyGv(apiary, mapCasteToColonyGv, queenTrait = 1, workersTrait = 2, workersFUN = colSums) +real_varA_c <- popVar(real_A_c) + +real_P_q <- calcColonyPheno(apiary, mapCasteToColonyPheno, queenTrait = 1, workersTrait = NULL) +real_E_q <- real_P_q - real_A_q +real_varE_q <- popVar(real_E_q) +real_P_wbar <- calcColonyPheno(apiary, mapCasteToColonyPheno, queenTrait = NULL, workersTrait = 2, workersFUN = colSums) +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 = colSums) +real_E_c <- real_P_c - real_A_c +real_varE_c <- popVar(real_E_c) + +variances <- data.frame(set_varA_q = varA_q, real_varA_q = real_A_q[1,1], + set_varA_wbar = varA_wbar, real_varA_wbar = real_varA_wbar[1,1], + real_varA_c = real_varA_c[1,1], + set_varE_q = varE_q, real_varE_q = real_varE_q[1,1], + set_varE_wbar = varE_wbar, real_varE_wbar = real_varE_wbar[1,1], + real_varE_c = real_varE_c[1,1], + fun = "sum") + +# Plot the results +variancesLong <- variances %>% + tidyr::pivot_longer(cols = -c(fun), names_to = "VarType", values_to = "Var") +variancesLong$RealCalc <- sapply(strsplit(as.character(variancesLong$VarType), "_"), "[", 1) +# Extract the second and third elements and paste them together to get the variance type for plotting +variancesLong$VarTypePlot <- paste0(sapply(strsplit(as.character(variancesLong$VarType), "_"), "[", 2), "_", sapply(strsplit(as.character(variancesLong$VarType), "_"), "[", 3)) + +variancesLong$VarTypePlot <- factor(variancesLong$VarTypePlot, levels = c("varA_q", "varA_wbar", "varA_c", + "varE_q", "varE_wbar", "varE_c")) + +variancesLong |> filter(VarTypePlot %in% c("varA_q", "varA_wbar", "varE_q", "varE_wbar")) |> + ggplot(aes(x = VarTypePlot, y = Var, fill = RealCalc)) + + geom_col(position = "dodge") + + facet_wrap(. ~fun, scales = "free") + + theme_bw(base_size = 20) + + scale_fill_manual(values = c("#D55E00", "#084159")) # one color per RealCalc level (set/real) ``` -And very close for phenotypic too, but we need to check some part above! From 24e9676a8cb23e6b45ff3f6ab6755a7f7b14a8ea Mon Sep 17 00:00:00 2001 From: janaobsteter Date: Mon, 31 Aug 2026 09:46:27 +0000 Subject: [PATCH 58/98] Update documentation --- DESCRIPTION | 3 +- NAMESPACE | 36 +-- man/MultiColony-class.Rd | 12 +- man/SimParamBee.Rd | 514 +++++++++++++++++++-------------------- man/cor2cov.Rd | 20 ++ 5 files changed, 293 insertions(+), 292 deletions(-) create mode 100644 man/cor2cov.Rd diff --git a/DESCRIPTION b/DESCRIPTION index 0ff973df..3733298c 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -38,5 +38,4 @@ Suggests: Config/testthat/edition: 3 Config/Needs/website: tidyverse/tidytemplate VignetteBuilder: knitr -Config/roxygen2/version: 8.0.0 -RoxygenNote: 7.3.2 +Config/roxygen2/version: 8.1.0 diff --git a/NAMESPACE b/NAMESPACE index 45670887..94889270 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -210,21 +210,25 @@ import(Rcpp) importFrom(R6,R6Class) importFrom(extraDistr,rtpois) importFrom(future.apply,future_lapply) -importFrom(methods,"slot<-") -importFrom(methods,classLabel) -importFrom(methods,is) -importFrom(methods,new) -importFrom(methods,setClass) -importFrom(methods,setClassUnion) -importFrom(methods,setMethod) -importFrom(methods,setValidity) -importFrom(methods,show) -importFrom(methods,slot) -importFrom(methods,validObject) -importFrom(stats,na.omit) -importFrom(stats,rbeta) -importFrom(stats,rnorm) -importFrom(stats,rpois) -importFrom(stats,runif) +importFrom(methods, + "slot<-", + classLabel, + is, + new, + setClass, + setClassUnion, + setMethod, + setValidity, + show, + slot, + validObject +) +importFrom(stats, + na.omit, + rbeta, + rnorm, + rpois, + runif +) importFrom(utils,packageVersion) useDynLib(SIMplyBee, .registration = TRUE) diff --git a/man/MultiColony-class.Rd b/man/MultiColony-class.Rd index d81e7d6f..6be082c7 100644 --- a/man/MultiColony-class.Rd +++ b/man/MultiColony-class.Rd @@ -70,17 +70,17 @@ An object holding a collection of honeybee colonies. It behaves \item \code{c(MultiColonyOrNULL)}: Combine multiple Colony and MultiColony objects -\item \code{x[i}: Extract a colony (one or more!) with an integer/numeric/logical index (position) (return \code{\link[SIMplyBee]{MultiColony-class}}) +\item \code{x = MultiColony[i = integerOrNumericOrLogical]}: Extract a colony (one or more!) with an integer/numeric/logical index (position) (return \code{\link[SIMplyBee]{MultiColony-class}}) -\item \code{x[i}: Extract a colony (one or more!) with a character ID (name) (return \code{\link[SIMplyBee]{MultiColony-class}}) +\item \code{x = MultiColony[i = character]}: Extract a colony (one or more!) with a character ID (name) (return \code{\link[SIMplyBee]{MultiColony-class}}) -\item \code{x[[i}: Extract a colony (just one!) with an integer/numeric/logical index (position) (return \code{\link[SIMplyBee]{Colony-class}}) +\item \code{x = MultiColony[[i = integerOrNumericOrLogical]]}: Extract a colony (just one!) with an integer/numeric/logical index (position) (return \code{\link[SIMplyBee]{Colony-class}}) -\item \code{x[[i}: Extract a colony (just one!) with a character ID (name) (return \code{\link[SIMplyBee]{Colony-class}}) +\item \code{x = MultiColony[[i = character]]}: Extract a colony (just one!) with a character ID (name) (return \code{\link[SIMplyBee]{Colony-class}}) -\item \code{`[`(x = MultiColony, i = integerOrNumericOrLogicalOrCharacter, j = ANY) <- value}: Assign colonies into MultiColony +\item \code{x = MultiColony[i = integerOrNumericOrLogicalOrCharacter, j = ANY] <- value}: Assign colonies into MultiColony -\item \code{`[[`(x = MultiColony, i = integerOrNumericOrLogicalOrCharacter, j = ANY) <- value}: Assign Colony into MultiColony +\item \code{x = MultiColony[[i = integerOrNumericOrLogicalOrCharacter, j = ANY]] <- value}: Assign Colony into MultiColony }} \section{Slots}{ 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/cor2cov.Rd b/man/cor2cov.Rd new file mode 100644 index 00000000..35572668 --- /dev/null +++ b/man/cor2cov.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/Functions_L0_auxilary.R +\name{cor2cov} +\alias{cor2cov} +\title{Convert correlation matrix to covariance matrix} +\usage{ +cor2cov(corr, var) +} +\arguments{ +\item{corr}{correlation matrix} + +\item{var}{vector of variances} +} +\value{ +covariance matrix +} +\description{ +Convert correlation matrix to covariance matrix +This function is adopted from AlphaSimR (Gaynor et al., 2021) +} From c97c73abf6fe1873fe93b8ca731ea7f382bf7363 Mon Sep 17 00:00:00 2001 From: Gregor Gorjanc Date: Tue, 29 Sep 2026 11:12:52 +0100 Subject: [PATCH 59/98] Filename changes --- ...indeer-clipart-cartoon-hd-png-download.png | Bin 107612 -> 0 bytes vignettes/D_Crossing.Rmd | 40 +++++++++--------- vignettes/H_Parallelisation.Rmd | 8 ++-- ...ony_locations.csv => colony_locations.csv} | 0 ..._mean.png => parallelisation_cpu_mean.png} | Bin ...parallelisation_function_timings_unix.png} | Bin ...an.png => parallelisation_memory_mean.png} | Bin ...mean.png => parallelisation_time_mean.png} | Bin 8 files changed, 24 insertions(+), 24 deletions(-) delete mode 100644 vignettes/582-5827311_reindeer-clipart-cartoon-hd-png-download.png rename vignettes/{Colony_locations.csv => colony_locations.csv} (100%) rename vignettes/{PCPU_mean.png => parallelisation_cpu_mean.png} (100%) rename vignettes/{Profiling_parallelised_functions_Unix.png => parallelisation_function_timings_unix.png} (100%) rename vignettes/{RSS_mean.png => parallelisation_memory_mean.png} (100%) rename vignettes/{Time_mean.png => parallelisation_time_mean.png} (100%) diff --git a/vignettes/582-5827311_reindeer-clipart-cartoon-hd-png-download.png b/vignettes/582-5827311_reindeer-clipart-cartoon-hd-png-download.png deleted file mode 100644 index 23aa9b67dadcc360c8f5747dcd064ba90af9f42c..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 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 Date: Tue, 29 Sep 2026 16:06:10 +0100 Subject: [PATCH 60/98] Correcting errors from Gregor's agent check --- .github/agents/develop-r-package.agent.md | 123 ++++++ R/Functions_L1_Pop.R | 9 +- R/Functions_L2_Colony.R | 14 +- TestingVarianceComponents.R | 397 ++++++++++++++++++ man/cor2cov.Rd | 20 + .../F2_Variance_calculations_functions.Rmd | 233 +++++++--- vignettes/H_Parallelisation.Rmd | 13 +- vignettes/scripts/variance_functions.R | 135 ++++++ 8 files changed, 871 insertions(+), 73 deletions(-) create mode 100644 .github/agents/develop-r-package.agent.md create mode 100644 TestingVarianceComponents.R create mode 100644 man/cor2cov.Rd create mode 100644 vignettes/scripts/variance_functions.R diff --git a/.github/agents/develop-r-package.agent.md b/.github/agents/develop-r-package.agent.md new file mode 100644 index 00000000..0262631d --- /dev/null +++ b/.github/agents/develop-r-package.agent.md @@ -0,0 +1,123 @@ +--- +name: develop-r-package +description: Use when creating, modifying, or maintaining R packages. Use when editing R/ source files, DESCRIPTION, NAMESPACE, roxygen2 documentation, tests, or CI workflows in an R package context. Use when adding functions, bumping versions, managing dependencies, or preparing releases. +--- + +# Developing R Packages + +## Overview + +Codified workflow for R package development following the R Packages book (Wickham & Bryan, 2e) and conventions established in BadranSeq. Covers the edit-document-check-commit cycle, dependency management, versioning, and release workflow. + +## Development Cycle + +Every code change follows this sequence **before** committing: + +``` +Edit R/ files → devtools::document() → devtools::check() → git add → git commit +``` + +- `document()` regenerates NAMESPACE and man/*.Rd files from roxygen2 comments +- `check()` runs R CMD check locally — expect **0 errors, 0 warnings** +- Known NOTEs (license format, timestamp) are acceptable +- Never commit if check fails — fix first, then commit + +## NAMESPACE & roxygen2 + +- NAMESPACE is **auto-generated by roxygen2** — never edit it manually +- Use `@export` to make functions available to users +- Use `@description`, `@param`, `@return`, `@examples` for documentation +- Run `devtools::document()` after any roxygen comment change + +## Dependencies + +### Imports vs Suggests + +| Field | Purpose | Access pattern | +|-------|---------|---------------| +| `Imports` | Required at runtime, auto-installed | `pkg::fn()` in source code | +| `Suggests` | Optional (testing, extended features) | `pkg::fn()` — never `@importFrom` | +| `Depends` | Only for R version floor | `R (>= x.y)` | + +### Rules + +- **Always use `pkg::fn()` syntax** for external functions — no exceptions +- Only use `@importFrom` for operators (e.g., `%>%`) that can't use `::` +- Add dependencies via `usethis::use_package("pkg")` (defaults to Imports) +- For Suggests: `usethis::use_package("pkg", type = "Suggests")` +- Never call `library()` or `require()` inside package code + +## Versioning + +Format: `..` — always `.` separator, always 3 components. + +| Component | When to bump | Example | +|-----------|-------------|---------| +| **Major** | Breaking changes to existing API | 1.0.0 → 2.0.0 | +| **Minor** | New exported functions (backward-compatible) | 1.3.1 → 1.4.0 | +| **Patch** | Bug fixes, adjustments to existing functions | 1.3.1 → 1.3.2 | + +After bumping: update DESCRIPTION, README.Rmd install instructions, re-knit README.md. + +## Release Workflow + +``` +1. Bump version in DESCRIPTION +2. Update README.Rmd version references +3. devtools::build_readme() +4. devtools::check() # must pass +5. git commit + push +6. git tag -a vX.Y.Z -m "BadranSeq X.Y.Z" +7. git push --tags +8. gh release create vX.Y.Z # with release notes +``` + +## Data in Packages + +- User-facing data: `usethis::use_data(obj)` → saved to `data/obj.rda` +- Document datasets in `R/data.R` using roxygen2 (`@format`, `@source`) — never `@export` +- Preparation scripts go in `data-raw/` +- `LazyData: true` in DESCRIPTION enables lazy loading + +## Testing + +- Initialize with `usethis::use_testthat(3)` (edition 3) +- Match test files to source: `R/foo.R` → `tests/testthat/test-foo.R` +- Create tests with `usethis::use_test("foo")` +- Run with `devtools::test()` or `Ctrl+Shift+T` + +## Lifecycle Badges + +- Set up with `usethis::use_lifecycle()` (one-time) +- Badge in `@description`: `` `r lifecycle::badge("stable")` `` +- Only badge functions whose stage **differs** from the package's stage +- Stages: experimental → stable → deprecated/superseded + +## pkgdown Site + +- **Never build locally** — CI handles it via GitHub Actions after push +- Fix source files (roxygen, vignettes) and push; CI does the rest + +## CI (GitHub Actions) + +- R CMD check runs on push to main via `.github/workflows/R-CMD-check.yaml` +- Standard matrix: macOS, Windows, Ubuntu release, Ubuntu devel +- Drop `oldrel-1` if upstream deps require current R + +## README + +- `README.Rmd` is the source — contains live R code chunks +- `README.md` is the rendered output — never edit directly +- Re-knit with `devtools::build_readme()` after changes + +## Common Mistakes + +| Mistake | Fix | +|---------|-----| +| Editing NAMESPACE manually | Let roxygen2 generate it via `document()` | +| `@importFrom` for Suggests packages | Use `pkg::fn()` instead | +| Committing without `check()` | Always document → check → commit | +| `library()` inside package code | Use `pkg::fn()` or `@importFrom` | +| Editing README.md directly | Edit README.Rmd, then `build_readme()` | +| Building pkgdown locally | Let CI handle it | +| Version as `1.3` instead of `1.3.0` | Always use 3 components | diff --git a/R/Functions_L1_Pop.R b/R/Functions_L1_Pop.R index f69c365c..94cab42b 100644 --- a/R/Functions_L1_Pop.R +++ b/R/Functions_L1_Pop.R @@ -620,6 +620,7 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, lastId = simParamBee$lastId ids = (lastId+1):(lastId+totalNInd) + end_lastId <- lastId+totalNInd ret <- future_lapply(X = seq_len(nCol), future.seed = TRUE, @@ -650,9 +651,11 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, # Add to simParamBee: pedigree, caste, recHist notNull = sapply(ret, FUN = function(x) !is.null(x)) - if (!simParamBee$isTrackPed) { + updatedIdBoolean <- simParamBee$lastId == end_lastId + + if (!simParamBee$isTrackPed & !updatedIdBoolean) { simParamBee$updateLastBeeId(n = totalNInd) - } else if (simParamBee$isTrackPed) { + } else if (simParamBee$isTrackPed & !updatedIdBoolean) { Pedigree <- do.call("rbind", lapply(ret[notNull], '[[', "pedigree")) if (!simParamBee$isTrackRec) { simParamBee$addToBeePed(nNewInd = totalNInd, id = rownames(Pedigree), @@ -1251,7 +1254,6 @@ pullCastePop <- function(x, caste, nInd = NULL, use = "rand", 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 = future_lapply(X = seq_len(nCol), @@ -1273,6 +1275,7 @@ pullCastePop <- function(x, caste, nInd = NULL, use = "rand", ) ret$pulled <- lapply(tmp, '[[', "pulled") + names(ret$pulled) <- getId(x) ret$remnant@colonies <- lapply(tmp, '[[', "remnant") if (collapse) { diff --git a/R/Functions_L2_Colony.R b/R/Functions_L2_Colony.R index 4bb61098..93b68cb1 100644 --- a/R/Functions_L2_Colony.R +++ b/R/Functions_L2_Colony.R @@ -644,11 +644,18 @@ buildUp <- function(x, nWorkers = NULL, nDrones = NULL, x = x, nInd = n, new = new, simParamBee = simParamBee) } + + if (new) { + n <- nDrones + } else { + n <- nDrones - nDrones(x, simParamBee = simParamBee) + } if (sum(nDrones) > 0) { x <- addDrones( x = x, nInd = n, new = new, simParamBee = simParamBee) } + x <- setEvents(x, slot = "production", value = TRUE, simParamBee = simParamBee) if (resetEvents) { x <- resetEvents(x, simParamBee = simParamBee) @@ -1591,6 +1598,11 @@ supersede <- function(x, simParamBee = NULL, ...) { if (is.null(nVirginQueens)) { nVirginQueens <- simParamBee$nVirginQueens } + if (is.function(simParamBee$nVirginQueens)) { + nVirginQueens <- nVirginQueens(x, ...) + } else { + nVirginQueens <- simParamBee$nVirginQueens + } if (any(hasCollapsed(x))) { stop(paste0("One of the collonies is collapsed, hence you can not split it!")) @@ -1604,7 +1616,7 @@ supersede <- function(x, simParamBee = NULL, ...) { # Do this because some colonies might not produce a viable virgin queen tmpVirginQueens <- createCastePop( - x = x, nInd = max(10, simParamBee$nVirginQueens), + x = x, nInd = max(10, nVirginQueens), caste = "virginQueens", simParamBee = simParamBee ) diff --git a/TestingVarianceComponents.R b/TestingVarianceComponents.R new file mode 100644 index 00000000..deefb739 --- /dev/null +++ b/TestingVarianceComponents.R @@ -0,0 +1,397 @@ +library(SIMplyBee) +library(tidyr) +library(ggplot2) +library(dplyr) + +# 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) { + for (fun in c("mean", "sum")) { + print(paste(fun, ", rep ", rep)) + + founderGenomes <- quickHaplo(nInd = 20, nChr = 16, segSites = 1000) + SP <- SimParamBee$new(founderGenomes) + SP$nWorkers <- 100 + SP$nFathers <- 15 + nQtlPerChr <- 100 + + mean <- c(0, 0) + if (fun == "mean") { + varA <- c(1, 1) + varE <- c(3, 3) + } else if (fun == "sum") { + varA <- c(1, 1 / SP$nWorkers) + varE <- c(3, 3 / 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")) + + 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) + + if (fun == "mean") { + workersFUN = colMeans + } else if (fun == "sum") { + workersFUN = colSums + } + + # 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 = fun) + + real_A_q <- calcColonyGv(apiary, FUN = mapCasteToColonyGv, queenTrait = 1, workersTrait = NULL) + real_A_wbar <- calcColonyGv(apiary, FUN = mapCasteToColonyGv, queenTrait = NULL, workersTrait = 2, workersFUN = workersFUN) + real_P_wbar <- calcColonyPheno(apiary, FUN = mapCasteToColonyPheno, queenTrait = NULL, workersTrait = 2, workersFUN = workersFUN) + real_E_wbar <- real_P_wbar - real_A_wbar + real_varE_wbar <- popVar(real_E_wbar) + real_covA_qwbar <- cov(real_A_q, real_A_wbar) + real_corA_qwbar <- cor(real_A_q, real_A_wbar) + + real_varA_wbar <- popVar(real_A_wbar) + + real_A_c <- calcColonyGv(apiary, FUN = mapCasteToColonyGv, workersFUN = workersFUN) + real_varA_c <- popVar(real_A_c) + real_P_c <- calcColonyPheno(apiary, FUN = mapCasteToColonyPheno, workersFUN = workersFUN) + real_E_c <- real_P_c - real_A_c + real_varE_c <- popVar(real_E_c) + + variances0 <- rbind(variances0, data.frame(rep = rep, + + calc_var_wbar = calcVar$varA_wbar, calc_var_c = calcVar$varA_c, + real_var_wbar = real_varA_wbar[1,1], real_var_c = real_varA_c[1,1], + + component = "A", + fun = fun)) + + variances0 <- rbind(variances0, data.frame(rep = rep, + + calc_var_wbar = calcVar$varE_wbar, calc_var_c = calcVar$varE_c, + real_var_wbar = real_varE_wbar, real_var_c = real_varE_c, + + component = "E", + fun = fun)) + + } +} + +variances0Long <- pivot_longer(variances0, + cols = c("calc_var_wbar", "calc_var_c", + "real_var_c", "real_var_wbar"), names_to = "VarType", values_to = "Var") +meanRealVar = variances0Long %>% group_by(fun, component, VarType) %>% summarise(meanVar = mean(Var)) + +variances0Long %>% + dplyr::mutate(rep = as.factor(rep)) %>% + dplyr::mutate(VarType = factor(VarType, levels = c("calc_var_wbar", "calc_var_c", + "real_var_wbar", "real_var_c", "real_varP_c"))) %>% + ggplot(aes(x = rep, y = Var, color = VarType)) + + geom_point(size = 3, aes(colour = VarType)) + + 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( + "#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 = 10 +variances = data.frame() + +for (rep in 1:nRep) { + print(rep) + 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(fun, ", 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 +)) + \ No newline at end of file diff --git a/man/cor2cov.Rd b/man/cor2cov.Rd new file mode 100644 index 00000000..35572668 --- /dev/null +++ b/man/cor2cov.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/Functions_L0_auxilary.R +\name{cor2cov} +\alias{cor2cov} +\title{Convert correlation matrix to covariance matrix} +\usage{ +cor2cov(corr, var) +} +\arguments{ +\item{corr}{correlation matrix} + +\item{var}{vector of variances} +} +\value{ +covariance matrix +} +\description{ +Convert correlation matrix to covariance matrix +This function is adopted from AlphaSimR (Gaynor et al., 2021) +} diff --git a/vignettes/F2_Variance_calculations_functions.Rmd b/vignettes/F2_Variance_calculations_functions.Rmd index 63668904..e41b391f 100644 --- a/vignettes/F2_Variance_calculations_functions.Rmd +++ b/vignettes/F2_Variance_calculations_functions.Rmd @@ -21,21 +21,12 @@ knitr::opts_chunk$set( ) ``` -```{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) -} +```{r load_variance_scripts, include = FALSE} +# load shared variance helper functions +source("vignettes/scripts/variance_functions.R") +library("SIMplyBee") +library("dplyr") +library("ggplot2") ``` Let's again run the example from the quantitative genetic vignette. @@ -213,32 +204,54 @@ 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 a MEAN # 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], + varE_q = varE[1], + varE_w = varE[2], corE_qw = corE[1,2], nW = nW, nF = nF, nDPQ = nDPQ, workersFUN = "mean") +# Let's obtain realised values real_gv_q <- calcColonyGv(apiary, FUN = mapCasteToColonyGv, queenTrait = 1, workersTrait = NULL) +real_pheno_q <- calcColonyPheno(apiary, FUN = mapCasteToColonyPheno, queenTrait = 1, workersTrait = NULL) +real_e_q <- real_pheno_q - real_gv_q 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_pheno_wbar <- calcColonyPheno(apiary, FUN = mapCasteToColonyPheno, queenTrait = NULL, workersTrait = 2, workersFUN = colMeans) +real_e_wbar <- real_pheno_wbar - real_gv_wbar +real_gv_c <- calcColonyGv(apiary, FUN = mapCasteToColonyGv, queenTrait = 1, workersTrait = 2, workersFUN = colMeans) +real_pheno_c <- calcColonyPheno(apiary, FUN = mapCasteToColonyPheno, queenTrait = 1, workersTrait = 2, workersFUN = colMeans) +real_e_c <- real_pheno_c - real_gv_c + + +# Now let's compute the realised variances and covariances 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)) +real_varA_c <- var(real_gv_c) + +real_varE_q <- var(real_e_q) +real_varE_wbar <- var(real_e_wbar) +real_varE_c <- var(real_e_c) + +real_varP_q <- var(real_pheno_q) +real_varP_wbar <- var(real_pheno_wbar) +real_varP_c <- var(real_pheno_c) + +real_covA_qwbar <- cov(real_gv_q, real_gv_wbar) +real_corA_qwbar <- cor(real_gv_q, real_gv_wbar) + +variances0 <- data.frame(calc_varA_q = calcVar$varA_q, real_varA_q = real_varA_q[1,1], + calc_varA_wbar = calcVar$varA_wbar, real_varA_wbar = real_varA_wbar[1,1], + calc_varA_c = calcVar$varA_c, real_varA_c = real_varA_c[1,1], + calc_varE_c = calcVar$varE_c, real_varE_c = real_varE_c[1,1], + fun = "mean") + + -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 @@ -270,8 +283,7 @@ 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) @@ -289,22 +301,68 @@ calcVar <- mapIndToColonyVar(varA_q = varA[1], nDPQ = nDPQ, workersFUN = "sum") +# Let's obtain realised values real_gv_q <- calcColonyGv(apiary, FUN = mapCasteToColonyGv, queenTrait = 1, workersTrait = NULL) +real_pheno_q <- calcColonyPheno(apiary, FUN = mapCasteToColonyPheno, queenTrait = 1, workersTrait = NULL) +real_e_q <- real_pheno_q - real_gv_q 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_pheno_wbar <- calcColonyPheno(apiary, FUN = mapCasteToColonyPheno, queenTrait = NULL, workersTrait = 2, workersFUN = colSums) +real_e_wbar <- real_pheno_wbar - real_gv_wbar +real_gv_c <- calcColonyGv(apiary, FUN = mapCasteToColonyGv, queenTrait = 1, workersTrait = 2, workersFUN = colSums) +real_pheno_c <- calcColonyPheno(apiary, FUN = mapCasteToColonyPheno, queenTrait = 1, workersTrait = 2, workersFUN = colSums) +real_e_c <- real_pheno_c - real_gv_c + + +# Now let's compute the realised variances and covariances 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)) +real_varA_c <- var(real_gv_c) + +real_varE_q <- var(real_e_q) +real_varE_wbar <- var(real_e_wbar) +real_varE_c <- var(real_e_c) +real_varP_q <- var(real_pheno_q) +real_varP_wbar <- var(real_pheno_wbar) +real_varP_c <- var(real_pheno_c) -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], +real_covA_qwbar <- cov(real_gv_q, real_gv_wbar) +real_corA_qwbar <- cor(real_gv_q, real_gv_wbar) + +variances0 <- rbind(variances0, data.frame(calc_varA_q = calcVar$varA_q, real_varA_q = real_varA_q[1,1], + calc_varA_wbar = calcVar$varA_wbar, real_varA_wbar = real_varA_wbar[1,1], + calc_varA_c = calcVar$varA_c, real_varA_c = real_varA_c[1,1], + calc_varE_c = calcVar$varE_c, real_varE_c = real_varE_c[1,1], fun = "sum")) + +# Plot the variances0 from the two different ways of aggregating worker effects +variances0Long <- variances0 %>% + tidyr::pivot_longer(cols = -c(fun), names_to = "VarType", values_to = "Var") +variances0Long$Component <- sapply(strsplit(as.character(variances0Long$VarType), "_"), "[", 2) +variances0Long$RealCalc <- sapply(strsplit(as.character(variances0Long$VarType), "_"), "[", 1) +# Now extract the second and the third element and paste them together to get the type of variance for plotting +variances0Long$VarTypePlot <- paste0(sapply(strsplit(as.character(variances0Long$VarType), "_"), "[", 2), "_", sapply(strsplit(as.character(variances0Long$VarType), "_"), "[", 3)) +variances0Long$Measure <- sapply(strsplit(as.character(variances0Long$VarTypePlot), "_"), "[", 1) + +variances0Long$VarTypePlot <- factor(variances0Long$VarTypePlot, levels = c("varA_q", "varA_wbar", "varA_c", + "varE_c", "varP_c")) + + +variances0Long |> + ggplot(aes(x = VarTypePlot, y = Var, fill = VarTypePlot, alpha = RealCalc)) + + geom_col(position = "dodge") + + facet_wrap(. ~fun, scales = "free") + + theme_bw(base_size = 20) + + scale_fill_manual(values = c( + "#D55E00", # vermillion + "#084159", # blue + "#32c237", + "#b560b4", + "#a80805", # reddish purple + "grey", # bluish green + "black", "black", "black" + ), guide = "none") + + scale_alpha_manual(values = c(0.5, 1), labels = c("Calculated", "Realised")) ``` 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. @@ -372,6 +430,7 @@ mapColonyToIndVar <- function(varA_q, 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} @@ -390,11 +449,10 @@ 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) + nW = nW, nF = nF, nDPQ = nDPQ, workersFUN = "mean") 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) - + nW = nW, nF = nF, nDPQ = nDPQ, workersFUN = "mean") founderGenomes <- quickHaplo(nInd = 20, nChr = 16, segSites = 1000) SP <- SimParamBee$new(founderGenomes) @@ -423,33 +481,41 @@ 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_A_q <- calcColonyGv(apiary, mapCasteToColonyGv, queenTrait = 1, workersTrait = NULL) +real_varA_q <- popVar(real_A_q) +real_A_wbar <- calcColonyGv(apiary, mapCasteToColonyGv, queenTrait = NULL, workersTrait = 2, workersFUN = colMeans) real_varA_wbar <- popVar(real_A_wbar) -real_A_c <- calcColonyGv(apiary, mapCasteToColonyGv, queenTrait = 1, workersTrait = 2, workersFUN = workersFUN) +real_A_c <- calcColonyGv(apiary, mapCasteToColonyGv, queenTrait = 1, workersTrait = 2, workersFUN = colMeans) real_varA_c <- popVar(real_A_c) -real_P_wbar <- calcColonyPheno(apiary, mapCasteToColonyPheno, queenTrait = NULL, workersTrait = 2, workersFUN = workersFUN) + +real_P_q <- calcColonyPheno(apiary, mapCasteToColonyPheno, queenTrait = 1, workersTrait = NULL) +real_E_q <- real_P_q - real_A_q +real_varE_q <- popVar(real_E_q) +real_P_wbar <- calcColonyPheno(apiary, mapCasteToColonyPheno, queenTrait = NULL, workersTrait = 2, workersFUN = colMeans) 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_P_c <- calcColonyPheno(apiary, mapCasteToColonyPheno, queenTrait = 1, workersTrait = 2, workersFUN = colMeans) real_E_c <- real_P_c - real_A_c real_varE_c <- popVar(real_E_c) +variances <- data.frame(set_varA_q = varA_q, calc_varA_q = calc_var_c$varA_q, real_varA_q = varA_q, + set_varA_wbar = varA_wbar, calc_varA_wbar = calc_var_c$varA_wbar, real_varA_wbar = real_varA_wbar[1,1], + calc_varA_c = calc_var_c$varA_c, real_varA_c = real_varA_c, + set_varE_q = varE_q, calc_varE_q = calc_var_c$varE_q, real_varE_q = real_varE_q[1,1], + set_varE_wbar = varE_wbar, calc_varE_wbar = calc_var_c$varE_wbar, real_varE_wbar = real_varE_wbar[1,1], + calc_varE_c = calc_var_c$varE_c, real_varE_c = real_varE_c, + fun = "mean") + 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) + nW = nW, nF = nF, nDPQ = nDPQ, workersFUN = "sum") 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) + nW = nW, nF = nF, nDPQ = nDPQ, workersFUN = "sum") founderGenomes <- quickHaplo(nInd = 20, nChr = 16, segSites = 1000) SP <- SimParamBee$new(founderGenomes) @@ -478,21 +544,62 @@ 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_A_q <- calcColonyGv(apiary, mapCasteToColonyGv, queenTrait = 1, workersTrait = NULL) +real_varA_q <- popVar(real_A_q) +real_A_wbar <- calcColonyGv(apiary, mapCasteToColonyGv, queenTrait = NULL, workersTrait = 2, workersFUN = colSums) real_varA_wbar <- popVar(real_A_wbar) -real_A_c <- calcColonyGv(apiary, mapCasteToColonyGv, queenTrait = 1, workersTrait = 2, workersFUN = workersFUN) +real_A_c <- calcColonyGv(apiary, mapCasteToColonyGv, queenTrait = 1, workersTrait = 2, workersFUN = colSums) real_varA_c <- popVar(real_A_c) -real_P_wbar <- calcColonyPheno(apiary, mapCasteToColonyPheno, queenTrait = NULL, workersTrait = 2, workersFUN = workersFUN) + +real_P_q <- calcColonyPheno(apiary, mapCasteToColonyPheno, queenTrait = 1, workersTrait = NULL) +real_E_q <- real_P_q - real_A_q +real_varE_q <- popVar(real_E_q) +real_P_wbar <- calcColonyPheno(apiary, mapCasteToColonyPheno, queenTrait = NULL, workersTrait = 2, workersFUN = colSums) 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_P_c <- calcColonyPheno(apiary, mapCasteToColonyPheno, queenTrait = 1, workersTrait = 2, workersFUN = colSums) real_E_c <- real_P_c - real_A_c real_varE_c <- popVar(real_E_c) + +variances <- rbind(variances, data.frame(set_varA_q = varA_q, calc_varA_q = calc_var_c$varA_q, real_varA_q = varA_q, + set_varA_wbar = varA_wbar, calc_varA_wbar = calc_var_c$varA_wbar, real_varA_wbar = real_varA_wbar[1,1], + calc_varA_c = calc_var_c$varA_c, real_varA_c = real_varA_c, + set_varE_q = varE_q, calc_varE_q = calc_var_c$varE_q, real_varE_q = real_varE_q[1,1], + set_varE_wbar = varE_wbar, calc_varE_wbar = calc_var_c$varE_wbar, real_varE_wbar = real_varE_wbar[1,1], + calc_varE_c = calc_var_c$varE_c, real_varE_c = real_varE_c, + fun = "sum")) ``` + +Now plot. + +```{r plotMapColonyToIndFunction} +# Plot the variances from the two different ways of aggregating worker effects +variancesLong <- variances %>% + tidyr::pivot_longer(cols = -c(fun), names_to = "VarType", values_to = "Var") +variancesLong$Component <- sapply(strsplit(as.character(variancesLong$VarType), "_"), "[", 2) +variancesLong$RealCalc <- sapply(strsplit(as.character(variancesLong$VarType), "_"), "[", 1) +# Now extract the second and the third element and paste them together to get the type of variance for plotting +variancesLong$VarTypePlot <- paste0(sapply(strsplit(as.character(variancesLong$VarType), "_"), "[", 2), "_", sapply(strsplit(as.character(variancesLong$VarType), "_"), "[", 3)) +variancesLong$Measure <- sapply(strsplit(as.character(variancesLong$VarTypePlot), "_"), "[", 1) + +variancesLong$VarTypePlot <- factor(variancesLong$VarTypePlot, levels = c("varA_q", "varA_wbar", "varA_c", + "varE_q", "varE_wbar", "varE_c")) + + +variancesLong |> + ggplot(aes(x = VarTypePlot, y = Var, fill = RealCalc)) + + geom_col(position = "dodge") + + facet_wrap(. ~fun, scales = "free") + + theme_bw(base_size = 20) + + scale_fill_manual(values = c( + "#D55E00", # vermillion + "#084159", # blue + "#32c237", + "#b560b4", + "#a80805", # reddish purple + "grey", # bluish green + "black", "black", "black" + )) + + scale_alpha_manual(values = c(0.5, 1, 0.75), labels = c("Calculated", "Realised", "Set")) +``` \ No newline at end of file diff --git a/vignettes/H_Parallelisation.Rmd b/vignettes/H_Parallelisation.Rmd index 2f7cde27..5bb66379 100644 --- a/vignettes/H_Parallelisation.Rmd +++ b/vignettes/H_Parallelisation.Rmd @@ -3,7 +3,7 @@ title: "Parallelisation and high-performing cluster setup" date: "`r Sys.Date()`" output: rmarkdown::html_vignette vignette: > - %\VignetteIndexEntry{Multiple colonies} + %\VignetteIndexEntry{Parallelisation and high-performing cluster setup} %\VignetteEngine{knitr::rmarkdown} %\VignetteEncoding{UTF-8} editor_options: @@ -30,7 +30,7 @@ simulation. We do recommend reading the remaining of this vignette. library(SIMplyBee) library(future) -NCORES = # e.g., 8 +NCORES = 8 # # Use function plan to set up parallel environment # There are three options @@ -41,7 +41,7 @@ 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", ...)) +#plan(cluster, workers = c("machine1", "machine2", ...)) # At the end of everything you run to stop parallelisation back-end plan(sequential) @@ -92,13 +92,13 @@ 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) + founderGenomes <- quickHaplo(nInd = 20, 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 <- buildUp(baseColonies, nWorkers = 10, nDrones = 10) baseColonies <- supersede(baseColonies) baseColonies <- cross(baseColonies, drones = drones, crossPlan = "create") tmp = split(baseColonies) @@ -115,6 +115,7 @@ plan(sequential) create_bee_colonies() # Second one - use forking +nCores = 1 plan(multicore, workers = nCores) create_bee_colonies() @@ -129,7 +130,7 @@ 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 meanTime_figure, echo=FALSE, out.width='100%'} +```{r mean_time_figure, echo=FALSE, out.width='100%'} knitr::include_graphics("Time_mean.png") ``` diff --git a/vignettes/scripts/variance_functions.R b/vignettes/scripts/variance_functions.R new file mode 100644 index 00000000..ea99f1d8 --- /dev/null +++ b/vignettes/scripts/variance_functions.R @@ -0,0 +1,135 @@ +# Shared helper functions for variance calculations vignette + +# cor2cov: convert correlation matrix (or vector) and variances to covariance matrix +cor2cov <- function(corr, var) { + corr <- as.matrix(corr) + var <- as.numeric(var) + sd <- sqrt(var) + cov <- corr * (sd %o% sd) + return(cov) +} + +# mapIndToColonyVar: map individual-level variances/covariances to colony-level +mapIndToColonyVar <- function(varA_q, varA_w, corA_qw, + varE_q, varE_w, corE_qw, + nW, nF, nDPQ, workersFUN = "sum") { + + if (!workersFUN %in% c("sum", "mean")) { + stop("Invalid value for workersFUN. We currently only support either 'sum' or 'mean'.") + } + + # Pair counts + n_SS <- (nW * nW / nF) - nW + n_FS <- (nW * nW / nDPQ) - (nW * nW / nF) + n_HS <- (nW * nW / nDPQ) * (nDPQ - 1) + + 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 + + # 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)) +} + +# mapColonyToIndVar: map colony-level variance components back to individual-level +mapColonyToIndVar <- function(varA_q, + varA_wbar, + corA_qwbar, + varE_q, + varE_wbar, + corE_qwbar, + nW, + nF, + nDPQ, + workersFUN = "sum") { + + if (!workersFUN %in% c("sum", "mean")) { + stop("Invalid value for workersFUN. We currently only support either 'sum' or 'mean'.") + } + + covA_qwbar <- corA_qwbar * sqrt(varA_q) * sqrt(varA_wbar) + + if (workersFUN == "sum") { + covA_qw <- covA_qwbar / nW + } else if (workersFUN == "mean") { + covA_qw <- covA_qwbar + } + + n_SS <- (nW * nW / nF) - nW + n_FS <- (nW * nW / nDPQ) - (nW * nW / nF) + n_HS <- (nW * nW / nDPQ) * (nDPQ - 1) + + 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)) + + # 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)) +} From 1be1b392c14e37904f65c466c21310d7451f6d49 Mon Sep 17 00:00:00 2001 From: janaobsteter Date: Tue, 29 Sep 2026 16:07:16 +0100 Subject: [PATCH 61/98] Adding docs to pull --- DESCRIPTION | 2 +- man/MultiColony-class.Rd | 8 ++++---- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 0ff973df..0ce916f0 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), future.apply +Imports: methods, R6, stats, utils, extraDistr (>= 1.9.1), RANN, Rcpp (>= 0.12.7), future, future.apply Depends: R (>= 3.3.0), AlphaSimR (>= 2.0.0) LinkingTo: Rcpp, RcppArmadillo (>= 0.7.500.0.0), BH Suggests: 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) From 49d5c5e2a8d39c55eec8099064eed6ab3f1402b4 Mon Sep 17 00:00:00 2001 From: janaobsteter Date: Tue, 29 Sep 2026 15:18:03 +0000 Subject: [PATCH 62/98] Update documentation --- man/MultiColony-class.Rd | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/man/MultiColony-class.Rd b/man/MultiColony-class.Rd index 278bb739..6be082c7 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) From 6ab93675658a7010593b028a280b0e52cadcbf3c Mon Sep 17 00:00:00 2001 From: janaobsteter Date: Tue, 29 Sep 2026 15:27:18 +0000 Subject: [PATCH 63/98] Update documentation --- man/buildUp.Rd | 2 ++ 1 file changed, 2 insertions(+) diff --git a/man/buildUp.Rd b/man/buildUp.Rd index cdb28242..650d8169 100644 --- a/man/buildUp.Rd +++ b/man/buildUp.Rd @@ -114,3 +114,5 @@ nDrones(apiary) # Queen's counters getQueen(buildUp(colony))@misc + +} From cbe04aa314006452434f971fcd9e8a26f2475d05 Mon Sep 17 00:00:00 2001 From: janaobsteter Date: Tue, 29 Sep 2026 16:49:25 +0100 Subject: [PATCH 64/98] Updating NEWS.md --- NEWS.md | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/NEWS.md b/NEWS.md index 838297ad..14c85a70 100644 --- a/NEWS.md +++ b/NEWS.md @@ -22,6 +22,11 @@ editor_options: - createMultiColony() no longer creates an empty apiary, but it adds empty colonies with IDs +- we no longer support creating an exact number of workers with the csd functionality turned on. Due to inbreeding at the csd locus, some workers are not viable. Previous funcionality re-ran the creation of workers until a required number was available. We no longer support this, so we number of returned workers +is the number of viable workers. + +- the 'cross' function now removed unsuccessfully mated queens. This can primarily happen when creating a spatial cross plan. If there are no drone producing colonies in the specified radius, the mating fails and the queens/colonies are removed from the object. This is to ensure all further functionality works well. + ## New features - parallelised all the major functions (so they run on From b4d86469b3894fc898d3dc2c19f8abd73cf7f4c9 Mon Sep 17 00:00:00 2001 From: janaobsteter Date: Tue, 29 Sep 2026 16:50:35 +0100 Subject: [PATCH 65/98] Adding .gitignore --- .gitignore | 2 ++ 1 file changed, 2 insertions(+) diff --git a/.gitignore b/.gitignore index 0428c571..594c21e0 100644 --- a/.gitignore +++ b/.gitignore @@ -42,3 +42,5 @@ vignettes/*.pdf # Other .DS_Store +/doc/ +/Meta/ From c1a9b82375c3299d32710e0b4b9b1b202fbd6596 Mon Sep 17 00:00:00 2001 From: Gregor Gorjanc Date: Wed, 30 Sep 2026 10:36:00 +0100 Subject: [PATCH 66/98] WIP --- .Rbuildignore | 2 + .gitignore | 4 +- AGENTS.md | 186 ++++--- DESCRIPTION | 12 +- NAMESPACE | 37 +- NEWS.md | 16 +- R/Class-SimParamBee.R | 21 +- R/Functions_L0_auxilary.R | 612 +++++++++++++++-------- R/SIMplyBee.R | 5 + README.md | 2 +- inst/REFERENCES.bib | 285 +++++++++++ literature/README.md | 75 +++ man/MultiColony-class.Rd | 12 +- man/SIMplyBee-package.Rd | 5 +- man/SimParamBee.Rd | 535 ++++++++++---------- man/calcBeeGRMIbd.Rd | 24 +- man/calcBeeGRMIbs.Rd | 4 +- man/calcColonyAndIndCoefficients.Rd | 72 +++ man/calcInheritanceCriterion.Rd | 4 +- man/calcPerformanceCriterion.Rd | 4 +- man/calcSelectionCriterion.Rd | 4 +- man/cor2cov.Rd | 5 +- man/covVar2Cor.Rd | 24 + man/mapColonyToIndVar.Rd | 46 -- man/mapIndToColonyVar.Rd | 208 +++++++- man/mapLoci.Rd | 5 +- man/rcircle.Rd | 7 +- man/simulateHoneyBeeGenomes.Rd | 21 +- man/validateVarsAndCors.Rd | 23 + tests/testthat/test-variance-mapping.R | 104 ++++ vignettes/A_Honeybee_biology.Rmd | 16 +- vignettes/C_Colony_events.Rmd | 19 +- vignettes/E_Genomics.Rmd | 32 +- vignettes/F2_Variance_calculations.Rmd | 155 +++--- vignettes/F_Quantitative_Genetics.Rmd | 11 +- vignettes/colony_variance_theory_plan.md | 364 -------------- 36 files changed, 1735 insertions(+), 1226 deletions(-) create mode 100644 inst/REFERENCES.bib create mode 100644 literature/README.md create mode 100644 man/calcColonyAndIndCoefficients.Rd create mode 100644 man/covVar2Cor.Rd delete mode 100644 man/mapColonyToIndVar.Rd create mode 100644 man/validateVarsAndCors.Rd create mode 100644 tests/testthat/test-variance-mapping.R delete mode 100644 vignettes/colony_variance_theory_plan.md diff --git a/.Rbuildignore b/.Rbuildignore index 679a4f13..23c49595 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -25,3 +25,5 @@ ^Meta$ ^SIMplyBee\.Rproj +^literature$ +^dev$ diff --git a/.gitignore b/.gitignore index 4ef1b687..8bc7bb8a 100644 --- a/.gitignore +++ b/.gitignore @@ -44,5 +44,5 @@ vignettes/*.pdf .DS_Store /doc/ /Meta/ -src/*.o -src/*.so + +literature/*.pdf diff --git a/AGENTS.md b/AGENTS.md index fd44b0ac..9e849848 100644 --- a/AGENTS.md +++ b/AGENTS.md @@ -3,7 +3,10 @@ ## 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. +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 @@ -56,11 +59,11 @@ curl -I -sS --max-time 15 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. +* Run applicable formatting/lint checks described below and `git diff --check`. +* `Rscript -e "devtools::test()"` + for package tests. +* `Rscript -e "devtools::check()"` + for full package checks. * Updated `NEWS.md` for user-visible changes. ### Task-class quality gates @@ -70,7 +73,7 @@ A task is done when all applicable items below are completed: `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()`). + handoff (`devtools::test()` and `devtools::check()`, plus applicable lint checks). * If full checks are intentionally skipped, explicitly report what was skipped, why, and which focused checks were run. @@ -80,9 +83,13 @@ 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 +git worktree add ../SIMplyBee_wt_ -b origin/ ``` +Choose `` from the task or PR target. The README distinguishes +`main` (pre-CRAN stable work) from `devel` (development); do not assume `main` +is always the correct base. Reuse an existing task worktree when appropriate. + Within this workflow, follow these rules: * In the shared root worktree, limit edits to small docs/meta/config work. @@ -96,17 +103,19 @@ Within this workflow, follow these rules: ```sh git fetch origin --prune -git rebase origin/main +git rebase origin/ ``` -* If there are local uncommitted edits, use `--autostash` or an explicit stash. +* Inspect staged and unstaged changes first. Preserve existing work; do not + stash, rebase, or change branches in a shared dirty checkout as routine setup. * 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: +Remove a task worktree only once its work is preserved and it is clean; never +force removal to discard uncommitted work. After merge/finish: ```sh git worktree remove ../SIMplyBee_wt_ @@ -125,71 +134,30 @@ For issue exploration, closure recommendations, or "what is left to do?" tasks: ## Quality toolchain -These checks mirror `README.md` guidance and enforce package quality. - -### Pre-commit hooks - -Install once per clone: - -```sh -pre-commit install -``` +The checkout has `air.toml` and `jarl.toml`. -Run before committing: +Use Air and Jarl when installed, scoped to changed R files, for example: ```sh -pre-commit run --all-files +air format R/Functions_L0_auxilary.R +jarl check R/Functions_L0_auxilary.R +git diff --check ``` -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: +Avoid repository-wide formatting churn. Check tool help before using unfamiliar +flags. Report unavailable checks rather than silently installing or upgrading +tools. If a tool is missing from `PATH`, also check user-local bin directories: ```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)" +Rscript -e "cov <- covr::package_coverage(clean = TRUE); print(cov)" ``` ### GitHub Actions (CI) @@ -198,6 +166,12 @@ 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. +* `.github/workflows/document.yaml`: regenerates roxygen documentation on R-source + pushes and can commit the generated changes back to the branch. +* `.github/workflows/pkgdown.yaml`: builds the website and deploys on non-PR runs. + +Check each workflow's triggers before assuming it runs for a particular branch. +Regenerate documentation locally when needed and inspect its diff before handoff. Local work should pass local checks before relying on CI feedback. @@ -209,13 +183,16 @@ Do not edit generated files by hand: * `src/RcppExports.cpp` * `NAMESPACE` * Files in `man/` generated from roxygen comments +* Generated website output in `docs/`; edit its sources in `R/`, `vignettes/`, + `README.md`, and `_pkgdown.yml` instead Regenerate as needed: ```sh -Rscript -e "setwd('SIMplyBee'); Rcpp::compileAttributes()" -Rscript -e "setwd('SIMplyBee'); devtools::document()" +Rscript -e "Rcpp::compileAttributes()" +Rscript -e "devtools::document()" ``` + ## R CMD Check ### Preferred way to R CMD Check @@ -223,7 +200,7 @@ Rscript -e "setwd('SIMplyBee'); devtools::document()" Run faster package checks from the package directory: ```sh -Rscript -e "setwd('SIMplyBee'); devtools::check(vignette = FALSE)" +Rscript -e "devtools::check(vignette = FALSE)" ``` Run this for every code change so changes are evaluated in the same package context (build, docs, and tests). @@ -231,42 +208,25 @@ in the same package context (build, docs, and tests). Run slower package checks from the package directory: ```sh -Rscript -e "setwd('SIMplyBee'); devtools::check()" +Rscript -e "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. +### Check environment and reporting -### Quarto caveat (why it can work interactively but fail in agent runs) +A fast check with `vignette = FALSE` is an intermediate check, not a replacement +for the full check when vignettes or package behavior change. Vignettes use +knitr/rmarkdown; CI sets up Pandoc. Check R, compiler, Pandoc, and LaTeX +availability as relevant to the actual failure. Do not assume Quarto is required +or hard-code an IDE installation path. -`which quarto` can return `quarto not found`, -yet `devtools::check()` may still work -in interactive Positron/R sessions. +If compiler detection fails inside the sandbox, inspect the error first; it +may be a sandbox restriction rather than a missing compiler. Request escalated +execution when needed under the standing authorization above. -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. +At handoff, record commands run, errors/warnings/notes, and any skipped checks +with reasons. Compare failures with the unchanged base when needed to distinguish +existing problems from regressions. Never claim a check passes based on an older +run or assume a fixed expected result for this machine. ## Testing @@ -275,16 +235,42 @@ 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). +- Keep stochastic tests reproducible with explicit seeds and small populations. + Set `SP$nThreads <- 1L` where appropriate; pass `simParamBee = SP` explicitly + to avoid dependence on global state. Restore any global options or parallel + plans changed by a test. +- Prefer independently derived expectations, biological invariants, and small + enumerated cases over tests that repeat the implementation. For simulation + estimates, use tolerances justified by sampling error. +- Cover relevant haplodiploid, caste, empty-colony, and single/multiple-colony + cases when changing population or colony operations. +- Guard genuinely optional external dependencies with explicit skips; do not + hide failures in required package dependencies such as AlphaSimR. 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')`. + +- `Rscript -e "devtools::test()"` + for package tests, or a focused run such as + `Rscript -e "devtools::test(filter = 'L2_colony_functions')"`. Tests are also run as part of R CMD check. +## Research, examples, and references + +* Keep development plans and exploratory or standalone validation scripts in + `dev/`; consult `dev/README.md` and the relevant topic plan before continuing + existing research. Update that plan when completing planned work. +* Put automated regression tests in `tests/testthat/` and user tutorials in + `vignettes/`. Keep expensive simulation experiments out of routine tests. +* Check `.Rbuildignore` before assuming a vignette or development script runs + in package checks; validate excluded material explicitly when changing it. +* Keep scientific assumptions explicit, especially individual versus colony + quantities, sum versus mean worker effects, mating/worker allocation, + relatedness, and covariance conventions. Keep equations, code, and examples + consistent and cite sources for model changes. +* Use `inst/REFERENCES.bib` for package citations and `literature/README.md` for + the local literature archive. Verify references rather than inventing them. + ## Proofreading If asked to proofread, act as an expert proofreader and editor diff --git a/DESCRIPTION b/DESCRIPTION index d0f3ec44..36cfce13 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -5,11 +5,11 @@ 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")), - person("Laura", "Strachan", role = "aut", + person("Laura", "Strachan", role = "aut", comment = c(ORCID = "0000-0002-2569-0250")), - person("Jernej", "Bubnič", role = "aut", + person("Jernej", "Bubnič", role = "aut", comment = c(ORCID = "0000-0003-1362-3736")), - person("Gregor", "Gorjanc", role = c("aut"), + person("Gregor", "Gorjanc", role = c("aut"), comment = c(ORCID = "0000-0001-8008-2787"))) Description: An extension of the 'AlphaSimR' package () for stochastic simulations of @@ -26,10 +26,10 @@ 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), future, future.apply +Imports: methods, R6, stats, utils, extraDistr (>= 1.9.1), RANN, Rcpp (>= 0.12.7), Rdpack, future, future.apply Depends: R (>= 3.3.0), AlphaSimR (>= 2.0.0) LinkingTo: Rcpp, RcppArmadillo (>= 0.7.500.0.0), BH -Suggests: +Suggests: rmarkdown, knitr, ggplot2, @@ -39,3 +39,5 @@ Config/testthat/edition: 3 Config/Needs/website: tidyverse/tidytemplate VignetteBuilder: knitr Config/roxygen2/version: 8.1.0 +RdMacros: Rdpack +RoxygenNote: 7.3.3 diff --git a/NAMESPACE b/NAMESPACE index 94889270..3d4fa682 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -208,27 +208,24 @@ exportClasses(MultiColony) import(AlphaSimR) import(Rcpp) importFrom(R6,R6Class) +importFrom(Rdpack,reprompt) importFrom(extraDistr,rtpois) importFrom(future.apply,future_lapply) -importFrom(methods, - "slot<-", - classLabel, - is, - new, - setClass, - setClassUnion, - setMethod, - setValidity, - show, - slot, - validObject -) -importFrom(stats, - na.omit, - rbeta, - rnorm, - rpois, - runif -) +importFrom(methods,"slot<-") +importFrom(methods,classLabel) +importFrom(methods,is) +importFrom(methods,new) +importFrom(methods,setClass) +importFrom(methods,setClassUnion) +importFrom(methods,setMethod) +importFrom(methods,setValidity) +importFrom(methods,show) +importFrom(methods,slot) +importFrom(methods,validObject) +importFrom(stats,na.omit) +importFrom(stats,rbeta) +importFrom(stats,rnorm) +importFrom(stats,rpois) +importFrom(stats,runif) importFrom(utils,packageVersion) useDynLib(SIMplyBee, .registration = TRUE) diff --git a/NEWS.md b/NEWS.md index 156adda7..1d1b869c 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,6 +1,6 @@ --- -editor_options: - markdown: +editor_options: + markdown: wrap: 72 --- @@ -10,6 +10,9 @@ editor_options: ## Major changes +- Added mapIndToColonyVar() and mapColonyToIndVar() to map variance + components between individuals and colony in both ways. + - swarm/split/supersede do no longer store the year of the queen - colonies with high inbreeding that do not produce a viable virgin @@ -35,6 +38,11 @@ is the number of viable workers. 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 +## Other + +- Added a shared `inst/REFERENCES.bib` bibliography for package help and + vignettes. + ## Bug fixes @@ -81,10 +89,10 @@ which caused an error. We now read in the locations from a csv file. the colonies' locations, and in the cross() function, that crosses bees according to their location. This did not break the old functionality of the cross function. - + - Unified setMisc and getMisc behaviour to comply with the new AlphaSimR behaviour -- Added new C++ function isHeterozygous() to speed up the SIMplyBee function isCsdHeterozygous() +- Added new C++ function isHeterozygous() to speed up the SIMplyBee function isCsdHeterozygous() ## Bug fixes diff --git a/R/Class-SimParamBee.R b/R/Class-SimParamBee.R index 9e7130fc..5445dbb5 100644 --- a/R/Class-SimParamBee.R +++ b/R/Class-SimParamBee.R @@ -254,23 +254,10 @@ SimParamBee <- R6Class( #' @param colonyValueFUN see \code{\link[SIMplyBee]{SimParamBee}} field \code{colonyValueFUN} #' #' @references - #' Bovo et al. (2021) Application of Next Generation Semiconductor-Based - #' Sequencing for the Identification of Apis mellifera Complementary Sex - #' Determiner (csd) Alleles from Honey DNA. Insects, 12(10), 868. - #' \doi{10.3390/insects12100868} - #' - #' Lechner et al. (2014) Nucleotide variability at its limit? Insights into - #' the number and evolutionary dynamics of the sex-determining specificities - #' of the honey bee Apis mellifera Molecular Biology and Evolution, 31, - #' 272-287. \doi{10.1093/molbev/mst207} - #' - #' Seeley (2019) The Lives of Bees: The Untold Story of the Honey - #' Bee in the Wild. Princeton: Princeton University Press. - #' \doi{10.1515/9780691189383} - #' - #' Zareba et al. (2017) Uneven distribution of complementary sex determiner - #' (csd) alleles in Apis mellifera population. Scientific Reports, 7, 2317. - #' \doi{10.1038/s41598-017-02629-9} + #' \insertRef{bovo2021Application}{SIMplyBee} + #' \insertRef{lechner2014Nucleotide}{SIMplyBee} + #' \insertRef{seeley2019Lives}{SIMplyBee} + #' \insertRef{zareba2017Uneven}{SIMplyBee} #' #' @examples #' founderGenomes <- quickHaplo(nInd = 10, nChr = 3, segSites = 10) diff --git a/R/Functions_L0_auxilary.R b/R/Functions_L0_auxilary.R index d0bf6cd8..96906a1a 100644 --- a/R/Functions_L0_auxilary.R +++ b/R/Functions_L0_auxilary.R @@ -1449,11 +1449,8 @@ getLocation <- function(x, collapse = FALSE) { #' @return matrix with two columns for the x and y coordinates of the points. #' #' @references -#' nubDotDev (2021) The BEST Way to Find a Random Point in a Circle -#' https://youtu.be/4y_nmpv-9lI -#' -#' Wolfram MathWorld (2023) Disk Point Picking -#' https://mathworld.wolfram.com/DiskPointPicking.html +#' \insertRef{nubdotdev2021Best}{SIMplyBee} +#' \insertRef{wolfram2023Disk}{SIMplyBee} #' #' @examples #' x <- rcircle(n = 500) @@ -1821,23 +1818,10 @@ isProductive <- function(x) { #' @return \code{\link[AlphaSimR]{MapPop-class}} #' #' @references -#' Wallberg, A., Bunikis, I., Pettersson, O.V. et al. -#' A hybrid de novo genome assembly of the honeybee, Apis mellifera, -#' with chromosome-length scaffolds. 2019, BMC Genomics 20:275. -#' \doi{10.1186/s12864-019-5642-0} -#' -#' Beye M, Gattermeier I, Hasselmann M, et al. Exceptionally high levels -#' of recombination across the honey bee genome. -#' 2006, Genome Res 16(11):1339-1344. \doi{10.1101/gr.5680406} -#' -#' Wallberg, A., Han, F., Wellhagen, G. et al. A worldwide survey of -#' genome sequence variation provides insight into the evolutionary -#' history of the honeybee Apis mellifera. -#' 2014, Nat Genet 46:1081–1088. \doi{10.1038/ng.3077} -#' -#' Yang S, Wang L, Huang J, Zhang X, Yuan Y, Chen JQ, Hurst LD, Tian D. -#' Parent-progeny sequencing indicates higher mutation rates in heterozygotes. -#' 2015, Nature 523(7561):463-7. \doi{10.1038/nature14649}. +#' \insertRef{beye2006Exceptionally}{SIMplyBee} +#' \insertRef{yang2015Parent}{SIMplyBee} +#' \insertRef{wallberg2014Worldwide}{SIMplyBee} +#' \insertRef{wallberg2019Hybrid}{SIMplyBee} #' #' @seealso Due to the computational time and resources required to run this function, #' we do not include an example here, but we demonstrate @@ -4593,9 +4577,8 @@ getPooledGeno <- function(x, type = "mean", sex = NULL) { #' scaling factor used to scale the crossproduct of centred genotype matrix #' to get the GRM. #' -#' @references Druet and Legarra (2020) Theoretical and empirical comparisons of -#' expected and realized relationships for the X-chromosome. Genetics -#' Selection Evolution, 52:50 \doi{10.1186/s12711-020-00570-6} +#' @references +#' \insertRef{druet2020Theoretical}{SIMplyBee} #' #' @examples #' founderGenomes <- quickHaplo(nInd = 3, nChr = 1, segSites = 100) @@ -4742,25 +4725,11 @@ calcBeeAlleleFreq <- function(x, sex) { #' a matrix of individual relatedness coefficients (indiv) #' #' @references -#' Grossman and Eisen (1989) Inbreeding, coancestry, and covariance between -#' relatives for X-chromosomal loci. The Journal of Heredity, -#' \doi{10.1093/oxfordjournals.jhered.a110812} -#' -#' Fernando and Grossman (1989) Covariance between relatives for X-chromosomal -#' loci in a population in disequilibrium. Theoretical and Applied Genetics, -#' \doi{10.1007/bf00305821} -#' -#' Fernando and Grossman (1990) Genetic evaluation with autosomal -#' and X-chromosomal inheritance. Theoretical and Applied Genetics, -#' \doi{10.1007/bf00224018} -#' -#' Van Arendonk, Tier, and Kinghorn (1994) Use of multiple genetic markers in -#' prediction of breeding values. Genetics, -#' \doi{10.1093/genetics/137.1.319} -#' -#' Hill and Weir (2011) Variation in actual relationship as a consequence of -#' Mendelian sampling and linkage. Genetics Research, -#' \doi{10.1017/s0016672310000480} +#' \insertRef{fernando1989Covariance}{SIMplyBee} +#' \insertRef{fernando1990Genetic}{SIMplyBee} +#' \insertRef{grossman1989Inbreeding}{SIMplyBee} +#' \insertRef{hill2011Variation}{SIMplyBee} +#' \insertRef{vanarendonk1994Use}{SIMplyBee} #' #' @examples #' founderGenomes <- quickHaplo(nInd = 3, nChr = 1, segSites = 100) @@ -5200,9 +5169,7 @@ calcColonyPheno <- function(x, FUN = mapCasteToColonyPheno, simParamBee = NULL, #' \code{vignette(topic = "QuantitativeGenetics", package = "SIMplyBee")} #' #' @references -#' Du, M., et al. (2021) Short-term effects of controlled mating and selection -#' on the genetic variance of honeybee populations. Heredity 126, 733–747. -#' \doi{10.1038/s41437-021-00411-2} +#' \insertRef{du2021Short}{SIMplyBee} #' #' @examples #' founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) @@ -5318,9 +5285,7 @@ calcInheritanceCriterion <- function(x, queenTrait = 1, workersTrait = 2, use = #' \code{\link[SIMplyBee]{MultiColony-class}}, where names are colony IDs #' #' @references -#' Du, M., et al. (2021) Short-term effects of controlled mating and selection -#' on the genetic variance of honeybee populations. Heredity 126, 733–747. -#' \doi{10.1038/s41437-021-00411-2} +#' \insertRef{du2021Short}{SIMplyBee} #' #' @examples #' founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) @@ -5440,9 +5405,7 @@ calcPerformanceCriterion <- function(x, queenTrait = 1, workersTrait = 2, #' \code{\link[SIMplyBee]{MultiColony-class}}, where names are colony IDs #' #' @references -#' Du, M., et al. (2021) Short-term effects of controlled mating and selection -#' on the genetic variance of honeybee populations. Heredity 126, 733–747. -#' \doi{10.1038/s41437-021-00411-2} +#' \insertRef{du2021Short}{SIMplyBee} #' #' @examples #' founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) @@ -6445,7 +6408,9 @@ createCrossPlan <- function(x, #' @title Finds loci on a genetic map and return a list of positions #' #' @description Finds loci on a genetic map and return a list of positions. -#' This function is adopted from AlphaSimR (Gaynor et al., 2021) +#' This function is adopted from AlphaSimR (Gaynor et al., 2021). +#' @references +#' \insertRef{gaynor2021AlphaSimR}{SIMplyBee} #' #' @param markers character, vector of marker positions as "chr_position" #' @param genMap list, genetic map @@ -6484,7 +6449,9 @@ mapLoci = function(markers, genMap){ #' @title Convert correlation matrix to covariance matrix #' #' @description Convert correlation matrix to covariance matrix -#' This function is adopted from AlphaSimR (Gaynor et al., 2021) +#' This function is adopted from AlphaSimR (Gaynor et al., 2021). +#' @references +#' \insertRef{gaynor2021AlphaSimR}{SIMplyBee} #' #' @param corr correlation matrix #' @param var vector of variances @@ -6497,163 +6464,408 @@ cor2cov <- function(corr, var) { return(cov) } -#' @rdname mapIndToColonyVar -#' @title Map individual-level variance components to colony-level variance components -#' -#' @description Map individual-level variance components to colony-level variance components -#' -#' @param varA_q numeric, additive genetic variance of the queen -#' @param varA_w numeric, additive genetic variance of the workers -#' @param corA_qw numeric, correlation between queen and workers -#' @param varE_q numeric, environmental variance of the queen -#' @param varE_w numeric, environmental variance of the workers -#' @param corE_qw numeric, correlation between queen and workers -#' @param nW numeric, number of workers in the colony -#' @param nF numeric, number of fathers of the workers -#' @param nDPQ numeric, number of drone producing queens in the colony -#' @param workersFUN character, either "sum" or "mean", indicating whether the workers' contributions are summed or averaged -#' -#' @return list with colony-level variance components -#' -#' @export -mapIndToColonyVar <- function(varA_q, varA_w, corA_qw, - varE_q, varE_w, corE_qw, - nW, nF, nDPQ, workersFUN = "sum") { - - if (!workersFUN %in% c("sum", "mean")) { - stop("Invalid value for workersFUN. We currently only support either 'sum' or 'mean'.") +#' Calculate coefficients to map across individual and colony variances +#' +#' Calculate the coefficients used to map variances in a fixed colony design. +#' Forward mappings in \code{mapIndToColonyVar} multiply individual components. +#' Inverse mappings in \code{mapColonyToIndVar} divide aggregate components. +#' +#' @param nW Positive integer scalar, number of workers in the colony. +#' @param nF Positive integer scalar, number of distinct mating fathers available +#' to sire workers. With random allocation, some fathers may sire no workers. +#' @param nDPQ Positive integer scalar, number of distinct drone-producing queens +#' (DPQs) represented among the mating fathers. Equal numbers of fathers per +#' DPQ are assumed; nF must be divisible by nDPQ. +#' @param workersFUN Character scalar, "sum" or "mean", specifying aggregation +#' of the workers' worker-effect trait values. +#' @param workerAllocation Character scalar, "random" for independent uniform +#' sampling of a father for each worker, or "balanced" for exactly nW/nF +#' workers per father. Balanced allocation requires nW divisible by nF. +#' +#' @return A list of three coefficients: +#' \itemize{ +#' \item \code{worker}: multiplier converting individual worker-effect additive +#' genetic variance to variance of the worker-group sum or mean. +#' \item \code{queenWorker}: multiplier converting within-individual genetic +#' covariance between queen-effect and worker-effect traits to covariance +#' between the colony queen's queen-effect contribution and the worker-group +#' worker-effect contribution. This coefficient does not include the factor +#' of two used when calculating total colony variance. +#' \item \code{environment}: multiplier converting individual worker-effect +#' environmental variance to variance of the worker-group sum or mean, +#' assuming environmental deviations are independent between workers. +#' } +#' +#' @details The model assumes non-inbred colony queens and DPQs, mutually +#' unrelated across those parents. Distinct fathers from the same DPQ may be +#' brothers. The queen-effect variance multiplier is one and is not returned. +#' +#' Let w be 1 for sums or 1/nW for means. +#' Ordered distinct-worker pairs are partitioned into +#' same father giving super-sisters with additive relationship of 3/4, +#' distinct fathers from the same DPQ giving full-sisters with additive relationship of 1/2, and +#' different DPQs giving half-sisters with additive relationship of 1/4. +#' The worker coefficient is w^2 * (nW + relationship-weighted pair counts). +#' Random allocation uses expected pair counts; +#' balanced allocation uses exact pair counts. +#' The queenWorker coefficient is nW*w/2, and +#' the environment coefficient is nW*w^2. +#' +#' Divisibility checks establish that the assumed equal allocation is possible; +#' totals alone cannot verify actual family composition. +#' These coefficients describe marginal colony components, +#' not sample variances across colonies sharing relatives. +#' Unequal contributions, general ancestry, and random colony sizes +#' require a more general model. +#' @seealso \code{\link{mapIndToColonyVar}}, \code{\link{mapColonyToIndVar}} +#' @keywords internal +calcColonyAndIndCoefficients <- function(nW, nF, nDPQ, workersFUN, + workerAllocation) { + for (name in c("nW", "nF", "nDPQ")) { + value <- get(name) + if (!is.numeric(value) || length(value) != 1L || !is.finite(value) || + value < 1 || value != floor(value)) { + stop(name, " must be a positive integer scalar.") + } } - - # Pair counts - n_SS <- (nW * nW / nF) - nW - n_FS <- (nW * nW / nDPQ) - (nW * nW / nF) - n_HS <- (nW * nW / nDPQ) * (nDPQ - 1) - - if (workersFUN == "mean") { - B1 = 1 / nW * varA_w - } else if (workersFUN == "sum") { - B1 = nW * varA_w + if (length(workersFUN) != 1L || is.na(workersFUN) || + !workersFUN %in% c("sum", "mean")) { + stop("workersFUN must be 'sum' or 'mean'.") } - - 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 + if (length(workerAllocation) != 1L || is.na(workerAllocation) || + !workerAllocation %in% c("random", "balanced")) { + stop("workerAllocation must be 'random' or 'balanced'.") } - - 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 + # Equal father counts per DPQ are assumed. + # Check that the supplied totals permit that allocation. + if (nF %% nDPQ != 0) { + stop("Equal fathers per DPQ requires nF divisible by nDPQ.") } - corA_qwbar <- covA_qwbar / (sqrt(varA_q) * sqrt(varA_wbar)) - - varA_c <- varA_q + varA_wbar + 2*covA_qwbar - - # Environmental part - if (workersFUN == "mean") { - varE_wbar = 1 / nW * varE_w - } else if (workersFUN == "sum") { - varE_wbar = nW * varE_w + if (workerAllocation == "balanced") { + if (nW %% nF != 0) { + stop("Balanced worker allocation requires nW divisible by nF.") + } + sameFather <- nW^2 / nF - nW + sameDPQ <- nW^2 / nDPQ - nW^2 / nF + differentDPQ <- nW^2 * (1 - 1 / nDPQ) + } else { + sameFather <- nW * (nW - 1) / nF + sameDPQ <- nW * (nW - 1) * (1 / nDPQ - 1 / nF) + differentDPQ <- nW * (nW - 1) * (1 - 1 / nDPQ) + } + weight <- if (workersFUN == "mean") 1 / nW else 1 + list(worker = weight^2 * (nW + 0.75 * sameFather + + 0.5 * sameDPQ + 0.25 * differentDPQ), + queenWorker = nW * weight / 2, + environment = nW * weight^2) +} + +#' Validate variance and correlation inputs +#' +#' Check named collections of scalar variance and correlation parameters used +#' by the individual/colony variance mappings. Invalid inputs raise an error. +#' +#' @param variances Named list of numeric, finite, nonnegative variance scalars. +#' @param correlations Named list of numeric, finite correlation scalars in +#' the interval [-1, 1]. +#' @return Invisibly returns \code{NULL} when all checked inputs are valid; +#' otherwise stops with an error. +#' @keywords internal +validateVarsAndCors <- function(variances, correlations) { + for (name in names(variances)) { + value <- variances[[name]] + if (!is.numeric(value) || length(value) != 1L || !is.finite(value) || value < 0) { + stop(name, " must be a finite nonnegative scalar.") + } } - - 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 + for (name in names(correlations)) { + value <- correlations[[name]] + if (!is.numeric(value) || length(value) != 1L || !is.finite(value) || + abs(value) > 1) { + stop(name, " must be a finite correlation in [-1, 1].") + } } - 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)) } -#' @rdname mapColonyToIndVar -#' @title Map colony-level variance components to individual-level variance components +#' Stable conversion of a covariance and two variances to a correlation #' -#' @description Map colony-level variance components to individual-level variance components +#' Divide a covariance by the product of the corresponding standard deviations, +#' but return \code{NA} when either variance (standard deviation) are zero. #' -#' @param varA_q numeric, additive genetic variance of the queen -#' @param varA_wbar numeric, additive genetic variance of the average worker -#' @param corA_qwbar numeric, correlation between queen and average worker -#' @param varE_q numeric, environmental variance of the queen -#' @param varE_wbar numeric, environmental variance of the average worker -#' @param corE_qwbar numeric, correlation between queen and average worker +#' @param covariance Numeric scalar covariance between the two variables. +#' @param variance1 Numeric scalar variance of the first variable. +#' @param variance2 Numeric scalar variance of the second variable. +#' @return Numeric scalar correlation, or \code{NA_real_} +#' if either variance is zero and the correlation is therefore undefined. +#' @keywords internal +covVar2Cor <- function(covariance, variance1, variance2) { + if (variance1 == 0 || variance2 == 0) return(NA_real_) + covariance / (sqrt(variance1) * sqrt(variance2)) +} + +#' @rdname mapIndToColonyVar +#' @title Map variance components between individuals and colonies +#' +#' @description Map individual queen-effect and worker-effect variance components +#' to colony variance components, or recover individual variance components from +#' separate queen and worker-group colony variance components. +#' +#' @param varAQueen Numeric scalar, additive genetic variance of +#' the queen-effect trait among individual diploid bees in a base population. +#' @param varAWorker Numeric scalar, additive genetic variance of +#' the worker-effect trait among individual diploid bees in a base population. +#' @param corAQueenWorker Numeric scalar, additive genetic correlation between +#' the queen-effect trait and the worker-effect trait +#' among individual diploid bees in a base population. +#' This is the within-individual cross-trait correlation among individuals. +#' @param varEQueen Numeric scalar, environmental variance of +#' the queen-effect trait among individual bees in a base population. +#' @param varEWorker Numeric scalar, environmental variance of +#' the worker-effect trait among individual bees in a base population. +#' @param corEQueenWorker Numeric scalar, environmental correlation between +#' the queen-effect trait and the worker-effect trait +#' among individual diploid bees in a base population. +#' This is the within-individual cross-trait correlation among individuals. +#' @param varAWorkerGroup Numeric scalar, additive genetic variance of +#' the aggregated worker-effect trait among colonies in a base population. +#' @param corAQueenWorkerGroup Numeric scalar, additive genetic correlation between +#' the queen's queen-effect trait and +#' the aggregated workers' worker-effect trait +#' among colonies in a base population. +#' This is the cross-caste and cross-trait correlation among colonies. +#' @param varEWorkerGroup Numeric scalar, environmental variance of +#' the aggregated worker-effect trait among colonies in a base population. +#' @param corEQueenWorkerGroup Numeric scalar, environmental correlation between +#' the queen's queen-effect trait and +#' the aggregated workers' worker-effect trait +#' among colonies in a base population. +#' This is the cross-caste and cross-trait correlation among colonies. #' @param nW numeric, number of workers in the colony #' @param nF numeric, number of fathers of the workers -#' @param nDPQ numeric, number of drone producing queens in the colony -#' @param workersFUN character, either "sum" or "mean", indicating whether the workers' contributions are summed or averaged +#' @param nDPQ numeric, number of drone producing queens (DPQs) +#' represented among the mating fathers +#' @param workersFUN character, either "sum" or "mean", +#' indicating whether the workers' contributions are summed or averaged +#' when forming the aggregated worker-effect contribution to colony value. +#' @param workerAllocation character, either "random" (default) or "balanced". +#' +#' @return Both functions return a flat list with the same named components. +#' +#' \strong{Components already described as inputs} +#' All components listed below are returned by both functions; the function +#' labels indicate which inputs they correspond to. +#' \itemize{ +#' \item Both functions: \code{varAQueen}, \code{varEQueen}, \code{nW}, +#' \code{nF}, \code{nDPQ}, \code{workersFUN}, and \code{workerAllocation}. +#' \item \code{mapIndToColonyVar}: \code{varAWorker}, \code{varEWorker}, +#' \code{corAQueenWorker}, and \code{corEQueenWorker}. +#' \item \code{mapColonyToIndVar}: \code{varAWorkerGroup}, +#' \code{varEWorkerGroup}, \code{corAQueenWorkerGroup}, and +#' \code{corEQueenWorkerGroup}. The returned group correlations are +#' \code{NA} if either corresponding variance is zero, even if zero +#' was supplied as the correlation. +#' } +#' +#' \strong{Additional components} +#' \itemize{ +#' \item \code{covAQueenWorker}: additive genetic covariance between +#' the queen-effect trait and the worker-effect trait +#' among individual diploid bees in a base population. +#' \item \code{covAQueenWorkerGroup}: additive genetic covariance between +#' the queen's queen-effect trait and +#' the aggregated workers' worker-effect trait +#' among colonies in a base population. +#' \item \code{covEQueenWorker}: environmental covariance between +#' the queen-effect trait and the worker-effect trait +#' among individual diploid bees in a base population. +#' \item \code{covEQueenWorkerGroup}: environmental covariance between +#' the queen's queen-effect trait and +#' the aggregated workers' worker-effect trait +#' among colonies in a base population. +#' Zero under the assumption of independent environmental deviations between bees. +#' \item \code{varAColony} and \code{varEColony}: additive genetic +#' and environmental variance of colony values. +#' Each is the sum of the queen and worker-group variances plus twice their covariance. +#' } +#' +#' Covariances are not multiplied by two. +#' Calculated correlations are \code{NA} if either corresponding variance is zero. +#' In \code{mapColonyToIndVar}, \code{covEQueenWorker} and \code{corEQueenWorker} +#' are both returned as \code{NA}, +#' because colony components do not identify +#' within-individual environmental covariance or correlation. +#' +#' @details These mappings describe marginal variances under an additive model +#' with non-inbred, mutually unrelated colony queens and drone-producing +#' queens (DPQs), distinct fathers, and equal numbers of fathers per DPQ. +#' They do not predict sample variance across colonies sharing relatives. +#' Each diploid bee has genetic values for both the queen-effect and +#' worker-effect traits. A colony value combines the queen's value for the +#' queen-effect trait with the aggregated workers' values for the +#' worker-effect trait. Thus Queen and Worker identify trait roles as well as +#' their expressing castes; WorkerGroup always denotes an aggregate. +#' +#' With random worker allocation, +#' each worker independently samples a father uniformly. +#' With balanced allocation, +#' each father has exactly \code{nW/nF} workers, +#' which requires \code{nW} to be divisible by \code{nF}. +#' Both require \code{nF} divisible by \code{nDPQ}. +#' The distinct-worker relationship is 3/4 for a shared father, +#' 1/2 for distinct fathers from the same DPQ, and 1/4 otherwise. +#' Queen-offspring relationship is 1/2. +#' Environmental deviations are independent between bees. +#' Calculated correlations are \code{NA} when either variance is zero; +#' individual correlations supplied to the forward mapping are retained. +#' +#' The inverse divides worker-group variances and queen-worker-group +#' covariance by the corresponding design coefficients. +#' Both directions must use the same colony design and aggregation. +#' A nonzero \code{corEQueenWorkerGroup} raises an error, +#' as do colony components implying an individual genetic correlation outside [-1, 1]. +#' If either genetic component variance is zero, +#' the inverse accepts \code{NA} or zero for \code{corAQueenWorkerGroup}. +#' Similarly, \code{NA} or zero can be supplied for \code{corEQueenWorkerGroup} +#' when either environmental component variance is zero. +#' The zero-correlation restriction between bees does not apply to \code{corEQueenWorker}, +#' which describes environmental association between traits within the same bee. +#' +#' Both results are flat lists. To pass a result to either mapping function, +#' select the entries named in \code{names(formals(fun))} before using +#' \code{do.call(fun, ...)}; the full result contains extra components. +#' Before mapping an inverse result forward, supply an explicit +#' \code{corEQueenWorker}, which the inverse cannot identify. #' -#' @return list with individual-level variance components +#' @references +#' \insertRef{brascamp2014Methods}{SIMplyBee} +#' \insertRef{brascamp2019Note}{SIMplyBee} #' -#' @export -mapColonyToIndVar <- function(varA_q, - varA_wbar, - corA_qwbar, - varE_q, - varE_wbar, - corE_qwbar, - nW, - nF, - nDPQ, - workersFUN = "sum") { - - if (!workersFUN %in% c("sum", "mean")) { - stop("Invalid value for workersFUN. We currently only support either 'sum' or 'mean'.") - } - - covA_qwbar <- corA_qwbar * sqrt(varA_q) * sqrt(varA_wbar) - - if (workersFUN == "sum") { - covA_qw <- covA_qwbar / nW - } else if (workersFUN == "mean") { - covA_qw <- covA_qwbar - } - - n_SS <- (nW * nW / nF) - nW - n_FS <- (nW * nW / nDPQ) - (nW * nW / nF) - n_HS <- (nW * nW / nDPQ) * (nDPQ - 1) - - 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)) - - # 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)) +#' @examples +#' nW <- 100 +#' nF <- 15 +#' nDPQ <- 5 +#' +#' # Mapping individual vars to colony with worker group mean +#' (colonyVars <- mapIndToColonyVar( +#' varAQueen = 1, varAWorker = 1, corAQueenWorker = -0.5, +#' varEQueen = 1, varEWorker = 1, corEQueenWorker = 0, +#' nW = nW, nF = nF, nDPQ = nDPQ, workersFUN = "mean")) +#' # ... and inverse +#' (indVars <- do.call(mapColonyToIndVar, +#' colonyVars[names(formals(mapColonyToIndVar))])) +#' +#' # Mapping colony vars with worker group sum to individual vars +#' (indVars <- mapColonyToIndVar( +#' varAQueen = 1, varAWorkerGroup = 1, corAQueenWorkerGroup = -0.5, +#' varEQueen = 1, varEWorkerGroup = 1, corEQueenWorkerGroup = 0, +#' nW = nW, nF = nF, nDPQ = nDPQ, workersFUN = "sum")) +#' # ... and back to colony components, assuming zero within-bee +#' # environmental correlation (not identified by the inverse mapping). +#' indArgs <- indVars[names(formals(mapIndToColonyVar))] +#' indArgs$corEQueenWorker <- 0 +#' (colonyVars <- do.call(mapIndToColonyVar, indArgs)) +#' @export +mapIndToColonyVar <- function(varAQueen, varAWorker, corAQueenWorker, + varEQueen, varEWorker, corEQueenWorker, + nW, nF, nDPQ, workersFUN = "sum", + workerAllocation = "random") { + validateVarsAndCors(list(varAQueen = varAQueen, varAWorker = varAWorker, + varEQueen = varEQueen, varEWorker = varEWorker), + list(corAQueenWorker = corAQueenWorker, corEQueenWorker = corEQueenWorker)) + k <- calcColonyAndIndCoefficients(nW, nF, nDPQ, workersFUN, workerAllocation) + varAWorkerGroup <- k$worker * varAWorker + covAQueenWorkerGroup <- k$queenWorker * corAQueenWorker * sqrt(varAQueen) * sqrt(varAWorker) + corAQueenWorkerGroup <- covVar2Cor(covAQueenWorkerGroup, varAQueen, varAWorkerGroup) + varAColony <- varAQueen + varAWorkerGroup + 2 * covAQueenWorkerGroup + varEWorkerGroup <- k$environment * varEWorker + covEQueenWorkerGroup <- 0 + # Correlation is zero unless either variance is zero, when it is undefined. + corEQueenWorkerGroup <- covVar2Cor(covEQueenWorkerGroup, varEQueen, varEWorkerGroup) + varEColony <- varEQueen + varEWorkerGroup + covAQueenWorker <- corAQueenWorker * sqrt(varAQueen) * sqrt(varAWorker) + covEQueenWorker <- corEQueenWorker * sqrt(varEQueen) * sqrt(varEWorker) + list( + varAQueen = varAQueen, + varAWorker = varAWorker, + covAQueenWorker = covAQueenWorker, + corAQueenWorker = corAQueenWorker, + varAWorkerGroup = varAWorkerGroup, + covAQueenWorkerGroup = covAQueenWorkerGroup, + corAQueenWorkerGroup = corAQueenWorkerGroup, + varAColony = varAColony, + varEQueen = varEQueen, + varEWorker = varEWorker, + covEQueenWorker = covEQueenWorker, + corEQueenWorker = corEQueenWorker, + varEWorkerGroup = varEWorkerGroup, + covEQueenWorkerGroup = covEQueenWorkerGroup, + corEQueenWorkerGroup = corEQueenWorkerGroup, + varEColony = varEColony, + nW = nW, + nF = nF, + nDPQ = nDPQ, + workersFUN = workersFUN, + workerAllocation = workerAllocation + ) +} - 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)) -} \ No newline at end of file +#' @describeIn mapIndToColonyVar Recover individual variance components from +#' separate queen and worker-group colony components. +#' @export +mapColonyToIndVar <- function(varAQueen, varAWorkerGroup, corAQueenWorkerGroup, + varEQueen, varEWorkerGroup, corEQueenWorkerGroup, + nW, nF, nDPQ, workersFUN = "sum", + workerAllocation = "random") { + # A correlation is undefined if either component has zero variance + if (length(corAQueenWorkerGroup) == 1L && is.na(corAQueenWorkerGroup) && + (isTRUE(varAQueen == 0) || isTRUE(varAWorkerGroup == 0))) corAQueenWorkerGroup <- 0 + if (length(corEQueenWorkerGroup) == 1L && is.na(corEQueenWorkerGroup) && + (isTRUE(varEQueen == 0) || isTRUE(varEWorkerGroup == 0))) corEQueenWorkerGroup <- 0 + validateVarsAndCors(list(varAQueen = varAQueen, varAWorkerGroup = varAWorkerGroup, + varEQueen = varEQueen, varEWorkerGroup = varEWorkerGroup), + list(corAQueenWorkerGroup = corAQueenWorkerGroup, corEQueenWorkerGroup = corEQueenWorkerGroup)) + if (corEQueenWorkerGroup != 0) { + stop("Nonzero corEQueenWorkerGroup requires a shared environment model; environments are assumed independent between bees.") + } + k <- calcColonyAndIndCoefficients(nW, nF, nDPQ, workersFUN, workerAllocation) + varAWorker <- varAWorkerGroup / k$worker + covAQueenWorkerGroup <- corAQueenWorkerGroup * sqrt(varAQueen) * sqrt(varAWorkerGroup) + covAQueenWorker <- covAQueenWorkerGroup / k$queenWorker + corAQueenWorker <- covVar2Cor(covAQueenWorker, varAQueen, varAWorker) + if (!is.na(corAQueenWorker) && abs(corAQueenWorker) > 1 + 1e-10) { + stop("Colony genetic components imply an infeasible individual correlation outside [-1, 1].") + } + if (!is.na(corAQueenWorker)) corAQueenWorker <- max(-1, min(1, corAQueenWorker)) + varEWorker <- varEWorkerGroup / k$environment + corAQueenWorkerGroup <- covVar2Cor(covAQueenWorkerGroup, varAQueen, varAWorkerGroup) + covEQueenWorkerGroup <- 0 + # Correlation is zero unless either variance is zero, when it is undefined. + corEQueenWorkerGroup <- covVar2Cor(covEQueenWorkerGroup, varEQueen, varEWorkerGroup) + varAColony <- varAQueen + varAWorkerGroup + 2 * covAQueenWorkerGroup + varEColony <- varEQueen + varEWorkerGroup + covEQueenWorker <- NA_real_ + corEQueenWorker <- NA_real_ + list( + varAQueen = varAQueen, + varAWorker = varAWorker, + covAQueenWorker = covAQueenWorker, + corAQueenWorker = corAQueenWorker, + varAWorkerGroup = varAWorkerGroup, + covAQueenWorkerGroup = covAQueenWorkerGroup, + corAQueenWorkerGroup = corAQueenWorkerGroup, + varAColony = varAColony, + varEQueen = varEQueen, + varEWorker = varEWorker, + covEQueenWorker = covEQueenWorker, + corEQueenWorker = corEQueenWorker, + varEWorkerGroup = varEWorkerGroup, + covEQueenWorkerGroup = covEQueenWorkerGroup, + corEQueenWorkerGroup = corEQueenWorkerGroup, + varEColony = varEColony, + nW = nW, + nF = nF, + nDPQ = nDPQ, + workersFUN = workersFUN, + workerAllocation = workerAllocation + ) +} diff --git a/R/SIMplyBee.R b/R/SIMplyBee.R index c138b5da..0215d08f 100644 --- a/R/SIMplyBee.R +++ b/R/SIMplyBee.R @@ -1,5 +1,6 @@ #' @useDynLib SIMplyBee, .registration = TRUE #' @import Rcpp +#' @importFrom Rdpack reprompt #' @import AlphaSimR #' @importFrom methods classLabel is new setClass setClassUnion setValidity #' @importFrom methods setMethod show slot slot<- validObject @@ -26,5 +27,9 @@ #' See the introductory vignette on using this package by running: #' \code{vignette("Honeybee_biology", package="SIMplyBee")} #' +#' @references +#' \insertRef{obsteter2023SIMplyBee}{SIMplyBee} +#' \insertRef{gaynor2021AlphaSimR}{SIMplyBee} +#' #' @keywords internal "_PACKAGE" diff --git a/README.md b/README.md index 1c17e7d8..839fc28c 100644 --- a/README.md +++ b/README.md @@ -13,7 +13,7 @@ http://simplybee.info ## Download -SIMplyBee is available on CRAN. You can install it with +SIMplyBee is available on CRAN. You can install it with install.packages(pkg = "SIMplyBee") diff --git a/inst/REFERENCES.bib b/inst/REFERENCES.bib new file mode 100644 index 00000000..2f5842e5 --- /dev/null +++ b/inst/REFERENCES.bib @@ -0,0 +1,285 @@ +% Shared bibliography for package help pages and vignettes. +% Keys use surnameYearFirst; sorted by key. + +@article{beye2006Exceptionally, + title = {Exceptionally high levels of recombination across the honey bee genome}, + author = {Beye, M. and Gattermeier, I. and Hasselmann, M. and Gempe, T. and Schioett, M. and Baines, J. F. and Schlipalius, D. and Mougel, F. and Emore, C. and Rueppell, O. and Sirviö, A. and Guzmán-Novoa, E. and Hunt, G. and Solignac, M. and Page, R. E.}, + year = {2006}, + journal = {Genome Research}, + volume = {16}, + number = {11}, + pages = {1339--1344}, + doi = {10.1101/gr.5680406}, + url = {https://doi.org/10.1101/gr.5680406} +} + +@article{bovo2021Application, + title = {Application of Next Generation Semiconductor-Based Sequencing for the Identification of {Apis} mellifera Complementary Sex Determiner ({csd}) Alleles from Honey {DNA}}, + author = {Bovo, S. and Ribani, A. and Utzeri, V. J. and Taurisano, V. and Schiavo, G. and Bolner, M. and Fontanesi, L.}, + year = {2021}, + journal = {Insects}, + volume = {12}, + number = {10}, + pages = {868}, + doi = {10.3390/insects12100868}, + url = {https://doi.org/10.3390/insects12100868} +} + +@article{brascamp2014Methods, + title = {Methods to estimate breeding values in honey bees}, + author = {Brascamp, E. W. and Bijma, P.}, + year = {2014}, + journal = {Genetics Selection Evolution}, + volume = {46}, + number = {1}, + pages = {53}, + doi = {10.1186/s12711-014-0053-9}, + url = {https://doi.org/10.1186/s12711-014-0053-9} +} + +@article{brascamp2019Note, + title = {A note on genetic parameters and accuracy of estimated breeding values in honey bees}, + author = {Brascamp, E. W. and Bijma, P.}, + year = {2019}, + journal = {Genetics Selection Evolution}, + volume = {51}, + number = {1}, + pages = {71}, + doi = {10.1186/s12711-019-0510-6}, + url = {https://doi.org/10.1186/s12711-019-0510-6} +} + +@article{chen2009Fast, + title = {Fast and flexible simulation of {DNA} sequence data}, + author = {Chen, G. K. and Marjoram, P. and Wall, J. D.}, + year = {2009}, + journal = {Genome Research}, + volume = {19}, + number = {1}, + pages = {136--142}, + doi = {10.1101/gr.083634.108}, + url = {https://doi.org/10.1101/gr.083634.108} +} + +@misc{clemson2020Frequently, + author = {Clemson Cooperative Extension}, + title = {Frequently asked questions about honey bee swarms}, + year = {2020}, + url = {https://hgic.clemson.edu/factsheet/frequently-asked-questions-about-honey-bee-swarms/}, + note = {Accessed 2022-11-11; publication year corrected from 2021 to 2020} +} + +@article{druet2020Theoretical, + title = {Theoretical and empirical comparisons of expected and realized relationships for the {X}-chromosome}, + author = {Druet, T. and Legarra, A.}, + year = {2020}, + journal = {Genetics Selection Evolution}, + volume = {52}, + number = {1}, + pages = {50}, + doi = {10.1186/s12711-020-00570-6}, + url = {https://doi.org/10.1186/s12711-020-00570-6} +} + +@article{du2021Short, + title = {Short-term effects of controlled mating and selection on the genetic variance of honeybee populations}, + author = {Du, M. and Bernstein, R. and Hoppe, A. and Bienefeld, K.}, + year = {2021}, + journal = {Heredity}, + volume = {126}, + number = {5}, + pages = {733--747}, + doi = {10.1038/s41437-021-00411-2}, + url = {https://doi.org/10.1038/s41437-021-00411-2} +} + +@article{fernando1989Covariance, + title = {Covariance between relatives for {X}-chromosomal loci in a population in disequilibrium}, + author = {Grossman, M. and Fernando, R. L.}, + year = {1989}, + journal = {Theoretical and Applied Genetics}, + volume = {77}, + number = {3}, + pages = {311--319}, + doi = {10.1007/bf00305821}, + url = {https://doi.org/10.1007/bf00305821} +} + +@article{fernando1990Genetic, + title = {Genetic evaluation with autosomal and {X}-chromosomal inheritance}, + author = {Fernando, R. L. and Grossman, M.}, + year = {1990}, + journal = {Theoretical and Applied Genetics}, + volume = {80}, + number = {1}, + pages = {75--80}, + doi = {10.1007/bf00224018}, + url = {https://doi.org/10.1007/bf00224018} +} + +@article{gaynor2021AlphaSimR, + title = {{AlphaSimR}: an {R} package for breeding program simulations}, + author = {Gaynor, R. C. and Gorjanc, G. and Hickey, J. M.}, + year = {2021}, + journal = {G3 Genes|Genomes|Genetics}, + volume = {11}, + number = {2}, + pages = {jkaa017}, + doi = {10.1093/g3journal/jkaa017}, + url = {https://doi.org/10.1093/g3journal/jkaa017} +} + +@article{grossman1989Inbreeding, + title = {Inbreeding, Coancestry, and Covariance between Relatives for {X}-Chromosomal Loci}, + author = {Grossman, M. and Eisen, E. J.}, + year = {1989}, + journal = {Journal of Heredity}, + volume = {80}, + number = {2}, + pages = {137--142}, + doi = {10.1093/oxfordjournals.jhered.a110812}, + url = {https://doi.org/10.1093/oxfordjournals.jhered.a110812} +} + +@article{hamdan2010Natural, + title = {Natural Supersedure of Queens in Honey Bee Colonies}, + author = {Hamdan, K.}, + year = {2010}, + journal = {Bee World}, + volume = {87}, + number = {3}, + pages = {52--54}, + doi = {10.1080/0005772X.2010.11417360}, + url = {https://doi.org/10.1080/0005772X.2010.11417360} +} + +@article{hill2011Variation, + title = {Variation in actual relationship as a consequence of {Mendelian} sampling and linkage}, + author = {HILL, W. G. and WEIR, B. S.}, + year = {2011}, + journal = {Genetics Research}, + volume = {93}, + number = {1}, + pages = {47--64}, + doi = {10.1017/s0016672310000480}, + url = {https://doi.org/10.1017/s0016672310000480} +} + +@article{lechner2014Nucleotide, + title = {Nucleotide Variability at Its Limit? {I}nsights into the Number and Evolutionary Dynamics of the Sex-Determining Specificities of the Honey Bee {Apis} mellifera}, + author = {Lechner, S. and Ferretti, L. and Schöning, C. and Kinuthia, W. and Willemsen, D. and Hasselmann, M.}, + year = {2014}, + journal = {Molecular Biology and Evolution}, + volume = {31}, + number = {2}, + pages = {272--287}, + doi = {10.1093/molbev/mst207}, + url = {https://doi.org/10.1093/molbev/mst207} +} + +@misc{nubdotdev2021Best, + author = {{nubDotDev}}, + title = {The BEST Way to Find a Random Point in a Circle}, + year = {2021}, + url = {https://youtu.be/4y_nmpv-9lI} +} + +@article{obsteter2023SIMplyBee, + title = {{SIMplyBee}: an {R} package to simulate honeybee populations and breeding programs}, + author = {Obšteter, J. and Strachan, L. K. and Bubnič, J. and Prešern, J. and Gorjanc, G.}, + year = {2023}, + journal = {Genetics Selection Evolution}, + volume = {55}, + number = {1}, + pages = {31}, + doi = {10.1186/s12711-023-00798-y}, + url = {https://doi.org/10.1186/s12711-023-00798-y} +} + +@article{rangel2012Colony, + title = {Colony fissioning in honey bees: size and significance of the swarm fraction}, + author = {Rangel, J. and Seeley, T. D.}, + year = {2012}, + journal = {Insectes Sociaux}, + volume = {59}, + number = {4}, + pages = {453--462}, + doi = {10.1007/s00040-012-0239-5}, + url = {https://doi.org/10.1007/s00040-012-0239-5} +} + +@book{seeley2019Lives, + title = {The Lives of Bees}, + author = {Seeley, T. D.}, + year = {2019}, + publisher = {Princeton University Press}, + doi = {10.1515/9780691189383}, + url = {https://doi.org/10.1515/9780691189383} +} + +@article{vanarendonk1994Use, + title = {Use of multiple genetic markers in prediction of breeding values}, + author = {Van Arendonk, J. A. and Tier, B. and Kinghorn, B. P.}, + year = {1994}, + journal = {Genetics}, + volume = {137}, + number = {1}, + pages = {319--329}, + doi = {10.1093/genetics/137.1.319}, + url = {https://doi.org/10.1093/genetics/137.1.319} +} + +@article{wallberg2014Worldwide, + title = {A worldwide survey of genome sequence variation provides insight into the evolutionary history of the honeybee {Apis} mellifera}, + author = {Wallberg, A. and Han, F. and Wellhagen, G. and Dahle, B. and Kawata, M. and Haddad, N. and Simões, Z. L. P. and Allsopp, M. H. and Kandemir, I. and De la Rúa, P. and Pirk, C. W. and Webster, M. T.}, + year = {2014}, + journal = {Nature Genetics}, + volume = {46}, + number = {10}, + pages = {1081--1088}, + doi = {10.1038/ng.3077}, + url = {https://doi.org/10.1038/ng.3077} +} + +@article{wallberg2019Hybrid, + title = {A hybrid de novo genome assembly of the honeybee, {Apis} mellifera, with chromosome-length scaffolds}, + author = {Wallberg, A. and Bunikis, I. and Pettersson, O. V. and Mosbech, M.-B. and Childers, A. K. and Evans, J. D. and Mikheyev, A. S. and Robertson, H. M. and Robinson, G. E. and Webster, M. T.}, + year = {2019}, + journal = {BMC Genomics}, + volume = {20}, + number = {1}, + pages = {275}, + doi = {10.1186/s12864-019-5642-0}, + url = {https://doi.org/10.1186/s12864-019-5642-0} +} + +@misc{wolfram2023Disk, + author = {{Wolfram MathWorld}}, + title = {Disk Point Picking}, + year = {2023}, + url = {https://mathworld.wolfram.com/DiskPointPicking.html} +} + +@article{yang2015Parent, + title = {Parent–progeny sequencing indicates higher mutation rates in heterozygotes}, + author = {Yang, S. and Wang, L. and Huang, J. and Zhang, X. and Yuan, Y. and Chen, J.-Q. and Hurst, L. D. and Tian, D.}, + year = {2015}, + journal = {Nature}, + volume = {523}, + number = {7561}, + pages = {463--467}, + doi = {10.1038/nature14649}, + url = {https://doi.org/10.1038/nature14649} +} + +@article{zareba2017Uneven, + title = {Uneven distribution of complementary sex determiner ({csd}) alleles in {Apis} mellifera population}, + author = {Zareba, J. and Blazej, P. and Laszkiewicz, A. and Sniezewski, L. and Majkowski, M. and Janik, S. and Cebrat, M.}, + year = {2017}, + journal = {Scientific Reports}, + volume = {7}, + number = {1}, + pages = {2317}, + doi = {10.1038/s41598-017-02629-9}, + url = {https://doi.org/10.1038/s41598-017-02629-9} +} diff --git a/literature/README.md b/literature/README.md new file mode 100644 index 00000000..d2cf74e0 --- /dev/null +++ b/literature/README.md @@ -0,0 +1,75 @@ +# SIMplyBee literature archive + +The citation inventory is [`inst/REFERENCES.bib`](../inst/REFERENCES.bib). +Checked on 2026-09-29: **21 of 22 scholarly references archived as PDFs**. +All 21 cited journal articles are available; +only Seeley's book remains missing. +Three additional citations are web/video resources. + +Open the local links below to read the papers. +All PDFs are named after their BibTeX keys. +PDF contents are unchanged. +Copyright and licences remain with the original rights holders. +The archive is excluded from package builds through `.Rbuildignore`. + +## Archived papers + +| BibTeX key | Local full text | Source / provenance | +| --- | --- | --- | +| `beye2006Exceptionally` | [Exceptionally high levels of recombination across the honey bee genome (PDF)](beye2006Exceptionally.pdf) | User supplied; [publication](https://doi.org/10.1101/gr.5680406) | +| `bovo2021Application` | [Application of Next Generation Semiconductor-Based Sequencing for the Identification of Apis mellifera Complementary Sex Determiner (csd) Alleles from Honey DNA (PDF)](bovo2021Application.pdf) | [Source](https://mdpi-res.com/d_attachment/insects/insects-12-00868/article_deploy/insects-12-00868.pdf) | +| `brascamp2014Methods` | [Methods to estimate breeding values in honey bees (PDF)](brascamp2014Methods.pdf) | [Source](https://doi.org/10.1186/s12711-014-0053-9) | +| `brascamp2019Note` | [A note on genetic parameters and accuracy of estimated breeding values in honey bees (PDF)](brascamp2019Note.pdf) | [Source](https://doi.org/10.1186/s12711-019-0510-6) | +| `chen2009Fast` | [Fast and flexible simulation of DNA sequence data (PDF)](chen2009Fast.pdf) | User supplied; [publication](https://doi.org/10.1101/gr.083634.108) | +| `druet2020Theoretical` | [Theoretical and empirical comparisons of expected and realized relationships for the X-chromosome (PDF)](druet2020Theoretical.pdf) | [Source](https://link.springer.com/content/pdf/10.1186/s12711-020-00570-6.pdf) | +| `du2021Short` | [Short-term effects of controlled mating and selection on the genetic variance of honeybee populations (PDF)](du2021Short.pdf) | [Source](https://www.nature.com/articles/s41437-021-00411-2.pdf) | +| `fernando1989Covariance` | [Covariance between relatives for X-chromosomal loci in a population in disequilibrium (PDF)](fernando1989Covariance.pdf) | [Source](https://link.springer.com/content/pdf/10.1007/bf00305821.pdf) | +| `fernando1990Genetic` | [Genetic evaluation with autosomal and X-chromosomal inheritance (PDF)](fernando1990Genetic.pdf) | [Source](https://link.springer.com/content/pdf/10.1007/bf00224018.pdf) | +| `gaynor2021AlphaSimR` | [AlphaSimR: an R package for breeding program simulations (PDF)](gaynor2021AlphaSimR.pdf) | [Source](https://pmc-oa-opendata.s3.amazonaws.com/PMC8022926.1/PMC8022926.1.pdf) | +| `grossman1989Inbreeding` | [Inbreeding, Coancestry, and Covariance between Relatives for X-Chromosomal Loci (PDF)](grossman1989Inbreeding.pdf) | User supplied; [publication](https://doi.org/10.1093/oxfordjournals.jhered.a110812) | +| `hamdan2010Natural` | [Natural Supersedure of Queens in Honey Bee Colonies (PDF)](hamdan2010Natural.pdf) | User supplied; [publication](https://doi.org/10.1080/0005772X.2010.11417360) | +| `hill2011Variation` | [Variation in actual relationship as a consequence of Mendelian sampling and linkage (PDF)](hill2011Variation.pdf) | [Source](https://www.cambridge.org/core/services/aop-cambridge-core/content/view/12D801902473A0F212EF49489DF0D687/S0016672310000480a.pdf/div-class-title-variation-in-actual-relationship-as-a-consequence-of-mendelian-sampling-and-linkage-div.pdf) | +| `lechner2014Nucleotide` | [Nucleotide Variability at Its Limit? Insights into the Number and Evolutionary Dynamics of the Sex-Determining Specificities of the Honey Bee Apis mellifera (PDF)](lechner2014Nucleotide.pdf) | [Source](https://pmc-oa-opendata.s3.amazonaws.com/PMC3907057.1/PMC3907057.1.pdf) | +| `obsteter2023SIMplyBee` | [SIMplyBee: an R package to simulate honeybee populations and breeding programs (PDF)](obsteter2023SIMplyBee.pdf) | [Source](https://link.springer.com/content/pdf/10.1186/s12711-023-00798-y.pdf) | +| `rangel2012Colony` | [Colony fissioning in honey bees: size and significance of the swarm fraction (PDF)](rangel2012Colony.pdf) | [Source](https://link.springer.com/content/pdf/10.1007/s00040-012-0239-5.pdf) | +| `vanarendonk1994Use` | [Use of multiple genetic markers in prediction of breeding values. (PDF)](vanarendonk1994Use.pdf) | User supplied; [publication](https://doi.org/10.1093/genetics/137.1.319) | +| `wallberg2014Worldwide` | [A worldwide survey of genome sequence variation provides insight into the evolutionary history of the honeybee Apis mellifera (PDF)](wallberg2014Worldwide.pdf) | [Source](https://repository.up.ac.za/bitstreams/6a6fbb44-8a17-45e7-adf9-cdefbbe313e5/download) | +| `wallberg2019Hybrid` | [A hybrid de novo genome assembly of the honeybee, Apis mellifera, with chromosome-length scaffolds (PDF)](wallberg2019Hybrid.pdf) | [Source](https://link.springer.com/content/pdf/10.1186/s12864-019-5642-0.pdf) | +| `yang2015Parent` | [Parent–progeny sequencing indicates higher mutation rates in heterozygotes (PDF)](yang2015Parent.pdf) | [Source](https://purehost.bath.ac.uk/ws/portalfiles/portal/136920961/Parent_progeny_sequencing_indicates_higher_mutation_rates_in_heterozygotes._.pdf) | +| `zareba2017Uneven` | [Uneven distribution of complementary sex determiner (csd) alleles in Apis mellifera population (PDF)](zareba2017Uneven.pdf) | [Source](https://www.nature.com/articles/s41598-017-02629-9.pdf) | + +## Full text still needed + +These references have no local full-text copy. + +| BibTeX key | Reference | Status | +| --- | --- | --- | +| `seeley2019Lives` | [The Lives of Bees](https://doi.org/10.1515/9780691189383) | Full text could not be downloaded from checked publisher/repository sources. | + +## Web and video references + +These are recorded as links, not counted as archived papers. + +- `clemson2020Frequently`: [Frequently asked questions about honey bee swarms](https://hgic.clemson.edu/factsheet/frequently-asked-questions-about-honey-bee-swarms/) +- `nubdotdev2021Best`: [The BEST Way to Find a Random Point in a Circle](https://youtu.be/4y_nmpv-9lI) +- `wolfram2023Disk`: [Disk Point Picking](https://mathworld.wolfram.com/DiskPointPicking.html) + +## Provenance and integrity + +[`manifest.json`](manifest.json) records each citation, local file, source, +retrieval date, format/version, validation, and download status. + +## Maintaining citations + +Use `surnameYearFirst` keys in `inst/REFERENCES.bib`. Vignettes use Pandoc +citations (`@key` or `[@key]`). +Roxygen help uses Rdpack references to the same file. Regenerate `man/` and +`NAMESPACE` through roxygen; do not edit generated help manually. + +The initial inventory includes all named scholarly references found in +`R/`, the vignettes, README, and `inst/CITATION`, +plus the three explicitly referenced web resources. +DOI metadata was resolved from Crossref/DOI records; +web-reference metadata was retained from existing docs. +`inst/CITATION` remains the package's conventional citation entry point. +General software links and incidental explanatory URLs are not treated as papers. diff --git a/man/MultiColony-class.Rd b/man/MultiColony-class.Rd index 6be082c7..d81e7d6f 100644 --- a/man/MultiColony-class.Rd +++ b/man/MultiColony-class.Rd @@ -70,17 +70,17 @@ An object holding a collection of honeybee colonies. It behaves \item \code{c(MultiColonyOrNULL)}: Combine multiple Colony and MultiColony objects -\item \code{x = MultiColony[i = integerOrNumericOrLogical]}: Extract a colony (one or more!) with an integer/numeric/logical index (position) (return \code{\link[SIMplyBee]{MultiColony-class}}) +\item \code{x[i}: Extract a colony (one or more!) with an integer/numeric/logical index (position) (return \code{\link[SIMplyBee]{MultiColony-class}}) -\item \code{x = MultiColony[i = character]}: Extract a colony (one or more!) with a character ID (name) (return \code{\link[SIMplyBee]{MultiColony-class}}) +\item \code{x[i}: Extract a colony (one or more!) with a character ID (name) (return \code{\link[SIMplyBee]{MultiColony-class}}) -\item \code{x = MultiColony[[i = integerOrNumericOrLogical]]}: Extract a colony (just one!) with an integer/numeric/logical index (position) (return \code{\link[SIMplyBee]{Colony-class}}) +\item \code{x[[i}: Extract a colony (just one!) with an integer/numeric/logical index (position) (return \code{\link[SIMplyBee]{Colony-class}}) -\item \code{x = MultiColony[[i = character]]}: Extract a colony (just one!) with a character ID (name) (return \code{\link[SIMplyBee]{Colony-class}}) +\item \code{x[[i}: Extract a colony (just one!) with a character ID (name) (return \code{\link[SIMplyBee]{Colony-class}}) -\item \code{x = MultiColony[i = integerOrNumericOrLogicalOrCharacter, j = ANY] <- value}: Assign colonies into MultiColony +\item \code{`[`(x = MultiColony, i = integerOrNumericOrLogicalOrCharacter, j = ANY) <- value}: Assign colonies into MultiColony -\item \code{x = MultiColony[[i = integerOrNumericOrLogicalOrCharacter, j = ANY]] <- value}: Assign Colony into MultiColony +\item \code{`[[`(x = MultiColony, i = integerOrNumericOrLogicalOrCharacter, j = ANY) <- value}: Assign Colony into MultiColony }} \section{Slots}{ diff --git a/man/SIMplyBee-package.Rd b/man/SIMplyBee-package.Rd index a22788f0..02b01c03 100644 --- a/man/SIMplyBee-package.Rd +++ b/man/SIMplyBee-package.Rd @@ -21,6 +21,10 @@ extended for honeybees, including haplo-diploidy, csd locus, colony events See the introductory vignette on using this package by running: \code{vignette("Honeybee_biology", package="SIMplyBee")} } +\references{ +\insertRef{obsteter2023SIMplyBee}{SIMplyBee} +\insertRef{gaynor2021AlphaSimR}{SIMplyBee} +} \seealso{ Useful links: \itemize{ @@ -33,7 +37,6 @@ 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 555e3730..79b873f7 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) @@ -83,31 +83,18 @@ SP$pedigree SP$caste } \references{ -Bovo et al. (2021) Application of Next Generation Semiconductor-Based - Sequencing for the Identification of Apis mellifera Complementary Sex - Determiner (csd) Alleles from Honey DNA. Insects, 12(10), 868. - \doi{10.3390/insects12100868} - -Lechner et al. (2014) Nucleotide variability at its limit? Insights into - the number and evolutionary dynamics of the sex-determining specificities - of the honey bee Apis mellifera Molecular Biology and Evolution, 31, - 272-287. \doi{10.1093/molbev/mst207} - -Seeley (2019) The Lives of Bees: The Untold Story of the Honey - Bee in the Wild. Princeton: Princeton University Press. - \doi{10.1515/9780691189383} - -Zareba et al. (2017) Uneven distribution of complementary sex determiner - (csd) alleles in Apis mellifera population. Scientific Reports, 7, 2317. - \doi{10.1038/s41598-017-02629-9} +\insertRef{bovo2021Application}{SIMplyBee} +\insertRef{lechner2014Nucleotide}{SIMplyBee} +\insertRef{seeley2019Lives}{SIMplyBee} +\insertRef{zareba2017Uneven}{SIMplyBee} } \section{Super class}{ \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 +116,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 +138,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 +160,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 +182,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 +203,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 +212,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 +233,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 +254,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,99 +266,100 @@ 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-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 +\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 -
    }} +
    +}} \if{html}{\out{
    }} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-SimParamBee-initialize}{}}} -\subsection{\code{SimParamBee$new()}}{ - Starts the process of building a new simulation by creating +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-SimParamBee-new}{}}} +\subsection{Method \code{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, @@ -385,81 +373,99 @@ generate this object} 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{\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 +\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 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) @@ -473,33 +479,35 @@ 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{\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 +\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 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 @@ -511,139 +519,140 @@ 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{\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{Method \code{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{
    }} +} +} \if{html}{\out{
    }} \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-SimParamBee-addToBeeRec}{}}} -\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{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{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{\code{SimParamBee$updateCaste()}}{ - A function to update the caste +\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{
    }} - } +\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-updateLastBeeId}{}}} -\subsection{\code{SimParamBee$updateLastBeeId()}}{ - A function to update the last +\subsection{Method \code{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{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{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{
    }} +} +} \if{html}{\out{
    }} \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-SimParamBee-updateLastColonyId}{}}} -\subsection{\code{SimParamBee$updateLastColonyId()}}{ - A function to update the colony last +\subsection{Method \code{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{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{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{
    }} +} +} \if{html}{\out{
    }} \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-SimParamBee-clone}{}}} -\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{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{Arguments}{ +\if{html}{\out{
    }} +\describe{ +\item{\code{deep}}{Whether to make a deep clone.} +} +\if{html}{\out{
    }} +} +} } diff --git a/man/calcBeeGRMIbd.Rd b/man/calcBeeGRMIbd.Rd index 0a9fe6af..106fbb98 100644 --- a/man/calcBeeGRMIbd.Rd +++ b/man/calcBeeGRMIbd.Rd @@ -83,23 +83,9 @@ GRMs$genome[dG, wG] GRMs$indiv[dI, wI] } \references{ -Grossman and Eisen (1989) Inbreeding, coancestry, and covariance between - relatives for X-chromosomal loci. The Journal of Heredity, - \doi{10.1093/oxfordjournals.jhered.a110812} - -Fernando and Grossman (1989) Covariance between relatives for X-chromosomal - loci in a population in disequilibrium. Theoretical and Applied Genetics, - \doi{10.1007/bf00305821} - -Fernando and Grossman (1990) Genetic evaluation with autosomal - and X-chromosomal inheritance. Theoretical and Applied Genetics, - \doi{10.1007/bf00224018} - -Van Arendonk, Tier, and Kinghorn (1994) Use of multiple genetic markers in - prediction of breeding values. Genetics, - \doi{10.1093/genetics/137.1.319} - -Hill and Weir (2011) Variation in actual relationship as a consequence of - Mendelian sampling and linkage. Genetics Research, - \doi{10.1017/s0016672310000480} +\insertRef{fernando1989Covariance}{SIMplyBee} +\insertRef{fernando1990Genetic}{SIMplyBee} +\insertRef{grossman1989Inbreeding}{SIMplyBee} +\insertRef{hill2011Variation}{SIMplyBee} +\insertRef{vanarendonk1994Use}{SIMplyBee} } diff --git a/man/calcBeeGRMIbs.Rd b/man/calcBeeGRMIbs.Rd index f0fe324d..bc619ff9 100644 --- a/man/calcBeeGRMIbs.Rd +++ b/man/calcBeeGRMIbs.Rd @@ -111,7 +111,5 @@ calcBeeGRMIbs(x = rbind(queenGeno, pooledGenoW), sex = c("F","F"), returnComponents = TRUE) } \references{ -Druet and Legarra (2020) Theoretical and empirical comparisons of - expected and realized relationships for the X-chromosome. Genetics - Selection Evolution, 52:50 \doi{10.1186/s12711-020-00570-6} +\insertRef{druet2020Theoretical}{SIMplyBee} } diff --git a/man/calcColonyAndIndCoefficients.Rd b/man/calcColonyAndIndCoefficients.Rd new file mode 100644 index 00000000..cbba8eae --- /dev/null +++ b/man/calcColonyAndIndCoefficients.Rd @@ -0,0 +1,72 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/Functions_L0_auxilary.R +\name{calcColonyAndIndCoefficients} +\alias{calcColonyAndIndCoefficients} +\title{Calculate coefficients to map across individual and colony variances} +\usage{ +calcColonyAndIndCoefficients(nW, nF, nDPQ, workersFUN, workerAllocation) +} +\arguments{ +\item{nW}{Positive integer scalar, number of workers in the colony.} + +\item{nF}{Positive integer scalar, number of distinct mating fathers available +to sire workers. With random allocation, some fathers may sire no workers.} + +\item{nDPQ}{Positive integer scalar, number of distinct drone-producing queens +(DPQs) represented among the mating fathers. Equal numbers of fathers per +DPQ are assumed; nF must be divisible by nDPQ.} + +\item{workersFUN}{Character scalar, "sum" or "mean", specifying aggregation +of the workers' worker-effect trait values.} + +\item{workerAllocation}{Character scalar, "random" for independent uniform +sampling of a father for each worker, or "balanced" for exactly nW/nF +workers per father. Balanced allocation requires nW divisible by nF.} +} +\value{ +A list of three coefficients: + \itemize{ + \item \code{worker}: multiplier converting individual worker-effect additive + genetic variance to variance of the worker-group sum or mean. + \item \code{queenWorker}: multiplier converting within-individual genetic + covariance between queen-effect and worker-effect traits to covariance + between the colony queen's queen-effect contribution and the worker-group + worker-effect contribution. This coefficient does not include the factor + of two used when calculating total colony variance. + \item \code{environment}: multiplier converting individual worker-effect + environmental variance to variance of the worker-group sum or mean, + assuming environmental deviations are independent between workers. + } +} +\description{ +Calculate the coefficients used to map variances in a fixed colony design. +Forward mappings in \code{mapIndToColonyVar} multiply individual components. +Inverse mappings in \code{mapColonyToIndVar} divide aggregate components. +} +\details{ +The model assumes non-inbred colony queens and DPQs, mutually + unrelated across those parents. Distinct fathers from the same DPQ may be + brothers. The queen-effect variance multiplier is one and is not returned. + + Let w be 1 for sums or 1/nW for means. + Ordered distinct-worker pairs are partitioned into + same father giving super-sisters with additive relationship of 3/4, + distinct fathers from the same DPQ giving full-sisters with additive relationship of 1/2, and + different DPQs giving half-sisters with additive relationship of 1/4. + The worker coefficient is w^2 * (nW + relationship-weighted pair counts). + Random allocation uses expected pair counts; + balanced allocation uses exact pair counts. + The queenWorker coefficient is nW*w/2, and + the environment coefficient is nW*w^2. + + Divisibility checks establish that the assumed equal allocation is possible; + totals alone cannot verify actual family composition. + These coefficients describe marginal colony components, + not sample variances across colonies sharing relatives. + Unequal contributions, general ancestry, and random colony sizes + require a more general model. +} +\seealso{ +\code{\link{mapIndToColonyVar}}, \code{\link{mapColonyToIndVar}} +} +\keyword{internal} diff --git a/man/calcInheritanceCriterion.Rd b/man/calcInheritanceCriterion.Rd index 50a8580c..73a5154b 100644 --- a/man/calcInheritanceCriterion.Rd +++ b/man/calcInheritanceCriterion.Rd @@ -76,9 +76,7 @@ calcInheritanceCriterion(apiary, queenTrait = 1, workersTrait = 2) } \references{ -Du, M., et al. (2021) Short-term effects of controlled mating and selection - on the genetic variance of honeybee populations. Heredity 126, 733–747. - \doi{10.1038/s41437-021-00411-2} +\insertRef{du2021Short}{SIMplyBee} } \seealso{ \code{\link[SIMplyBee]{calcSelectionCriterion}} and diff --git a/man/calcPerformanceCriterion.Rd b/man/calcPerformanceCriterion.Rd index 62db9e8b..4cd6ad5d 100644 --- a/man/calcPerformanceCriterion.Rd +++ b/man/calcPerformanceCriterion.Rd @@ -82,9 +82,7 @@ calcPerformanceCriterion(apiary, queenTrait = 1, } \references{ -Du, M., et al. (2021) Short-term effects of controlled mating and selection - on the genetic variance of honeybee populations. Heredity 126, 733–747. - \doi{10.1038/s41437-021-00411-2} +\insertRef{du2021Short}{SIMplyBee} } \seealso{ \code{\link[SIMplyBee]{calcSelectionCriterion}} and diff --git a/man/calcSelectionCriterion.Rd b/man/calcSelectionCriterion.Rd index 1ed27420..906c29e4 100644 --- a/man/calcSelectionCriterion.Rd +++ b/man/calcSelectionCriterion.Rd @@ -90,9 +90,7 @@ calcSelectionCriterion(apiary, queenTrait = 1, } \references{ -Du, M., et al. (2021) Short-term effects of controlled mating and selection - on the genetic variance of honeybee populations. Heredity 126, 733–747. - \doi{10.1038/s41437-021-00411-2} +\insertRef{du2021Short}{SIMplyBee} } \seealso{ \code{\link[SIMplyBee]{calcInheritanceCriterion}} and diff --git a/man/cor2cov.Rd b/man/cor2cov.Rd index 35572668..6a863f68 100644 --- a/man/cor2cov.Rd +++ b/man/cor2cov.Rd @@ -16,5 +16,8 @@ covariance matrix } \description{ Convert correlation matrix to covariance matrix -This function is adopted from AlphaSimR (Gaynor et al., 2021) +This function is adopted from AlphaSimR (Gaynor et al., 2021). +} +\references{ +\insertRef{gaynor2021AlphaSimR}{SIMplyBee} } diff --git a/man/covVar2Cor.Rd b/man/covVar2Cor.Rd new file mode 100644 index 00000000..06990edb --- /dev/null +++ b/man/covVar2Cor.Rd @@ -0,0 +1,24 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/Functions_L0_auxilary.R +\name{covVar2Cor} +\alias{covVar2Cor} +\title{Stable conversion of a covariance and two variances to a correlation} +\usage{ +covVar2Cor(covariance, variance1, variance2) +} +\arguments{ +\item{covariance}{Numeric scalar covariance between the two variables.} + +\item{variance1}{Numeric scalar variance of the first variable.} + +\item{variance2}{Numeric scalar variance of the second variable.} +} +\value{ +Numeric scalar correlation, or \code{NA_real_} + if either variance is zero and the correlation is therefore undefined. +} +\description{ +Divide a covariance by the product of the corresponding standard deviations, +but return \code{NA} when either variance (standard deviation) are zero. +} +\keyword{internal} diff --git a/man/mapColonyToIndVar.Rd b/man/mapColonyToIndVar.Rd deleted file mode 100644 index d5de8977..00000000 --- a/man/mapColonyToIndVar.Rd +++ /dev/null @@ -1,46 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/Functions_L0_auxilary.R -\name{mapColonyToIndVar} -\alias{mapColonyToIndVar} -\title{Map colony-level variance components to individual-level variance components} -\usage{ -mapColonyToIndVar( - varA_q, - varA_wbar, - corA_qwbar, - varE_q, - varE_wbar, - corE_qwbar, - nW, - nF, - nDPQ, - workersFUN = "sum" -) -} -\arguments{ -\item{varA_q}{numeric, additive genetic variance of the queen} - -\item{varA_wbar}{numeric, additive genetic variance of the average worker} - -\item{corA_qwbar}{numeric, correlation between queen and average worker} - -\item{varE_q}{numeric, environmental variance of the queen} - -\item{varE_wbar}{numeric, environmental variance of the average worker} - -\item{corE_qwbar}{numeric, correlation between queen and average worker} - -\item{nW}{numeric, number of workers in the colony} - -\item{nF}{numeric, number of fathers of the workers} - -\item{nDPQ}{numeric, number of drone producing queens in the colony} - -\item{workersFUN}{character, either "sum" or "mean", indicating whether the workers' contributions are summed or averaged} -} -\value{ -list with individual-level variance components -} -\description{ -Map colony-level variance components to individual-level variance components -} diff --git a/man/mapIndToColonyVar.Rd b/man/mapIndToColonyVar.Rd index aa3b35cd..535dc7fb 100644 --- a/man/mapIndToColonyVar.Rd +++ b/man/mapIndToColonyVar.Rd @@ -2,45 +2,217 @@ % Please edit documentation in R/Functions_L0_auxilary.R \name{mapIndToColonyVar} \alias{mapIndToColonyVar} -\title{Map individual-level variance components to colony-level variance components} +\alias{mapColonyToIndVar} +\title{Map variance components between individuals and colonies} \usage{ mapIndToColonyVar( - varA_q, - varA_w, - corA_qw, - varE_q, - varE_w, - corE_qw, + varAQueen, + varAWorker, + corAQueenWorker, + varEQueen, + varEWorker, + corEQueenWorker, nW, nF, nDPQ, - workersFUN = "sum" + workersFUN = "sum", + workerAllocation = "random" +) + +mapColonyToIndVar( + varAQueen, + varAWorkerGroup, + corAQueenWorkerGroup, + varEQueen, + varEWorkerGroup, + corEQueenWorkerGroup, + nW, + nF, + nDPQ, + workersFUN = "sum", + workerAllocation = "random" ) } \arguments{ -\item{varA_q}{numeric, additive genetic variance of the queen} +\item{varAQueen}{Numeric scalar, additive genetic variance of +the queen-effect trait among individual diploid bees in a base population.} -\item{varA_w}{numeric, additive genetic variance of the workers} +\item{varAWorker}{Numeric scalar, additive genetic variance of +the worker-effect trait among individual diploid bees in a base population.} -\item{corA_qw}{numeric, correlation between queen and workers} +\item{corAQueenWorker}{Numeric scalar, additive genetic correlation between +the queen-effect trait and the worker-effect trait +among individual diploid bees in a base population. +This is the within-individual cross-trait correlation among individuals.} -\item{varE_q}{numeric, environmental variance of the queen} +\item{varEQueen}{Numeric scalar, environmental variance of +the queen-effect trait among individual bees in a base population.} -\item{varE_w}{numeric, environmental variance of the workers} +\item{varEWorker}{Numeric scalar, environmental variance of +the worker-effect trait among individual bees in a base population.} -\item{corE_qw}{numeric, correlation between queen and workers} +\item{corEQueenWorker}{Numeric scalar, environmental correlation between +the queen-effect trait and the worker-effect trait +among individual diploid bees in a base population. +This is the within-individual cross-trait correlation among individuals.} \item{nW}{numeric, number of workers in the colony} \item{nF}{numeric, number of fathers of the workers} -\item{nDPQ}{numeric, number of drone producing queens in the colony} +\item{nDPQ}{numeric, number of drone producing queens (DPQs) +represented among the mating fathers} + +\item{workersFUN}{character, either "sum" or "mean", +indicating whether the workers' contributions are summed or averaged +when forming the aggregated worker-effect contribution to colony value.} -\item{workersFUN}{character, either "sum" or "mean", indicating whether the workers' contributions are summed or averaged} +\item{workerAllocation}{character, either "random" (default) or "balanced".} + +\item{varAWorkerGroup}{Numeric scalar, additive genetic variance of +the aggregated worker-effect trait among colonies in a base population.} + +\item{corAQueenWorkerGroup}{Numeric scalar, additive genetic correlation between +the queen's queen-effect trait and +the aggregated workers' worker-effect trait +among colonies in a base population. +This is the cross-caste and cross-trait correlation among colonies.} + +\item{varEWorkerGroup}{Numeric scalar, environmental variance of +the aggregated worker-effect trait among colonies in a base population.} + +\item{corEQueenWorkerGroup}{Numeric scalar, environmental correlation between +the queen's queen-effect trait and +the aggregated workers' worker-effect trait +among colonies in a base population. +This is the cross-caste and cross-trait correlation among colonies.} } \value{ -list with colony-level variance components +Both functions return a flat list with the same named components. + + \strong{Components already described as inputs} + All components listed below are returned by both functions; the function + labels indicate which inputs they correspond to. + \itemize{ + \item Both functions: \code{varAQueen}, \code{varEQueen}, \code{nW}, + \code{nF}, \code{nDPQ}, \code{workersFUN}, and \code{workerAllocation}. + \item \code{mapIndToColonyVar}: \code{varAWorker}, \code{varEWorker}, + \code{corAQueenWorker}, and \code{corEQueenWorker}. + \item \code{mapColonyToIndVar}: \code{varAWorkerGroup}, + \code{varEWorkerGroup}, \code{corAQueenWorkerGroup}, and + \code{corEQueenWorkerGroup}. The returned group correlations are + \code{NA} if either corresponding variance is zero, even if zero + was supplied as the correlation. + } + + \strong{Additional components} + \itemize{ + \item \code{covAQueenWorker}: additive genetic covariance between + the queen-effect trait and the worker-effect trait + among individual diploid bees in a base population. + \item \code{covAQueenWorkerGroup}: additive genetic covariance between + the queen's queen-effect trait and + the aggregated workers' worker-effect trait + among colonies in a base population. + \item \code{covEQueenWorker}: environmental covariance between + the queen-effect trait and the worker-effect trait + among individual diploid bees in a base population. + \item \code{covEQueenWorkerGroup}: environmental covariance between + the queen's queen-effect trait and + the aggregated workers' worker-effect trait + among colonies in a base population. + Zero under the assumption of independent environmental deviations between bees. + \item \code{varAColony} and \code{varEColony}: additive genetic + and environmental variance of colony values. + Each is the sum of the queen and worker-group variances plus twice their covariance. + } + + Covariances are not multiplied by two. + Calculated correlations are \code{NA} if either corresponding variance is zero. + In \code{mapColonyToIndVar}, \code{covEQueenWorker} and \code{corEQueenWorker} + are both returned as \code{NA}, + because colony components do not identify + within-individual environmental covariance or correlation. } \description{ -Map individual-level variance components to colony-level variance components +Map individual queen-effect and worker-effect variance components + to colony variance components, or recover individual variance components from + separate queen and worker-group colony variance components. +} +\details{ +These mappings describe marginal variances under an additive model + with non-inbred, mutually unrelated colony queens and drone-producing + queens (DPQs), distinct fathers, and equal numbers of fathers per DPQ. + They do not predict sample variance across colonies sharing relatives. + Each diploid bee has genetic values for both the queen-effect and + worker-effect traits. A colony value combines the queen's value for the + queen-effect trait with the aggregated workers' values for the + worker-effect trait. Thus Queen and Worker identify trait roles as well as + their expressing castes; WorkerGroup always denotes an aggregate. + + With random worker allocation, + each worker independently samples a father uniformly. + With balanced allocation, + each father has exactly \code{nW/nF} workers, + which requires \code{nW} to be divisible by \code{nF}. + Both require \code{nF} divisible by \code{nDPQ}. + The distinct-worker relationship is 3/4 for a shared father, + 1/2 for distinct fathers from the same DPQ, and 1/4 otherwise. + Queen-offspring relationship is 1/2. + Environmental deviations are independent between bees. + Calculated correlations are \code{NA} when either variance is zero; + individual correlations supplied to the forward mapping are retained. + + The inverse divides worker-group variances and queen-worker-group + covariance by the corresponding design coefficients. + Both directions must use the same colony design and aggregation. + A nonzero \code{corEQueenWorkerGroup} raises an error, + as do colony components implying an individual genetic correlation outside [-1, 1]. + If either genetic component variance is zero, + the inverse accepts \code{NA} or zero for \code{corAQueenWorkerGroup}. + Similarly, \code{NA} or zero can be supplied for \code{corEQueenWorkerGroup} + when either environmental component variance is zero. + The zero-correlation restriction between bees does not apply to \code{corEQueenWorker}, + which describes environmental association between traits within the same bee. + + Both results are flat lists. To pass a result to either mapping function, + select the entries named in \code{names(formals(fun))} before using + \code{do.call(fun, ...)}; the full result contains extra components. + Before mapping an inverse result forward, supply an explicit + \code{corEQueenWorker}, which the inverse cannot identify. +} +\section{Functions}{ +\itemize{ +\item \code{mapColonyToIndVar()}: Recover individual variance components from +separate queen and worker-group colony components. + +}} +\examples{ +nW <- 100 +nF <- 15 +nDPQ <- 5 + +# Mapping individual vars to colony with worker group mean +(colonyVars <- mapIndToColonyVar( + varAQueen = 1, varAWorker = 1, corAQueenWorker = -0.5, + varEQueen = 1, varEWorker = 1, corEQueenWorker = 0, + nW = nW, nF = nF, nDPQ = nDPQ, workersFUN = "mean")) +# ... and inverse +(indVars <- do.call(mapColonyToIndVar, + colonyVars[names(formals(mapColonyToIndVar))])) + +# Mapping colony vars with worker group sum to individual vars +(indVars <- mapColonyToIndVar( + varAQueen = 1, varAWorkerGroup = 1, corAQueenWorkerGroup = -0.5, + varEQueen = 1, varEWorkerGroup = 1, corEQueenWorkerGroup = 0, + nW = nW, nF = nF, nDPQ = nDPQ, workersFUN = "sum")) +# ... and back to colony components, assuming zero within-bee +# environmental correlation (not identified by the inverse mapping). +indArgs <- indVars[names(formals(mapIndToColonyVar))] +indArgs$corEQueenWorker <- 0 +(colonyVars <- do.call(mapIndToColonyVar, indArgs)) +} +\references{ +\insertRef{brascamp2014Methods}{SIMplyBee} +\insertRef{brascamp2019Note}{SIMplyBee} } diff --git a/man/mapLoci.Rd b/man/mapLoci.Rd index 5ccf535c..d08cb198 100644 --- a/man/mapLoci.Rd +++ b/man/mapLoci.Rd @@ -16,5 +16,8 @@ A list with number of loci per chromosome and genetic positions of the markers } \description{ Finds loci on a genetic map and return a list of positions. -This function is adopted from AlphaSimR (Gaynor et al., 2021) +This function is adopted from AlphaSimR (Gaynor et al., 2021). +} +\references{ +\insertRef{gaynor2021AlphaSimR}{SIMplyBee} } diff --git a/man/rcircle.Rd b/man/rcircle.Rd index 7aec0c6e..3c2885f5 100644 --- a/man/rcircle.Rd +++ b/man/rcircle.Rd @@ -34,9 +34,6 @@ lim <- range(x) plot(x, xlim = lim, ylim = lim, main = "Gaussian") } \references{ -nubDotDev (2021) The BEST Way to Find a Random Point in a Circle -https://youtu.be/4y_nmpv-9lI - -Wolfram MathWorld (2023) Disk Point Picking -https://mathworld.wolfram.com/DiskPointPicking.html +\insertRef{nubdotdev2021Best}{SIMplyBee} +\insertRef{wolfram2023Disk}{SIMplyBee} } diff --git a/man/simulateHoneyBeeGenomes.Rd b/man/simulateHoneyBeeGenomes.Rd index 3e5c70d1..03017da2 100644 --- a/man/simulateHoneyBeeGenomes.Rd +++ b/man/simulateHoneyBeeGenomes.Rd @@ -60,23 +60,10 @@ automatically detected} Level 0 function that returns simulated honeybee genomes } \references{ -Wallberg, A., Bunikis, I., Pettersson, O.V. et al. - A hybrid de novo genome assembly of the honeybee, Apis mellifera, - with chromosome-length scaffolds. 2019, BMC Genomics 20:275. - \doi{10.1186/s12864-019-5642-0} - -Beye M, Gattermeier I, Hasselmann M, et al. Exceptionally high levels - of recombination across the honey bee genome. - 2006, Genome Res 16(11):1339-1344. \doi{10.1101/gr.5680406} - -Wallberg, A., Han, F., Wellhagen, G. et al. A worldwide survey of - genome sequence variation provides insight into the evolutionary - history of the honeybee Apis mellifera. - 2014, Nat Genet 46:1081–1088. \doi{10.1038/ng.3077} - -Yang S, Wang L, Huang J, Zhang X, Yuan Y, Chen JQ, Hurst LD, Tian D. - Parent-progeny sequencing indicates higher mutation rates in heterozygotes. - 2015, Nature 523(7561):463-7. \doi{10.1038/nature14649}. +\insertRef{beye2006Exceptionally}{SIMplyBee} +\insertRef{yang2015Parent}{SIMplyBee} +\insertRef{wallberg2014Worldwide}{SIMplyBee} +\insertRef{wallberg2019Hybrid}{SIMplyBee} } \seealso{ Due to the computational time and resources required to run this function, diff --git a/man/validateVarsAndCors.Rd b/man/validateVarsAndCors.Rd new file mode 100644 index 00000000..b12e84a9 --- /dev/null +++ b/man/validateVarsAndCors.Rd @@ -0,0 +1,23 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/Functions_L0_auxilary.R +\name{validateVarsAndCors} +\alias{validateVarsAndCors} +\title{Validate variance and correlation inputs} +\usage{ +validateVarsAndCors(variances, correlations) +} +\arguments{ +\item{variances}{Named list of numeric, finite, nonnegative variance scalars.} + +\item{correlations}{Named list of numeric, finite correlation scalars in +the interval [-1, 1].} +} +\value{ +Invisibly returns \code{NULL} when all checked inputs are valid; + otherwise stops with an error. +} +\description{ +Check named collections of scalar variance and correlation parameters used +by the individual/colony variance mappings. Invalid inputs raise an error. +} +\keyword{internal} diff --git a/tests/testthat/test-variance-mapping.R b/tests/testthat/test-variance-mapping.R new file mode 100644 index 00000000..519552e8 --- /dev/null +++ b/tests/testthat/test-variance-mapping.R @@ -0,0 +1,104 @@ +test_that("individual-to-colony round trip recovers the identifiable individual components", { + for (workersFUN in c("sum", "mean")) { + for (workerAllocation in c("random", "balanced")) { + referenceColony <- NULL + for (corE in c(0, 0.7)) { + # Start with individual inputs, independently of the inverse mapping + indArgs <- list( + varAQueen = 1, + varAWorker = 1, + corAQueenWorker = -0.5, + varEQueen = 1, + varEWorker = 1, + corEQueenWorker = corE, + nW = if (workerAllocation == "balanced") 120 else 100, + nF = 15, + nDPQ = 5, + workersFUN = workersFUN, + workerAllocation = workerAllocation + ) + colonyVars <- do.call(mapIndToColonyVar, indArgs) + indVars <- do.call( + mapColonyToIndVar, + colonyVars[names(formals(mapColonyToIndVar))] + ) + + expect_equal(colonyVars[names(indArgs)], indArgs) + identifiableInputs <- setdiff(names(indArgs), "corEQueenWorker") + expect_equal(indVars[identifiableInputs], indArgs[identifiableInputs]) + expect_equal(indVars$covAQueenWorker, -0.5) + expect_equal(colonyVars$covEQueenWorker, corE) + expect_equal(colonyVars$corEQueenWorker, corE) + expect_equal(colonyVars$covEQueenWorkerGroup, 0) + expect_equal(colonyVars$corEQueenWorkerGroup, 0) + + # An unknown within-bee association must not become an assumed zero + expect_identical(indVars$covEQueenWorker, NA_real_) + expect_identical(indVars$corEQueenWorker, NA_real_) + expect_false(identical(indVars, colonyVars)) + expect_identical(names(indVars), names(colonyVars)) + recoverable <- setdiff( + names(colonyVars), + c("covEQueenWorker", "corEQueenWorker") + ) + # Numerical equality allows floating-point rounding in the inverse + expect_equal(indVars[recoverable], colonyVars[recoverable]) + + # Changing within-bee corE must leave colony components unchanged + if (is.null(referenceColony)) { + referenceColony <- colonyVars[recoverable] + } else { + expect_equal(colonyVars[recoverable], referenceColony) + } + } + } + } +}) + +test_that("colony-to-individual round trip recovers the supplied colony components", { + for (workersFUN in c("sum", "mean")) { + for (workerAllocation in c("random", "balanced")) { + # Start with colony inputs, independently of the forward mapping + colonyArgs <- list( + varAQueen = 1, + varAWorkerGroup = 1, + corAQueenWorkerGroup = -0.5, + varEQueen = 1, + varEWorkerGroup = 1, + corEQueenWorkerGroup = 0, + nW = if (workerAllocation == "balanced") 120 else 100, + nF = 15, + nDPQ = 5, + workersFUN = workersFUN, + workerAllocation = workerAllocation + ) + indVars <- do.call(mapColonyToIndVar, colonyArgs) + expect_identical(indVars$covEQueenWorker, NA_real_) + expect_identical(indVars$corEQueenWorker, NA_real_) + + # The within-bee environmental assumption does not affect colony values + for (corE in c(0, 0.7)) { + indArgs <- indVars[names(formals(mapIndToColonyVar))] + indArgs$corEQueenWorker <- corE + colonyVars <- do.call(mapIndToColonyVar, indArgs) + + expect_equal(colonyVars[names(colonyArgs)], colonyArgs) + expect_equal(colonyVars$covAQueenWorkerGroup, -0.5) + expect_equal(colonyVars$varAColony, 1) + expect_equal(colonyVars$covEQueenWorkerGroup, 0) + expect_equal(colonyVars$varEColony, 2) + expect_equal(colonyVars$corEQueenWorker, corE) + expect_equal( + colonyVars$covEQueenWorker, + corE * sqrt(indVars$varEQueen * indVars$varEWorker) + ) + recoverable <- setdiff( + names(indVars), + c("covEQueenWorker", "corEQueenWorker") + ) + expect_identical(names(colonyVars), names(indVars)) + expect_equal(colonyVars[recoverable], indVars[recoverable]) + } + } + } +}) diff --git a/vignettes/A_Honeybee_biology.Rmd b/vignettes/A_Honeybee_biology.Rmd index 85cc1c3f..8241c168 100644 --- a/vignettes/A_Honeybee_biology.Rmd +++ b/vignettes/A_Honeybee_biology.Rmd @@ -2,6 +2,7 @@ title: "Honeybee biology" date: "`r Sys.Date()`" output: rmarkdown::html_vignette +bibliography: '`r normalizePath(if (file.exists("../inst/REFERENCES.bib")) "../inst/REFERENCES.bib" else system.file("REFERENCES.bib", package = "SIMplyBee", mustWork = TRUE), mustWork = TRUE)`' vignette: > %\VignetteIndexEntry{Honeybee biology} %\VignetteEngine{knitr::rmarkdown} @@ -57,10 +58,8 @@ approach only for demonstrations and testing. Alternatively, you can more accurately simulate honeybee genomes with SIMplyBee's `simulateHoneyBeeGenomes()`. This function simulates the honeybee -genome using coalescent simulation of whole chromosomes using MaCS (Chen et al., -2009) for three subspecies: *A. m. ligustica*, *A. m. carnica*, and *A. m. -mellifera* according to the demographic model described by Wallberg et al. -(2014). +genome using coalescent simulation of whole chromosomes using MaCS [@chen2009Fast] for three subspecies: *A. m. ligustica*, *A. m. carnica*, and *A. m. +mellifera* according to the demographic model described by @wallberg2014Worldwide. As a demonstration, we will use `quickHaplo()` and simulate genomes of two founding individuals. In this example, the genomes will be represented by only @@ -416,12 +415,3 @@ getQueen(inbredColony)@misc ``` # References - -Chen G.K., Marjoram P., Wall J.D. (2009) Fast and flexible simulation of DNA -sequence data. Genome Research, 19(1):136--142. - - -Wallberg, A., Han, F., Wellhagen, G. et al. (2014) A worldwide survey of genome -sequence variation provides insight into the evolutionary history of the -honeybee Apis mellifera. Nature Genetics, 46:1081--1088. - diff --git a/vignettes/C_Colony_events.Rmd b/vignettes/C_Colony_events.Rmd index 39374f33..8a56c309 100644 --- a/vignettes/C_Colony_events.Rmd +++ b/vignettes/C_Colony_events.Rmd @@ -2,6 +2,7 @@ title: "Colony events" date: "`r Sys.Date()`" output: rmarkdown::html_vignette +bibliography: '`r normalizePath(if (file.exists("../inst/REFERENCES.bib")) "../inst/REFERENCES.bib" else system.file("REFERENCES.bib", package = "SIMplyBee", mustWork = TRUE), mustWork = TRUE)`' vignette: > %\VignetteIndexEntry{Colony events} %\VignetteEngine{knitr::rmarkdown} @@ -59,7 +60,7 @@ When a honeybee colony outgrows its hive, becomes too congested, or too populated for the queen's pheromones to spread among workers, then the swarming begins. The workers start building swarm cells for new virgin queens. When the queen is ready, she leaves the hive and is followed by about 70% of the workers -in a massive cloud of flying bees, the swarm (Rangel and Seeley, 2012). The +in a massive cloud of flying bees, the swarm [@rangel2012Colony]. The swarm will cluster on a nearby tree or bush and remain there until they find a suitable new home. @@ -69,7 +70,7 @@ swarm. After few days, the new virgin queens begin to emerge. Typically, the first queen to emerge will kill the rest of virgin queens to assume the role as the new queen for the colony. She will then go on a mating flight to find drones to mate with to begin laying eggs and rebuilding the workforce in the colony -(Clemson Cooperative Extension, 2021; Rangel and Seeley, 2012). +[@clemson2020Frequently; @rangel2012Colony]. In SIMplyBee, function `swarm()` simulates swarming (Figure 1). The function takes a `Colony` class object and a percentage `p` of workers that leave with @@ -287,7 +288,7 @@ Supersedure is a replacement of the queen by one of her daughters without interference of the beekeeper. Supersedure is a natural way of re-queening a colony without swarming. There are many reasons for supersedure: poor physical condition of a queen, old age, diseases, depleted spermatheca, poorly bread -queen, reduced pheromone output and many others (Hamdan, 2010). +queen, reduced pheromone output and many others [@hamdan2010Natural]. Function `supersede()` removes the old queen and triggers the creation of new virgin queens from the brood (Figure 3). The function returns a single `Colony` @@ -362,15 +363,3 @@ apiary ``` # References - -Clemson Cooperative Extension (2021) Frequently asked questions about honey bee -swarms. - -(accessed on 2022-11-11) - -Hamdan K. (2010) Natural Supersedure of Queens in Honey Bee Colonies. Bee World, -87(3):52-54. - -Rangel J., Seeley T. D. (2012) Colony fissioning in honey bees: size and -significance of the swarm fraction. Insectes sociaux, 59(4):453-462. - diff --git a/vignettes/E_Genomics.Rmd b/vignettes/E_Genomics.Rmd index e138cd4a..9cc49847 100644 --- a/vignettes/E_Genomics.Rmd +++ b/vignettes/E_Genomics.Rmd @@ -2,6 +2,7 @@ title: "Genomics" date: "`r Sys.Date()`" output: rmarkdown::html_vignette +bibliography: '`r normalizePath(if (file.exists("../inst/REFERENCES.bib")) "../inst/REFERENCES.bib" else system.file("REFERENCES.bib", package = "SIMplyBee", mustWork = TRUE), mustWork = TRUE)`' vignette: > %\VignetteIndexEntry{Genomics} %\VignetteEngine{knitr::rmarkdown} @@ -243,7 +244,7 @@ Matrices (GRM) using SIMplyBee's `calcBeeGRMIbs()` and `calcBeeGRMIbd()`. Let's look at the `calcBeeGRMIbs()` first. This function returns a Genomic Relatedness Matrix (GRM) for honeybees from IBS genomic data (bi-allelic SNP represented as allele dosages) following the method for the sex X chromosome -(Druet and Legarra, 2020). +[@druet2020Theoretical]. To see this, let's obtain the genotypes and sex information of all individuals in the colony. @@ -315,9 +316,8 @@ Now lets look at `calcBeeGRMIbd()`. This function creates Genomic Relatedness Matrix (GRM) for honeybees based on Identical-By-Descent (IBD) information. It returns a list with a matrix of gametic relatedness coefficients (between genomes) and a matrix of individual relatedness coefficients (between -individuals). Please refer to Grossman and Eisen (1989), Fernando and Grossman -(1989), Fernando and Grossman (1990), Van Arendonk, Tier, and Kinghorn (1994), -and Hill and Weir (2011) for the background on this function. +individuals). Please refer to @grossman1989Inbreeding, @fernando1989Covariance, +@fernando1990Genetic, @vanarendonk1994Use, and @hill2011Variation for the background on this function. Now obtain the IBD haplotypes and compute IBD GRM. @@ -396,27 +396,3 @@ hist(GRMs$indiv[dI, qI], xlim = r) ``` # References - -Druet and Legarra (2020) Theoretical and empirical comparisons of expected and -realized relationships for the X-chromosome. Genetics Selection Evolution, -52:50. - -Grossman and Eisen (1989) Inbreeding, coancestry, and covariance between -relatives for X-chromosomal loci. The Journal of Heredity, 80(2):137--142. - - -Fernando and Grossman (1989) Covariance between relatives for X-chromosomal loci -in a population in disequilibrium. Theoretical and Applied Genetics, -77:311--319. - -Fernando and Grossman (1990) Genetic evaluation with autosomal and X-chromosomal -inheritance. Theoretical and Applied Genetics, 80:75--80. - - -Van Arendonk, Tier, and Kinghorn (1994) Use of multiple genetic markers in -prediction of breeding values. Genetics, 137(1):319--329. - - -Hill and Weir (2011) Variation in actual relationship as a consequence of -Mendelian sampling and linkage. Genetics Research, 93(1):47--64. - diff --git a/vignettes/F2_Variance_calculations.Rmd b/vignettes/F2_Variance_calculations.Rmd index 0d540d5c..40c758b3 100644 --- a/vignettes/F2_Variance_calculations.Rmd +++ b/vignettes/F2_Variance_calculations.Rmd @@ -2,6 +2,7 @@ title: "Variance calculations between individual and colony level values" date: "`r Sys.Date()`" output: rmarkdown::html_vignette +bibliography: '`r normalizePath(if (file.exists("../inst/REFERENCES.bib")) "../inst/REFERENCES.bib" else system.file("REFERENCES.bib", package = "SIMplyBee", mustWork = TRUE), mustWork = TRUE)`' vignette: > %\VignetteIndexEntry{VarianceCalculations} %\VignetteEngine{knitr::rmarkdown} @@ -19,50 +20,69 @@ knitr::opts_chunk$set( include = TRUE ) ``` + # Introduction of the problem -As seen in the quantitative genetics vignette, in SIMplyBee, traits are defined -and simulated at the individual (queen, worker, drone) level and mapped to -colony-level values. This requires specification of individual-level variances -and covariances for the queen and workers effects. However, in practice and -literature, we can obtain only colony-level values, and we would like to be able -to use these to inform the individual-level trait definitions. This requires -understanding how colony-level variances and covariances translate to + +As seen in the quantitative genetics vignette, in SIMplyBee, +traits are defined and simulated at the individual (queen, worker, drone) level and +mapped to colony-level values. +This requires specification of individual-level variances and covariances +for the queen and workers effects. +However, in practice and literature, we can obtain only colony-level values, and +we would like to be able to use these to inform the individual-level trait definitions. +This requires understanding how colony-level variances and covariances translate to individual-level variances and covariances, as well as vice-versa. This vignettes presents: -- the theory behind the relationship between individual-level and colony-level variances and covariances, +- the theory behind the relationship between individual-level and colony-level (co)variances, - the implementation of this theory in SIMplyBee, and - examples of implementation for when the workers's values are combined as a mean or a sum. # Theory: colony-level variance components -As seen in the quantitative genetics vignette, in SIMplyBee, traits are defined -and simulated at the individual (queen, worker, drone) level and mapped to -colony-level values. This requires specification of individual-level variances -and covariances for the queen and workers effects. However, in practice and -literature, we can obtain only colony-level values, and we would like to be able -to use these to inform the individual-level trait definitions. This requires -understanding how colony-level variances and covariances translate to -individual-level variances and covariances, as well as vice-versa. +The theory builds on prior work of @brascamp2014Methods and @brascamp2019Note. +Their worker-group mean and colony residual must be distinguished from +SIMplyBee's configurable worker aggregation and individual environmental deviations. -We will follow the example from Brascamp and Bijma (2019): +Both papers use the individual variance parameters below; +the worker-group variance of 0.32 and its comparison with 0.40 +under equilibrium relatedness come from the 2019 study. $\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_{g_w}^2=1.0$ - this is their $\sigma_{A_w}^2=1.0$ on the individual worker-trait scale $\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. +Equation (3) of @brascamp2019Note gives the relationship between +individual worker variance and worker-group mean variance. +In our notation, its finite-worker form and an equivalent rearrangement are: + +$$ +\sigma_{\bar{g}_w}^2 += \frac{1+(n_w-1)a_{ii}}{n_w}\sigma_{g_w}^2 += \left[a_{ii}+\frac{1-a_{ii}}{n_w}\right]\sigma_{g_w}^2 +\approx a_{ii}\sigma_{g_w}^2, +$$ + +where $n_w$ is the number of workers. +The paper writes the final approximation as an equality and +explains that it holds because the worker group is very large. +We retain the finite-worker term when simulating smaller groups. + +The coefficient $a_{ii}$ is the average additive genetic relationship between +two distinct workers in a colony and 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 distinct DPQs. +This relationship is given in Equation 4 of @brascamp2019Note, +derived from Equation 24 of @brascamp2014Methods +for a non-related and non-inbred population. + +TODO: At the moment we ignore the $a_{ss}$ part in this example by assuming unrelated DPQs. $\sigma_{{g_q},{g_w}}=-0.35$ @@ -70,31 +90,39 @@ $\sigma_{P}^2 = \sigma_{\bar{g}_w^w}^2 + \sigma_{g_q^q}^2 + 2*\sigma_{\bar{g}_w^ $\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^2=(a_{base}\sigma_{g,w}^2 + \sigma_{{g,w},{g,q}} + \sigma_{g,q}^2)/\sigma_{p,c}^2\approx0.19$ + +Here $a_{base}=0.32$, +so the large-worker-group genetic variance is $0.5+0.32-0.35=0.47$ and +phenotypic variance is $2.47$. +This variance ratio is distinct from $T^2$, the heritable-variation ratio below. $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^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$ +$r_g = cor(g_w, g_q) \approx -0.50$ (the covariance above is rounded). TODO: show sensitivity to the number of workers - the larger the number of -workers, the smaller the variance between workers +workers, the smaller the variance of the worker mean (towards a nonzero relatedness limit) $covA[1, 1] + nW * covA[2, 2] + 2 * k * covA[1, 2]$ -Let's run again the example from the quantitative genetics vignette to have some -data to work with. In this example, we assumed that the contribution of workers -was summed up to obtain the combined colony-level worker contribution. -Accordingly, the variance for the worker trait was naively scaled by -$1/nWorkers$, which assumed that workers' contributions were independent. What -does this give us? +Let's run again the example from the quantitative genetics vignette +to have some data to work with. +In this example, +we assumed that the contribution of workers was summed up +to obtain the combined colony-level worker contribution. +Accordingly, +the variance for the worker trait was naively scaled by $1/nWorkers$, +which assumed that workers' contributions were independent. +What does this give us? ```{r load_variance_scripts, include = FALSE} # load shared variance helper functions for this vignette @@ -110,13 +138,13 @@ 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, +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(3.0, 0.3, - 0.3, 3.0), nrow = 2, byrow = TRUE) +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) drones <- createDrones(x = basePop[1:5], nInd = 3) @@ -140,7 +168,7 @@ 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! Also, if we naively compute the expected colony-level variances based on our assumptions of worker-independence when -setting individual-level variances, we get: +setting individual-level variances, we get: ```{r variance_expectation} (covA <- corA * outer(X = sqrt(varA), Y = sqrt(varA), FUN = "*")) @@ -347,7 +375,7 @@ Is this correct? nW * nW (a <- nW * nW / nF) (b <- (nF - 1) * nW * nW / nF) -a+b +a+b #TODO define nDPQ ``` @@ -480,14 +508,14 @@ And very close for phenotypic too, but we need to check some part above! We have developed a set of functions that use the theory explained above to: (i) calculate expected colony-level variances and covariances based on the provided individual-level variances and covariances: `mapIndToColonyVar()` -(ii) calculate the required individual-level variances and covariances to achieve the desired +(ii) calculate the required individual-level variances and covariances to achieve the desired colony-level variances and covariances: `mapColonyToIndVar()` # Example: summarising worker effects as a sum Let's see how these work in practice. We will use the same example as above, so let's just recall what values we've set. -Note again, that we are summarising the workers' effects as a sum, so we naively set the individual-level variance for the worker effect -to be $1/nWorkers$ of the desired colony-level variance for the worker effect. +Note again, that we are summarising the workers' effects as a sum, so we naively set the individual-level variance for the worker effect +to be $1/nWorkers$ of the desired colony-level variance for the worker effect. Let's start off with a fresh simulation. @@ -497,12 +525,12 @@ 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, +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(3.0, 0.3, +corE <- matrix(data = c(3.0, 0.3, 0.3, 3.0), nrow = 2, byrow = TRUE) SP$setVarE(varE = varE, corE = corE) basePop <- createVirginQueens(founderGenomes, n = 20) @@ -520,7 +548,7 @@ apiary <- buildUp(apiary) Now, let's compute the corresponding colony-level variances and covariances using the `mapIndToColonyVar()` function. ```{r mapIndToColonyVar_sum} # When the function to summarise worker effects is SUM -calcColonyValues <- mapIndToColonyVar(varA_q = varA[1], +calcColonyValues <- mapIndToColonyVar(varA_q = varA[1], varA_w= varA[2], corA_qw = corA[1, 2], varE_q = varE[1], @@ -534,9 +562,9 @@ calcColonyValues$varA_c colonyGv <- calcColonyGv(apiary, FUN = mapCasteToColonyGv, workersFUN = colSums) var(colonyGv) ``` -We see that the realised and calculated colony-level variances match quite closely. +We see that the realised and calculated colony-level variances match quite closely. -Now, let's do it the other way around. This is a more realistic scenario since you would normally obtain +Now, let's do it the other way around. This is a more realistic scenario since you would normally obtain the colony-level variances and covariances from the literature and would want to recreate them using simulation. Here, we assume, you obtain a separate estimate for the queen and for the worker trait. Let's say we want to achieve the following colony-level variances and covariances: @@ -553,8 +581,8 @@ nW <- 100 nF <- 15 nDPQ <- 5 -calcIndValues <- 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, +calcIndValues <- 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 = "sum") ``` Now, let's use these calculated individual-level variances and covariances to simulate a new population and check if we achieve the desired colony-level variances and covariances. @@ -608,7 +636,7 @@ real_varE_c <- popVar(real_E_c) variances <- data.frame(set_varA_q = varA_q, real_varA_q = real_varA_q[1,1], set_varA_wbar = varA_wbar, real_varA_wbar = real_varA_wbar[1,1], - real_varA_c = real_varA_c[1,1], + real_varA_c = real_varA_c[1,1], set_varE_q = varE_q, real_varE_q = real_varE_q[1,1], set_varE_wbar = varE_wbar, real_varE_wbar = real_varE_wbar[1,1], real_varE_c = real_varE_c[1,1], @@ -628,12 +656,12 @@ variancesLong |> filter(VarTypePlot %in% c("varA_q", "varA_wbar", "varE_q", "v ggplot(aes(x = VarTypePlot, y = Var, fill = RealCalc)) + geom_col(position = "dodge") + facet_wrap(. ~fun, scales = "free") + - theme_bw(base_size = 20) + + theme_bw(base_size = 20) + scale_fill_manual(values = c("#D55E00", "#084159")) # one color per RealCalc level (set/real) ``` As we see, we are pretty much on point with matching the desired values! There is of course the element of stochasticity and -the limited samples size. +the limited samples size. # Example: summarising worker effects as a mean @@ -647,12 +675,12 @@ SP <- SimParamBee$new(founderGenomes) nQtlPerChr <- 100 mean <- c(10, 10) varA <- c(1, 1) -corA <- matrix(data = c( 1.0, -0.5, +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(3.0, 0.3, +corE <- matrix(data = c(3.0, 0.3, 0.3, 3.0), nrow = 2, byrow = TRUE) SP$setVarE(varE = varE, corE = corE) basePop <- createVirginQueens(founderGenomes, n = 20) @@ -670,7 +698,7 @@ apiary <- buildUp(apiary) Let's again compute the corresponding colony-level variances and covariances using the `mapIndToColonyVar()` function. ```{r mapIndToColonyVar_mean} # When the function to summarise worker effects is MEAN -calcColonyValues <- mapIndToColonyVar(varA_q = varA[1], +calcColonyValues <- mapIndToColonyVar(varA_q = varA[1], varA_w= varA[2], corA_qw = corA[1, 2], varE_q = varE[1], @@ -684,12 +712,12 @@ calcColonyValues$varA_c colonyGv <- calcColonyGv(apiary, FUN = mapCasteToColonyGv, workersFUN = colMeans) var(colonyGv) ``` -We again see that the realised and calculated colony-level variances match very closely. +We again see that the realised and calculated colony-level variances match very closely. And for the other way around: ```{r mapColonyToIndVar_mean} -calcIndValues <- 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, +calcIndValues <- 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 = "sum") ``` Now, let's use these calculated individual-level variances and covariances to simulate a new population and check if we achieve the desired colony-level variances and covariances. @@ -743,7 +771,7 @@ real_varE_c <- popVar(real_E_c) variances <- data.frame(set_varA_q = varA_q, real_varA_q = real_A_q[1,1], set_varA_wbar = varA_wbar, real_varA_wbar = real_varA_wbar[1,1], - real_varA_c = real_varA_c[1,1], + real_varA_c = real_varA_c[1,1], set_varE_q = varE_q, real_varE_q = real_varE_q[1,1], set_varE_wbar = varE_wbar, real_varE_wbar = real_varE_wbar[1,1], real_varE_c = real_varE_c[1,1], @@ -763,7 +791,8 @@ variancesLong |> filter(VarTypePlot %in% c("varA_q", "varA_wbar", "varE_q", "v ggplot(aes(x = VarTypePlot, y = Var, fill = RealCalc)) + geom_col(position = "dodge") + facet_wrap(. ~fun, scales = "free") + - theme_bw(base_size = 20) + + theme_bw(base_size = 20) + scale_fill_manual(values = c("#D55E00", "#084159")) # one color per RealCalc level (set/real) ``` +# References diff --git a/vignettes/F_Quantitative_Genetics.Rmd b/vignettes/F_Quantitative_Genetics.Rmd index b9706671..16ee529d 100644 --- a/vignettes/F_Quantitative_Genetics.Rmd +++ b/vignettes/F_Quantitative_Genetics.Rmd @@ -2,6 +2,7 @@ title: "Quantitative genetics" date: "`r Sys.Date()`" output: rmarkdown::html_vignette +bibliography: '`r normalizePath(if (file.exists("../inst/REFERENCES.bib")) "../inst/REFERENCES.bib" else system.file("REFERENCES.bib", package = "SIMplyBee", mustWork = TRUE), mustWork = TRUE)`' vignette: > %\VignetteIndexEntry{Quantitative genetics} %\VignetteEngine{knitr::rmarkdown} @@ -124,7 +125,7 @@ all the other trait simulation options in AlphaSimR via: `vignette(topic = "traits", package="AlphaSimR")`. ```{r SimParamBee_corA_and_addTrait} -corA <- matrix(data = c( 1.0, -0.5, +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")) @@ -139,7 +140,7 @@ simulation scenarios of interest. ```{r SimParamBee_varE_and_corR} 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) ``` @@ -436,9 +437,9 @@ nQtlPerChr <- 100 # Quantitative genetic parameters - for two traits, each with the queen and workers effects meanP <- c(10, 10 / SP$nWorkers, 0, 0) varA <- c(1, 1 / SP$nWorkers, 1, 1 / SP$nWorkers) -corA <- matrix(data = c( 1.0, -0.5, 0.0, 0.0, +corA <- matrix(data = c( 1.0, -0.5, 0.0, 0.0, -0.5, 1.0, 0.0, 0.0, - 0.0, 0.0, 1.0, -0.4, + 0.0, 0.0, 1.0, -0.4, 0.0, 0.0, -0.4, 1.0), nrow = 4, byrow = TRUE) SP$addTraitA(nQtlPerChr = 100, mean = meanP, var = varA, corA = corA, name = c("yieldQueenTrait", "yieldWorkersTrait", @@ -568,7 +569,7 @@ nWorkers <- 100 mean <- c(nWorkers, 10, 10 / nWorkers) varA <- c(25, 1, 1 / nWorkers) corA <- matrix(data = c(1.0, 0.0, 0.0, - 0.0, 1.0, -0.5, + 0.0, 1.0, -0.5, 0.0, -0.5, 1.0), nrow = 3, byrow = TRUE) SP$addTraitA(nQtlPerChr = 100, mean = mean, var = varA, corA = corA, name = c("fecundityQueenTrait", "yieldQueenTrait", "yieldWorkersTrait")) diff --git a/vignettes/colony_variance_theory_plan.md b/vignettes/colony_variance_theory_plan.md deleted file mode 100644 index 2e0a0e02..00000000 --- a/vignettes/colony_variance_theory_plan.md +++ /dev/null @@ -1,364 +0,0 @@ -# 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 662047d580690d7a8bd60089b16c1fa2109a8fee Mon Sep 17 00:00:00 2001 From: gregorgorjanc Date: Wed, 30 Sep 2026 09:47:36 +0000 Subject: [PATCH 67/98] Update documentation --- DESCRIPTION | 1 - NAMESPACE | 36 +-- man/MultiColony-class.Rd | 12 +- man/SIMplyBee-package.Rd | 1 + man/SimParamBee.Rd | 514 +++++++++++++++++++-------------------- 5 files changed, 273 insertions(+), 291 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 36cfce13..a636f5e4 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -40,4 +40,3 @@ Config/Needs/website: tidyverse/tidytemplate VignetteBuilder: knitr Config/roxygen2/version: 8.1.0 RdMacros: Rdpack -RoxygenNote: 7.3.3 diff --git a/NAMESPACE b/NAMESPACE index 3d4fa682..e400fa59 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -211,21 +211,25 @@ importFrom(R6,R6Class) importFrom(Rdpack,reprompt) importFrom(extraDistr,rtpois) importFrom(future.apply,future_lapply) -importFrom(methods,"slot<-") -importFrom(methods,classLabel) -importFrom(methods,is) -importFrom(methods,new) -importFrom(methods,setClass) -importFrom(methods,setClassUnion) -importFrom(methods,setMethod) -importFrom(methods,setValidity) -importFrom(methods,show) -importFrom(methods,slot) -importFrom(methods,validObject) -importFrom(stats,na.omit) -importFrom(stats,rbeta) -importFrom(stats,rnorm) -importFrom(stats,rpois) -importFrom(stats,runif) +importFrom(methods, + "slot<-", + classLabel, + is, + new, + setClass, + setClassUnion, + setMethod, + setValidity, + show, + slot, + validObject +) +importFrom(stats, + na.omit, + rbeta, + rnorm, + rpois, + runif +) importFrom(utils,packageVersion) useDynLib(SIMplyBee, .registration = TRUE) diff --git a/man/MultiColony-class.Rd b/man/MultiColony-class.Rd index d81e7d6f..6be082c7 100644 --- a/man/MultiColony-class.Rd +++ b/man/MultiColony-class.Rd @@ -70,17 +70,17 @@ An object holding a collection of honeybee colonies. It behaves \item \code{c(MultiColonyOrNULL)}: Combine multiple Colony and MultiColony objects -\item \code{x[i}: Extract a colony (one or more!) with an integer/numeric/logical index (position) (return \code{\link[SIMplyBee]{MultiColony-class}}) +\item \code{x = MultiColony[i = integerOrNumericOrLogical]}: Extract a colony (one or more!) with an integer/numeric/logical index (position) (return \code{\link[SIMplyBee]{MultiColony-class}}) -\item \code{x[i}: Extract a colony (one or more!) with a character ID (name) (return \code{\link[SIMplyBee]{MultiColony-class}}) +\item \code{x = MultiColony[i = character]}: Extract a colony (one or more!) with a character ID (name) (return \code{\link[SIMplyBee]{MultiColony-class}}) -\item \code{x[[i}: Extract a colony (just one!) with an integer/numeric/logical index (position) (return \code{\link[SIMplyBee]{Colony-class}}) +\item \code{x = MultiColony[[i = integerOrNumericOrLogical]]}: Extract a colony (just one!) with an integer/numeric/logical index (position) (return \code{\link[SIMplyBee]{Colony-class}}) -\item \code{x[[i}: Extract a colony (just one!) with a character ID (name) (return \code{\link[SIMplyBee]{Colony-class}}) +\item \code{x = MultiColony[[i = character]]}: Extract a colony (just one!) with a character ID (name) (return \code{\link[SIMplyBee]{Colony-class}}) -\item \code{`[`(x = MultiColony, i = integerOrNumericOrLogicalOrCharacter, j = ANY) <- value}: Assign colonies into MultiColony +\item \code{x = MultiColony[i = integerOrNumericOrLogicalOrCharacter, j = ANY] <- value}: Assign colonies into MultiColony -\item \code{`[[`(x = MultiColony, i = integerOrNumericOrLogicalOrCharacter, j = ANY) <- value}: Assign Colony into MultiColony +\item \code{x = MultiColony[[i = integerOrNumericOrLogicalOrCharacter, j = ANY]] <- value}: Assign Colony into MultiColony }} \section{Slots}{ diff --git a/man/SIMplyBee-package.Rd b/man/SIMplyBee-package.Rd index 02b01c03..99748e94 100644 --- a/man/SIMplyBee-package.Rd +++ b/man/SIMplyBee-package.Rd @@ -37,6 +37,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 79b873f7..dad6b6eb 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) @@ -92,9 +92,9 @@ SP$caste \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}}. @@ -116,7 +116,7 @@ SP$caste 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}}. @@ -138,7 +138,7 @@ SP$caste 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}}. @@ -160,7 +160,7 @@ SP$caste 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}}. @@ -182,7 +182,7 @@ SP$caste 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}}. @@ -203,7 +203,7 @@ SP$caste 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. @@ -212,7 +212,7 @@ SP$caste 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}}. @@ -233,7 +233,7 @@ SP$caste 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}}. @@ -254,7 +254,7 @@ SP$caste 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}}. @@ -266,100 +266,99 @@ SP$caste 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, @@ -373,99 +372,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) @@ -479,35 +460,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 @@ -519,140 +498,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{
    }} -} -} } From c7ba958c4fa46b2c5022298ec944f1e32f122ec3 Mon Sep 17 00:00:00 2001 From: Gregor Gorjanc Date: Wed, 30 Sep 2026 10:47:28 +0100 Subject: [PATCH 68/98] Exclude AGENTS.md from R package builds --- .Rbuildignore | 1 + 1 file changed, 1 insertion(+) diff --git a/.Rbuildignore b/.Rbuildignore index 23c49595..19126c11 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -6,6 +6,7 @@ ^\.gitignore ^[.]?air[.]toml$ ^[.]?jarl[.]toml$ +^AGENTS\.md$ ^_pkgdown\.yml ^cran-comments\.html$ ^cran-comments\.md$ From 6c4d9df0a271f5ca64753dec174d2da4232cee32 Mon Sep 17 00:00:00 2001 From: Gregor Gorjanc Date: Wed, 30 Sep 2026 13:29:56 +0100 Subject: [PATCH 69/98] Added h2 to mapping output --- R/Functions_L0_auxilary.R | 26 +++++++++-- man/mapIndToColonyVar.Rd | 18 ++++++-- tests/testthat/test-variance-mapping.R | 63 ++++++++++++++++++++++++++ 3 files changed, 99 insertions(+), 8 deletions(-) diff --git a/R/Functions_L0_auxilary.R b/R/Functions_L0_auxilary.R index 96906a1a..487b0609 100644 --- a/R/Functions_L0_auxilary.R +++ b/R/Functions_L0_auxilary.R @@ -6686,6 +6686,16 @@ covVar2Cor <- function(covariance, variance1, variance2) { #' \item \code{varAColony} and \code{varEColony}: additive genetic #' and environmental variance of colony values. #' Each is the sum of the queen and worker-group variances plus twice their covariance. +#' \item \code{h2Queen}: \code{varAQueen / (varAQueen + varEQueen)}, +#' heritability of the queen-effect trait among individual bees. +#' \item \code{h2Worker}: \code{varAWorker / (varAWorker + varEWorker)}, +#' heritability of the worker-effect trait among individual bees. +#' \item \code{h2WorkerGroup}: \code{varAWorkerGroup / (varAWorkerGroup + varEWorkerGroup)}, +#' heritability of the aggregated worker-effect trait among colonies. +#' \item \code{h2Colony}: \code{varAColony / (varAColony + varEColony)}, +#' heritability of colony values, including genetic covariance between +#' queen's queen trait and worker-group's worker trait in \code{varAColony}. +#' All four heritabilities are \code{NA} when their denominator is zero. #' } #' #' Covariances are not multiplied by two. @@ -6747,8 +6757,8 @@ covVar2Cor <- function(covariance, variance1, variance2) { #' #' # Mapping individual vars to colony with worker group mean #' (colonyVars <- mapIndToColonyVar( -#' varAQueen = 1, varAWorker = 1, corAQueenWorker = -0.5, -#' varEQueen = 1, varEWorker = 1, corEQueenWorker = 0, +#' varAQueen = 2, varAWorker = 0.01, corAQueenWorker = -0.5, +#' varEQueen = 3, varEWorker = 0.02, corEQueenWorker = 0.3, #' nW = nW, nF = nF, nDPQ = nDPQ, workersFUN = "mean")) #' # ... and inverse #' (indVars <- do.call(mapColonyToIndVar, @@ -6756,8 +6766,8 @@ covVar2Cor <- function(covariance, variance1, variance2) { #' #' # Mapping colony vars with worker group sum to individual vars #' (indVars <- mapColonyToIndVar( -#' varAQueen = 1, varAWorkerGroup = 1, corAQueenWorkerGroup = -0.5, -#' varEQueen = 1, varEWorkerGroup = 1, corEQueenWorkerGroup = 0, +#' varAQueen = 2, varAWorkerGroup = 0.01, corAQueenWorkerGroup = -0.5, +#' varEQueen = 3, varEWorkerGroup = 0.02, corEQueenWorkerGroup = 0.0, #' nW = nW, nF = nF, nDPQ = nDPQ, workersFUN = "sum")) #' # ... and back to colony components, assuming zero within-bee #' # environmental correlation (not identified by the inverse mapping). @@ -6801,6 +6811,10 @@ mapIndToColonyVar <- function(varAQueen, varAWorker, corAQueenWorker, covEQueenWorkerGroup = covEQueenWorkerGroup, corEQueenWorkerGroup = corEQueenWorkerGroup, varEColony = varEColony, + h2Queen = if (varAQueen + varEQueen == 0) NA_real_ else varAQueen / (varAQueen + varEQueen), + h2Worker = if (varAWorker + varEWorker == 0) NA_real_ else varAWorker / (varAWorker + varEWorker), + h2WorkerGroup = if (varAWorkerGroup + varEWorkerGroup == 0) NA_real_ else varAWorkerGroup / (varAWorkerGroup + varEWorkerGroup), + h2Colony = if (varAColony + varEColony == 0) NA_real_ else varAColony / (varAColony + varEColony), nW = nW, nF = nF, nDPQ = nDPQ, @@ -6862,6 +6876,10 @@ mapColonyToIndVar <- function(varAQueen, varAWorkerGroup, corAQueenWorkerGroup, covEQueenWorkerGroup = covEQueenWorkerGroup, corEQueenWorkerGroup = corEQueenWorkerGroup, varEColony = varEColony, + h2Queen = if (varAQueen + varEQueen == 0) NA_real_ else varAQueen / (varAQueen + varEQueen), + h2Worker = if (varAWorker + varEWorker == 0) NA_real_ else varAWorker / (varAWorker + varEWorker), + h2WorkerGroup = if (varAWorkerGroup + varEWorkerGroup == 0) NA_real_ else varAWorkerGroup / (varAWorkerGroup + varEWorkerGroup), + h2Colony = if (varAColony + varEColony == 0) NA_real_ else varAColony / (varAColony + varEColony), nW = nW, nF = nF, nDPQ = nDPQ, diff --git a/man/mapIndToColonyVar.Rd b/man/mapIndToColonyVar.Rd index 535dc7fb..c77073b0 100644 --- a/man/mapIndToColonyVar.Rd +++ b/man/mapIndToColonyVar.Rd @@ -125,6 +125,16 @@ Both functions return a flat list with the same named components. \item \code{varAColony} and \code{varEColony}: additive genetic and environmental variance of colony values. Each is the sum of the queen and worker-group variances plus twice their covariance. + \item \code{h2queen}: \code{varAQueen / (varAQueen + varEQueen)}, + heritability of the queen-effect trait among individual bees. + \item \code{h2worker}: \code{varAWorker / (varAWorker + varEWorker)}, + heritability of the worker-effect trait among individual bees. + \item \code{h2workerGroup}: \code{varAWorkerGroup / (varAWorkerGroup + varEWorkerGroup)}, + heritability of the aggregated worker-effect trait among colonies. + \item \code{h2colony}: \code{varAColony / (varAColony + varEColony)}, + heritability of colony values, including genetic covariance between + queen's queen trait and worker-group's worker trait in \code{varAColony}. + All four heritabilities are \code{NA} when their denominator is zero. } Covariances are not multiplied by two. @@ -194,8 +204,8 @@ nDPQ <- 5 # Mapping individual vars to colony with worker group mean (colonyVars <- mapIndToColonyVar( - varAQueen = 1, varAWorker = 1, corAQueenWorker = -0.5, - varEQueen = 1, varEWorker = 1, corEQueenWorker = 0, + varAQueen = 2, varAWorker = 0.01, corAQueenWorker = -0.5, + varEQueen = 3, varEWorker = 0.02, corEQueenWorker = 0.3, nW = nW, nF = nF, nDPQ = nDPQ, workersFUN = "mean")) # ... and inverse (indVars <- do.call(mapColonyToIndVar, @@ -203,8 +213,8 @@ nDPQ <- 5 # Mapping colony vars with worker group sum to individual vars (indVars <- mapColonyToIndVar( - varAQueen = 1, varAWorkerGroup = 1, corAQueenWorkerGroup = -0.5, - varEQueen = 1, varEWorkerGroup = 1, corEQueenWorkerGroup = 0, + varAQueen = 2, varAWorkerGroup = 0.01, corAQueenWorkerGroup = -0.5, + varEQueen = 3, varEWorkerGroup = 0.02, corEQueenWorkerGroup = 0, nW = nW, nF = nF, nDPQ = nDPQ, workersFUN = "sum")) # ... and back to colony components, assuming zero within-bee # environmental correlation (not identified by the inverse mapping). diff --git a/tests/testthat/test-variance-mapping.R b/tests/testthat/test-variance-mapping.R index 519552e8..31eff40c 100644 --- a/tests/testthat/test-variance-mapping.R +++ b/tests/testthat/test-variance-mapping.R @@ -102,3 +102,66 @@ test_that("colony-to-individual round trip recovers the supplied colony componen } } }) + + +test_that("mapping heritabilities distinguish worker groups and include colony covariance", { + colonyVars <- mapIndToColonyVar( + varAQueen = 1, + varAWorker = 1, + corAQueenWorker = -0.5, + varEQueen = 1, + varEWorker = 1, + corEQueenWorker = 0, + nW = 100, + nF = 15, + nDPQ = 5, + workersFUN = "mean" + ) + indVars <- do.call( + mapColonyToIndVar, + colonyVars[names(formals(mapColonyToIndVar))] + ) + for (result in list(colonyVars, indVars)) { + expect_equal(result$h2Queen, 0.5) + expect_equal(result$h2Worker, 0.5) + # Worker-group VarA = 0.3235 and VarE = 0.01; individual heritability is 0.5. + expect_equal(result$h2WorkerGroup, 0.3235 / (0.3235 + 0.01)) + # Colony VarA = 1 + 0.3235 - 0.5 = 0.8235 and VarE = 1.01. + expect_equal(result$h2Colony, 0.8235 / (0.8235 + 1.01)) + } +}) + +test_that("mapping heritabilities handle zero genetic and environmental variances", { + for (varA in c(0, 1)) { + for (varE in c(0, 1)) { + colonyVars <- mapIndToColonyVar( + varAQueen = varA, + varAWorker = varA, + corAQueenWorker = 0, + varEQueen = varE, + varEWorker = varE, + corEQueenWorker = 0, + nW = 1, + nF = 1, + nDPQ = 1 + ) + indVars <- do.call( + mapColonyToIndVar, + colonyVars[names(formals(mapColonyToIndVar))] + ) + expected <- if (varA == 0 && varE == 0) { + NA_real_ + } else if (varA == varE) { + 0.5 + } else { + varA + } + for (result in list(colonyVars, indVars)) { + expect_identical(result$h2Queen, expected) + expect_identical(result$h2Worker, expected) + expect_identical(result$h2WorkerGroup, expected) + expect_identical(result$h2Colony, expected) + } + } + } +}) From 946a8f02a8d9463ffb50a70ca2234cfbdeb11d3a Mon Sep 17 00:00:00 2001 From: Gregor Gorjanc Date: Wed, 30 Sep 2026 14:08:51 +0100 Subject: [PATCH 70/98] Docs --- man/mapIndToColonyVar.Rd | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/man/mapIndToColonyVar.Rd b/man/mapIndToColonyVar.Rd index c77073b0..3d43235f 100644 --- a/man/mapIndToColonyVar.Rd +++ b/man/mapIndToColonyVar.Rd @@ -125,13 +125,13 @@ Both functions return a flat list with the same named components. \item \code{varAColony} and \code{varEColony}: additive genetic and environmental variance of colony values. Each is the sum of the queen and worker-group variances plus twice their covariance. - \item \code{h2queen}: \code{varAQueen / (varAQueen + varEQueen)}, + \item \code{h2Queen}: \code{varAQueen / (varAQueen + varEQueen)}, heritability of the queen-effect trait among individual bees. - \item \code{h2worker}: \code{varAWorker / (varAWorker + varEWorker)}, + \item \code{h2Worker}: \code{varAWorker / (varAWorker + varEWorker)}, heritability of the worker-effect trait among individual bees. - \item \code{h2workerGroup}: \code{varAWorkerGroup / (varAWorkerGroup + varEWorkerGroup)}, + \item \code{h2WorkerGroup}: \code{varAWorkerGroup / (varAWorkerGroup + varEWorkerGroup)}, heritability of the aggregated worker-effect trait among colonies. - \item \code{h2colony}: \code{varAColony / (varAColony + varEColony)}, + \item \code{h2Colony}: \code{varAColony / (varAColony + varEColony)}, heritability of colony values, including genetic covariance between queen's queen trait and worker-group's worker trait in \code{varAColony}. All four heritabilities are \code{NA} when their denominator is zero. From 8d83dd52bc030789a3566b12fe4d186722f69193 Mon Sep 17 00:00:00 2001 From: Gregor Gorjanc Date: Wed, 30 Sep 2026 14:11:58 +0100 Subject: [PATCH 71/98] Document heritability outputs in release notes --- NEWS.md | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/NEWS.md b/NEWS.md index 1d1b869c..cd2fbd4b 100644 --- a/NEWS.md +++ b/NEWS.md @@ -31,6 +31,10 @@ is the number of viable workers. - the 'cross' function now removes unsuccessfully mated queens. This can primarily happen when creating a spatial cross plan. If there are no drone producing colonies in the specified radius, the mating fails and the queens/colonies are removed from the object. This is to ensure all further functionality works well. ## New features + +- Both variance mappings now return `h2Queen`, `h2Worker`, + `h2WorkerGroup`, and `h2Colony`, with `NA` for zero total variance. + - added functionality to map individual-level variance to colony-level variance and vice-versa with functions 'mapIndToColonyVar' and 'mapColonyToIndVar' From 69aa910617fad73223adceb3006f613174d3bfe9 Mon Sep 17 00:00:00 2001 From: gregorgorjanc Date: Wed, 30 Sep 2026 13:16:39 +0000 Subject: [PATCH 72/98] Update documentation --- man/mapIndToColonyVar.Rd | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/man/mapIndToColonyVar.Rd b/man/mapIndToColonyVar.Rd index 3d43235f..fa7dedab 100644 --- a/man/mapIndToColonyVar.Rd +++ b/man/mapIndToColonyVar.Rd @@ -214,7 +214,7 @@ nDPQ <- 5 # Mapping colony vars with worker group sum to individual vars (indVars <- mapColonyToIndVar( varAQueen = 2, varAWorkerGroup = 0.01, corAQueenWorkerGroup = -0.5, - varEQueen = 3, varEWorkerGroup = 0.02, corEQueenWorkerGroup = 0, + varEQueen = 3, varEWorkerGroup = 0.02, corEQueenWorkerGroup = 0.0, nW = nW, nF = nF, nDPQ = nDPQ, workersFUN = "sum")) # ... and back to colony components, assuming zero within-bee # environmental correlation (not identified by the inverse mapping). From 605301d5e7f2a33d3f59a63fede54af54c604a03 Mon Sep 17 00:00:00 2001 From: Gregor Gorjanc Date: Wed, 30 Sep 2026 18:41:26 +0100 Subject: [PATCH 73/98] Polish of various things (pHomBrood, etc.) --- DESCRIPTION | 1 + NAMESPACE | 36 +- NEWS.md | 28 +- R/Class-Colony.R | 10 +- R/Class-SimParamBee.R | 13 +- R/Functions_L0_auxilary.R | 90 +- R/Functions_L1_Pop.R | 31 +- R/Functions_L2_Colony.R | 2 +- man/MultiColony-class.Rd | 12 +- man/SIMplyBee-package.Rd | 1 - man/SimParamBee.Rd | 514 ++++---- man/calcQueensPHomBrood.Rd | 11 +- man/cross.Rd | 11 +- man/crossVirginQueen.Rd | 6 + man/getId.Rd | 15 +- man/nCaste.Rd | 7 +- man/splitPFun.Rd | 11 +- tests/testthat/test-L0_auxiliary_functions.R | 1234 +++++++++++++----- tests/testthat/test-L1_pop_functions.R | 2 +- vignettes/A_Honeybee_biology.Rmd | 2 +- vignettes/C_Colony_events.Rmd | 2 +- vignettes/E_Genomics.Rmd | 2 +- vignettes/F2_Variance_calculations.Rmd | 2 +- vignettes/F_Quantitative_Genetics.Rmd | 2 +- 24 files changed, 1366 insertions(+), 679 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index a636f5e4..36cfce13 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -40,3 +40,4 @@ Config/Needs/website: tidyverse/tidytemplate VignetteBuilder: knitr Config/roxygen2/version: 8.1.0 RdMacros: Rdpack +RoxygenNote: 7.3.3 diff --git a/NAMESPACE b/NAMESPACE index e400fa59..3d4fa682 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -211,25 +211,21 @@ importFrom(R6,R6Class) importFrom(Rdpack,reprompt) importFrom(extraDistr,rtpois) importFrom(future.apply,future_lapply) -importFrom(methods, - "slot<-", - classLabel, - is, - new, - setClass, - setClassUnion, - setMethod, - setValidity, - show, - slot, - validObject -) -importFrom(stats, - na.omit, - rbeta, - rnorm, - rpois, - runif -) +importFrom(methods,"slot<-") +importFrom(methods,classLabel) +importFrom(methods,is) +importFrom(methods,new) +importFrom(methods,setClass) +importFrom(methods,setClassUnion) +importFrom(methods,setMethod) +importFrom(methods,setValidity) +importFrom(methods,show) +importFrom(methods,slot) +importFrom(methods,validObject) +importFrom(stats,na.omit) +importFrom(stats,rbeta) +importFrom(stats,rnorm) +importFrom(stats,rpois) +importFrom(stats,runif) importFrom(utils,packageVersion) useDynLib(SIMplyBee, .registration = TRUE) diff --git a/NEWS.md b/NEWS.md index cd2fbd4b..d2c417f7 100644 --- a/NEWS.md +++ b/NEWS.md @@ -25,10 +25,17 @@ editor_options: - createMultiColony() no longer creates an empty apiary, but it adds empty colonies with IDs -- we no longer support creating an exact number of workers with the csd functionality turned on. Due to inbreeding at the csd locus, some workers are not viable. Previous funcionality re-ran the creation of workers until a required number was available. We no longer support this, so the number of returned workers -is the number of viable workers. - -- the 'cross' function now removes unsuccessfully mated queens. This can primarily happen when creating a spatial cross plan. If there are no drone producing colonies in the specified radius, the mating fails and the queens/colonies are removed from the object. This is to ensure all further functionality works well. +- we no longer support creating an exact number of workers with the csd + functionality turned on. Due to inbreeding at the csd locus, some workers + are not viable. Previous funcionality re-ran the creation of workers until + a required number was available. We no longer support this, so the number of + returned workers is the number of viable workers. + +- the 'cross' function now removes unsuccessfully mated queens. + This can primarily happen when creating a spatial cross plan. + If there are no drone producing colonies in the specified radius, + the mating fails and the queens/colonies are removed from the object. + This is to ensure all further functionality works well. ## New features @@ -49,6 +56,19 @@ is the number of viable workers. ## Bug fixes +- `calcQueensPHomBrood()`, `pHomBrood()`, and `nHomBrood()` now warn and + return `NA_real_` for queenless colonies, allowing `MultiColony` summaries + to continue. + +- `nFathers()` now lists all supported classes, including `Pop`, in its + invalid-input error message and documents queen population input. + +- Brood summaries now use numeric missing values and return `numeric(0)` + for empty populations. Inactive csd metadata also uses numeric missing + values. `getId(NULL)` now returns `NA_character_`. + +- Spotted a couple of cases where `SimParamBee` was not passed to the + calling functions. # SIMplyBee version 0.4.1 diff --git a/R/Class-Colony.R b/R/Class-Colony.R index d5fcff2b..1925698c 100644 --- a/R/Class-Colony.R +++ b/R/Class-Colony.R @@ -7,7 +7,10 @@ setClassUnion("logicalOrNULL", c("logical", "NULL")) setClassUnion("listOrNULL", c("list", "NULL")) setClassUnion("PopOrNULL", c("Pop", "NULL")) setClassUnion("NULLOrPop", c("NULL", "Pop")) -setClassUnion("integerOrNumericOrLogicalOrCharacter", c("integer", "numeric", "logical", "character")) +setClassUnion( + "integerOrNumericOrLogicalOrCharacter", + c("integer", "numeric", "logical", "character") +) #' @rdname Colony-class #' @title Honeybee colony @@ -95,7 +98,8 @@ setClassUnion("ColonyOrNULL", c("Colony", "NULL")) setValidity(Class = "Colony", method = function(object) { errors <- character() 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 + 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) { @@ -169,7 +173,7 @@ setMethod( signature(x = "NULLOrPop"), definition = function(x, ...) { if (is.null(x)) { - nList = length(list(...)) + nList <- length(list(...)) pop <- list(...)[[1]] if (nList > 1) { for (y in list(...)[[2:nList]]) { diff --git a/R/Class-SimParamBee.R b/R/Class-SimParamBee.R index 5445dbb5..e178e191 100644 --- a/R/Class-SimParamBee.R +++ b/R/Class-SimParamBee.R @@ -943,6 +943,8 @@ swarmPUnif <- function(x = NULL, n = 1, min = 0.4, max = 0.6) { #' @param nWorkersFull numeric, average number of workers in a full/strong #' colony for \code{splitPColonyStrength} (actual number can go beyond this #' value) +#' @param simParamBee \code{\link[SIMplyBee]{SimParamBee}}, simulation parameters +#' for \code{splitPColonyStrength} #' @param scale numeric, scaling of numbers in \code{splitPColonyStrength} #' to avoid to narrow range when colonies have a large number of bees (in that #' case change \code{nWorkersFull} too!) @@ -1014,13 +1016,14 @@ splitPUnif <- function(x = NULL, n = 1, min = 0.2, max = 0.4) { #' @describeIn splitPFun Sample the split proportion - the proportion of #' removed workers in a managed split based on the colony strength #' @export -splitPColonyStrength <- function(x, n = 1, nWorkersFull = 100, scale = 1) { +splitPColonyStrength <- function(x, n = 1, nWorkersFull = 100, scale = 1, + simParamBee = NULL) { if (isColony(x)) { n <- 1 } else if (isMultiColony(x)) { n <- nColonies(x) } - nW <- nWorkers(colony) + nW <- nWorkers(x, simParamBee = simParamBee) pKeep <- rbeta( n = n, shape1 = (nW + nWorkersFull) / scale, @@ -1214,7 +1217,7 @@ mapCasteToColonyValue <- function(x, if (is.null(queenTrait)) { queenEff <- 0 } else { - if (isQueenPresent(x)) { + if (isQueenPresent(x, simParamBee = simParamBee)) { if (value %in% c("pheno", "gv")) { tmp <- valueFUN(x@queen)[, queenTrait, drop = FALSE] } else { # bv, dd, and aa: leaving this in for future use! @@ -1228,7 +1231,7 @@ mapCasteToColonyValue <- function(x, if (is.null(workersTrait)) { workersEff <- 0 } else { - if (nWorkers(x) != 0) { + if (nWorkers(x, simParamBee = simParamBee) != 0) { if (value %in% c("pheno", "gv")) { tmp <- valueFUN(x@workers)[, workersTrait, drop = FALSE] } else { # bv, dd, and aa @@ -1242,7 +1245,7 @@ mapCasteToColonyValue <- function(x, if (is.null(dronesTrait)) { dronesEff <- 0 } else { - if (nDrones(x) != 0) { + if (nDrones(x, simParamBee = simParamBee) != 0) { if (value %in% c("pheno", "gv")) { tmp <- valueFUN(x@drones)[, dronesTrait, drop = FALSE] } else { # bv, dd, and aa diff --git a/R/Functions_L0_auxilary.R b/R/Functions_L0_auxilary.R index 487b0609..19d68054 100644 --- a/R/Functions_L0_auxilary.R +++ b/R/Functions_L0_auxilary.R @@ -81,7 +81,9 @@ nEmptyColonies <- function(multicolony) { #' #' @description Returns the number of individuals of a caste in a colony #' -#' @param x \code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}} +#' @param x \code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}}. +#' For \code{nFathers()}, also a \code{\link[AlphaSimR]{Pop-class}} +#' containing queens. #' @param caste character, "queen", "fathers", "workers", "drones", #' "virginQueens", or "all" #' @param simParamBee \code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters @@ -94,7 +96,8 @@ nEmptyColonies <- function(multicolony) { #' \code{caste != "all"} or list for \code{caste == "all"} with nodes named #' by caste; when \code{x} is \code{\link[SIMplyBee]{MultiColony-class}} return is named #' integer for \code{caste != "all"} or named list of lists for -#' \code{caste == "all"} +#' \code{caste == "all"}. For \code{nFathers()} with a queen population, +#' returns a numeric vector with one father count per queen. #' #' @examples #' founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) @@ -214,8 +217,10 @@ nFathers <- function(x, simParamBee = NULL) { ret[ind] <- nInd(x@misc$fathers[[ind]]) } } - } else { + } else if (isColony(x) || isMultiColony(x)) { ret <- nCaste(x, caste = "fathers", simParamBee = simParamBee) + } else { + stop("Argument x must be a Pop, Colony, or MultiColony class object!") } return(ret) } @@ -262,9 +267,13 @@ nVirginQueens <- function(x, simParamBee = NULL) { #' @seealso Demo in the introductory vignette #' \code{vignette("Honeybee_biology", package="SIMplyBee")} #' -#' @return numeric, expected csd homozygosity named by colony id when \code{x} -#' is \code{\link[SIMplyBee]{MultiColony-class}} -#' +#' @return Numeric brood proportions for \code{calcQueensPHomBrood()} and +#' \code{pHomBrood()}, or counts for \code{nHomBrood()}, named by colony ID +#' when \code{x} is \code{\link[SIMplyBee]{MultiColony-class}}. An empty +#' \code{\link[AlphaSimR]{Pop-class}} returns \code{numeric(0)}. Missing +#' brood proportions and counts are represented by \code{NA_real_}. +#' All three functions warn and return \code{NA_real_} for a colony without +#' a queen. #' #' @examples #' # This is a bit long example - the key is at the end! @@ -313,7 +322,7 @@ calcQueensPHomBrood <- function(x, simParamBee = NULL) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } if (isPop(x)) { - ret <- rep(x = NA, times = nInd(x)) + ret <- rep(x = NA_real_, times = nInd(x)) for (ind in seq_len(nInd(x))) { if (!(all(isQueen(x, simParamBee = simParamBee)))) { stop("calcQueensPHomBrood can only be used with queens!") @@ -331,9 +340,14 @@ calcQueensPHomBrood <- function(x, simParamBee = NULL) { } } } else if (isColony(x)) { - ret <- calcQueensPHomBrood(x = x@queen) + if (is.null(x@queen) || nInd(x@queen) == 0L) { + warning("Colony has no queen - returning NA!") + ret <- NA_real_ + } else { + ret <- calcQueensPHomBrood(x = x@queen, simParamBee = simParamBee) + } } else if (isMultiColony(x)) { - ret <- sapply(X = x@colonies, FUN = calcQueensPHomBrood) + ret <- sapply(X = x@colonies, FUN = calcQueensPHomBrood, simParamBee = simParamBee) names(ret) <- getId(x) } else { stop("Argument x must be a Pop, Colony, or MultiColony class object!") @@ -341,7 +355,7 @@ calcQueensPHomBrood <- function(x, simParamBee = NULL) { return(ret) } -#' @describeIn calcQueensPHomBrood Expected percentage of csd homozygous brood +#' @describeIn calcQueensPHomBrood Expected proportion of csd homozygous brood #' of a queen / colony #' @export pHomBrood <- function(x, simParamBee = NULL) { @@ -352,23 +366,29 @@ pHomBrood <- function(x, simParamBee = NULL) { if (any(!isQueen(x, simParamBee = simParamBee))) { stop("Individuals in x must be queens!") } - ret <- rep(x = NA, times = nInd(x)) + ret <- rep(x = NA_real_, times = nInd(x)) for (ind in seq_len(nInd(x))) { if (!is.null(x@misc$pHomBrood[[ind]])) { ret[ind] <- x@misc$pHomBrood[[ind]] } } } else if (isColony(x)) { - if (is.null(x@queen@misc$pHomBrood[[1]])) { - ret <- NA + if (is.null(x@queen) || nInd(x@queen) == 0L) { + warning("Colony has no queen - returning NA!") + ret <- NA_real_ } else { - ret <- x@queen@misc$pHomBrood[[1]] + if (is.null(x@queen@misc$pHomBrood[[1]])) { + ret <- NA_real_ + } else { + ret <- x@queen@misc$pHomBrood[[1]] + } } + } else if (isMultiColony(x)) { - ret <- sapply(X = x@colonies, FUN = pHomBrood) + ret <- sapply(X = x@colonies, FUN = pHomBrood, simParamBee = simParamBee) names(ret) <- getId(x) } else { - stop("Argument x must be a Colony or MultiColony class object!") + stop("Argument x must be a Pop, Colony, or MultiColony class object!") } return(ret) } @@ -384,23 +404,26 @@ nHomBrood <- function(x, simParamBee = NULL) { if (any(!isQueen(x, simParamBee = simParamBee))) { stop("Individuals in x must be queens!") } - ret <- rep(x = NA, times = nInd(x)) + ret <- rep(x = NA_real_, times = nInd(x)) for (ind in seq_len(nInd(x))) { if (!is.null(x@misc$nHomBrood[[ind]])) { ret[ind] <- x@misc$nHomBrood[[ind]] } } } else if (isColony(x)) { - if (is.null(x@queen@misc$nHomBrood[[1]])) { - ret <- NA + if (is.null(x@queen) || nInd(x@queen) == 0L) { + warning("Colony has no queen - returning NA!") + ret <- NA_real_ + } else if (is.null(x@queen@misc$nHomBrood[[1]])) { + ret <- NA_real_ } else { ret <- x@queen@misc$nHomBrood[[1]] } } else if (isMultiColony(x)) { - ret <- sapply(X = x@colonies, FUN = nHomBrood) + ret <- sapply(X = x@colonies, FUN = nHomBrood, simParamBee = simParamBee) names(ret) <- getId(x) } else { - stop("Argument x must be a Colony or MultiColony class object!") + stop("Argument x must be a Pop, Colony, or MultiColony class object!") } return(ret) } @@ -953,14 +976,19 @@ isNULLColonies <- function(multicolony) { # get (general) ---- #' @rdname getId -#' @title Get the colony ID +#' @title Get the population/queen or colony IDs #' -#' @description Level 0 function that returns the colony ID. This is by -#' definition the ID of the queen. +#' @description Level 0 function that returns individual IDs from a population +#' or colony IDs from colonies. #' -#' @param x \code{\link[AlphaSimR]{Pop-class}}, \code{\link[SIMplyBee]{Colony-class}}, or \code{\link[SIMplyBee]{MultiColony-class}} +#' @param x \code{NULL}, \code{\link[AlphaSimR]{Pop-class}}, +#' \code{\link[SIMplyBee]{Colony-class}}, or +#' \code{\link[SIMplyBee]{MultiColony-class}} #' -#' @return character, \code{NA} when queen not present +#' @return Character individual IDs for a \code{Pop}, or integer colony IDs +#' for a \code{Colony} or nonempty \code{MultiColony}. An empty \code{Pop} +#' returns \code{character(0)}; \code{NULL} input returns +#' \code{NA_character_}. An empty \code{MultiColony} returns an empty list. #' #' @examples #' founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) @@ -986,11 +1014,11 @@ isNULLColonies <- function(multicolony) { #' @export getId <- function(x) { if (is.null(x)) { - id <- NA + id <- NA_character_ } else if (isPop(x)) { id <- x@id } else if (isColony(x)) { - id <- ifelse(is.null(x@id), NA, x@id) + id <- ifelse(is.null(x@id), NA_character_, x@id) } else if (isMultiColony(x)) { id <- sapply(x@colonies, FUN = getId) } else { @@ -5230,10 +5258,10 @@ calcInheritanceCriterion <- function(x, queenTrait = 1, workersTrait = 2, use = if(!isQueenPresent(x, simParamBee = simParamBee)) { stop("No queen in the Colony!") } - ret <- calcInheritanceCriterion(getQueen(colony, simParamBee = simParamBee), + ret <- calcInheritanceCriterion(getQueen(x, simParamBee = simParamBee), queenTrait = queenTrait, workersTrait = workersTrait, - use = use) + use = use, simParamBee = simParamBee) } else if (isMultiColony(x)) { nCol <- nColonies(x) ret <- vector(mode = "list", length = nCol) @@ -5242,7 +5270,7 @@ calcInheritanceCriterion <- function(x, queenTrait = 1, workersTrait = 2, use = ret[[colony]] <- calcInheritanceCriterion(x[[colony]], queenTrait = queenTrait, workersTrait = workersTrait, - use = use) + use = use, simParamBee = simParamBee) } else { ret[colony] <- list(NULL) } diff --git a/R/Functions_L1_Pop.R b/R/Functions_L1_Pop.R index b44173a9..abdca327 100644 --- a/R/Functions_L1_Pop.R +++ b/R/Functions_L1_Pop.R @@ -280,7 +280,6 @@ getVirginQueens <- function(x, nInd = NULL, use = "rand", collapse = FALSE, simP return(ret) } - #' @rdname createCastePop #' @title Creates caste population individuals from the colony #' @@ -531,7 +530,7 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, ret$nHomBrood <- nInd(ret$workers) - sum(sel) ret$workers <- ret$workers[sel] } else { - ret$nHomBrood <- NA + ret$nHomBrood <- NA_real_ } } else if (caste == "virginQueens") { @@ -1383,10 +1382,13 @@ pullVirginQueens <- function(x, nInd = NULL, use = "rand", collapse = FALSE, sim #' queen. For more examples for mating with either externally or internally created cross plan, #' please see \code{\link[SIMplyBee]{createCrossPlan}} #' -#' @return \code{\link[AlphaSimR]{Pop-class}} with mated queen(s). The misc slot of the -#' queens contains additional information about the number of workers, drones, -#' and homozygous brood produced, and the expected percentage of csd homozygous -#' brood. +#' @return A \code{\link[AlphaSimR]{Pop-class}}, +#' \code{\link[SIMplyBee]{Colony-class}}, or +#' \code{\link[SIMplyBee]{MultiColony-class}} with mated queen(s), matching +#' the input type. The queens' \code{misc} slots contain worker, drone, and +#' homozygous brood counts, initially zero, and the expected proportion of +#' csd homozygous brood (\code{pHomBrood}). When csd is inactive, +#' \code{pHomBrood} is \code{NA_real_}. #' #' @examples #' founderGenomes <- quickHaplo(nInd = 30, nChr = 1, segSites = 100) @@ -1581,7 +1583,7 @@ cross <- function(x, } if (isColony(x) | isMultiColony(x)) { if (any(isQueenPresent(x, simParamBee = simParamBee))) { - stop("Queen already present in the colony!") + stop("Queen already present in a colony!") } if (any(!isVirginQueensPresent(x, simParamBee = simParamBee))) { stop("No virgin queen(s) in the colony to cross!") @@ -1660,7 +1662,7 @@ cross <- function(x, IDs = IDs[IDs %in% crossPlanDF$virginID] x = x[IDs] if (type == "MultiColony") { - multicolony <- multicolony[getId(getVirginQueens(multicolony, collapse=TRUE)) %in% IDs] + multicolony <- multicolony[getId(getVirginQueens(multicolony, collapse = TRUE, simParamBee = simParamBee)) %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, @@ -1673,7 +1675,7 @@ cross <- function(x, 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)) + selectedDPC = selectColonies(droneColonies, ID = as.character(crossPlanDF_DPCtable$DPC), simParamBee = simParamBee) # And here I create the drones dronesByDPC <- createCastePop(selectedDPC, caste = "drones", nInd = as.integer(crossPlanDF_DPCtable$noDrones), @@ -1744,7 +1746,7 @@ cross <- function(x, if (isCsdActive(simParamBee = simParamBee)) { #This does still not work it the CSD is turned on val <- calcQueensPHomBrood(x = virginQueen, simParamBee = simParamBee) } else { - val <- NA + val <- NA_real_ } virginQueen@misc[["pHomBrood"]] <- val @@ -1780,8 +1782,6 @@ cross <- function(x, return(ret) } - - #' @rdname crossVirginQueen #' @title Internal function to cross a virgin queen #' @@ -1791,6 +1791,11 @@ cross <- function(x, #' @param virginQueenDrones, list with drones #' @param simParamBee, SimParamBee object #' +#' @return The supplied queen \code{\link[AlphaSimR]{Pop-class}} with fathers +#' stored in \code{misc}, worker, drone, and homozygous brood counts set to +#' zero, and \code{pHomBrood} set to the expected proportion of csd homozygous +#' brood, or \code{NA_real_} when csd is inactive. +#' #' @export crossVirginQueen <- function(virginQueen, virginQueenDrones, simParamBee = NULL) { virginQueen@misc$fathers[[1]] <- virginQueenDrones @@ -1801,7 +1806,7 @@ crossVirginQueen <- function(virginQueen, virginQueenDrones, simParamBee = NULL) if (isCsdActive(simParamBee = simParamBee)) { #This does still not work it the CSD is turned on val <- calcQueensPHomBrood(x = virginQueen, simParamBee = simParamBee) } else { - val <- NA + val <- NA_real_ } virginQueen@misc[["pHomBrood"]] <- val diff --git a/R/Functions_L2_Colony.R b/R/Functions_L2_Colony.R index 93b68cb1..1b4ef5e0 100644 --- a/R/Functions_L2_Colony.R +++ b/R/Functions_L2_Colony.R @@ -600,7 +600,7 @@ buildUp <- function(x, nWorkers = NULL, nDrones = NULL, # Events if (resetEvents) { - x <- resetEvents(x) + x <- resetEvents(x, simParamBee = simParamBee) } x@production <- TRUE } else if (isMultiColony(x)) { diff --git a/man/MultiColony-class.Rd b/man/MultiColony-class.Rd index 6be082c7..d81e7d6f 100644 --- a/man/MultiColony-class.Rd +++ b/man/MultiColony-class.Rd @@ -70,17 +70,17 @@ An object holding a collection of honeybee colonies. It behaves \item \code{c(MultiColonyOrNULL)}: Combine multiple Colony and MultiColony objects -\item \code{x = MultiColony[i = integerOrNumericOrLogical]}: Extract a colony (one or more!) with an integer/numeric/logical index (position) (return \code{\link[SIMplyBee]{MultiColony-class}}) +\item \code{x[i}: Extract a colony (one or more!) with an integer/numeric/logical index (position) (return \code{\link[SIMplyBee]{MultiColony-class}}) -\item \code{x = MultiColony[i = character]}: Extract a colony (one or more!) with a character ID (name) (return \code{\link[SIMplyBee]{MultiColony-class}}) +\item \code{x[i}: Extract a colony (one or more!) with a character ID (name) (return \code{\link[SIMplyBee]{MultiColony-class}}) -\item \code{x = MultiColony[[i = integerOrNumericOrLogical]]}: Extract a colony (just one!) with an integer/numeric/logical index (position) (return \code{\link[SIMplyBee]{Colony-class}}) +\item \code{x[[i}: Extract a colony (just one!) with an integer/numeric/logical index (position) (return \code{\link[SIMplyBee]{Colony-class}}) -\item \code{x = MultiColony[[i = character]]}: Extract a colony (just one!) with a character ID (name) (return \code{\link[SIMplyBee]{Colony-class}}) +\item \code{x[[i}: Extract a colony (just one!) with a character ID (name) (return \code{\link[SIMplyBee]{Colony-class}}) -\item \code{x = MultiColony[i = integerOrNumericOrLogicalOrCharacter, j = ANY] <- value}: Assign colonies into MultiColony +\item \code{`[`(x = MultiColony, i = integerOrNumericOrLogicalOrCharacter, j = ANY) <- value}: Assign colonies into MultiColony -\item \code{x = MultiColony[[i = integerOrNumericOrLogicalOrCharacter, j = ANY]] <- value}: Assign Colony into MultiColony +\item \code{`[[`(x = MultiColony, i = integerOrNumericOrLogicalOrCharacter, j = ANY) <- value}: Assign Colony into MultiColony }} \section{Slots}{ diff --git a/man/SIMplyBee-package.Rd b/man/SIMplyBee-package.Rd index 99748e94..02b01c03 100644 --- a/man/SIMplyBee-package.Rd +++ b/man/SIMplyBee-package.Rd @@ -37,7 +37,6 @@ 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 dad6b6eb..79b873f7 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) @@ -92,9 +92,9 @@ SP$caste \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}}. @@ -116,7 +116,7 @@ SP$caste 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}}. @@ -138,7 +138,7 @@ SP$caste 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}}. @@ -160,7 +160,7 @@ SP$caste 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}}. @@ -182,7 +182,7 @@ SP$caste 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}}. @@ -203,7 +203,7 @@ SP$caste 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. @@ -212,7 +212,7 @@ SP$caste 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}}. @@ -233,7 +233,7 @@ SP$caste 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}}. @@ -254,7 +254,7 @@ SP$caste 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}}. @@ -266,99 +266,100 @@ SP$caste 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-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 +\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 -
    }} +
    +}} \if{html}{\out{
    }} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-SimParamBee-initialize}{}}} -\subsection{\code{SimParamBee$new()}}{ - Starts the process of building a new simulation by creating +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-SimParamBee-new}{}}} +\subsection{Method \code{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, @@ -372,81 +373,99 @@ generate this object} 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{\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 +\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 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) @@ -460,33 +479,35 @@ 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{\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 +\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 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 @@ -498,139 +519,140 @@ 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{\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{Method \code{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{
    }} +} +} \if{html}{\out{
    }} \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-SimParamBee-addToBeeRec}{}}} -\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{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{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{\code{SimParamBee$updateCaste()}}{ - A function to update the caste +\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{
    }} - } +\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-updateLastBeeId}{}}} -\subsection{\code{SimParamBee$updateLastBeeId()}}{ - A function to update the last +\subsection{Method \code{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{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{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{
    }} +} +} \if{html}{\out{
    }} \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-SimParamBee-updateLastColonyId}{}}} -\subsection{\code{SimParamBee$updateLastColonyId()}}{ - A function to update the colony last +\subsection{Method \code{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{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{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{
    }} +} +} \if{html}{\out{
    }} \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-SimParamBee-clone}{}}} -\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{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{Arguments}{ +\if{html}{\out{
    }} +\describe{ +\item{\code{deep}}{Whether to make a deep clone.} +} +\if{html}{\out{
    }} +} +} } diff --git a/man/calcQueensPHomBrood.Rd b/man/calcQueensPHomBrood.Rd index 76378eef..2b3a3028 100644 --- a/man/calcQueensPHomBrood.Rd +++ b/man/calcQueensPHomBrood.Rd @@ -19,8 +19,13 @@ nHomBrood(x, simParamBee = NULL) \item{simParamBee}{\code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters} } \value{ -numeric, expected csd homozygosity named by colony id when \code{x} - is \code{\link[SIMplyBee]{MultiColony-class}} +Numeric brood proportions for \code{calcQueensPHomBrood()} and + \code{pHomBrood()}, or counts for \code{nHomBrood()}, named by colony ID + when \code{x} is \code{\link[SIMplyBee]{MultiColony-class}}. An empty + \code{\link[AlphaSimR]{Pop-class}} returns \code{numeric(0)}. Missing + brood proportions and counts are represented by \code{NA_real_}. + All three functions warn and return \code{NA_real_} for a colony without + a queen. } \description{ Level 0 functions that calculate or report the proportion of csd @@ -34,7 +39,7 @@ Level 0 functions that calculate or report the proportion of csd } \section{Functions}{ \itemize{ -\item \code{pHomBrood()}: Expected percentage of csd homozygous brood +\item \code{pHomBrood()}: Expected proportion of csd homozygous brood of a queen / colony \item \code{nHomBrood()}: Realised number of csd homozygous brood diff --git a/man/cross.Rd b/man/cross.Rd index 8d34e3a6..7bd44f8c 100644 --- a/man/cross.Rd +++ b/man/cross.Rd @@ -62,10 +62,13 @@ This will also remove the unmated queens and return only the mated ones.} \item{...}{other arguments for \code{nDrones}, when \code{nDrones} is a function} } \value{ -\code{\link[AlphaSimR]{Pop-class}} with mated queen(s). The misc slot of the - queens contains additional information about the number of workers, drones, - and homozygous brood produced, and the expected percentage of csd homozygous - brood. +A \code{\link[AlphaSimR]{Pop-class}}, + \code{\link[SIMplyBee]{Colony-class}}, or + \code{\link[SIMplyBee]{MultiColony-class}} with mated queen(s), matching + the input type. The queens' \code{misc} slots contain worker, drone, and + homozygous brood counts, initially zero, and the expected proportion of + csd homozygous brood (\code{pHomBrood}). When csd is inactive, + \code{pHomBrood} is \code{NA_real_}. } \description{ Level 1 function that crosses (mates) a virgin queen to a group diff --git a/man/crossVirginQueen.Rd b/man/crossVirginQueen.Rd index f28bd134..dcc178f9 100644 --- a/man/crossVirginQueen.Rd +++ b/man/crossVirginQueen.Rd @@ -13,6 +13,12 @@ crossVirginQueen(virginQueen, virginQueenDrones, simParamBee = NULL) \item{simParamBee, }{SimParamBee object} } +\value{ +The supplied queen \code{\link[AlphaSimR]{Pop-class}} with fathers + stored in \code{misc}, worker, drone, and homozygous brood counts set to + zero, and \code{pHomBrood} set to the expected proportion of csd homozygous + brood, or \code{NA_real_} when csd is inactive. +} \description{ Internal function to cross a virgin queen } diff --git a/man/getId.Rd b/man/getId.Rd index bdd5915e..a57eee35 100644 --- a/man/getId.Rd +++ b/man/getId.Rd @@ -2,19 +2,24 @@ % Please edit documentation in R/Functions_L0_auxilary.R \name{getId} \alias{getId} -\title{Get the colony ID} +\title{Get the population/queen or colony IDs} \usage{ getId(x) } \arguments{ -\item{x}{\code{\link[AlphaSimR]{Pop-class}}, \code{\link[SIMplyBee]{Colony-class}}, or \code{\link[SIMplyBee]{MultiColony-class}}} +\item{x}{\code{NULL}, \code{\link[AlphaSimR]{Pop-class}}, +\code{\link[SIMplyBee]{Colony-class}}, or +\code{\link[SIMplyBee]{MultiColony-class}}} } \value{ -character, \code{NA} when queen not present +Character individual IDs for a \code{Pop}, or integer colony IDs + for a \code{Colony} or nonempty \code{MultiColony}. An empty \code{Pop} + returns \code{character(0)}; \code{NULL} input returns + \code{NA_character_}. An empty \code{MultiColony} returns an empty list. } \description{ -Level 0 function that returns the colony ID. This is by - definition the ID of the queen. +Level 0 function that returns individual IDs from a population + or colony IDs from colonies. } \examples{ founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) diff --git a/man/nCaste.Rd b/man/nCaste.Rd index 84c973ee..44141a63 100644 --- a/man/nCaste.Rd +++ b/man/nCaste.Rd @@ -23,7 +23,9 @@ nDrones(x, simParamBee = NULL) nVirginQueens(x, simParamBee = NULL) } \arguments{ -\item{x}{\code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}}} +\item{x}{\code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}}. +For \code{nFathers()}, also a \code{\link[AlphaSimR]{Pop-class}} +containing queens.} \item{caste}{character, "queen", "fathers", "workers", "drones", "virginQueens", or "all"} @@ -35,7 +37,8 @@ when \code{x} is \code{\link[SIMplyBee]{Colony-class}} return is integer for \code{caste != "all"} or list for \code{caste == "all"} with nodes named by caste; when \code{x} is \code{\link[SIMplyBee]{MultiColony-class}} return is named integer for \code{caste != "all"} or named list of lists for - \code{caste == "all"} + \code{caste == "all"}. For \code{nFathers()} with a queen population, + returns a numeric vector with one father count per queen. } \description{ Returns the number of individuals of a caste in a colony diff --git a/man/splitPFun.Rd b/man/splitPFun.Rd index d4f222ad..768312e9 100644 --- a/man/splitPFun.Rd +++ b/man/splitPFun.Rd @@ -8,7 +8,13 @@ \usage{ splitPUnif(x = NULL, n = 1, min = 0.2, max = 0.4) -splitPColonyStrength(x, n = 1, nWorkersFull = 100, scale = 1) +splitPColonyStrength( + x, + n = 1, + nWorkersFull = 100, + scale = 1, + simParamBee = NULL +) } \arguments{ \item{x}{\code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}}} @@ -26,6 +32,9 @@ value)} \item{scale}{numeric, scaling of numbers in \code{splitPColonyStrength} to avoid to narrow range when colonies have a large number of bees (in that case change \code{nWorkersFull} too!)} + +\item{simParamBee}{\code{\link[SIMplyBee]{SimParamBee}}, simulation parameters +for \code{splitPColonyStrength}} } \value{ numeric, split proportion diff --git a/tests/testthat/test-L0_auxiliary_functions.R b/tests/testthat/test-L0_auxiliary_functions.R index 7d7f11b4..fdfbb63c 100644 --- a/tests/testthat/test-L0_auxiliary_functions.R +++ b/tests/testthat/test-L0_auxiliary_functions.R @@ -10,8 +10,8 @@ test_that("nColonies", { expect_equal(nColonies(createMultiColony(n = 10, simParamBee = SP)), 10) }) - # ---- nCaste ---- + test_that("nCaste", { founderGenomes <- quickHaplo(nInd = 5, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) @@ -19,7 +19,12 @@ test_that("nCaste", { basePop <- createVirginQueens(founderGenomes, simParamBee = SP) drones <- createDrones(x = basePop[1], nInd = 45, simParamBee = SP) - droneGroups <- pullDroneGroupsFromDCA(drones, n = 3, nDrones = 10, simParamBee = SP) + droneGroups <- pullDroneGroupsFromDCA( + drones, + n = 3, + nDrones = 10, + simParamBee = SP + ) colony <- createColony(x = basePop[2], simParamBee = SP) colony <- cross(colony, drones = droneGroups[[1]], simParamBee = SP) colony <- buildUp(colony, nDrones = 10, nWorkers = 20, simParamBee = SP) @@ -41,11 +46,16 @@ test_that("nCaste", { test_that("nQueens", { founderGenomes <- quickHaplo(nInd = 10, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) - SP$nThreads = 1L + 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) + fatherGroups <- pullDroneGroupsFromDCA( + drones, + n = 10, + nDrones = 10, + simParamBee = SP + ) colony1 <- createColony(x = basePop[1], simParamBee = SP) colony1 <- cross(colony1, drones = fatherGroups[[1]], simParamBee = SP) @@ -59,21 +69,26 @@ test_that("nQueens", { }) # ---- nDrones ---- + test_that("nDrones", { founderGenomes <- quickHaplo(nInd = 10, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) - SP$nThreads = 1L + 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) + fatherGroups <- pullDroneGroupsFromDCA( + drones, + n = 10, + nDrones = 10, + simParamBee = SP + ) colony1 <- createColony(x = basePop[1], simParamBee = SP) colony1 <- cross(colony1, drones = fatherGroups[[1]], simParamBee = SP) colony2 <- createColony(x = basePop[2], simParamBee = SP) colony2 <- cross(colony2, drones = fatherGroups[[2]], simParamBee = SP) - expect_equal(nDrones(colony1, simParamBee = SP), 0) colony1 <- addDrones(colony1, nInd = 5, simParamBee = SP) colony2 <- addDrones(colony2, nInd = 10, simParamBee = SP) @@ -83,22 +98,62 @@ test_that("nDrones", { expect_error(nDrones(basePop, simParamBee = SP)) }) +# ---- nFathers ---- + +test_that("nFathers accepts queens and colonies and reports all supported classes", { + set.seed(123) + founderGenomes <- quickHaplo(nInd = 3, nChr = 1, segSites = 10) + SP <- SimParamBee$new(founderGenomes, csdChr = NULL) + SP$nThreads <- 1L + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) + drones <- createDrones(basePop[1], nInd = 4, simParamBee = SP) + colony <- createColony(basePop[2], simParamBee = SP) + colony <- cross(colony, drones = drones, simParamBee = SP) + + expect_equal(nFathers(colony@queen, simParamBee = SP), 4) + expect_equal(nFathers(colony, simParamBee = SP), 4) + expect_equal(unname(nFathers(c(colony), simParamBee = SP)), 4) + expect_error( + nFathers(basePop, simParamBee = SP), + "Individuals in x must be queens!", + fixed = TRUE + ) + for (invalid in list(NULL, 123, "queen", list())) { + expect_error( + nFathers(invalid, simParamBee = SP), + "Argument x must be a Pop, Colony, or MultiColony class object!", + fixed = TRUE + ) + } + expect_error( + nCaste(colony@queen, caste = "fathers", simParamBee = SP), + "Argument colony must be a Colony or MultiColony class object!", + fixed = TRUE + ) +}) + # ---- isGenoHeterozygous ---- -####----- isGenoHeterozygous ---- #### test_that("isGenoHeterozygous", { geno <- matrix( data = c( - 0, 1, 2, - 0, 0, 0, - 2, 2, 2 + 0, + 1, + 2, + 0, + 0, + 0, + 2, + 2, + 2 ), - nrow = 3, byrow = TRUE + nrow = 3, + byrow = TRUE ) - expect_true(SIMplyBee:::isGenoHeterozygous(geno[1, , drop = FALSE])) - expect_false(SIMplyBee:::isGenoHeterozygous(geno[2, , drop = FALSE])) - expect_false(SIMplyBee:::isGenoHeterozygous(geno[3, , drop = FALSE])) - expect_equal(SIMplyBee:::isGenoHeterozygous(geno), c(TRUE, FALSE, FALSE)) + expect_true(isGenoHeterozygous(geno[1, , drop = FALSE])) + expect_false(isGenoHeterozygous(geno[2, , drop = FALSE])) + expect_false(isGenoHeterozygous(geno[3, , drop = FALSE])) + expect_equal(isGenoHeterozygous(geno), c(TRUE, FALSE, FALSE)) }) # ---- isCaste ---- @@ -106,12 +161,17 @@ test_that("isGenoHeterozygous", { test_that("isCaste", { founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) - SP$nThreads = 1L + 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) + fatherGroups <- pullDroneGroupsFromDCA( + drones, + n = 10, + nDrones = 10, + simParamBee = SP + ) # Create a Colony class colony <- createColony(x = basePop[2], simParamBee = SP) @@ -120,15 +180,38 @@ test_that("isCaste", { # get the queen that is a caste "queen" and ask if it is a caste "queen" # and drones and drones - expect_true(isCaste(getQueen(colony, simParamBee = SP), caste = "queen", simParamBee = SP)) - expect_true(all(isCaste(getDrones(colony, simParamBee = SP), caste = "drones", simParamBee = SP))) - expect_true(all(isCaste(getDrones(colony, simParamBee = SP), caste = "drones", simParamBee = SP))) + expect_true(isCaste( + getQueen(colony, simParamBee = SP), + caste = "queen", + simParamBee = SP + )) + expect_true(all(isCaste( + getDrones(colony, simParamBee = SP), + caste = "drones", + simParamBee = SP + ))) + expect_true(all(isCaste( + getDrones(colony, simParamBee = SP), + caste = "drones", + simParamBee = SP + ))) # get the queen that is a caste "queen" and test if it is a caste "workers", #test on virgin queen that is not present in a colony - expect_false(isCaste(getQueen(colony, simParamBee = SP), caste = "workers", simParamBee = SP)) + expect_false(isCaste( + getQueen(colony, simParamBee = SP), + caste = "workers", + simParamBee = SP + )) #test on virgin queen that is not present in a colony - expect_null(isCaste(getVirginQueens(colony, simParamBee = SP), caste = "virginQueens", simParamBee = SP)) - malePop <- c(getDrones(colony, simParamBee = SP), getFathers(colony, simParamBee = SP)) + expect_null(isCaste( + getVirginQueens(colony, simParamBee = SP), + caste = "virginQueens", + simParamBee = SP + )) + malePop <- c( + getDrones(colony, simParamBee = SP), + getFathers(colony, simParamBee = SP) + ) expect_true(any(isCaste(malePop, caste = "drones", simParamBee = SP))) expect_true(any(isCaste(malePop, caste = "fathers", simParamBee = SP))) expect_false(all(isCaste(malePop, caste = "drones", simParamBee = SP))) @@ -138,101 +221,290 @@ test_that("isCaste", { # ---- calcQueensPHomBrood ---- test_that("calcQueensPHomBrood", { + set.seed(1) founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes) - SP$nThreads = 1L + SP$nThreads <- 1L basePop <- createVirginQueens(founderGenomes, simParamBee = SP) + expect_error( + calcQueensPHomBrood(basePop, simParamBee = SP), + "calcQueensPHomBrood can only be used with queens!", + fixed = TRUE + ) + expect_error( + calcQueensPHomBrood(basePop[3], simParamBee = SP), + "calcQueensPHomBrood can only be used with queens!", + fixed = TRUE + ) + expect_length(calcQueensPHomBrood(basePop[integer(0)], simParamBee = SP), 0L) + expect_identical( + calcQueensPHomBrood(basePop[integer(0)], simParamBee = SP), + numeric(0) + ) - drones <- createDrones(x = basePop[1], nInd = 1000, simParamBee = SP) - fatherGroups <- pullDroneGroupsFromDCA(drones, n = 10, nDrones = 10, simParamBee = SP) + drones <- createDrones(x = basePop[1], nInd = 100, simParamBee = SP) + fatherGroups <- pullDroneGroupsFromDCA( + drones, + n = 3, + nDrones = 10, + simParamBee = SP + ) - # Create a Colony class object 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) - expect_error(calcQueensPHomBrood(colony@drones, simParamBee = SP)) - expect_error(calcQueensPHomBrood(colony@workers, simParamBee = SP)) + expect_error( + calcQueensPHomBrood(colony@workers, simParamBee = SP), + "calcQueensPHomBrood can only be used with queens!" + ) + # Empty populations return an empty numeric vector, regardless of caste. + expect_identical( + calcQueensPHomBrood(colony@virginQueens[integer(0)], simParamBee = SP), + numeric(0) + ) + expect_error( + calcQueensPHomBrood(colony@drones, simParamBee = SP), + "calcQueensPHomBrood can only be used with queens!" + ) expect_true(is.numeric(calcQueensPHomBrood(colony@queen, simParamBee = SP))) expect_true(calcQueensPHomBrood(colony@queen, simParamBee = SP) > 0) + expect_true(calcQueensPHomBrood(colony@queen, simParamBee = SP) == 0.5) colony@queen <- NULL - expect_error(calcQueensPHomBrood(colony@queen, simParamBee = SP)) - apiary <- createMultiColony(simParamBee = SP) - colony@workers <- NULL - colony@drones <- NULL - colony@virginQueens <- NULL - expect_error(calcQueensPHomBrood(colony, simParamBee = SP)) - expect_equal((length(calcQueensPHomBrood(apiary, simParamBee = SP))), 0) - + expect_error( + calcQueensPHomBrood(colony@queen, simParamBee = SP), + "Argument x must be a Pop, Colony, or MultiColony class object!" + ) + expect_warning( + missing <- calcQueensPHomBrood(colony, simParamBee = SP), + "Colony has no queen - returning NA!", + fixed = TRUE + ) + expect_identical(missing, NA_real_) + apiary <- createMultiColony(simParamBee = SP) + expect_equal(length(calcQueensPHomBrood(apiary, simParamBee = SP)), 0) + + apiary <- createMultiColony(x = basePop[2:3], simParamBee = SP) + apiary <- cross(apiary, drones = fatherGroups[2:3], simParamBee = SP) + tmp <- calcQueensPHomBrood(apiary, simParamBee = SP) + expect_equal(length(tmp), 2) + expect_equal(tmp, c(`2` = 0, `3` = 0)) + + drones <- createDrones(x = basePop[4:5], nInd = 100, simParamBee = SP) + fatherGroups <- pullDroneGroupsFromDCA( + drones, + n = 2, + nDrones = 10, + simParamBee = SP + ) + colony2 <- createColony(x = basePop[4], simParamBee = SP) + colony2 <- cross(colony2, drones = fatherGroups[[1]], simParamBee = SP) + colony3 <- createColony(x = basePop[5], simParamBee = SP) + colony3 <- cross(colony3, drones = fatherGroups[[2]], simParamBee = SP) + + apiary <- c(colony2, colony3) + tmp <- calcQueensPHomBrood(apiary, simParamBee = SP) + expect_equal(length(tmp), 2) + expect_equal(tmp, c(`6` = 0.35, `7` = 0.10)) }) # ---- pHomBrood ---- test_that("pHomBrood", { + set.seed(1) founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes) - SP$nThreads = 1L + SP$nThreads <- 1L basePop <- createVirginQueens(founderGenomes, simParamBee = SP) + expect_error( + pHomBrood(basePop, simParamBee = SP), + "Individuals in x must be queens!", + fixed = TRUE + ) + expect_error( + pHomBrood(basePop[3], simParamBee = SP), + "Individuals in x must be queens!", + fixed = TRUE + ) + expect_length(pHomBrood(basePop[integer(0)], simParamBee = SP), 0L) + expect_identical(pHomBrood(basePop[integer(0)], simParamBee = SP), numeric(0)) + + drones <- createDrones(x = basePop[1], nInd = 100, simParamBee = SP) + fatherGroups <- pullDroneGroupsFromDCA( + drones, + n = 3, + nDrones = 10, + simParamBee = SP + ) - drones <- createDrones(x = basePop[1], nInd = 1000, simParamBee = SP) - 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) - expect_error(pHomBrood(colony@workers, simParamBee = SP)) - expect_error(pHomBrood(colony@virginQueens, simParamBee = SP)) - expect_error(pHomBrood(colony@drones, simParamBee = SP)) + expect_error( + pHomBrood(colony@workers, simParamBee = SP), + "Individuals in x must be queens!" + ) + # This does not work because colony@virginQueens is empty pop so we get out zero length output + # expect_error( + # pHomBrood(colony@virginQueens, simParamBee = SP), + # "Individuals in x must be queens!" + # ) + # ... so let's do this instead + expect_length(pHomBrood(colony@virginQueens, simParamBee = SP), 0L) + expect_error( + pHomBrood(colony@drones, simParamBee = SP), + "Individuals in x must be queens!" + ) expect_true(is.numeric(pHomBrood(colony@queen, simParamBee = SP))) + expect_true(pHomBrood(colony@queen, simParamBee = SP) > 0) + expect_true(pHomBrood(colony@queen, simParamBee = SP) == 0.5) + colonyCopy <- colony colony@queen <- NULL - expect_error(pHomBrood(colony@queen, simParamBee = SP)) + expect_error( + pHomBrood(colony@queen, simParamBee = SP), + "Argument x must be a Pop, Colony, or MultiColony class object!" + ) + expect_warning( + missing <- pHomBrood(colony, simParamBee = SP), + "Colony has no queen - returning NA!", + fixed = TRUE + ) + expect_identical(missing, NA_real_) + apiary <- createMultiColony(simParamBee = SP) - colony@workers <- NULL - colony@drones <- NULL - colony@virginQueens <- NULL - expect_error(pHomBrood(colony, simParamBee = SP)) expect_equal(length(pHomBrood(apiary, simParamBee = SP)), 0) + + apiary <- createMultiColony(x = basePop[2:3], simParamBee = SP) + apiary <- cross(apiary, drones = fatherGroups[2:3], simParamBee = SP) + tmp <- pHomBrood(apiary, simParamBee = SP) + expect_equal(length(tmp), 2) + expect_equal(tmp, c(`2` = 0, `3` = 0)) + + drones <- createDrones(x = basePop[4:5], nInd = 100, simParamBee = SP) + fatherGroups <- pullDroneGroupsFromDCA( + drones, + n = 2, + nDrones = 10, + simParamBee = SP + ) + colony2 <- createColony(x = basePop[4], simParamBee = SP) + colony2 <- cross(colony2, drones = fatherGroups[[1]], simParamBee = SP) + colony3 <- createColony(x = basePop[5], simParamBee = SP) + colony3 <- cross(colony3, drones = fatherGroups[[2]], simParamBee = SP) + + apiary <- c(colony2, colony3) + tmp <- pHomBrood(apiary, simParamBee = SP) + expect_equal(length(tmp), 2) + expect_equal(tmp, c(`6` = 0.35, `7` = 0.10)) }) #---- nHomBrood ----- test_that("nHomBrood", { + set.seed(1) founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes) - SP$nThreads = 1L + SP$nThreads <- 1L basePop <- createVirginQueens(founderGenomes, simParamBee = SP) + expect_error( + nHomBrood(basePop, simParamBee = SP), + "Individuals in x must be queens!", + fixed = TRUE + ) + expect_error( + nHomBrood(basePop[3], simParamBee = SP), + "Individuals in x must be queens!", + fixed = TRUE + ) + expect_length(nHomBrood(basePop[integer(0)], simParamBee = SP), 0L) + expect_identical(nHomBrood(basePop[integer(0)], simParamBee = SP), numeric(0)) + + drones <- createDrones(x = basePop[1], nInd = 100, simParamBee = SP) + fatherGroups <- pullDroneGroupsFromDCA( + drones, + n = 3, + nDrones = 10, + simParamBee = SP + ) - drones <- createDrones(x = basePop[1], nInd = 1000, simParamBee = SP) - 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) - expect_error(nHomBrood(colony@workers, simParamBee = SP)) - expect_error(nHomBrood(colony@virginQueens, simParamBee = SP)) - expect_error(nHomBrood(colony@drones, simParamBee = SP)) + expect_error( + nHomBrood(colony@workers, simParamBee = SP), + "Individuals in x must be queens!" + ) + # Empty populations return an empty numeric vector, regardless of caste. + expect_identical( + nHomBrood(colony@virginQueens[integer(0)], simParamBee = SP), + numeric(0) + ) + expect_error( + nHomBrood(colony@drones, simParamBee = SP), + "Individuals in x must be queens!" + ) expect_true(is.numeric(nHomBrood(colony@queen, simParamBee = SP))) + expect_true(nHomBrood(colony@queen, simParamBee = SP) > 0) + # Of the 120 worker offspring requested, csd homozygotes did not survive. + expect_equal( + nHomBrood(colony@queen, simParamBee = SP), + 120 - nWorkers(colony, simParamBee = SP) + ) + colony@queen <- NULL + expect_error( + nHomBrood(colony@queen, simParamBee = SP), + "Argument x must be a Pop, Colony, or MultiColony class object!" + ) + expect_warning( + missing <- nHomBrood(colony, simParamBee = SP), + "Colony has no queen - returning NA!", + fixed = TRUE + ) + expect_identical(missing, NA_real_) apiary <- createMultiColony(simParamBee = SP) - colony@workers <- NULL - colony@drones <- NULL - colony@virginQueens <- NULL - expect_error(nHomBrood(removeQueen(colony), simParamBee = SP)) expect_equal(length(nHomBrood(apiary, simParamBee = SP)), 0) + + apiary <- createMultiColony(x = basePop[2:3], simParamBee = SP) + apiary <- cross(apiary, drones = fatherGroups[2:3], simParamBee = SP) + tmp <- nHomBrood(apiary, simParamBee = SP) + expect_equal(length(tmp), 2) + expect_equal(tmp, c(`2` = 0, `3` = 0)) + + drones <- createDrones(x = basePop[4:5], nInd = 100, simParamBee = SP) + fatherGroups <- pullDroneGroupsFromDCA( + drones, + n = 2, + nDrones = 10, + simParamBee = SP + ) + colony2 <- createColony(x = basePop[4], simParamBee = SP) + colony2 <- cross(colony2, drones = fatherGroups[[1]], simParamBee = SP) + colony3 <- createColony(x = basePop[5], simParamBee = SP) + colony3 <- cross(colony3, drones = fatherGroups[[2]], simParamBee = SP) + + apiary <- c(colony2, colony3) + tmp <- nHomBrood(apiary, simParamBee = SP) + expect_equal(length(tmp), 2) + expect_equal(tmp, c(`6` = 0, `7` = 0)) + + apiary <- buildUp(apiary, nWorkers = 40, nDrones = 0, simParamBee = SP) + expect_equal( + nHomBrood(apiary, simParamBee = SP), + 40 - nWorkers(apiary, simParamBee = SP) + ) }) # ---- isQueenPresent ---- @@ -240,19 +512,24 @@ test_that("nHomBrood", { test_that("isQueenPresent", { founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) - SP$nThreads = 1L + 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) + fatherGroups <- pullDroneGroupsFromDCA( + drones, + n = 10, + nDrones = 10, + simParamBee = SP + ) # Create a Colony class object colony <- createColony(x = basePop[2], simParamBee = SP) colony <- cross(colony, drones = fatherGroups[[1]], simParamBee = SP) colony <- addVirginQueens(x = colony, nInd = 1, simParamBee = SP) apiary <- createMultiColony(n = 1, simParamBee = SP) - vec <- c(1,2,3,4) + vec <- c(1, 2, 3, 4) apiary2 <- createMultiColony(simParamBee = SP) colony2 <- createColony(simParamBee = SP) @@ -269,12 +546,17 @@ test_that("isQueenPresent", { test_that("isVirginQueensPresent", { founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) - SP$nThreads = 1L + 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) + fatherGroups <- pullDroneGroupsFromDCA( + drones, + n = 10, + nDrones = 10, + simParamBee = SP + ) # Create a Colony class object colony <- createColony(x = basePop[2], simParamBee = SP) @@ -282,11 +564,10 @@ test_that("isVirginQueensPresent", { colony <- buildUp(x = colony, nWorkers = 120, nDrones = 20, simParamBee = SP) colony <- addVirginQueens(x = colony, nInd = 1, simParamBee = SP) apiary <- createMultiColony(n = 1, simParamBee = SP) - vec <- c(1,2,3,4) + vec <- c(1, 2, 3, 4) apiary2 <- createMultiColony(simParamBee = SP) colony2 <- createColony(simParamBee = SP) - expect_true(isVirginQueensPresent(colony, simParamBee = SP)) expect_false(isVirginQueensPresent(apiary2, simParamBee = SP)) expect_error(isVirginQueenPresent(vec, simParamBee = SP)) @@ -300,12 +581,17 @@ test_that("isVirginQueensPresent", { test_that("isProductive", { founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) - SP$nThreads = 1L + 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) + fatherGroups <- pullDroneGroupsFromDCA( + drones, + n = 10, + nDrones = 10, + simParamBee = SP + ) # Create a Colony and a MultiColony class colony <- createColony(x = basePop[2], simParamBee = SP) @@ -335,18 +621,21 @@ test_that("isProductive", { test_that("reduceDroneHaplo", { 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) drones <- createDrones(x = basePop[1], nInd = 2, simParamBee = SP) virginQueens <- c(basePop[2:3]) - vec <- c(1,2,"a") + vec <- c(1, 2, "a") tmp <- getSegSiteHaplo(virginQueens, simParamBee = SP) df <- as.data.frame(tmp) tmpD <- getSegSiteHaplo(drones, simParamBee = SP) mix <- rbind(tmp, tmpD) - expect_equal(nrow(reduceDroneHaplo(haplo = mix, pop = c(drones, virginQueens))), 6) + expect_equal( + nrow(reduceDroneHaplo(haplo = mix, pop = c(drones, virginQueens))), + 6 + ) expect_equal(nrow(reduceDroneHaplo(haplo = tmpD, pop = drones)), 2) expect_error(reduceDroneHaplo(haplo = vec, pop = drones)) expect_error(reduceDroneHaplo(haplo = df, pop = drones)) @@ -360,20 +649,19 @@ test_that("reduceDroneHaplo", { test_that("reduceDroneGeno", { founderGenomes <- quickHaplo(nInd = 10, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) - SP$nThreads = 1L + SP$nThreads <- 1L basePop <- createVirginQueens(founderGenomes, simParamBee = SP) drones <- createDrones(x = basePop[1], nInd = 2, simParamBee = SP) virginQueens <- c(basePop[2:3]) - vec <- c(1,2,"a") + vec <- c(1, 2, "a") tmp <- getSegSiteGeno(virginQueens, simParamBee = SP) df <- as.data.frame(tmp) tmpD <- getSegSiteGeno(drones, simParamBee = SP) - expect_equal(nrow(reduceDroneGeno(geno = tmpD, pop = drones)), 2) expect_error(reduceDroneGeno(geno = vec, pop = drones)) - expect_error(reduceDroneGeno(geno = df, pop = drones)) + expect_error(reduceDroneGeno(geno = df, pop = drones)) expect_true(is.matrix(reduceDroneGeno(geno = tmpD, pop = drones))) tmp <- reduceDroneGeno(geno = tmpD, pop = drones) expect_true(all(rle(as.vector(tmp))$values %in% 0:1)) @@ -384,7 +672,7 @@ test_that("reduceDroneGeno", { test_that("getCsdAlleles", { founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes) - SP$nThreads = 1L + SP$nThreads <- 1L basePop <- createVirginQueens(founderGenomes, simParamBee = SP) baseAlleles <- getCsdAlleles(basePop, simParamBee = SP) @@ -393,25 +681,38 @@ test_that("getCsdAlleles", { 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) + fatherGroups <- pullDroneGroupsFromDCA( + drones, + n = 10, + nDrones = 10, + simParamBee = SP + ) # Create a Colony class - colony <- createColony(x = basePop[2],simParamBee = SP) + colony <- createColony(x = basePop[2], simParamBee = SP) colony <- cross(colony, drones = fatherGroups[[1]], simParamBee = SP) colony <- buildUp(x = colony, simParamBee = SP) expect_true(is.list(getCsdAlleles(colony, simParamBee = SP))) - expect_true(is.matrix(getCsdAlleles(getQueen(colony, simParamBee = SP), simParamBee = SP))) + expect_true(is.matrix(getCsdAlleles( + getQueen(colony, simParamBee = SP), + simParamBee = SP + ))) # set CSD to NULL rm(SP) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) - SP$nThreads = 1L + 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) + fatherGroups <- pullDroneGroupsFromDCA( + drones, + n = 10, + nDrones = 10, + simParamBee = SP + ) # Create a Colony class colony <- createColony(x = basePop[2], simParamBee = SP) @@ -423,26 +724,55 @@ test_that("getCsdAlleles", { # test unique and colapse rm(SP) SP <- SimParamBee$new(founderGenomes, nCsdAlleles = 5) - SP$nThreads = 1L + 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) + 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_true(is.matrix(getCsdAlleles(colony, collapse = TRUE, simParamBee = SP))) - expect_equal(nrow(getCsdAlleles(colony, collapse = TRUE, simParamBee = SP)), - sum(nQueens(colony, simParamBee = SP)*2, nDrones(colony, simParamBee = SP), - nWorkers(colony, simParamBee = SP)*2, nFathers(colony, simParamBee = SP), - nVirginQueens(colony, simParamBee = SP)*2)) - expect_equal(nrow(getCsdAlleles(colony, collapse = TRUE, unique = TRUE, simParamBee = SP)), - nrow(unique(getCsdAlleles(colony, collapse = TRUE, simParamBee = SP)))) - expect_true(nrow(getCsdAlleles(colony, collapse = TRUE, unique = TRUE, simParamBee = SP)) <= SP$nCsdAlleles) - + expect_true(is.matrix(getCsdAlleles( + colony, + collapse = TRUE, + simParamBee = SP + ))) + expect_equal( + nrow(getCsdAlleles(colony, collapse = TRUE, simParamBee = SP)), + sum( + nQueens(colony, simParamBee = SP) * 2, + nDrones(colony, simParamBee = SP), + nWorkers(colony, simParamBee = SP) * 2, + nFathers(colony, simParamBee = SP), + nVirginQueens(colony, simParamBee = SP) * 2 + ) + ) + expect_equal( + nrow(getCsdAlleles( + colony, + collapse = TRUE, + unique = TRUE, + simParamBee = SP + )), + nrow(unique(getCsdAlleles(colony, collapse = TRUE, simParamBee = SP))) + ) + expect_true( + nrow(getCsdAlleles( + colony, + collapse = TRUE, + unique = TRUE, + simParamBee = SP + )) <= + SP$nCsdAlleles + ) }) # ---- getCsdGeno ---- @@ -450,12 +780,17 @@ test_that("getCsdAlleles", { test_that("getCsdGeno", { founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, nCsdAlleles = 5) - SP$nThreads = 1L + 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) + fatherGroups <- pullDroneGroupsFromDCA( + drones, + n = 10, + nDrones = 10, + simParamBee = SP + ) # Create a Colony class colony <- createColony(x = basePop[2], simParamBee = SP) @@ -463,19 +798,29 @@ test_that("getCsdGeno", { colony <- buildUp(x = colony, simParamBee = SP) expect_true(is.list(getCsdGeno(colony, simParamBee = SP))) - expect_true(is.matrix(getCsdGeno(getQueen(colony, simParamBee = SP), simParamBee = SP))) - expect_true(nCsdAlleles(colony, collapse = TRUE, simParamBee = SP) <= SP$nCsdAlleles) + expect_true(is.matrix(getCsdGeno( + getQueen(colony, simParamBee = SP), + simParamBee = SP + ))) + expect_true( + nCsdAlleles(colony, collapse = TRUE, simParamBee = SP) <= SP$nCsdAlleles + ) geno <- getCsdGeno(colony, simParamBee = SP) expect_equal(nrow(geno$fathers), 10) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) - SP$nThreads = 1L + 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) + fatherGroups <- pullDroneGroupsFromDCA( + drones, + n = 10, + nDrones = 10, + simParamBee = SP + ) # Create a Colony class colony <- createColony(x = basePop[2], simParamBee = SP) @@ -483,7 +828,6 @@ test_that("getCsdGeno", { colony <- buildUp(x = colony, simParamBee = SP) expect_error(getCsdGeno(colony, simParamBee = SP)) - }) # ---- isCsdHeterozygous ---- @@ -491,14 +835,19 @@ test_that("getCsdGeno", { test_that("isCsdHeterozygous", { founderGenomes <- quickHaplo(nInd = 50, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, nCsdAlleles = 5) - SP$nThreads = 1L + 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) + fatherGroups <- pullDroneGroupsFromDCA( + drones, + n = 10, + nDrones = 10, + simParamBee = SP + ) # Create a Colony class colony <- createColony(x = basePop[2], simParamBee = SP) @@ -513,7 +862,7 @@ test_that("isCsdHeterozygous", { # set CSD to NULL SP <- SimParamBee$new(founderGenomes, csdChr = NULL) - SP$nThreads = 1L + SP$nThreads <- 1L basePop <- createVirginQueens(founderGenomes[10:15], simParamBee = SP) expect_error(isCsdHeterozygous(basePop, simParamBee = SP)) @@ -524,12 +873,17 @@ test_that("isCsdHeterozygous", { test_that("nCsdAlleles", { founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes) - SP$nThreads = 1L + 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) + fatherGroups <- pullDroneGroupsFromDCA( + drones, + n = 10, + nDrones = 10, + simParamBee = SP + ) # Create a Colony class colony <- createColony(x = basePop[2], simParamBee = SP) @@ -543,12 +897,17 @@ test_that("nCsdAlleles", { # set CSD to NULL SP <- SimParamBee$new(founderGenomes, csdChr = NULL) - SP$nThreads = 1L + 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) + fatherGroups <- pullDroneGroupsFromDCA( + drones, + n = 10, + nDrones = 10, + simParamBee = SP + ) # Create a Colony class colony <- createColony(x = basePop[2], simParamBee = SP) @@ -560,19 +919,30 @@ test_that("nCsdAlleles", { #collapse argument nCsdAlleles <- 5 SP <- SimParamBee$new(founderGenomes, nCsdAlleles = nCsdAlleles) - SP$nThreads = 1L + 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) + 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_true(is.numeric(nCsdAlleles(colony, collapse = TRUE, simParamBee = SP))) - expect_true(nCsdAlleles(colony, collapse = TRUE, simParamBee = SP) <= nCsdAlleles) + expect_true(is.numeric(nCsdAlleles( + colony, + collapse = TRUE, + simParamBee = SP + ))) + expect_true( + nCsdAlleles(colony, collapse = TRUE, simParamBee = SP) <= nCsdAlleles + ) }) # ---- calcBeeGRMIbs ---- @@ -580,16 +950,20 @@ test_that("nCsdAlleles", { test_that("calcBeeGRMIbs", { founderGenomes <- quickHaplo(nInd = 3, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) - SP$nThreads = 1L + SP$nThreads <- 1L SP$setTrackRec(TRUE) SP$setTrackPed(isTrackPed = TRUE) 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) + fatherGroups <- pullDroneGroupsFromDCA( + drones, + n = 10, + nDrones = 10, + simParamBee = SP + ) apiary <- createMultiColony(basePop[2:3], n = 2, simParamBee = SP) apiary <- cross(x = apiary, drones = fatherGroups[c(2, 3)], simParamBee = SP) apiary <- buildUp(x = apiary, simParamBee = SP) @@ -609,8 +983,13 @@ test_that("calcBeeGRMIbs", { sex <- getCasteSex(x = apiary[[1]], simParamBee = SP) sex <- c( - sex$queen, sex$fathers, sex$workers, sex$drones, sex$virginQueens, - "F", "M" + sex$queen, + sex$fathers, + sex$workers, + sex$drones, + sex$virginQueens, + "F", + "M" ) GRM <- calcBeeGRMIbs(x = geno, sex = sex) @@ -618,7 +997,7 @@ test_that("calcBeeGRMIbs", { # added a vector since x must be a matrix - vec <- c(1,2,"a") + vec <- c(1, 2, "a") expect_error(calcBeeGRMIbs(x = vec, sex = sex)) @@ -626,8 +1005,13 @@ test_that("calcBeeGRMIbs", { sex <- getCasteSex(x = apiary[[1]], simParamBee = SP) sex <- c( - sex$queen, sex$drones, sex$workers, sex$drones, sex$virginQueens, - "A", "B" + sex$queen, + sex$drones, + sex$workers, + sex$drones, + sex$virginQueens, + "A", + "B" ) expect_error(calcBeeGRMIbs(x = GRM, sex = sex)) @@ -635,17 +1019,20 @@ test_that("calcBeeGRMIbs", { # ---- editCsdLocus ---- - test_that("editCsdLocus", { founderGenomes <- quickHaplo(nInd = 100, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = 1, nCsdAlleles = 8) - SP$nThreads = 1L + SP$nThreads <- 1L - basePop <- createVirginQueens(founderGenomes, editCsd = FALSE, simParamBee = SP) + basePop <- createVirginQueens( + founderGenomes, + editCsd = FALSE, + simParamBee = SP + ) nrow(getCsdAlleles(basePop, unique = TRUE, simParamBee = SP)) expect_false(all(isCsdHeterozygous(basePop, simParamBee = SP))) - basePopEdited <- SIMplyBee:::editCsdLocus(basePop, simParamBee = SP) + basePopEdited <- editCsdLocus(basePop, simParamBee = SP) expect_true(isPop(basePopEdited)) expect_true(all(isCsdHeterozygous(basePopEdited, simParamBee = SP))) @@ -657,7 +1044,11 @@ test_that("emptyNULL", { SP <- SimParamBee$new(founderGenomes, csdChr = 1, nCsdAlleles = 8) SP$nThreads <- 1L - basePop <- createVirginQueens(founderGenomes, editCsd = FALSE, simParamBee = SP) + basePop <- createVirginQueens( + founderGenomes, + editCsd = FALSE, + simParamBee = SP + ) expect_true(isEmpty(new(Class = "Pop"))) expect_true(isEmpty(basePop[0])) @@ -669,7 +1060,10 @@ test_that("emptyNULL", { expect_false(isEmpty(nonEmptyColony)) emptyApiary <- createMultiColony(n = 3, simParamBee = SP) - emptyApiary1 <- c(createColony(simParamBee = SP), createColony(simParamBee = SP)) + emptyApiary1 <- c( + createColony(simParamBee = SP), + createColony(simParamBee = SP) + ) nonEmptyApiary <- createMultiColony(basePop[2:5], n = 4, simParamBee = SP) expect_true(all(isEmpty(emptyApiary))) @@ -692,12 +1086,17 @@ test_that("emptyNULL", { test_that("isDronesPresent", { founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) - SP$nThreads = 1L + SP$nThreads <- 1L basePop <- createVirginQueens(founderGenomes, simParamBee = SP) drones <- createDrones(x = basePop[1], nInd = 1000, simParamBee = SP) - fatherGroups <- pullDroneGroupsFromDCA(drones, n = 10, nDrones = nFathersPoisson, simParamBee = SP) + fatherGroups <- pullDroneGroupsFromDCA( + drones, + n = 10, + nDrones = nFathersPoisson, + simParamBee = SP + ) # Create a Colony class object colony <- createColony(x = basePop[2], simParamBee = SP) @@ -705,7 +1104,7 @@ test_that("isDronesPresent", { colony <- buildUp(x = colony, nWorkers = 120, nDrones = 20, simParamBee = SP) colony <- addVirginQueens(x = colony, nInd = 1, simParamBee = SP) apiary <- createMultiColony(n = 1, simParamBee = SP) - vec <- c(1,2,3,4) + vec <- c(1, 2, 3, 4) apiary2 <- createMultiColony(simParamBee = SP) expect_true(isDronesPresent(colony, simParamBee = SP)) @@ -718,12 +1117,17 @@ test_that("isDronesPresent", { test_that("isFathersPresent", { founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) - SP$nThreads = 1L + 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) + fatherGroups <- pullDroneGroupsFromDCA( + drones, + n = 10, + nDrones = 10, + simParamBee = SP + ) # Create a Colony class object colony <- createColony(x = basePop[2], simParamBee = SP) @@ -731,7 +1135,7 @@ test_that("isFathersPresent", { colony <- buildUp(x = colony, nWorkers = 120, nDrones = 20, simParamBee = SP) colony <- addVirginQueens(x = colony, nInd = 1, simParamBee = SP) apiary <- createMultiColony(n = 1, simParamBee = SP) - vec <- c(1,2,3,4) + vec <- c(1, 2, 3, 4) apiary2 <- createMultiColony(simParamBee = SP) expect_true(isFathersPresent(colony, simParamBee = SP)) @@ -747,12 +1151,17 @@ test_that("isFathersPresent", { test_that("isWorkersPresent", { founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) - SP$nThreads = 1L + 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) + fatherGroups <- pullDroneGroupsFromDCA( + drones, + n = 10, + nDrones = 10, + simParamBee = SP + ) # Create a Colony class object colony <- createColony(x = basePop[2], simParamBee = SP) @@ -760,7 +1169,7 @@ test_that("isWorkersPresent", { colony <- buildUp(x = colony, nWorkers = 120, nDrones = 20, simParamBee = SP) colony <- addVirginQueens(x = colony, nInd = 1, simParamBee = SP) apiary <- createMultiColony(n = 1, simParamBee = SP) - vec <- c(1,2,3,4) + vec <- c(1, 2, 3, 4) apiary2 <- createMultiColony(simParamBee = SP) expect_true(isWorkersPresent(colony, simParamBee = SP)) @@ -770,236 +1179,346 @@ test_that("isWorkersPresent", { }) # ---- isGenoHeterozygous ---- -test_that("isGenoHeterozygous", { - founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) - SP <- SimParamBee$new(founderGenomes) - SP$nThreads = 1L - basePop <- createVirginQueens(founderGenomes, simParamBee = SP) - - #Test on a Pop - (tmp <- getCsdGeno(basePop, simParamBee = SP)) - expect_true(all(SIMplyBee:::isGenoHeterozygous(tmp))) +test_that("isGenoHeterozygous", { + founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) + SP <- SimParamBee$new(founderGenomes) + SP$nThreads <- 1L - drones <- createDrones(x = basePop[1], nInd = 1000, simParamBee = SP) - # Test on drones - (tmp <- getCsdGeno(drones, simParamBee = SP)) - expect_true(all(SIMplyBee:::isGenoHeterozygous(tmp))) + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) - droneGroups <- pullDroneGroupsFromDCA(drones, n = 10, nDrones = nFathersPoisson, simParamBee = SP) + #Test on a Pop + (tmp <- getCsdGeno(basePop, simParamBee = SP)) + expect_true(all(isGenoHeterozygous(tmp))) - # 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 = 6, nDrones = 3, simParamBee = SP) - colony <- addVirginQueens(x = colony, nInd = 4, simParamBee = SP) + drones <- createDrones(x = basePop[1], nInd = 1000, simParamBee = SP) + # Test on drones + (tmp <- getCsdGeno(drones, simParamBee = SP)) + expect_true(all(isGenoHeterozygous(tmp))) + + droneGroups <- pullDroneGroupsFromDCA( + drones, + n = 10, + nDrones = nFathersPoisson, + simParamBee = SP + ) - apiary <- createMultiColony(basePop[3:4], n = 2, simParamBee = SP) - apiary <- cross(apiary, drones = droneGroups[c(2, 3)], simParamBee = SP) - apiary <- buildUp(x = apiary, nWorkers = 6, nDrones = 3, simParamBee = SP) - apiary <- addVirginQueens(x = apiary, nInd = 5, 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 = 6, nDrones = 3, simParamBee = SP) + colony <- addVirginQueens(x = colony, nInd = 4, simParamBee = SP) - # Caste members taken from Colony class - (tmp <- getCsdGeno(getQueen(colony, simParamBee = SP), simParamBee = SP)) - expect_true(SIMplyBee:::isGenoHeterozygous(tmp)) + apiary <- createMultiColony(basePop[3:4], n = 2, simParamBee = SP) + apiary <- cross(apiary, drones = droneGroups[c(2, 3)], simParamBee = SP) + apiary <- buildUp(x = apiary, nWorkers = 6, nDrones = 3, simParamBee = SP) + apiary <- addVirginQueens(x = apiary, nInd = 5, simParamBee = SP) - # Caste members taken from MultiColony class - (tmp <- getCsdGeno(getQueen(apiary[[1]], simParamBee = SP), simParamBee = SP)) - expect_true(SIMplyBee:::isGenoHeterozygous(tmp)) + # Caste members taken from Colony class + (tmp <- getCsdGeno(getQueen(colony, simParamBee = SP), simParamBee = SP)) + expect_true(isGenoHeterozygous(tmp)) + # Caste members taken from MultiColony class + (tmp <- getCsdGeno(getQueen(apiary[[1]], simParamBee = SP), simParamBee = SP)) + expect_true(isGenoHeterozygous(tmp)) }) # ---- getBV ---- test_that("getBV", { - founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) - SP <- SimParamBee$new(founderGenomes, csdChr = NULL) - SP$nThreads = 1L - SP$addTraitA(nQtlPerChr = 10, var = 1) - SP$addSnpChip(5) - - basePop <- createVirginQueens(founderGenomes, simParamBee = SP) + founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) + SP <- SimParamBee$new(founderGenomes, csdChr = NULL) + SP$nThreads <- 1L + SP$addTraitA(nQtlPerChr = 10, var = 1) + SP$addSnpChip(5) - drones <- createDrones(x = basePop[1], nInd = 1000, simParamBee = SP) - droneGroups <- pullDroneGroupsFromDCA(drones, n = 10, nDrones = nFathersPoisson, simParamBee = SP) + basePop <- createVirginQueens(founderGenomes, 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 = 6, nDrones = 3, simParamBee = SP) + drones <- createDrones(x = basePop[1], nInd = 1000, simParamBee = SP) + droneGroups <- pullDroneGroupsFromDCA( + drones, + n = 10, + nDrones = nFathersPoisson, + simParamBee = SP + ) - apiary <- createMultiColony(basePop[3:4], n = 2, simParamBee = SP) - apiary <- cross(apiary, drones = droneGroups[c(2, 3)], simParamBee = SP) - apiary <- buildUp(x = apiary, nWorkers = 6, nDrones = 3, 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 = 6, nDrones = 3, simParamBee = SP) - expect_equal(nrow(SIMplyBee:::getBv(x = getQueen(colony, simParamBee = SP), simParamBee = SP)), 1) - expect_equal(nrow(SIMplyBee:::getQueenBv(x = colony, simParamBee = SP)), 1) - expect_equal(nrow(SIMplyBee:::getBv(x = getWorkers(colony, simParamBee = SP), simParamBee = SP)), 6) - expect_equal(nrow(SIMplyBee:::getWorkersBv(x = colony, simParamBee = SP)), 6) + apiary <- createMultiColony(basePop[3:4], n = 2, simParamBee = SP) + apiary <- cross(apiary, drones = droneGroups[c(2, 3)], simParamBee = SP) + apiary <- buildUp(x = apiary, nWorkers = 6, nDrones = 3, simParamBee = SP) + + expect_equal( + nrow(getBv( + x = getQueen(colony, simParamBee = SP), + simParamBee = SP + )), + 1 + ) + expect_equal(nrow(getQueenBv(x = colony, simParamBee = SP)), 1) + expect_equal( + nrow(getBv( + x = getWorkers(colony, simParamBee = SP), + simParamBee = SP + )), + 6 + ) + expect_equal(nrow(getWorkersBv(x = colony, simParamBee = SP)), 6) - expect_length(SIMplyBee:::getBv(apiary, caste = "workers", simParamBee = SP), 2) - expect_equal(nrow(SIMplyBee:::getBv(apiary, caste = "workers", simParamBee = SP)[[1]]), 6) + expect_length( + getBv(apiary, caste = "workers", simParamBee = SP), + 2 + ) + expect_equal( + nrow(getBv(apiary, caste = "workers", simParamBee = SP)[[1]]), + 6 + ) }) # ---- getDd ---- 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) + founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) + SP <- SimParamBee$new(founderGenomes, csdChr = NULL) + SP$nThreads <- 1L - drones <- createDrones(x = basePop[1], nInd = 1000, simParamBee = SP) - droneGroups <- pullDroneGroupsFromDCA(drones, n = 10, nDrones = nFathersPoisson, simParamBee = SP) + SP$addTraitAD(nQtlPerChr = 10, meanDD = 0.2, varDD = 0.1) + basePop <- createVirginQueens(founderGenomes, 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 = 6, nDrones = 3, simParamBee = SP) + drones <- createDrones(x = basePop[1], nInd = 1000, simParamBee = SP) + droneGroups <- pullDroneGroupsFromDCA( + drones, + n = 10, + nDrones = nFathersPoisson, + simParamBee = SP + ) - apiary <- createMultiColony(basePop[3:4], n = 2, simParamBee = SP) - apiary <- cross(apiary, drones = droneGroups[c(2, 3)], simParamBee = SP) - apiary <- buildUp(x = apiary, nWorkers = 6, nDrones = 3, 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 = 6, nDrones = 3, simParamBee = SP) - expect_equal(nrow(SIMplyBee:::getDd(x = getQueen(colony, simParamBee = SP), simParamBee = SP)), 1) - expect_equal(nrow(SIMplyBee:::getQueenDd(x = colony, simParamBee = SP)), 1) - expect_equal(nrow(SIMplyBee:::getDd(x = getWorkers(colony, simParamBee = SP), simParamBee = SP)), 6) - expect_equal(nrow(SIMplyBee:::getWorkersDd(x = colony, simParamBee = SP)), 6) + apiary <- createMultiColony(basePop[3:4], n = 2, simParamBee = SP) + apiary <- cross(apiary, drones = droneGroups[c(2, 3)], simParamBee = SP) + apiary <- buildUp(x = apiary, nWorkers = 6, nDrones = 3, simParamBee = SP) + + expect_equal( + nrow(getDd( + x = getQueen(colony, simParamBee = SP), + simParamBee = SP + )), + 1 + ) + expect_equal(nrow(getQueenDd(x = colony, simParamBee = SP)), 1) + expect_equal( + nrow(getDd( + x = getWorkers(colony, simParamBee = SP), + simParamBee = SP + )), + 6 + ) + expect_equal(nrow(getWorkersDd(x = colony, simParamBee = SP)), 6) - expect_length(SIMplyBee:::getDd(apiary, caste = "workers", simParamBee = SP), 2) - expect_equal(nrow(SIMplyBee:::getDd(apiary, caste = "workers", simParamBee = SP)[[1]]), 6) + expect_length( + getDd(apiary, caste = "workers", simParamBee = SP), + 2 + ) + expect_equal( + nrow(getDd(apiary, caste = "workers", simParamBee = SP)[[1]]), + 6 + ) }) # ---- getAa ---- 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) + founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) + SP <- SimParamBee$new(founderGenomes, csdChr = NULL) + SP$nThreads <- 1L - drones <- createDrones(x = basePop[1], nInd = 1000, simParamBee = SP) - droneGroups <- pullDroneGroupsFromDCA(drones, n = 10, nDrones = nFathersPoisson, simParamBee = SP) + SP$addTraitADE(nQtlPerChr = 10, meanDD = 0.2, varDD = 0.1, relAA = 0.5) + basePop <- createVirginQueens(founderGenomes, 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 = 6, nDrones = 3, simParamBee = SP) + drones <- createDrones(x = basePop[1], nInd = 1000, simParamBee = SP) + droneGroups <- pullDroneGroupsFromDCA( + drones, + n = 10, + nDrones = nFathersPoisson, + simParamBee = SP + ) - apiary <- createMultiColony(basePop[3:4], n = 2, simParamBee = SP) - apiary <- cross(apiary, drones = droneGroups[c(2, 3)], simParamBee = SP) - apiary <- buildUp(x = apiary, nWorkers = 6, nDrones = 3, 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 = 6, nDrones = 3, simParamBee = SP) - expect_equal(nrow(SIMplyBee:::getAa(x = getQueen(colony, simParamBee = SP), simParamBee = SP)), 1) - expect_equal(nrow(SIMplyBee:::getQueenAa(x = colony, simParamBee = SP)), 1) - expect_equal(nrow(SIMplyBee:::getAa(x = getWorkers(colony, simParamBee = SP), simParamBee = SP)), 6) - expect_equal(nrow(SIMplyBee:::getWorkersAa(x = colony, simParamBee = SP)), 6) + apiary <- createMultiColony(basePop[3:4], n = 2, simParamBee = SP) + apiary <- cross(apiary, drones = droneGroups[c(2, 3)], simParamBee = SP) + apiary <- buildUp(x = apiary, nWorkers = 6, nDrones = 3, simParamBee = SP) + + expect_equal( + nrow(getAa( + x = getQueen(colony, simParamBee = SP), + simParamBee = SP + )), + 1 + ) + expect_equal(nrow(getQueenAa(x = colony, simParamBee = SP)), 1) + expect_equal( + nrow(getAa( + x = getWorkers(colony, simParamBee = SP), + simParamBee = SP + )), + 6 + ) + expect_equal(nrow(getWorkersAa(x = colony, simParamBee = SP)), 6) - expect_length(SIMplyBee:::getAa(apiary, caste = "workers", simParamBee = SP), 2) - expect_equal(nrow(SIMplyBee:::getAa(apiary, caste = "workers", simParamBee = SP)[[1]]), 6) + expect_length( + getAa(apiary, caste = "workers", simParamBee = SP), + 2 + ) + expect_equal( + nrow(getAa(apiary, caste = "workers", simParamBee = SP)[[1]]), + 6 + ) }) # ---- editCsdLocus ---- test_that("editCsdLocus", { - founderGenomes <- quickHaplo(nInd = 100, nChr = 1, segSites = 100) - SP <- SimParamBee$new(founderGenomes, csdChr = 1, nCsdAlleles = 8) - SP$nThreads = 1L + 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)) + basePop <- createVirginQueens( + founderGenomes, + editCsd = FALSE, + simParamBee = SP + ) + nrow(getCsdAlleles(basePop, unique = TRUE, simParamBee = SP)) + all(isCsdHeterozygous(basePop, simParamBee = SP)) - basePopEdited <- SIMplyBee:::editCsdLocus(basePop, simParamBee = SP) - nrow(getCsdAlleles(basePopEdited, unique = TRUE, simParamBee = SP)) - expect_true(all(isCsdHeterozygous(basePopEdited, simParamBee = SP))) + basePopEdited <- editCsdLocus(basePop, simParamBee = SP) + nrow(getCsdAlleles(basePopEdited, unique = TRUE, simParamBee = SP)) + expect_true(all(isCsdHeterozygous(basePopEdited, simParamBee = SP))) }) # ---- getLocation ---- test_that("getLocation", { - 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) - droneGroups <- pullDroneGroupsFromDCA(drones, n = 10, nDrones = nFathersPoisson, simParamBee = SP) - colony <- createColony(x = basePop[2], simParamBee = SP) - colony <- cross(colony, drones = droneGroups[[1]], simParamBee = SP) - apiary <- createMultiColony(basePop[3:4], simParamBee = SP) - apiary <- cross(apiary, drones = droneGroups[c(2, 3)], simParamBee = SP) - - expect_equal(getLocation(colony), c(0, 0)) - expect_equal(getLocation(apiary[[1]]), c(0, 0)) - expect_equal(getLocation(apiary), list("2" = c(0, 0), "3" = c(0, 0))) - tmp <- matrix(data = 0, nrow = 2, ncol = 2, dimnames = list(c("2", "3"), NULL)) - expect_equal(getLocation(apiary, collapse = TRUE), tmp) - - loc <- c(123, 456) - expect_equal(getLocation(setLocation(colony, location = loc, simParamBee = SP)), loc) - - expect_equal(getLocation(setLocation(apiary, location = loc, simParamBee = SP)), - list("2" = loc, "3" = loc)) + 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) + droneGroups <- pullDroneGroupsFromDCA( + drones, + n = 10, + nDrones = nFathersPoisson, + simParamBee = SP + ) + colony <- createColony(x = basePop[2], simParamBee = SP) + colony <- cross(colony, drones = droneGroups[[1]], simParamBee = SP) + apiary <- createMultiColony(basePop[3:4], simParamBee = SP) + apiary <- cross(apiary, drones = droneGroups[c(2, 3)], simParamBee = SP) + + expect_equal(getLocation(colony), c(0, 0)) + expect_equal(getLocation(apiary[[1]]), c(0, 0)) + expect_equal(getLocation(apiary), list("2" = c(0, 0), "3" = c(0, 0))) + tmp <- matrix( + data = 0, + nrow = 2, + ncol = 2, + dimnames = list(c("2", "3"), NULL) + ) + expect_equal(getLocation(apiary, collapse = TRUE), tmp) + + loc <- c(123, 456) + expect_equal( + getLocation(setLocation(colony, location = loc, simParamBee = SP)), + loc + ) + + expect_equal( + getLocation(setLocation(apiary, location = loc, simParamBee = SP)), + list("2" = loc, "3" = loc) + ) }) # ---- createCrossPlan ---- test_that("createCrossPlan", { founderGenomes <- quickHaplo(nInd = 1000, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes) - SP$nThreads = 1L + 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)), - simParamBee = SP) + virginColonies1 <- setLocation( + virginColonies1, + location = Map(c, 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)), - simParamBee = SP) + virginColonies2 <- setLocation( + virginColonies2, + location = Map(c, 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)), - simParamBee = SP) + virginColonies3 <- setLocation( + virginColonies3, + location = Map(c, 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)), - simParamBee = SP) + droneColonies <- setLocation( + droneColonies, + location = Map(c, 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) # Cross initial virgin drone colonies to the DCA with a random cross plan - randomCrossPlan <- createCrossPlan(x = droneColonies, - drones = DCA, - nDrones = 15, - spatial = FALSE, - simParamBee = SP) + randomCrossPlan <- createCrossPlan( + x = droneColonies, + drones = DCA, + nDrones = 15, + spatial = FALSE, + simParamBee = SP + ) expect_length(randomCrossPlan, 3) - droneColonies <- cross(droneColonies, - drones = DCA, - nDrones = nFathersPoisson, - crossPlan = randomCrossPlan, - simParamBee = SP) + droneColonies <- cross( + droneColonies, + drones = DCA, + nDrones = nFathersPoisson, + crossPlan = randomCrossPlan, + simParamBee = SP + ) - expect_equal(as.vector(nFathers(droneColonies, simParamBee = SP)), c(15, 15, 15)) + expect_equal( + as.vector(nFathers(droneColonies, simParamBee = SP)), + c(15, 15, 15) + ) # 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, - simParamBee = SP) + crossPlanSpatial <- createCrossPlan( + x = virginColonies1, + droneColonies = droneColonies, + nDrones = nFathersPoisson, + spatial = TRUE, + radius = 1.5, + simParamBee = SP + ) expect_length(crossPlanSpatial, 2) - expect_error(createCrossPlan(x = droneColonies, droneColonies = virginColonies1, simParamBee = SP)) + expect_error(createCrossPlan( + x = droneColonies, + droneColonies = virginColonies1, + simParamBee = SP + )) }) @@ -1007,14 +1526,19 @@ test_that("createCrossPlan", { test_that("getCaste", { founderGenomes <- quickHaplo(nInd = 1000, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes) - SP$nThreads = 1L + SP$nThreads <- 1L basePop <- createVirginQueens(founderGenomes, simParamBee = SP) expect_vector(getCaste(basePop, simParamBee = SP), "virginQueens") #Create drones drones <- createDrones(x = basePop[1], nInd = 1000, simParamBee = SP) - droneGroups <- pullDroneGroupsFromDCA(drones, n = 10, nDrones = nFathersPoisson, simParamBee = SP) + droneGroups <- pullDroneGroupsFromDCA( + drones, + n = 10, + nDrones = nFathersPoisson, + simParamBee = SP + ) expect_vector(getCaste(drones, simParamBee = SP), "drones") # Create a Colony and a MultiColony class @@ -1022,42 +1546,86 @@ test_that("getCaste", { colony <- cross(colony, drones = droneGroups[[1]], simParamBee = SP) # test that all drones in colony are now fathers. Colony should only contain queen and fathers - expect_vector(getCaste(getQueen(colony, simParamBee = SP), simParamBee = SP), "queen") - expect_vector(getCaste(getFathers(colony, simParamBee = SP), simParamBee = SP), "fathers") + expect_vector( + getCaste(getQueen(colony, simParamBee = SP), simParamBee = SP), + "queen" + ) + expect_vector( + getCaste(getFathers(colony, simParamBee = SP), simParamBee = SP), + "fathers" + ) expect_error(getCaste(getWorkers(colony, simParamBee = SP), simParamBee = SP)) expect_error(getCaste(getDrones(colony, simParamBee = SP), simParamBee = SP)) - expect_error(getCaste(getVirginQueens(colony, simParamBee = SP), simParamBee = SP)) + expect_error(getCaste( + getVirginQueens(colony, simParamBee = SP), + simParamBee = SP + )) # all caste members are now present colony <- buildUp(x = colony, nWorkers = 20, nDrones = 5, simParamBee = SP) colony <- addVirginQueens(colony, nInd = 5, simParamBee = SP) - expect_vector(getCaste(getQueen(colony, simParamBee = SP), simParamBee = SP), "queen") - expect_vector(getCaste(getFathers(colony, simParamBee = SP), simParamBee = SP), "fathers") - expect_vector(getCaste(getWorkers(colony, simParamBee = SP), simParamBee = SP), "workers") - expect_vector(getCaste(getDrones(colony, simParamBee = SP), simParamBee = SP), "drones") - expect_vector(getCaste(getVirginQueens(colony, simParamBee = SP), simParamBee = SP), "virginQueen") + expect_vector( + getCaste(getQueen(colony, simParamBee = SP), simParamBee = SP), + "queen" + ) + expect_vector( + getCaste(getFathers(colony, simParamBee = SP), simParamBee = SP), + "fathers" + ) + expect_vector( + getCaste(getWorkers(colony, simParamBee = SP), simParamBee = SP), + "workers" + ) + expect_vector( + getCaste(getDrones(colony, simParamBee = SP), simParamBee = SP), + "drones" + ) + expect_vector( + getCaste(getVirginQueens(colony, simParamBee = SP), simParamBee = SP), + "virginQueen" + ) # Check colony collapses expect_length(getCaste(colony, collapse = FALSE, simParamBee = SP), 5) - expect_vector(getCaste(colony, collapse = TRUE, simParamBee = SP), c("queen", "fathers", "workers", "drones", "virginQueens")) + expect_vector( + getCaste(colony, collapse = TRUE, simParamBee = SP), + c("queen", "fathers", "workers", "drones", "virginQueens") + ) # Create virgin apiary containing 2 colonies apiary <- createMultiColony(basePop[3:4], n = 2, simParamBee = SP) expect_length(getCaste(apiary, simParamBee = SP), 2) - expect_vector(getCaste(getVirginQueens(apiary[[1]], simParamBee = SP), simParamBee = SP), "virginQueen") + expect_vector( + getCaste(getVirginQueens(apiary[[1]], simParamBee = SP), simParamBee = SP), + "virginQueen" + ) # Mate apiaries, now only contains queens and fathers apiary <- cross(apiary, drones = droneGroups[c(2, 3)], simParamBee = SP) - expect_vector(getCaste(getQueen(apiary[[1]], simParamBee = SP), simParamBee = SP), "queen") - expect_vector(getCaste(getFathers(apiary[[1]], simParamBee = SP), simParamBee = SP), "fathers") + expect_vector( + getCaste(getQueen(apiary[[1]], simParamBee = SP), simParamBee = SP), + "queen" + ) + expect_vector( + getCaste(getFathers(apiary[[1]], simParamBee = SP), simParamBee = SP), + "fathers" + ) # all caste members are now present in apiary apiary <- buildUp(x = apiary, nWorkers = 10, nDrones = 2, simParamBee = SP) apiary <- addVirginQueens(apiary, nInd = 4, simParamBee = SP) - expect_vector(getCaste(getWorkers(apiary[[1]], simParamBee = SP), simParamBee = SP), "workers") - expect_vector(getCaste(getDrones(apiary[[1]], simParamBee = SP), simParamBee = SP), "drones") - expect_vector(getCaste(getVirginQueens(apiary[[1]], simParamBee = SP), simParamBee = SP), "virginQueen") - + expect_vector( + getCaste(getWorkers(apiary[[1]], simParamBee = SP), simParamBee = SP), + "workers" + ) + expect_vector( + getCaste(getDrones(apiary[[1]], simParamBee = SP), simParamBee = SP), + "drones" + ) + expect_vector( + getCaste(getVirginQueens(apiary[[1]], simParamBee = SP), simParamBee = SP), + "virginQueen" + ) bees <- c( getQueen(colony, simParamBee = SP), @@ -1066,27 +1634,32 @@ test_that("getCaste", { getDrones(colony, nInd = 2, simParamBee = SP), getVirginQueens(colony, nInd = 2, simParamBee = SP) ) - expect_vector(getCaste(bees, simParamBee = SP), c("queen", "fathers", "workers", "drones", "virginQueens")) - - + expect_vector( + getCaste(bees, simParamBee = SP), + c("queen", "fathers", "workers", "drones", "virginQueens") + ) }) - test_that("getIbdHaplo", { founderGenomes <- quickHaplo(nInd = 4, nChr = 1, segSites = 5) SP <- SimParamBee$new(founderGenomes, nCsdAlleles = 4) - SP$nThreads = 1L + 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) + 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) + 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) @@ -1100,13 +1673,13 @@ test_that("getIbdHaplo", { 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) - }) +}) test_that("trackingHomozygotes", { founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes) - SP$nThreads = 1L + SP$nThreads <- 1L SP$setTrackPed(T) SP$setTrackRec(T) expect_equal(nrow(SP$pedigree), 0) @@ -1121,7 +1694,12 @@ test_that("trackingHomozygotes", { 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) + 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) diff --git a/tests/testthat/test-L1_pop_functions.R b/tests/testthat/test-L1_pop_functions.R index dc31682e..b6b5fa44 100644 --- a/tests/testthat/test-L1_pop_functions.R +++ b/tests/testthat/test-L1_pop_functions.R @@ -370,7 +370,7 @@ test_that("combineBeeGametes", { queen <- basePop[1] drones <- createDrones(x = basePop[2], nInd = 5, simParamBee = SP) - workers <- SIMplyBee:::combineBeeGametes(queen, drones, nProgeny = 4, simParamBee = SP) + workers <- combineBeeGametes(queen, drones, nProgeny = 4, simParamBee = SP) expect_equal(drones@ploidy, 2) expect_equal(nInd(drones), 5) diff --git a/vignettes/A_Honeybee_biology.Rmd b/vignettes/A_Honeybee_biology.Rmd index 8241c168..b76beb6e 100644 --- a/vignettes/A_Honeybee_biology.Rmd +++ b/vignettes/A_Honeybee_biology.Rmd @@ -2,7 +2,7 @@ title: "Honeybee biology" date: "`r Sys.Date()`" output: rmarkdown::html_vignette -bibliography: '`r normalizePath(if (file.exists("../inst/REFERENCES.bib")) "../inst/REFERENCES.bib" else system.file("REFERENCES.bib", package = "SIMplyBee", mustWork = TRUE), mustWork = TRUE)`' +bibliography: '`r normalizePath(if (file.exists("../inst/REFERENCES.bib")) "../inst/REFERENCES.bib" else system.file("REFERENCES.bib", package = "SIMplyBee", mustWork = TRUE), winslash = "/", mustWork = TRUE)`' vignette: > %\VignetteIndexEntry{Honeybee biology} %\VignetteEngine{knitr::rmarkdown} diff --git a/vignettes/C_Colony_events.Rmd b/vignettes/C_Colony_events.Rmd index 8a56c309..809bdc41 100644 --- a/vignettes/C_Colony_events.Rmd +++ b/vignettes/C_Colony_events.Rmd @@ -2,7 +2,7 @@ title: "Colony events" date: "`r Sys.Date()`" output: rmarkdown::html_vignette -bibliography: '`r normalizePath(if (file.exists("../inst/REFERENCES.bib")) "../inst/REFERENCES.bib" else system.file("REFERENCES.bib", package = "SIMplyBee", mustWork = TRUE), mustWork = TRUE)`' +bibliography: '`r normalizePath(if (file.exists("../inst/REFERENCES.bib")) "../inst/REFERENCES.bib" else system.file("REFERENCES.bib", package = "SIMplyBee", mustWork = TRUE), winslash = "/", mustWork = TRUE)`' vignette: > %\VignetteIndexEntry{Colony events} %\VignetteEngine{knitr::rmarkdown} diff --git a/vignettes/E_Genomics.Rmd b/vignettes/E_Genomics.Rmd index 9cc49847..17cb63fc 100644 --- a/vignettes/E_Genomics.Rmd +++ b/vignettes/E_Genomics.Rmd @@ -2,7 +2,7 @@ title: "Genomics" date: "`r Sys.Date()`" output: rmarkdown::html_vignette -bibliography: '`r normalizePath(if (file.exists("../inst/REFERENCES.bib")) "../inst/REFERENCES.bib" else system.file("REFERENCES.bib", package = "SIMplyBee", mustWork = TRUE), mustWork = TRUE)`' +bibliography: '`r normalizePath(if (file.exists("../inst/REFERENCES.bib")) "../inst/REFERENCES.bib" else system.file("REFERENCES.bib", package = "SIMplyBee", mustWork = TRUE), winslash = "/", mustWork = TRUE)`' vignette: > %\VignetteIndexEntry{Genomics} %\VignetteEngine{knitr::rmarkdown} diff --git a/vignettes/F2_Variance_calculations.Rmd b/vignettes/F2_Variance_calculations.Rmd index 40c758b3..547ad6bf 100644 --- a/vignettes/F2_Variance_calculations.Rmd +++ b/vignettes/F2_Variance_calculations.Rmd @@ -2,7 +2,7 @@ title: "Variance calculations between individual and colony level values" date: "`r Sys.Date()`" output: rmarkdown::html_vignette -bibliography: '`r normalizePath(if (file.exists("../inst/REFERENCES.bib")) "../inst/REFERENCES.bib" else system.file("REFERENCES.bib", package = "SIMplyBee", mustWork = TRUE), mustWork = TRUE)`' +bibliography: '`r normalizePath(if (file.exists("../inst/REFERENCES.bib")) "../inst/REFERENCES.bib" else system.file("REFERENCES.bib", package = "SIMplyBee", mustWork = TRUE), winslash = "/", mustWork = TRUE)`' vignette: > %\VignetteIndexEntry{VarianceCalculations} %\VignetteEngine{knitr::rmarkdown} diff --git a/vignettes/F_Quantitative_Genetics.Rmd b/vignettes/F_Quantitative_Genetics.Rmd index 16ee529d..e24e0ae1 100644 --- a/vignettes/F_Quantitative_Genetics.Rmd +++ b/vignettes/F_Quantitative_Genetics.Rmd @@ -2,7 +2,7 @@ title: "Quantitative genetics" date: "`r Sys.Date()`" output: rmarkdown::html_vignette -bibliography: '`r normalizePath(if (file.exists("../inst/REFERENCES.bib")) "../inst/REFERENCES.bib" else system.file("REFERENCES.bib", package = "SIMplyBee", mustWork = TRUE), mustWork = TRUE)`' +bibliography: '`r normalizePath(if (file.exists("../inst/REFERENCES.bib")) "../inst/REFERENCES.bib" else system.file("REFERENCES.bib", package = "SIMplyBee", mustWork = TRUE), winslash = "/", mustWork = TRUE)`' vignette: > %\VignetteIndexEntry{Quantitative genetics} %\VignetteEngine{knitr::rmarkdown} From ebb8e8a3ecbf14443c7180f9e0c92057c28033f3 Mon Sep 17 00:00:00 2001 From: gregorgorjanc Date: Wed, 30 Sep 2026 17:58:16 +0000 Subject: [PATCH 74/98] Update documentation --- DESCRIPTION | 1 - NAMESPACE | 36 +-- man/MultiColony-class.Rd | 12 +- man/SIMplyBee-package.Rd | 1 + man/SimParamBee.Rd | 514 +++++++++++++++++++-------------------- 5 files changed, 273 insertions(+), 291 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 36cfce13..a636f5e4 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -40,4 +40,3 @@ Config/Needs/website: tidyverse/tidytemplate VignetteBuilder: knitr Config/roxygen2/version: 8.1.0 RdMacros: Rdpack -RoxygenNote: 7.3.3 diff --git a/NAMESPACE b/NAMESPACE index 3d4fa682..e400fa59 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -211,21 +211,25 @@ importFrom(R6,R6Class) importFrom(Rdpack,reprompt) importFrom(extraDistr,rtpois) importFrom(future.apply,future_lapply) -importFrom(methods,"slot<-") -importFrom(methods,classLabel) -importFrom(methods,is) -importFrom(methods,new) -importFrom(methods,setClass) -importFrom(methods,setClassUnion) -importFrom(methods,setMethod) -importFrom(methods,setValidity) -importFrom(methods,show) -importFrom(methods,slot) -importFrom(methods,validObject) -importFrom(stats,na.omit) -importFrom(stats,rbeta) -importFrom(stats,rnorm) -importFrom(stats,rpois) -importFrom(stats,runif) +importFrom(methods, + "slot<-", + classLabel, + is, + new, + setClass, + setClassUnion, + setMethod, + setValidity, + show, + slot, + validObject +) +importFrom(stats, + na.omit, + rbeta, + rnorm, + rpois, + runif +) importFrom(utils,packageVersion) useDynLib(SIMplyBee, .registration = TRUE) diff --git a/man/MultiColony-class.Rd b/man/MultiColony-class.Rd index d81e7d6f..6be082c7 100644 --- a/man/MultiColony-class.Rd +++ b/man/MultiColony-class.Rd @@ -70,17 +70,17 @@ An object holding a collection of honeybee colonies. It behaves \item \code{c(MultiColonyOrNULL)}: Combine multiple Colony and MultiColony objects -\item \code{x[i}: Extract a colony (one or more!) with an integer/numeric/logical index (position) (return \code{\link[SIMplyBee]{MultiColony-class}}) +\item \code{x = MultiColony[i = integerOrNumericOrLogical]}: Extract a colony (one or more!) with an integer/numeric/logical index (position) (return \code{\link[SIMplyBee]{MultiColony-class}}) -\item \code{x[i}: Extract a colony (one or more!) with a character ID (name) (return \code{\link[SIMplyBee]{MultiColony-class}}) +\item \code{x = MultiColony[i = character]}: Extract a colony (one or more!) with a character ID (name) (return \code{\link[SIMplyBee]{MultiColony-class}}) -\item \code{x[[i}: Extract a colony (just one!) with an integer/numeric/logical index (position) (return \code{\link[SIMplyBee]{Colony-class}}) +\item \code{x = MultiColony[[i = integerOrNumericOrLogical]]}: Extract a colony (just one!) with an integer/numeric/logical index (position) (return \code{\link[SIMplyBee]{Colony-class}}) -\item \code{x[[i}: Extract a colony (just one!) with a character ID (name) (return \code{\link[SIMplyBee]{Colony-class}}) +\item \code{x = MultiColony[[i = character]]}: Extract a colony (just one!) with a character ID (name) (return \code{\link[SIMplyBee]{Colony-class}}) -\item \code{`[`(x = MultiColony, i = integerOrNumericOrLogicalOrCharacter, j = ANY) <- value}: Assign colonies into MultiColony +\item \code{x = MultiColony[i = integerOrNumericOrLogicalOrCharacter, j = ANY] <- value}: Assign colonies into MultiColony -\item \code{`[[`(x = MultiColony, i = integerOrNumericOrLogicalOrCharacter, j = ANY) <- value}: Assign Colony into MultiColony +\item \code{x = MultiColony[[i = integerOrNumericOrLogicalOrCharacter, j = ANY]] <- value}: Assign Colony into MultiColony }} \section{Slots}{ diff --git a/man/SIMplyBee-package.Rd b/man/SIMplyBee-package.Rd index 02b01c03..99748e94 100644 --- a/man/SIMplyBee-package.Rd +++ b/man/SIMplyBee-package.Rd @@ -37,6 +37,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 79b873f7..dad6b6eb 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) @@ -92,9 +92,9 @@ SP$caste \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}}. @@ -116,7 +116,7 @@ SP$caste 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}}. @@ -138,7 +138,7 @@ SP$caste 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}}. @@ -160,7 +160,7 @@ SP$caste 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}}. @@ -182,7 +182,7 @@ SP$caste 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}}. @@ -203,7 +203,7 @@ SP$caste 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. @@ -212,7 +212,7 @@ SP$caste 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}}. @@ -233,7 +233,7 @@ SP$caste 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}}. @@ -254,7 +254,7 @@ SP$caste 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}}. @@ -266,100 +266,99 @@ SP$caste 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, @@ -373,99 +372,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) @@ -479,35 +460,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 @@ -519,140 +498,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{
    }} -} -} } From 72b4311400bd2d3ee0d4e7ee331020336a7ead99 Mon Sep 17 00:00:00 2001 From: Gregor Gorjanc Date: Wed, 30 Sep 2026 19:12:59 +0100 Subject: [PATCH 75/98] Ignore local IDE state and generated build artifacts --- .gitignore | 27 ++++++++++++++++++++++++++- 1 file changed, 26 insertions(+), 1 deletion(-) diff --git a/.gitignore b/.gitignore index 8bc7bb8a..736032a2 100644 --- a/.gitignore +++ b/.gitignore @@ -7,6 +7,7 @@ # User-specific files .Ruserdata +Rplots.pdf # Example code in package build process *-Ex.R @@ -19,12 +20,35 @@ src/*.so # Output files from R CMD check /*.Rcheck/ -# RStudio files +# Local IDE state .Rproj.user/ +.idea/ +.vscode/ + +# Compiled code and coverage output +/src/**/*.o +/src/**/*.so +/src/**/*.dll +/src/**/*.dylib +/src/**/*.gcda +/src/**/*.gcno +/covr/ + +# Binary package builds +/SIMplyBee_*.tgz +/SIMplyBee_*.zip + +# Installed documentation and rendered development documents +/inst/doc/ +/README.html +/README_files/ +/cran-comments.html +/cran-comments_files/ # produced vignettes vignettes/*.html vignettes/*.pdf +vignettes/*_files/ # OAuth2 token, see https://github.com/hadley/httr/releases/tag/v0.3 .httr-oauth @@ -32,6 +56,7 @@ vignettes/*.pdf # knitr and R markdown default cache directories *_cache/ /cache/ +.quarto/ # Temporary files created by R markdown *.utf8.md From dd323de11e87bf8209ee6f684d0207c564742deb Mon Sep 17 00:00:00 2001 From: Gregor Gorjanc Date: Wed, 30 Sep 2026 19:36:23 +0100 Subject: [PATCH 76/98] Fortifying the pHomBrood test --- tests/testthat/test-L0_auxiliary_functions.R | 207 +++++++++++++------ 1 file changed, 146 insertions(+), 61 deletions(-) diff --git a/tests/testthat/test-L0_auxiliary_functions.R b/tests/testthat/test-L0_auxiliary_functions.R index fdfbb63c..dc6e1b47 100644 --- a/tests/testthat/test-L0_auxiliary_functions.R +++ b/tests/testthat/test-L0_auxiliary_functions.R @@ -222,11 +222,18 @@ test_that("isCaste", { test_that("calcQueensPHomBrood", { set.seed(1) - founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) - SP <- SimParamBee$new(founderGenomes) + founderGenomes <- quickHaplo(nInd = 3, nChr = 1, segSites = 100) + SP <- SimParamBee$new(founderGenomes, csdChr = 1, nCsdAlleles = 4) SP$nThreads <- 1L - basePop <- createVirginQueens(founderGenomes, simParamBee = SP) + # Queen 1 is AB; queens 2 and 3 are CD, so their fathers cannot match. + AB <- rbind(c(0, 0), c(0, 1)) + CD <- rbind(c(1, 0), c(1, 1)) + basePop <- createVirginQueens( + founderGenomes, + csdAlleles = list(AB, CD, CD), + simParamBee = SP + ) expect_error( calcQueensPHomBrood(basePop, simParamBee = SP), "calcQueensPHomBrood can only be used with queens!", @@ -293,34 +300,65 @@ test_that("calcQueensPHomBrood", { tmp <- calcQueensPHomBrood(apiary, simParamBee = SP) expect_equal(length(tmp), 2) expect_equal(tmp, c(`2` = 0, `3` = 0)) +}) - drones <- createDrones(x = basePop[4:5], nInd = 100, simParamBee = SP) - fatherGroups <- pullDroneGroupsFromDCA( - drones, - n = 2, - nDrones = 10, +test_that("calcQueensPHomBrood reflects controlled father proportions", { + set.seed(1) + founderGenomes <- quickHaplo(nInd = 4, nChr = 1, segSites = 100) + SP <- SimParamBee$new(founderGenomes, csdChr = 1, nCsdAlleles = 4) + SP$nThreads <- 1L + + # Four distinct csd alleles, each encoded by two SNPs. + AB <- rbind(c(0, 0), c(0, 1)) + CD <- rbind(c(1, 0), c(1, 1)) + queens <- createVirginQueens( + founderGenomes, + csdAlleles = list(AB, AB, AB, CD), simParamBee = SP ) - colony2 <- createColony(x = basePop[4], simParamBee = SP) - colony2 <- cross(colony2, drones = fatherGroups[[1]], simParamBee = SP) - colony3 <- createColony(x = basePop[5], simParamBee = SP) - colony3 <- cross(colony3, drones = fatherGroups[[2]], simParamBee = SP) - apiary <- c(colony2, colony3) - tmp <- calcQueensPHomBrood(apiary, simParamBee = SP) - expect_equal(length(tmp), 2) - expect_equal(tmp, c(`6` = 0.35, `7` = 0.10)) + # Both recipient queens are AB. Every drone from queen 3 matches; + # none from queen 4 matches, regardless of random segregation. + matching <- createDrones(queens[3], nInd = 9, simParamBee = SP) + nonmatching <- createDrones(queens[4], nInd = 11, simParamBee = SP) + fatherGroups <- list( + c(matching[1:7], nonmatching[1:3]), + c(matching[8:9], nonmatching[4:11]) + ) + apiary <- createMultiColony(queens[1:2], simParamBee = SP) + apiary <- cross(apiary, drones = fatherGroups, simParamBee = SP) + + # Matching fathers contribute homozygous brood with probability 1/2. + expected <- setNames(c(0.35, 0.10), getId(apiary)) + expect_equal(calcQueensPHomBrood(apiary, simParamBee = SP), expected) + for (i in seq_len(2)) { + expect_equal( + calcQueensPHomBrood(apiary[[i]], simParamBee = SP), + unname(expected[i]) + ) + expect_equal( + calcQueensPHomBrood(apiary[[i]]@queen, simParamBee = SP), + unname(expected[i]) + ) + } }) # ---- pHomBrood ---- test_that("pHomBrood", { set.seed(1) - founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) - SP <- SimParamBee$new(founderGenomes) + founderGenomes <- quickHaplo(nInd = 3, nChr = 1, segSites = 100) + SP <- SimParamBee$new(founderGenomes, csdChr = 1, nCsdAlleles = 4) SP$nThreads <- 1L - basePop <- createVirginQueens(founderGenomes, simParamBee = SP) + # Queen 1 is AB; queens 2 and 3 are CD, so their fathers cannot match. + AB <- rbind(c(0, 0), c(0, 1)) + CD <- rbind(c(1, 0), c(1, 1)) + basePop <- createVirginQueens( + founderGenomes, + csdAlleles = list(AB, CD, CD), + simParamBee = SP + ) expect_error( pHomBrood(basePop, simParamBee = SP), "Individuals in x must be queens!", @@ -351,13 +389,11 @@ test_that("pHomBrood", { pHomBrood(colony@workers, simParamBee = SP), "Individuals in x must be queens!" ) - # This does not work because colony@virginQueens is empty pop so we get out zero length output - # expect_error( - # pHomBrood(colony@virginQueens, simParamBee = SP), - # "Individuals in x must be queens!" - # ) - # ... so let's do this instead - expect_length(pHomBrood(colony@virginQueens, simParamBee = SP), 0L) + # Explicitly empty populations return numeric(0), regardless of caste. + expect_identical( + pHomBrood(colony@virginQueens[integer(0)], simParamBee = SP), + numeric(0) + ) expect_error( pHomBrood(colony@drones, simParamBee = SP), "Individuals in x must be queens!" @@ -366,7 +402,6 @@ test_that("pHomBrood", { expect_true(pHomBrood(colony@queen, simParamBee = SP) > 0) expect_true(pHomBrood(colony@queen, simParamBee = SP) == 0.5) - colonyCopy <- colony colony@queen <- NULL expect_error( pHomBrood(colony@queen, simParamBee = SP), @@ -387,34 +422,62 @@ test_that("pHomBrood", { tmp <- pHomBrood(apiary, simParamBee = SP) expect_equal(length(tmp), 2) expect_equal(tmp, c(`2` = 0, `3` = 0)) +}) - drones <- createDrones(x = basePop[4:5], nInd = 100, simParamBee = SP) - fatherGroups <- pullDroneGroupsFromDCA( - drones, - n = 2, - nDrones = 10, +test_that("pHomBrood reflects controlled father proportions", { + set.seed(1) + founderGenomes <- quickHaplo(nInd = 4, nChr = 1, segSites = 100) + SP <- SimParamBee$new(founderGenomes, csdChr = 1, nCsdAlleles = 4) + SP$nThreads <- 1L + + # Four distinct csd alleles, each encoded by two SNPs. + AB <- rbind(c(0, 0), c(0, 1)) + CD <- rbind(c(1, 0), c(1, 1)) + queens <- createVirginQueens( + founderGenomes, + csdAlleles = list(AB, AB, AB, CD), simParamBee = SP ) - colony2 <- createColony(x = basePop[4], simParamBee = SP) - colony2 <- cross(colony2, drones = fatherGroups[[1]], simParamBee = SP) - colony3 <- createColony(x = basePop[5], simParamBee = SP) - colony3 <- cross(colony3, drones = fatherGroups[[2]], simParamBee = SP) - apiary <- c(colony2, colony3) - tmp <- pHomBrood(apiary, simParamBee = SP) - expect_equal(length(tmp), 2) - expect_equal(tmp, c(`6` = 0.35, `7` = 0.10)) + # Both recipient queens are AB. Every drone from queen 3 matches; + # none from queen 4 matches, regardless of random segregation. + matching <- createDrones(queens[3], nInd = 9, simParamBee = SP) + nonmatching <- createDrones(queens[4], nInd = 11, simParamBee = SP) + fatherGroups <- list( + c(matching[1:7], nonmatching[1:3]), + c(matching[8:9], nonmatching[4:11]) + ) + apiary <- createMultiColony(queens[1:2], simParamBee = SP) + apiary <- cross(apiary, drones = fatherGroups, simParamBee = SP) + + # Matching fathers contribute homozygous brood with probability 1/2. + expected <- setNames(c(0.35, 0.10), getId(apiary)) + expect_equal(pHomBrood(apiary, simParamBee = SP), expected) + for (i in seq_len(2)) { + expect_equal(pHomBrood(apiary[[i]], simParamBee = SP), unname(expected[i])) + expect_equal( + pHomBrood(apiary[[i]]@queen, simParamBee = SP), + unname(expected[i]) + ) + } }) #---- nHomBrood ----- test_that("nHomBrood", { set.seed(1) - founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) - SP <- SimParamBee$new(founderGenomes) + founderGenomes <- quickHaplo(nInd = 3, nChr = 1, segSites = 100) + SP <- SimParamBee$new(founderGenomes, csdChr = 1, nCsdAlleles = 4) SP$nThreads <- 1L - basePop <- createVirginQueens(founderGenomes, simParamBee = SP) + # Queen 1 is AB; queens 2 and 3 are CD, so their fathers cannot match. + AB <- rbind(c(0, 0), c(0, 1)) + CD <- rbind(c(1, 0), c(1, 1)) + basePop <- createVirginQueens( + founderGenomes, + csdAlleles = list(AB, CD, CD), + simParamBee = SP + ) expect_error( nHomBrood(basePop, simParamBee = SP), "Individuals in x must be queens!", @@ -455,7 +518,6 @@ test_that("nHomBrood", { "Individuals in x must be queens!" ) expect_true(is.numeric(nHomBrood(colony@queen, simParamBee = SP))) - expect_true(nHomBrood(colony@queen, simParamBee = SP) > 0) # Of the 120 worker offspring requested, csd homozygotes did not survive. expect_equal( nHomBrood(colony@queen, simParamBee = SP), @@ -482,29 +544,52 @@ test_that("nHomBrood", { tmp <- nHomBrood(apiary, simParamBee = SP) expect_equal(length(tmp), 2) expect_equal(tmp, c(`2` = 0, `3` = 0)) +}) - drones <- createDrones(x = basePop[4:5], nInd = 100, simParamBee = SP) - fatherGroups <- pullDroneGroupsFromDCA( - drones, - n = 2, - nDrones = 10, +test_that("nHomBrood tracks realised brood with controlled fathers", { + set.seed(1) + founderGenomes <- quickHaplo(nInd = 4, nChr = 1, segSites = 100) + SP <- SimParamBee$new(founderGenomes, csdChr = 1, nCsdAlleles = 4) + SP$nThreads <- 1L + + # Four distinct csd alleles, each encoded by two SNPs. + AB <- rbind(c(0, 0), c(0, 1)) + CD <- rbind(c(1, 0), c(1, 1)) + queens <- createVirginQueens( + founderGenomes, + csdAlleles = list(AB, AB, AB, CD), simParamBee = SP ) - colony2 <- createColony(x = basePop[4], simParamBee = SP) - colony2 <- cross(colony2, drones = fatherGroups[[1]], simParamBee = SP) - colony3 <- createColony(x = basePop[5], simParamBee = SP) - colony3 <- cross(colony3, drones = fatherGroups[[2]], simParamBee = SP) - apiary <- c(colony2, colony3) - tmp <- nHomBrood(apiary, simParamBee = SP) - expect_equal(length(tmp), 2) - expect_equal(tmp, c(`6` = 0, `7` = 0)) + # Both recipient queens are AB. Every drone from queen 3 matches; + # none from queen 4 matches, regardless of random segregation. + matching <- createDrones(queens[3], nInd = 9, simParamBee = SP) + nonmatching <- createDrones(queens[4], nInd = 11, simParamBee = SP) + fatherGroups <- list( + c(matching[1:7], nonmatching[1:3]), + c(matching[8:9], nonmatching[4:11]) + ) + apiary <- createMultiColony(queens[1:2], simParamBee = SP) + apiary <- cross(apiary, drones = fatherGroups, simParamBee = SP) + + expected <- setNames(c(0, 0), getId(apiary)) + expect_equal(nHomBrood(apiary, simParamBee = SP), expected) + for (i in seq_len(2)) { + expect_equal(nHomBrood(apiary[[i]], simParamBee = SP), 0) + expect_equal(nHomBrood(apiary[[i]]@queen, simParamBee = SP), 0) + } apiary <- buildUp(apiary, nWorkers = 40, nDrones = 0, simParamBee = SP) - expect_equal( - nHomBrood(apiary, simParamBee = SP), - 40 - nWorkers(apiary, simParamBee = SP) - ) + # Realised counts vary, but every missing worker is csd homozygous. + expected <- 40 - nWorkers(apiary, simParamBee = SP) + expect_equal(nHomBrood(apiary, simParamBee = SP), expected) + for (i in seq_len(2)) { + expect_equal(nHomBrood(apiary[[i]], simParamBee = SP), unname(expected[i])) + expect_equal( + nHomBrood(apiary[[i]]@queen, simParamBee = SP), + unname(expected[i]) + ) + } }) # ---- isQueenPresent ---- From 1d6010b77197a8d7d3980a1db807d4d3297d07c6 Mon Sep 17 00:00:00 2001 From: Gregor Gorjanc Date: Thu, 1 Oct 2026 08:20:33 +0100 Subject: [PATCH 77/98] more testing --- R/Class-Colony.R | 1 + R/Class-MultiColony.R | 1 + R/Class-SimParamBee.R | 1 + R/Functions_L0_auxilary.R | 1 + R/Functions_L1_Pop.R | 2 + R/Functions_L2_Colony.R | 1 + R/Functions_L3_Colonies.R | 1 + tests/testthat/test-L0_auxiliary_functions.R | 75 ++++++++++++++++++-- tests/testthat/test-L1_pop_functions.R | 5 +- tests/testthat/test-L2_colony_functions.R | 3 +- tests/testthat/test-L3_Colonies_functions.R | 1 + 11 files changed, 84 insertions(+), 8 deletions(-) diff --git a/R/Class-Colony.R b/R/Class-Colony.R index 1925698c..bd5e5639 100644 --- a/R/Class-Colony.R +++ b/R/Class-Colony.R @@ -1,3 +1,4 @@ + # ---- Class Colony ---- setClassUnion("characterOrNULL", c("character", "NULL")) diff --git a/R/Class-MultiColony.R b/R/Class-MultiColony.R index 271b1fd5..177f2b2b 100644 --- a/R/Class-MultiColony.R +++ b/R/Class-MultiColony.R @@ -1,3 +1,4 @@ + # ---- Class MultiColony ---- setClassUnion("integerOrNumeric", c("integer", "numeric")) diff --git a/R/Class-SimParamBee.R b/R/Class-SimParamBee.R index e178e191..43576186 100644 --- a/R/Class-SimParamBee.R +++ b/R/Class-SimParamBee.R @@ -1,3 +1,4 @@ + # ---- Class SimParamBee ---- setClassUnion("numericOrFunction", c("numeric", "function")) diff --git a/R/Functions_L0_auxilary.R b/R/Functions_L0_auxilary.R index 19d68054..57a9eb09 100644 --- a/R/Functions_L0_auxilary.R +++ b/R/Functions_L0_auxilary.R @@ -1,3 +1,4 @@ + # ---- Level 0 Auxiliary Functions ---- # n* ---- diff --git a/R/Functions_L1_Pop.R b/R/Functions_L1_Pop.R index abdca327..621c32c1 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") utils::globalVariables("cl") diff --git a/R/Functions_L2_Colony.R b/R/Functions_L2_Colony.R index 1b4ef5e0..99a96a1c 100644 --- a/R/Functions_L2_Colony.R +++ b/R/Functions_L2_Colony.R @@ -1,3 +1,4 @@ + # ---- Level 2 Colony Functions ---- #' @rdname createColony diff --git a/R/Functions_L3_Colonies.R b/R/Functions_L3_Colonies.R index 78f240c3..52160b4f 100644 --- a/R/Functions_L3_Colonies.R +++ b/R/Functions_L3_Colonies.R @@ -1,3 +1,4 @@ + # ---- Level 3 MultiColony Functions ---- #' @rdname createMultiColony diff --git a/tests/testthat/test-L0_auxiliary_functions.R b/tests/testthat/test-L0_auxiliary_functions.R index dc6e1b47..e67aad94 100644 --- a/tests/testthat/test-L0_auxiliary_functions.R +++ b/tests/testthat/test-L0_auxiliary_functions.R @@ -156,6 +156,60 @@ test_that("isGenoHeterozygous", { expect_equal(isGenoHeterozygous(geno), c(TRUE, FALSE, FALSE)) }) +test_that("isHeterozygous detects differences between chromosome copies", { + # Two rows per bee, one column per locus; entries are ordinary 0/1 alleles + haplotypes <- matrix(0, nrow = 6, ncol = 16) + haplotypes[2, 9] <- 1 # Bee 1: its two copies differ at locus 9 + haplotypes[3:4, ] <- 1 # Bee 2: both copies are identical (all 1s) + haplotypes[6, 8] <- 1 # Bee 3: its two copies differ at locus 8 + founders <- newMapPop( + genMap = list(seq(0, 1, length.out = 16)), + haplotypes = list(haplotypes) + ) + + # Loci 8 and 9 straddle an internal storage boundary + # Four threads for three bees also tests the automatic thread limit + for (nThreads in c(1L, 4L)) { + observed <- isHeterozygous( + geno = founders@geno, + lociPerChr = 4L, + lociLoc = c(1L, 8L, 9L, 16L), + nThreads = nThreads + ) + expect_equal(as.vector(observed), c(1, 0, 1)) + } +}) + +test_that("isHeterozygous ignores chromosomes and loci that were not selected", { + # Two bees, each with two chromosome copies (rows 1:2 and 3:4) + chr1 <- chr2 <- chr3 <- matrix(0, nrow = 4, ncol = 16) + chr1[2, 1] <- 1 # Bee 1 differs at chromosome 1, locus 1 + chr2[c(2, 4), ] <- 1 # Both bees differ throughout chromosome 2 + chr3[4, 9] <- 1 # Bee 2 differs at chromosome 3, locus 9 + founders <- newMapPop( + genMap = rep(list(seq(0, 1, length.out = 16)), 3), + haplotypes = list(chr1, chr2, chr3) + ) + + # Select chromosome 1 locus 8 and chromosome 3 locus 9: only bee 2 differs + observed <- isHeterozygous( + geno = founders@geno, + lociPerChr = c(1L, 0L, 1L), + lociLoc = c(8L, 9L), + nThreads = 1L + ) + expect_equal(as.vector(observed), c(0, 1)) + + # Select only chromosome 1 locus 1: only bee 1 differs + observed <- isHeterozygous( + geno = founders@geno, + lociPerChr = c(1L, 0L, 0L), + lociLoc = 1L, + nThreads = 1L + ) + expect_equal(as.vector(observed), c(1, 0)) +}) + # ---- isCaste ---- test_that("isCaste", { @@ -701,6 +755,7 @@ test_that("isProductive", { apiary <- createMultiColony(simParamBee = SP) expect_true(is.list(isProductive(apiary))) }) + # ---- reduceDroneHaplo ---- test_that("reduceDroneHaplo", { @@ -1124,6 +1179,7 @@ test_that("editCsdLocus", { }) # ---- emptyNULL ---- + test_that("emptyNULL", { founderGenomes <- quickHaplo(nInd = 5, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = 1, nCsdAlleles = 8) @@ -1266,20 +1322,21 @@ test_that("isWorkersPresent", { # ---- isGenoHeterozygous ---- test_that("isGenoHeterozygous", { + set.seed(123) founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes) SP$nThreads <- 1L basePop <- createVirginQueens(founderGenomes, simParamBee = SP) - #Test on a Pop - (tmp <- getCsdGeno(basePop, simParamBee = SP)) + # Test on a Pop + tmp <- getCsdGeno(basePop, simParamBee = SP) expect_true(all(isGenoHeterozygous(tmp))) drones <- createDrones(x = basePop[1], nInd = 1000, simParamBee = SP) - # Test on drones - (tmp <- getCsdGeno(drones, simParamBee = SP)) - expect_true(all(isGenoHeterozygous(tmp))) + tmp <- getCsdGeno(drones, dronesHaploid = FALSE, simParamBee = SP) + expect_false(any(isGenoHeterozygous(tmp))) + expect_true(all(isCsdHeterozygous(drones, simParamBee = SP))) droneGroups <- pullDroneGroupsFromDCA( drones, @@ -1309,6 +1366,7 @@ test_that("isGenoHeterozygous", { }) # ---- getBV ---- + test_that("getBV", { founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) @@ -1363,6 +1421,7 @@ test_that("getBV", { }) # ---- getDd ---- + test_that("getDd", { founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) @@ -1416,6 +1475,7 @@ test_that("getDd", { }) # ---- getAa ---- + test_that("getAa", { founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) @@ -1469,6 +1529,7 @@ test_that("getAa", { }) # ---- editCsdLocus ---- + test_that("editCsdLocus", { founderGenomes <- quickHaplo(nInd = 100, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = 1, nCsdAlleles = 8) @@ -1488,6 +1549,7 @@ test_that("editCsdLocus", { }) # ---- getLocation ---- + test_that("getLocation", { founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes) @@ -1529,6 +1591,7 @@ test_that("getLocation", { }) # ---- createCrossPlan ---- + test_that("createCrossPlan", { founderGenomes <- quickHaplo(nInd = 1000, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes) @@ -1606,8 +1669,8 @@ test_that("createCrossPlan", { )) }) - # ---- Get Caste ---- + test_that("getCaste", { founderGenomes <- quickHaplo(nInd = 1000, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes) diff --git a/tests/testthat/test-L1_pop_functions.R b/tests/testthat/test-L1_pop_functions.R index b6b5fa44..7532400c 100644 --- a/tests/testthat/test-L1_pop_functions.R +++ b/tests/testthat/test-L1_pop_functions.R @@ -1,3 +1,4 @@ + # ---- getCastePop ---- test_that("getCastePop", { @@ -228,6 +229,7 @@ test_that("pullCastePop", { }) # ---- cross ---- + test_that("cross", { founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) @@ -292,8 +294,8 @@ test_that("cross", { #expect_message(cross(virginQueen2, drones= selectInd(colony@drones,nInd = 0, use = "rand", simParam = SP), checkCross = "warning", simParamBee = SP)) }) - # ---- createDCA ---- + test_that("createDCA", { founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) @@ -330,6 +332,7 @@ test_that("createDCA", { }) # ---- pullDroneGroupsFromDCA ---- + test_that("pullDroneGroupsFromDCA", { founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) diff --git a/tests/testthat/test-L2_colony_functions.R b/tests/testthat/test-L2_colony_functions.R index 7154f39e..afed1b04 100644 --- a/tests/testthat/test-L2_colony_functions.R +++ b/tests/testthat/test-L2_colony_functions.R @@ -1,3 +1,4 @@ + # ---- Create Colony ---- test_that("createColony", { @@ -281,6 +282,7 @@ test_that("removeFunctions", { }) # ---- SetLocation ---- + test_that("setLocation", { founderGenomes <- quickHaplo(nInd = 5, nChr = 1, segSites = 50) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) @@ -516,7 +518,6 @@ test_that("swarm", { expect_true(areVirginQueensPresent(tmp$remnant[[4]], simParamBee = SP)) }) - # ---- Collapse ----- test_that("collapse", { diff --git a/tests/testthat/test-L3_Colonies_functions.R b/tests/testthat/test-L3_Colonies_functions.R index 2598dc2b..a56133a7 100644 --- a/tests/testthat/test-L3_Colonies_functions.R +++ b/tests/testthat/test-L3_Colonies_functions.R @@ -1,4 +1,5 @@ # Level 3 MultiColony Functions + # ---- createMultiColony ---- test_that("createMultiColony", { From 348249d2896eae5557d148e056d309fc6f8a5725 Mon Sep 17 00:00:00 2001 From: Gregor Gorjanc Date: Sat, 3 Oct 2026 17:41:43 +0100 Subject: [PATCH 78/98] Polish indexing, character IDs, colony vs queen ID, and AGENTS.md --- .Rbuildignore | 4 + .github/agents/develop-r-package.agent.md | 123 -------- .gitignore | 31 +- AGENTS.md | 293 ++++++++++++------- NEWS.md | 68 +++-- R/Class-Colony.R | 4 +- R/Class-MultiColony.R | 80 +++-- R/Functions_L0_auxilary.R | 25 +- R/Functions_L1_Pop.R | 14 +- R/Functions_L2_Colony.R | 9 +- R/Functions_L3_Colonies.R | 90 ++++-- man/Colony-class.Rd | 2 +- man/MultiColony-class.Rd | 17 +- man/createColony.Rd | 2 +- man/getId.Rd | 19 +- man/reQueen.Rd | 2 +- tests/testthat/test-L0_auxiliary_functions.R | 59 +++- tests/testthat/test-L1_pop_functions.R | 32 +- tests/testthat/test-L2_colony_functions.R | 28 +- tests/testthat/test-L3_Colonies_functions.R | 70 ++++- 20 files changed, 605 insertions(+), 367 deletions(-) delete mode 100644 .github/agents/develop-r-package.agent.md diff --git a/.Rbuildignore b/.Rbuildignore index 679a4f13..47f82f82 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -6,6 +6,7 @@ ^\.gitignore ^[.]?air[.]toml$ ^[.]?jarl[.]toml$ +^AGENTS\.md$ ^_pkgdown\.yml ^cran-comments\.html$ ^cran-comments\.md$ @@ -25,3 +26,6 @@ ^Meta$ ^SIMplyBee\.Rproj +^literature$ +^dev$ +^TestingVarianceComponents\.R$ diff --git a/.github/agents/develop-r-package.agent.md b/.github/agents/develop-r-package.agent.md deleted file mode 100644 index 0262631d..00000000 --- a/.github/agents/develop-r-package.agent.md +++ /dev/null @@ -1,123 +0,0 @@ ---- -name: develop-r-package -description: Use when creating, modifying, or maintaining R packages. Use when editing R/ source files, DESCRIPTION, NAMESPACE, roxygen2 documentation, tests, or CI workflows in an R package context. Use when adding functions, bumping versions, managing dependencies, or preparing releases. ---- - -# Developing R Packages - -## Overview - -Codified workflow for R package development following the R Packages book (Wickham & Bryan, 2e) and conventions established in BadranSeq. Covers the edit-document-check-commit cycle, dependency management, versioning, and release workflow. - -## Development Cycle - -Every code change follows this sequence **before** committing: - -``` -Edit R/ files → devtools::document() → devtools::check() → git add → git commit -``` - -- `document()` regenerates NAMESPACE and man/*.Rd files from roxygen2 comments -- `check()` runs R CMD check locally — expect **0 errors, 0 warnings** -- Known NOTEs (license format, timestamp) are acceptable -- Never commit if check fails — fix first, then commit - -## NAMESPACE & roxygen2 - -- NAMESPACE is **auto-generated by roxygen2** — never edit it manually -- Use `@export` to make functions available to users -- Use `@description`, `@param`, `@return`, `@examples` for documentation -- Run `devtools::document()` after any roxygen comment change - -## Dependencies - -### Imports vs Suggests - -| Field | Purpose | Access pattern | -|-------|---------|---------------| -| `Imports` | Required at runtime, auto-installed | `pkg::fn()` in source code | -| `Suggests` | Optional (testing, extended features) | `pkg::fn()` — never `@importFrom` | -| `Depends` | Only for R version floor | `R (>= x.y)` | - -### Rules - -- **Always use `pkg::fn()` syntax** for external functions — no exceptions -- Only use `@importFrom` for operators (e.g., `%>%`) that can't use `::` -- Add dependencies via `usethis::use_package("pkg")` (defaults to Imports) -- For Suggests: `usethis::use_package("pkg", type = "Suggests")` -- Never call `library()` or `require()` inside package code - -## Versioning - -Format: `..` — always `.` separator, always 3 components. - -| Component | When to bump | Example | -|-----------|-------------|---------| -| **Major** | Breaking changes to existing API | 1.0.0 → 2.0.0 | -| **Minor** | New exported functions (backward-compatible) | 1.3.1 → 1.4.0 | -| **Patch** | Bug fixes, adjustments to existing functions | 1.3.1 → 1.3.2 | - -After bumping: update DESCRIPTION, README.Rmd install instructions, re-knit README.md. - -## Release Workflow - -``` -1. Bump version in DESCRIPTION -2. Update README.Rmd version references -3. devtools::build_readme() -4. devtools::check() # must pass -5. git commit + push -6. git tag -a vX.Y.Z -m "BadranSeq X.Y.Z" -7. git push --tags -8. gh release create vX.Y.Z # with release notes -``` - -## Data in Packages - -- User-facing data: `usethis::use_data(obj)` → saved to `data/obj.rda` -- Document datasets in `R/data.R` using roxygen2 (`@format`, `@source`) — never `@export` -- Preparation scripts go in `data-raw/` -- `LazyData: true` in DESCRIPTION enables lazy loading - -## Testing - -- Initialize with `usethis::use_testthat(3)` (edition 3) -- Match test files to source: `R/foo.R` → `tests/testthat/test-foo.R` -- Create tests with `usethis::use_test("foo")` -- Run with `devtools::test()` or `Ctrl+Shift+T` - -## Lifecycle Badges - -- Set up with `usethis::use_lifecycle()` (one-time) -- Badge in `@description`: `` `r lifecycle::badge("stable")` `` -- Only badge functions whose stage **differs** from the package's stage -- Stages: experimental → stable → deprecated/superseded - -## pkgdown Site - -- **Never build locally** — CI handles it via GitHub Actions after push -- Fix source files (roxygen, vignettes) and push; CI does the rest - -## CI (GitHub Actions) - -- R CMD check runs on push to main via `.github/workflows/R-CMD-check.yaml` -- Standard matrix: macOS, Windows, Ubuntu release, Ubuntu devel -- Drop `oldrel-1` if upstream deps require current R - -## README - -- `README.Rmd` is the source — contains live R code chunks -- `README.md` is the rendered output — never edit directly -- Re-knit with `devtools::build_readme()` after changes - -## Common Mistakes - -| Mistake | Fix | -|---------|-----| -| Editing NAMESPACE manually | Let roxygen2 generate it via `document()` | -| `@importFrom` for Suggests packages | Use `pkg::fn()` instead | -| Committing without `check()` | Always document → check → commit | -| `library()` inside package code | Use `pkg::fn()` or `@importFrom` | -| Editing README.md directly | Edit README.Rmd, then `build_readme()` | -| Building pkgdown locally | Let CI handle it | -| Version as `1.3` instead of `1.3.0` | Always use 3 components | diff --git a/.gitignore b/.gitignore index 4ef1b687..736032a2 100644 --- a/.gitignore +++ b/.gitignore @@ -7,6 +7,7 @@ # User-specific files .Ruserdata +Rplots.pdf # Example code in package build process *-Ex.R @@ -19,12 +20,35 @@ src/*.so # Output files from R CMD check /*.Rcheck/ -# RStudio files +# Local IDE state .Rproj.user/ +.idea/ +.vscode/ + +# Compiled code and coverage output +/src/**/*.o +/src/**/*.so +/src/**/*.dll +/src/**/*.dylib +/src/**/*.gcda +/src/**/*.gcno +/covr/ + +# Binary package builds +/SIMplyBee_*.tgz +/SIMplyBee_*.zip + +# Installed documentation and rendered development documents +/inst/doc/ +/README.html +/README_files/ +/cran-comments.html +/cran-comments_files/ # produced vignettes vignettes/*.html vignettes/*.pdf +vignettes/*_files/ # OAuth2 token, see https://github.com/hadley/httr/releases/tag/v0.3 .httr-oauth @@ -32,6 +56,7 @@ vignettes/*.pdf # knitr and R markdown default cache directories *_cache/ /cache/ +.quarto/ # Temporary files created by R markdown *.utf8.md @@ -44,5 +69,5 @@ vignettes/*.pdf .DS_Store /doc/ /Meta/ -src/*.o -src/*.so + +literature/*.pdf diff --git a/AGENTS.md b/AGENTS.md index fd44b0ac..2080bcda 100644 --- a/AGENTS.md +++ b/AGENTS.md @@ -3,7 +3,62 @@ ## 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. +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. + +## Package map + +* `R/Class-SimParamBee.R`: R6 simulation parameters extending AlphaSimR's + `SimParam`; holds shared simulation settings and bookkeeping. +* `R/Class-Colony.R`: S4 colony holding the queen, virgin queens, workers, + drones, colony state, and metadata. +* `R/Class-MultiColony.R`: list-like collection of colonies, including + subsetting and replacement methods. +* `R/Functions_L0_auxilary.R`: auxiliary functions (the filename spelling is + intentional here); `Functions_L1_Pop.R`, `Functions_L2_Colony.R`, and + `Functions_L3_Colonies.R` respectively provide population, colony, and + multicolony operations. +* `src/`: compiled helpers to speed up operations. +* `tests/testthat/` unit tests. +* `vignettes`: longer form documentation. +* `docs`: pkgdown output. + +## Scientific invariants and shared state + +* Seeded results are part of observable behavior. Reordering random operations, + batching crosses, or changing parallel execution can change results even when + their distributions remain correct. Assess these effects explicitly and record + intentional user-visible changes in `NEWS.md`. +* Running the same seed twice in a modified implementation checks repeatability, + not compatibility with the previous implementation. For changes that should + preserve seeded results, compare against the previous implementation under + the same R and dependency versions using a small representative regression case. +* Test thread-count independence where the supported implementation promises it. + Review RNG handling when changing `future.apply` paths, including `future.seed`; + do not assume worker-count, scheduling, and sequential/parallel equivalence + without checking the relevant path. +* `SimParamBee` has R6 reference semantics: changing a field affects the caller. + Do not silently overwrite user settings. When temporarily changing settings + such as `nThreads`, register restoration with `on.exit(..., add = TRUE)` before + doing work that can fail. Preserve intentional updates to simulation counters + and records. +* Create new individuals through supported SIMplyBee/AlphaSimR constructors and + crossing functions. Direct S4 construction or manual ID changes can bypass + ID, pedigree, and recombination bookkeeping. Check these invariants explicitly + when changing population creation, especially across parallel workers. +* Treat population and colony metadata as biological state. Queens' `misc` + includes fathers and brood counts. When subsetting, merging, or rebuilding + populations, verify metadata, individual order, IDs, and class preservation; + inspect the supported AlphaSimR/SIMplyBee methods + rather than assuming all slots survive. +* Preserve the package's representation of haploid drones and diploid females, + caste-specific inheritance, and complementary sex determination. For relevant + changes, test maternal-only inheritance in drones, parental allele inheritance + in female offspring, and homozygous-brood handling with csd enabled, as well as + the supported csd-disabled path. Respect the existing genotype representation + rather than inferring ploidy solely from storage dimensions. ## The way of working @@ -14,6 +69,8 @@ SIMplyBee aims to provide an easy to use simulation platform to simulate honeybe * 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. +* Package checks should have no new errors or warnings. Report existing failures + and explain any accepted NOTEs; do not assume every NOTE is harmless. * We update `NEWS.md` for user-visible behavior or API changes. ## Permissions and authorization @@ -53,14 +110,16 @@ curl -I -sS --max-time 15 ## Definition of done +Run the R commands below from the package directory of the active worktree. + 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. +* Run applicable formatting/lint checks described below and `git diff --check`. +* `Rscript -e "devtools::test()"` + for package tests. +* `Rscript -e "devtools::check()"` + for full package checks. * Updated `NEWS.md` for user-visible changes. ### Task-class quality gates @@ -70,7 +129,7 @@ A task is done when all applicable items below are completed: `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()`). + handoff (`devtools::test()` and `devtools::check()`, plus applicable lint checks). * If full checks are intentionally skipped, explicitly report what was skipped, why, and which focused checks were run. @@ -80,9 +139,13 @@ 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 +git worktree add ../SIMplyBee_wt_ -b origin/ ``` +Choose `` from the task or PR target. The README distinguishes +`main` (pre-CRAN stable work) from `devel` (development); do not assume `main` +is always the correct base. Reuse an existing task worktree when appropriate. + Within this workflow, follow these rules: * In the shared root worktree, limit edits to small docs/meta/config work. @@ -96,17 +159,19 @@ Within this workflow, follow these rules: ```sh git fetch origin --prune -git rebase origin/main +git rebase origin/ ``` -* If there are local uncommitted edits, use `--autostash` or an explicit stash. +* Inspect staged and unstaged changes first. Preserve existing work; do not + stash, rebase, or change branches in a shared dirty checkout as routine setup. * 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: +Remove a task worktree only once its work is preserved and it is clean; never +force removal to discard uncommitted work. After merge/finish: ```sh git worktree remove ../SIMplyBee_wt_ @@ -125,71 +190,30 @@ For issue exploration, closure recommendations, or "what is left to do?" tasks: ## Quality toolchain -These checks mirror `README.md` guidance and enforce package quality. - -### Pre-commit hooks +The checkout has `air.toml` and `jarl.toml`. -Install once per clone: +Use Air and Jarl when installed, scoped to changed R files, for example: ```sh -pre-commit install +air format R/Functions_L0_auxilary.R +jarl check R/Functions_L0_auxilary.R +git diff --check ``` -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: +Avoid repository-wide formatting churn. Check tool help before using unfamiliar +flags. Report unavailable checks rather than silently installing or upgrading +tools. If a tool is missing from `PATH`, also check user-local bin directories: ```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)" +Rscript -e "cov <- covr::package_coverage(clean = TRUE); print(cov)" ``` ### GitHub Actions (CI) @@ -198,9 +222,31 @@ 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. +* `.github/workflows/document.yaml`: regenerates roxygen documentation on R-source + pushes and can commit the generated changes back to the branch. +* `.github/workflows/pkgdown.yaml`: builds the website and deploys on non-PR runs. + +Check each workflow's triggers before assuming it runs for a particular branch. +Regenerate documentation locally when needed and inspect its diff before handoff. Local work should pass local checks before relying on CI feedback. +## Dependencies and package data + +* Keep dependencies minimal and justify additions. Required runtime packages + belong in `Imports`; optional features, examples, and tests use `Suggests`. + Preserve the intentional `Depends: AlphaSimR` relationship. +* Prefer `pkg::fun()` for new external calls, while respecting established + namespace imports. Do not call `library()` or `require()` inside package + functions. Guard optional features with `requireNamespace(..., quietly = TRUE)` + and a useful message, and skip tests when optional dependencies are unavailable. + Do not create unconditional namespace imports from suggested packages. +* When adding package datasets, keep preparation scripts in `data-raw/`, use + `usethis::use_data()` where appropriate, and document datasets with roxygen + `@format` and `@source`. Dataset documentation does not need `@export`. +* Exclude development-only top-level files and directories from package builds + in `.Rbuildignore`, including agent instructions and data-preparation scripts. + ## Generated files and source-of-truth rules Do not edit generated files by hand: @@ -209,13 +255,34 @@ Do not edit generated files by hand: * `src/RcppExports.cpp` * `NAMESPACE` * Files in `man/` generated from roxygen comments +* Generated website output in `docs/`; edit its sources in `R/`, `vignettes/`, + `README.md`, and `_pkgdown.yml` instead Regenerate as needed: ```sh -Rscript -e "setwd('SIMplyBee'); Rcpp::compileAttributes()" -Rscript -e "setwd('SIMplyBee'); devtools::document()" +Rscript -e "Rcpp::compileAttributes()" +Rscript -e "devtools::document()" ``` + +Additional source-of-truth rules: + +* This checkout maintains `README.md` directly; there is no `README.Rmd`. + If a generated README workflow is introduced, edit its source and regenerate + the output (for an R Markdown source, use `devtools::build_readme()`). +* `.github/workflows/document.yaml` runs on pushes touching `R/**` and commits + generated `man/`, `NAMESPACE`, and `DESCRIPTION` changes back to the branch. + Account for these automated commits when synchronising work. +* For local documentation generation, use the roxygen2 version recorded in + `DESCRIPTION` when available. Report a version mismatch and inspect generated + diffs for unrelated churn; CI currently installs roxygen2 without that pin. +* Changes to Rcpp-exported signatures require `Rcpp::compileAttributes()` and + rebuilding the package; the documentation workflow does not regenerate Rcpp + exports. +* Leave release version/date changes to release work explicitly requested by the + maintainer. A development NEWS heading differing from `DESCRIPTION` is not, + on its own, a reason to bump the package version. + ## R CMD Check ### Preferred way to R CMD Check @@ -223,68 +290,88 @@ Rscript -e "setwd('SIMplyBee'); devtools::document()" Run faster package checks from the package directory: ```sh -Rscript -e "setwd('SIMplyBee'); devtools::check(vignette = FALSE)" +Rscript -e "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()" +Rscript -e "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. +### Check environment and reporting -Use unsandboxed/escalated execution for full package checks. +A fast check with `vignette = FALSE` is an intermediate check, not a replacement +for the full check when vignettes or package behavior change. Vignettes use +knitr/rmarkdown; CI sets up Pandoc. Check R, compiler, Pandoc, and LaTeX +availability as relevant to the actual failure. Do not assume Quarto is required +or hard-code an IDE installation path. -### Quarto caveat (why it can work interactively but fail in agent runs) +If compiler detection fails inside the sandbox, inspect the error first; it +may be a sandbox restriction rather than a missing compiler. Request escalated +execution when needed under the standing authorization above. -`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. +At handoff, record commands run, errors/warnings/notes, and any skipped checks +with reasons. Compare failures with the unchanged base when needed to distinguish +existing problems from regressions. Never claim a check passes based on an older +run or assume a fixed expected result for this machine. ## 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). +* Add or update `testthat` tests for every behavior change. +* Prefer focused regression tests for bug fixes. +* Use the configured testthat edition (currently edition 3); do not change it + incidentally when adding tests. +* For stochastic tests, prefer biological invariants over arbitrary sampled + values. Use controlled seeds and justified tolerances when random outcomes are + part of the assertion; keep fixtures small and avoid flaky Monte Carlo checks. +* Keep ordinary simulation tests and examples single threaded with + `SP$nThreads = 1L` (use `\dontshow{SP$nThreads = 1L}` in roxygen examples). + Dedicated parallel/thread tests should set their own configuration and skip + explicitly when the required execution capability is unavailable. +* Keep tests runnable via package tests and checks. +* Keep stochastic tests reproducible with explicit seeds and small populations. + Set `SP$nThreads <- 1L` where appropriate; pass `simParamBee = SP` explicitly + to avoid dependence on global state. Restore any global options or parallel + plans changed by a test. +* Prefer independently derived expectations, biological invariants, and small + enumerated cases over tests that repeat the implementation. For simulation + estimates, use tolerances justified by sampling error. +* Cover relevant haplodiploid, caste, empty-colony, and single/multiple-colony + cases when changing population or colony operations. +* Guard genuinely optional external dependencies with explicit skips; do not + hide failures in required package dependencies such as AlphaSimR. 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')`. + +* `Rscript -e "devtools::test()"` + for package tests, or a focused run such as + `Rscript -e "devtools::test(filter = 'L2_colony_functions')"`. Tests are also run as part of R CMD check. +## Research, examples, and references + +* Keep development plans and exploratory or standalone validation scripts in + `dev/`; consult `dev/README.md` and the relevant topic plan when present + before continuing existing research. Update that plan when completing planned work. +* Put automated regression tests in `tests/testthat/` and user tutorials in + `vignettes/`. Keep expensive simulation experiments out of routine tests. +* Check `.Rbuildignore` before assuming a vignette or development script runs + in package checks; validate excluded material explicitly when changing it. +* Keep scientific assumptions explicit, especially individual versus colony + quantities, sum versus mean worker effects, mating/worker allocation, + relatedness, and covariance conventions. Keep equations, code, and examples + consistent and cite sources for model changes. +* Where present, use `inst/REFERENCES.bib` for package citations and + `literature/README.md` for the local literature archive. Verify references + rather than inventing them. + ## Proofreading If asked to proofread, act as an expert proofreader and editor diff --git a/NEWS.md b/NEWS.md index 156adda7..c2c75c4c 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,110 +1,116 @@ --- -editor_options: - markdown: +editor_options: + markdown: wrap: 72 --- # SIMplyBee version 0.5.0 -- 2026-29-09 +- 2026-29-09 ## Major changes -- swarm/split/supersede do no longer store the year of the queen +- Colony IDs are now character, consistently with AlphaSimR individual IDs. + `getId()` returns character IDs, including for empty collections and missing + entries, so `apiary[getId(apiary)]` selects by ID/name and not by position! + Colony IDs are independent of queen IDs and remain unchanged when queens + are removed or replaced. Crossing plans now support non-numeric donor-colony IDs and + correctly map reordered colony names to queen IDs. -- colonies with high inbreeding that do not produce a viable virgin +- 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 +- 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 +- createMultiColony() no longer creates an empty apiary, but it adds empty colonies with IDs -- we no longer support creating an exact number of workers with the csd functionality turned on. Due to inbreeding at the csd locus, some workers are not viable. Previous funcionality re-ran the creation of workers until a required number was available. We no longer support this, so the number of returned workers +- we no longer support creating an exact number of workers with the csd functionality turned on. Due to inbreeding at the csd locus, some workers are not viable. Previous funcionality re-ran the creation of workers until a required number was available. We no longer support this, so the number of returned workers is the number of viable workers. -- the 'cross' function now removes unsuccessfully mated queens. This can primarily happen when creating a spatial cross plan. If there are no drone producing colonies in the specified radius, the mating fails and the queens/colonies are removed from the object. This is to ensure all further functionality works well. +- the 'cross' function now removes unsuccessfully mated queens. This can primarily happen when creating a spatial cross plan. If there are no drone producing colonies in the specified radius, the mating fails and the queens/colonies are removed from the object. This is to ensure all further functionality works well. ## New features + - added functionality to map individual-level variance to colony-level variance and vice-versa with functions 'mapIndToColonyVar' and 'mapColonyToIndVar' -- parallelised all the major functions (so they run on +- 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 +- 2024-09-19 ## Bug fixes -- locations of the colonies in the D_Crossing vignettes were previously +- 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 +- 2024-08-23 ## Major changes -- createColony() and createMultiColony() do not have the location +- createColony() and createMultiColony() do not have the location argument anymore; use setLocation() instead; by default, location is now c(0, 0) PR#500 - ## New features -- In setLocation(MultiColony) we can set one location (numeric) or + +- In setLocation(MultiColony) we can set one location (numeric) or multiple (list or data.frame) PR#500 -- getLocation(MultiColony) got the collapse argument +- getLocation(MultiColony) got the collapse argument Commit#f4e629c3e8920948ad576eae3615a86b26300790 -- We can now sample location of a swarm - see sampleLocation and +- We can now sample location of a swarm - see sampleLocation and radius arguments in swarm() PR#500 PR#502 -- New function rcircle() to sample a random point within a circle with +- New function rcircle() to sample a random point within a circle with a given radius PR#502 -- Removed the function createRandomCrossPlan() - that option is now +- Removed the function createRandomCrossPlan() - that option is now included in the newly added createCrossPlan() fuction -- Added the **functionality for spatially-aware mating** of honeybee +- Added the **functionality for spatially-aware mating** of honeybee colonies. The new functionality is included in the createCrossPlan(), that allows to create the cross plan according to the colonies' locations, and in the cross() function, that crosses bees according to their location. This did not break the old functionality of the cross function. - -- Unified setMisc and getMisc behaviour to comply with the new AlphaSimR behaviour -- Added new C++ function isHeterozygous() to speed up the SIMplyBee function isCsdHeterozygous() +- Unified setMisc and getMisc behaviour to comply with the new AlphaSimR behaviour + +- Added new C++ function isHeterozygous() to speed up the SIMplyBee function isCsdHeterozygous() ## Bug fixes -- Bug fix - get\*Haplo() functions were returning diploid drones when +- 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 +- 2022-12-05 First public/CRAN version of the package ## Major changes -- \~2 years of work went into this first public version! +- \~2 years of work went into this first public version! ## New features -- Many;) See the vignettes and help pages. +- Many;) See the vignettes and help pages. ## Bug fixes -- Many bugs and issues squashed - see +- Many bugs and issues squashed - see . Please contribute to the development of this package. diff --git a/R/Class-Colony.R b/R/Class-Colony.R index d5fcff2b..1851c128 100644 --- a/R/Class-Colony.R +++ b/R/Class-Colony.R @@ -14,7 +14,7 @@ setClassUnion("integerOrNumericOrLogicalOrCharacter", c("integer", "numeric", "l #' #' @description An object holding honeybee colony #' -#' @slot id integer, unique ID of the colony +#' @slot id character, unique ID of the colony, independent of its queen ID #' @slot location numeric, location of the colony (x, y) #' @slot queen \code{\link[AlphaSimR]{Pop-class}}, the queen of the colony (we use #' its misc slot for queen's age and drones (fathers) she mated with) @@ -68,7 +68,7 @@ setClassUnion("integerOrNumericOrLogicalOrCharacter", c("integer", "numeric", "l setClass( Class = "Colony", slots = c( - id = "integer", + id = "character", location = "numeric", queen = "PopOrNULL", workers = "PopOrNULL", diff --git a/R/Class-MultiColony.R b/R/Class-MultiColony.R index 271b1fd5..202ac77c 100644 --- a/R/Class-MultiColony.R +++ b/R/Class-MultiColony.R @@ -2,13 +2,18 @@ setClassUnion("integerOrNumeric", c("integer", "numeric")) setClassUnion("integerOrNumericOrLogical", c("integer", "numeric", "logical")) -setClassUnion("integerOrNumericOrLogicalOrCharacter", c("integer", "numeric", "logical", "character")) +setClassUnion( + "integerOrNumericOrLogicalOrCharacter", + c("integer", "numeric", "logical", "character") +) #' @rdname MultiColony-class #' @title Honeybee multicolony object #' #' @description An object holding a collection of honeybee colonies. It behaves -#' like a list. +#' like a list. Numeric indices select positions; character indices select +#' colony by their IDs/names. Single bracket indexing returns a MultiColony, +#' while double brackets return one Colony (or NULL for an unpopulated entry). #' #' @slot colonies list, a collection of \code{\link[SIMplyBee]{Colony-class}} objects #' @@ -33,7 +38,7 @@ setClassUnion("integerOrNumericOrLogicalOrCharacter", c("integer", "numeric", "l #' \dontshow{SP$nThreads = 1L} #' basePop <- createVirginQueens(founderGenomes) #' -#' drones <- createDrones(x = basePop[1], nInd = 1000) +#' drones <- createDrones(x = basePop[1], nInd = 200) #' droneGroups <- pullDroneGroupsFromDCA(drones, n = 10, nDrones = nFathersPoisson) #' apiary <- createMultiColony(basePop[1:6], n = 6) #' apiary <- cross(apiary, drones = droneGroups[1:6]) @@ -43,27 +48,23 @@ setClassUnion("integerOrNumericOrLogicalOrCharacter", c("integer", "numeric", "l #' isMultiColony(apiary) #' #' getId(apiary) -#' apiary[1] #' getId(apiary[1]) #' getId(apiary["2"]) #' getId(apiary[2]) #' getId(apiary[-1]) #' getId(apiary[5]) #' -#' getId(apiary) #' getId(apiary[c(1, 3)]) #' getId(apiary[c("2", "4")]) #' getId(apiary[c(TRUE, FALSE, TRUE, FALSE)]) #' getId(apiary[c(TRUE, FALSE)]) # beware of recycling! -#' getId(apiary[c(5, 6)]) +#' getId(apiary[c(6, 7)]) #' getId(apiary[c("6", "7")]) #' +#' apiary[1] #' apiary[[1]] #' apiary[["2"]] -#' apiary[[3]] -#' apiary[["4"]] -#' try(apiary[[6]]) -#' apiary[["7"]] +#' try(apiary[[7]]) #' #' getId(c(apiary[c(1, 3)], apiary[2])) #' getId(c(apiary[2], apiary[c(1, 3)])) @@ -209,7 +210,12 @@ setMethod( #' @describeIn MultiColony-class Extract a colony (one or more!) with an integer/numeric/logical index (position) (return \code{\link[SIMplyBee]{MultiColony-class}}) setMethod( f = "[", - signature(x = "MultiColony", i = "integerOrNumericOrLogical", j = "ANY", drop = "ANY"), + signature( + x = "MultiColony", + i = "integerOrNumericOrLogical", + j = "ANY", + drop = "ANY" + ), definition = function(x, i, j, drop) { x@colonies <- x@colonies[i] validObject(x) @@ -237,7 +243,11 @@ setMethod( definition = function(x, i) { n <- length(i) if (n > 1) { - warning(paste("Selecting only the first colony out of ", n, " requested\n")) + warning(paste( + "Selecting only the first colony out of ", + n, + " requested\n" + )) } # ...@colonies[[i[1L]]] is to get just one colony ret <- x@colonies[[i[1L]]] @@ -253,7 +263,11 @@ setMethod( definition = function(x, i) { n <- length(i) if (n > 1) { - warning(paste("Selecting only the first colony out of ", n, " requested\n")) + warning(paste( + "Selecting only the first colony out of ", + n, + " requested\n" + )) } # x[i[1L]] calls x[character] # ...@colonies[[1L]] is to get just one colony @@ -269,25 +283,33 @@ setMethod( setReplaceMethod( f = "[", signature( - x = "MultiColony", i = "integerOrNumericOrLogicalOrCharacter", - j = "ANY", value = "MultiColony" + x = "MultiColony", + i = "integerOrNumericOrLogicalOrCharacter", + j = "ANY", + value = "MultiColony" ), definition = function(x, i, j, value) { nCol <- nColonies(value) if (is.numeric(i)) { if (length(i) != nCol) { - stop("Length of i (position index) does not match the number of assigned colonies!") + stop( + "Length of i (position index) does not match the number of assigned colonies!" + ) } x@colonies[i] <- value@colonies } else if (is.logical(i)) { if (sum(i) != nCol) { - stop("Number of TRUE values in i (position index) does not match the number of assigned colonies!") + stop( + "Number of TRUE values in i (position index) does not match the number of assigned colonies!" + ) } x@colonies[i] <- value@colonies } else if (is.character(i)) { matches <- getId(x) %in% i if (sum(matches) != nCol) { - stop("Number of matched colony names in x from i (name index) does not match the number of assigned colonies!") + stop( + "Number of matched colony names in x from i (name index) does not match the number of assigned colonies!" + ) } x@colonies[matches] <- value@colonies } @@ -301,27 +323,37 @@ setReplaceMethod( setReplaceMethod( f = "[[", signature( - x = "MultiColony", i = "integerOrNumericOrLogicalOrCharacter", - j = "ANY", value = "Colony" + x = "MultiColony", + i = "integerOrNumericOrLogicalOrCharacter", + j = "ANY", + value = "Colony" ), definition = function(x, i, j, value) { if (is.numeric(i)) { if (length(i) > 1) { - stop("Length of numeric i (position index) must be 1 when value (assignment) is a Colony class object!") + stop( + "Length of numeric i (position index) must be 1 when value (assignment) is a Colony class object!" + ) } x@colonies[[i]] <- value } else if (is.logical(i)) { if (sum(i) != 1) { - stop("Number of TRUE values in i (position index) must be equal to 1 when value (assignment) is a Colony class object!") + stop( + "Number of TRUE values in i (position index) must be equal to 1 when value (assignment) is a Colony class object!" + ) } x@colonies[i][[1L]] <- value } else if (is.character(i)) { if (length(i) > 1) { - stop("Length of character i (name index) must be 1 when value (assignment) is a Colony class object!") + stop( + "Length of character i (name index) must be 1 when value (assignment) is a Colony class object!" + ) } match <- getId(x) %in% i if (sum(match) != 1) { - stop("Number of matched colony names in x from i (name index) must be equal to 1 when value (assignment) is a Colony class object!") + stop( + "Number of matched colony names in x from i (name index) must be equal to 1 when value (assignment) is a Colony class object!" + ) } x@colonies[match][[1L]] <- value } diff --git a/R/Functions_L0_auxilary.R b/R/Functions_L0_auxilary.R index d0bf6cd8..ebbb5868 100644 --- a/R/Functions_L0_auxilary.R +++ b/R/Functions_L0_auxilary.R @@ -953,14 +953,23 @@ isNULLColonies <- function(multicolony) { # get (general) ---- #' @rdname getId -#' @title Get the colony ID +#' @title Get individual or colony IDs #' -#' @description Level 0 function that returns the colony ID. This is by -#' definition the ID of the queen. +#' @description Level 0 function that returns individual IDs for a Pop or +#' colony IDs for a Colony or MultiColony. Colony IDs are independent of +#' queen IDs and are retained when a queen is removed or replaced. #' -#' @param x \code{\link[AlphaSimR]{Pop-class}}, \code{\link[SIMplyBee]{Colony-class}}, or \code{\link[SIMplyBee]{MultiColony-class}} +#' @param x \code{NULL}, \code{\link[AlphaSimR]{Pop-class}}, +#' \code{\link[SIMplyBee]{Colony-class}}, or \code{\link[SIMplyBee]{MultiColony-class}} #' -#' @return character, \code{NA} when queen not present +#' @return character, \code{NA_character_} for NULL entries or a Colony without +#' an assigned ID, and \code{character(0)} for an empty Pop or MultiColony. +#' +#' @details A NULL entry represents a missing colony or individual, +#' so it contributes one missing ID and preserves alignment with the MultiColony's entries. +#' An empty Pop or MultiColony contains no individuals or entries to identify. +#' An empty colony created with \code{createColony()} still has an assigned ID; +#' an uninitialised \code{new("Colony")} has no assigned ID. #' #' @examples #' founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) @@ -986,13 +995,13 @@ isNULLColonies <- function(multicolony) { #' @export getId <- function(x) { if (is.null(x)) { - id <- NA + id <- NA_character_ } else if (isPop(x)) { id <- x@id } else if (isColony(x)) { - id <- ifelse(is.null(x@id), NA, x@id) + id <- if (length(x@id) == 0L) NA_character_ else x@id } else if (isMultiColony(x)) { - id <- sapply(x@colonies, FUN = getId) + id <- vapply(x@colonies, FUN = getId, FUN.VALUE = character(1)) } else { stop("Argument x must be a NULL, Pop, Colony, or MultiColony class object!") } diff --git a/R/Functions_L1_Pop.R b/R/Functions_L1_Pop.R index b44173a9..20ed07f7 100644 --- a/R/Functions_L1_Pop.R +++ b/R/Functions_L1_Pop.R @@ -1630,7 +1630,7 @@ cross <- function(x, } # Rename crossPlan if (crossPlan_create | crossPlan_given) { - names(crossPlan) <- ID_by_input$virginId[match(ID_by_input$inputId, names(crossPlan))] + names(crossPlan) <- ID_by_input$virginId[match(names(crossPlan), ID_by_input$inputId)] } } @@ -1660,20 +1660,20 @@ cross <- function(x, IDs = IDs[IDs %in% crossPlanDF$virginID] x = x[IDs] if (type == "MultiColony") { - multicolony <- multicolony[getId(getVirginQueens(multicolony, collapse=TRUE)) %in% IDs] + multicolony <- multicolony[getId(getVirginQueens(multicolony, collapse=TRUE, simParamBee = simParamBee)) %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)) } )) - crossPlanDF_sample <- crossPlanDF_sample[order(as.integer(crossPlanDF_sample$DPC)),] + crossPlanDF_sample <- crossPlanDF_sample[order(as.character(crossPlanDF_sample$DPC)),] # Here I gather how many drones each DPC needs to produce crossPlanDF_DPCtable <- as.data.frame(table(crossPlanDF_sample$DPC)) - crossPlanDF_DPCtable <- crossPlanDF_DPCtable[order(as.integer(as.character(crossPlanDF_DPCtable$Var1))),] + crossPlanDF_DPCtable <- crossPlanDF_DPCtable[order(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)) + selectedDPC = selectColonies(droneColonies, ID = as.character(crossPlanDF_DPCtable$DPC), simParamBee = simParamBee) # And here I create the drones dronesByDPC <- createCastePop(selectedDPC, caste = "drones", nInd = as.integer(crossPlanDF_DPCtable$noDrones), @@ -1681,7 +1681,7 @@ cross <- function(x, # 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)))) - dronesByDPC_DF <- dronesByDPC_DF[order(as.integer(dronesByDPC_DF$DPC)),] + dronesByDPC_DF <- dronesByDPC_DF[order(as.character(dronesByDPC_DF$DPC)),] dronePop = mergePops(dronesByDPC) if (any(!crossPlanDF_sample$DPC == dronesByDPC_DF$DPC)) { @@ -1689,7 +1689,7 @@ cross <- function(x, } dronesByVirgin_DF <- cbind(dronesByDPC_DF, crossPlanDF_sample[, c("virginID"), drop = FALSE]) - dronesByVirgin_DF <- dronesByVirgin_DF[order(as.integer(dronesByVirgin_DF$virginID)),] + dronesByVirgin_DF <- dronesByVirgin_DF[order(match(dronesByVirgin_DF$virginID, IDs)),] 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 93b68cb1..f7cc0544 100644 --- a/R/Functions_L2_Colony.R +++ b/R/Functions_L2_Colony.R @@ -8,7 +8,8 @@ #' #' @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) +#' @param id character, ID of the colony that is going to be created (used internally for parallel computing). +#' Numeric IDs are converted to character. #' #' @return new \code{\link[SIMplyBee]{Colony-class}} #' @@ -41,6 +42,8 @@ createColony <- function(x = NULL, simParamBee = NULL, id = NULL) { id <- simParamBee$lastColonyId } + id <- as.character(id) + if (is.null(x)) { colony <- new( Class = "Colony", @@ -81,7 +84,7 @@ createColony <- function(x = NULL, simParamBee = NULL, id = NULL) { #' #' @description Level 2 function that re-queens a Colony or #' MultiColony object by adding a mated or a virgin queen, removing the -#' previous queen, and changing the colony id to the new mated queen. +#' previous queen, while preserving the colony ID. #' #' @param x \code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}} #' @param queen \code{\link[AlphaSimR]{Pop-class}} with one individual that will be the @@ -1484,7 +1487,7 @@ swarm <- function(x, p = NULL, if (isColony(x)) { swarmColony <- createColony(x = x@queen, simParamBee = simParamBee) - # It's not re-queening, but the function also sets the colony id + # The swarm receives a new colony ID, independent of its queen ID swarmColony@workers <- tmp$pulled swarmColony <- setLocation(x = swarmColony, location = newLocation[[1]], simParamBee = simParamBee) diff --git a/R/Functions_L3_Colonies.R b/R/Functions_L3_Colonies.R index 78f240c3..53f569ca 100644 --- a/R/Functions_L3_Colonies.R +++ b/R/Functions_L3_Colonies.R @@ -49,7 +49,12 @@ #' apiary[[2]] #' #' @export -createMultiColony <- function(x = NULL, n = NULL, simParamBee = NULL, populateColonies = FALSE) { +createMultiColony <- function( + x = NULL, + n = NULL, + simParamBee = NULL, + populateColonies = FALSE +) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } @@ -58,24 +63,29 @@ createMultiColony <- function(x = NULL, n = NULL, simParamBee = NULL, populateCo if (is.null(n)) { ret <- new(Class = "MultiColony") } else { - ret <- new(Class = "MultiColony", colonies = vector(mode = "list", length = n)) + ret <- new( + Class = "MultiColony", + colonies = vector(mode = "list", length = n) + ) if (populateColonies) { - ids <- (simParamBee$lastColonyId+1):(simParamBee$lastColonyId + n) + ids <- (simParamBee$lastColonyId + 1):(simParamBee$lastColonyId + n) - ret@colonies <- future_lapply(X = seq_len(n), - FUN = function(colony) { + ret@colonies <- future_lapply(X = seq_len(n), FUN = function(colony) { createColony(simParamBee = simParamBee, id = ids[colony]) }) simParamBee$updateLastColonyId(n = n) - } else { - - } + } else {} } } else { if (!isPop(x)) { stop("Argument x must be a Pop class object!") } - if (any(!(isVirginQueen(x, simParamBee = simParamBee) | isQueen(x, simParamBee = simParamBee)))) { + if ( + any( + !(isVirginQueen(x, simParamBee = simParamBee) | + isQueen(x, simParamBee = simParamBee)) + ) + ) { stop("Individuals in x must be virgin queens or queens!") } if (is.null(n)) { @@ -84,12 +94,14 @@ createMultiColony <- function(x = NULL, n = NULL, simParamBee = NULL, populateCo 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 <- new( + Class = "MultiColony", + colonies = vector(mode = "list", length = n) + ) + ids <- (simParamBee$lastColonyId + 1):(simParamBee$lastColonyId + n) - ret@colonies <- future_lapply(X = seq_len(n), - FUN = function(colony) { - 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) } @@ -181,8 +193,15 @@ createMultiColony <- function(x = NULL, n = NULL, simParamBee = NULL, populateCo #' selectColonies(apiary, n = 1, by = queenGv) #' #' @export -selectColonies <- function(multicolony, ID = NULL, n = NULL, p = NULL, - by = NULL, selectTop = TRUE, simParamBee = NULL) { +selectColonies <- function( + multicolony, + ID = NULL, + n = NULL, + p = NULL, + by = NULL, + selectTop = TRUE, + simParamBee = NULL +) { if (!isMultiColony(multicolony)) { stop("Argument multicolony must be a MultiColony class object!") } @@ -311,8 +330,15 @@ selectColonies <- function(multicolony, ID = NULL, n = NULL, p = NULL, #' colonyGv <- calcColonyGv(apiary) #' pullColonies(apiary, n = 1, by = colonyGv) #' @export -pullColonies <- function(multicolony, ID = NULL, n = NULL, p = NULL, - by = NULL, pullTop = TRUE, simParamBee = NULL) { +pullColonies <- function( + multicolony, + ID = NULL, + n = NULL, + p = NULL, + by = NULL, + pullTop = TRUE, + simParamBee = NULL +) { if (!isMultiColony(multicolony)) { stop("Argument multicolony must be a MultiColony class object!") } @@ -320,13 +346,15 @@ pullColonies <- function(multicolony, ID = NULL, n = NULL, p = NULL, simParamBee <- get(x = "SP", envir = .GlobalEnv) } if (!is.null(ID)) { + if (!(is.character(ID) | is.numeric(ID))) { + stop("ID must be character or numeric!") + } trueID <- ID %in% getId(multicolony) if (!all(trueID)) { ID <- ID[trueID] warning("ID parameter contains come invalid IDs!") } - pulled <- selectColonies(multicolony, ID, - simParamBee = simParamBee) # selectColonies does the checking of the IDs + pulled <- selectColonies(multicolony, ID, simParamBee = simParamBee) # selectColonies does the checking of the IDs remnant <- removeColonies(multicolony, ID, simParamBee = simParamBee) } else if (!is.null(n) | !is.null(p)) { nCol <- nColonies(multicolony) @@ -424,8 +452,15 @@ pullColonies <- function(multicolony, ID = NULL, n = NULL, p = NULL, #' removeColonies(apiary, n = 1, by = colonyPheno) #' #' @export -removeColonies <- function(multicolony, ID = NULL, n = NULL, p = NULL, - by = NULL, removeTop = FALSE, simParamBee = NULL) { +removeColonies <- function( + multicolony, + ID = NULL, + n = NULL, + p = NULL, + by = NULL, + removeTop = FALSE, + simParamBee = NULL +) { if (!isMultiColony(multicolony)) { stop("Argument multicolony must be a MultiColony class object!") } @@ -433,14 +468,19 @@ removeColonies <- function(multicolony, ID = NULL, n = NULL, p = NULL, simParamBee <- get(x = "SP", envir = .GlobalEnv) } if (!is.null(ID)) { + if (!(is.character(ID) | is.numeric(ID))) { + stop("ID must be character or numeric!") + } trueID <- ID %in% getId(multicolony) if (!all(trueID)) { ID <- ID[trueID] warning("ID parameter contains come invalid IDs!") } - ret <- selectColonies(multicolony, - ID = getId(multicolony)[!getId(multicolony) %in% ID], - simParamBee = simParamBee) + ret <- selectColonies( + multicolony, + ID = getId(multicolony)[!getId(multicolony) %in% ID], + simParamBee = simParamBee + ) } else if (!is.null(n) | !is.null(p)) { nCol <- nColonies(multicolony) if (!is.null(p)) { diff --git a/man/Colony-class.Rd b/man/Colony-class.Rd index 8138470b..056d8832 100644 --- a/man/Colony-class.Rd +++ b/man/Colony-class.Rd @@ -40,7 +40,7 @@ An object holding honeybee colony \section{Slots}{ \describe{ -\item{\code{id}}{integer, unique ID of the colony} +\item{\code{id}}{character, unique ID of the colony, independent of its queen ID} \item{\code{location}}{numeric, location of the colony (x, y)} diff --git a/man/MultiColony-class.Rd b/man/MultiColony-class.Rd index 6be082c7..4c87192d 100644 --- a/man/MultiColony-class.Rd +++ b/man/MultiColony-class.Rd @@ -58,7 +58,9 @@ assign into \code{x} based on colony index or name \code{i}} } \description{ An object holding a collection of honeybee colonies. It behaves - like a list. + like a list. Numeric indices select positions; character indices select + colony IDs. Single brackets return a MultiColony, while double brackets + return one Colony (or NULL for an unpopulated entry). } \section{Functions}{ \itemize{ @@ -70,17 +72,17 @@ An object holding a collection of honeybee colonies. It behaves \item \code{c(MultiColonyOrNULL)}: Combine multiple Colony and MultiColony objects -\item \code{x = MultiColony[i = integerOrNumericOrLogical]}: Extract a colony (one or more!) with an integer/numeric/logical index (position) (return \code{\link[SIMplyBee]{MultiColony-class}}) +\item \code{x[i}: Extract a colony (one or more!) with an integer/numeric/logical index (position) (return \code{\link[SIMplyBee]{MultiColony-class}}) -\item \code{x = MultiColony[i = character]}: Extract a colony (one or more!) with a character ID (name) (return \code{\link[SIMplyBee]{MultiColony-class}}) +\item \code{x[i}: Extract a colony (one or more!) with a character ID (name) (return \code{\link[SIMplyBee]{MultiColony-class}}) -\item \code{x = MultiColony[[i = integerOrNumericOrLogical]]}: Extract a colony (just one!) with an integer/numeric/logical index (position) (return \code{\link[SIMplyBee]{Colony-class}}) +\item \code{x[[i}: Extract a colony (just one!) with an integer/numeric/logical index (position) (return \code{\link[SIMplyBee]{Colony-class}}) -\item \code{x = MultiColony[[i = character]]}: Extract a colony (just one!) with a character ID (name) (return \code{\link[SIMplyBee]{Colony-class}}) +\item \code{x[[i}: Extract a colony (just one!) with a character ID (name) (return \code{\link[SIMplyBee]{Colony-class}}) -\item \code{x = MultiColony[i = integerOrNumericOrLogicalOrCharacter, j = ANY] <- value}: Assign colonies into MultiColony +\item \code{`[`(x = MultiColony, i = integerOrNumericOrLogicalOrCharacter, j = ANY) <- value}: Assign colonies into MultiColony -\item \code{x = MultiColony[[i = integerOrNumericOrLogicalOrCharacter, j = ANY]] <- value}: Assign Colony into MultiColony +\item \code{`[[`(x = MultiColony, i = integerOrNumericOrLogicalOrCharacter, j = ANY) <- value}: Assign Colony into MultiColony }} \section{Slots}{ @@ -105,6 +107,7 @@ is(apiary) isMultiColony(apiary) getId(apiary) +apiary[getId(apiary)[c(3, 1)]] # select by ID, preserving requested order apiary[1] getId(apiary[1]) getId(apiary["2"]) diff --git a/man/createColony.Rd b/man/createColony.Rd index d1707f07..86f28896 100644 --- a/man/createColony.Rd +++ b/man/createColony.Rd @@ -11,7 +11,7 @@ createColony(x = NULL, simParamBee = NULL, id = NULL) \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)} +\item{id}{character, ID of the colony that is going to be created (used internally for parallel computing). Numeric IDs are converted to character.} } \value{ new \code{\link[SIMplyBee]{Colony-class}} diff --git a/man/getId.Rd b/man/getId.Rd index bdd5915e..f3ac65e2 100644 --- a/man/getId.Rd +++ b/man/getId.Rd @@ -2,19 +2,28 @@ % Please edit documentation in R/Functions_L0_auxilary.R \name{getId} \alias{getId} -\title{Get the colony ID} +\title{Get individual or colony IDs} \usage{ getId(x) } \arguments{ -\item{x}{\code{\link[AlphaSimR]{Pop-class}}, \code{\link[SIMplyBee]{Colony-class}}, or \code{\link[SIMplyBee]{MultiColony-class}}} +\item{x}{\code{NULL}, \code{\link[AlphaSimR]{Pop-class}}, \code{\link[SIMplyBee]{Colony-class}}, or \code{\link[SIMplyBee]{MultiColony-class}}} } \value{ -character, \code{NA} when queen not present +character, \code{NA_character_} for NULL entries or a Colony without + an assigned ID, and \code{character(0)} for an empty Pop or MultiColony. } \description{ -Level 0 function that returns the colony ID. This is by - definition the ID of the queen. +Level 0 function that returns individual IDs for a Pop or + colony IDs for a Colony or MultiColony. Colony IDs are independent of + queen IDs and are retained when a queen is removed or replaced. +} +\details{ +A NULL entry represents one missing colony, so it contributes one + missing ID and preserves alignment with the MultiColony's entries. + An empty Pop or MultiColony contains no individuals or entries to identify. + An empty colony created with \code{createColony()} still has an assigned ID; + an uninitialised \code{new("Colony")} has no assigned ID. } \examples{ founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) diff --git a/man/reQueen.Rd b/man/reQueen.Rd index 61e22665..dab59c0a 100644 --- a/man/reQueen.Rd +++ b/man/reQueen.Rd @@ -26,7 +26,7 @@ to ensure the provided queen prevails (see details)} \description{ Level 2 function that re-queens a Colony or MultiColony object by adding a mated or a virgin queen, removing the - previous queen, and changing the colony id to the new mated queen. + previous queen, while preserving the colony ID. } \details{ If the provided queen is mated, then she is saved in the queen slot diff --git a/tests/testthat/test-L0_auxiliary_functions.R b/tests/testthat/test-L0_auxiliary_functions.R index 7d7f11b4..0c0a85c3 100644 --- a/tests/testthat/test-L0_auxiliary_functions.R +++ b/tests/testthat/test-L0_auxiliary_functions.R @@ -10,8 +10,8 @@ test_that("nColonies", { expect_equal(nColonies(createMultiColony(n = 10, simParamBee = SP)), 10) }) - # ---- nCaste ---- + test_that("nCaste", { founderGenomes <- quickHaplo(nInd = 5, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) @@ -59,6 +59,7 @@ test_that("nQueens", { }) # ---- nDrones ---- + test_that("nDrones", { founderGenomes <- quickHaplo(nInd = 10, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) @@ -85,7 +86,6 @@ test_that("nDrones", { # ---- isGenoHeterozygous ---- -####----- isGenoHeterozygous ---- #### test_that("isGenoHeterozygous", { geno <- matrix( data = c( @@ -203,7 +203,7 @@ test_that("pHomBrood", { expect_equal(length(pHomBrood(apiary, simParamBee = SP)), 0) }) -#---- nHomBrood ----- +# ---- nHomBrood ---- test_that("nHomBrood", { founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) @@ -330,6 +330,7 @@ test_that("isProductive", { apiary <- createMultiColony(simParamBee = SP) expect_true(is.list(isProductive(apiary))) }) + # ---- reduceDroneHaplo ---- test_that("reduceDroneHaplo", { @@ -635,7 +636,6 @@ test_that("calcBeeGRMIbs", { # ---- editCsdLocus ---- - test_that("editCsdLocus", { founderGenomes <- quickHaplo(nInd = 100, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = 1, nCsdAlleles = 8) @@ -652,6 +652,7 @@ test_that("editCsdLocus", { }) # ---- emptyNULL ---- + test_that("emptyNULL", { founderGenomes <- quickHaplo(nInd = 5, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = 1, nCsdAlleles = 8) @@ -770,6 +771,7 @@ test_that("isWorkersPresent", { }) # ---- isGenoHeterozygous ---- + test_that("isGenoHeterozygous", { founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes) @@ -810,6 +812,7 @@ test_that("isGenoHeterozygous", { }) # ---- getBV ---- + test_that("getBV", { founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) @@ -841,6 +844,7 @@ test_that("getBV", { }) # ---- getDd ---- + test_that("getDd", { founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) @@ -871,6 +875,7 @@ test_that("getDd", { }) # ---- getAa ---- + test_that("getAa", { founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) @@ -901,6 +906,7 @@ test_that("getAa", { }) # ---- editCsdLocus ---- + test_that("editCsdLocus", { founderGenomes <- quickHaplo(nInd = 100, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = 1, nCsdAlleles = 8) @@ -916,6 +922,7 @@ test_that("editCsdLocus", { }) # ---- getLocation ---- + test_that("getLocation", { founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes) @@ -942,6 +949,7 @@ test_that("getLocation", { }) # ---- createCrossPlan ---- + test_that("createCrossPlan", { founderGenomes <- quickHaplo(nInd = 1000, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes) @@ -1002,8 +1010,8 @@ test_that("createCrossPlan", { expect_error(createCrossPlan(x = droneColonies, droneColonies = virginColonies1, simParamBee = SP)) }) +# ---- getCaste ---- -# ---- Get Caste ---- test_that("getCaste", { founderGenomes <- quickHaplo(nInd = 1000, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes) @@ -1071,7 +1079,7 @@ test_that("getCaste", { }) - +# ---- getIbdHaplo ---- test_that("getIbdHaplo", { founderGenomes <- quickHaplo(nInd = 4, nChr = 1, segSites = 5) @@ -1100,8 +1108,9 @@ test_that("getIbdHaplo", { 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) - }) +}) +# ---- trackingHomozygotes ---- test_that("trackingHomozygotes", { founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) @@ -1129,3 +1138,39 @@ test_that("trackingHomozygotes", { expect_equal(nrow(SP$pedigree), length(SP$caste)) expect_equal(nrow(SP$pedigree), length(SP$recHist)) }) + +# ---- getId ---- + +test_that("getId returns character IDs independently of queen IDs", { + set.seed(123) + founderGenomes <- quickHaplo(nInd = 4, nChr = 1, segSites = 100) + SP <- SimParamBee$new(founderGenomes, csdChr = NULL) + SP$nThreads = 1L + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) + colony <- createColony(basePop[2], simParamBee = SP) + expect_identical(colony@id, "1") + expect_identical(getId(basePop), c("1", "2", "3", "4")) + expect_identical(getId(colony), "1") + expect_identical(getId(NULL), NA_character_) + expect_identical(getId(new("Colony")), NA_character_) + expect_identical(getId(basePop[0]), character(0)) + expect_identical(getId(createMultiColony(simParamBee = SP)), character(0)) + expect_identical(getId(createMultiColony(n = 2, simParamBee = SP)), rep(NA_character_, 2)) + populated <- createMultiColony(n = 2, populateColonies = TRUE, simParamBee = SP) + expect_type(getId(populated), "character") + expect_false(anyNA(getId(populated))) + emptyColony <- createColony(simParamBee = SP) + expect_identical(getId(emptyColony), as.character(SP$lastColonyId)) + mixed <- new("MultiColony", colonies = list(colony, NULL, emptyColony)) + expect_identical(getId(mixed), c("1", NA_character_, getId(emptyColony))) + expect_identical(getId(createColony(id = 20L, simParamBee = SP)), "20") + expect_identical(getId(createColony(id = "hive-A", simParamBee = SP)), "hive-A") + drones <- createDrones(basePop[1], nInd = 10, simParamBee = SP) + colony <- cross(colony, drones = drones, simParamBee = SP) + expect_identical(getId(colony), "1") + expect_identical(getId(getQueen(colony, simParamBee = SP)), "2") + expect_identical(getId(removeQueen(colony, simParamBee = SP)), "1") + colony <- reQueen(colony, queen = basePop[3], simParamBee = SP) + expect_identical(getId(colony), "1") + expect_identical(getId(getVirginQueens(colony, simParamBee = SP)), "3") +}) diff --git a/tests/testthat/test-L1_pop_functions.R b/tests/testthat/test-L1_pop_functions.R index dc31682e..caf593d1 100644 --- a/tests/testthat/test-L1_pop_functions.R +++ b/tests/testthat/test-L1_pop_functions.R @@ -228,6 +228,7 @@ test_that("pullCastePop", { }) # ---- cross ---- + test_that("cross", { founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) @@ -292,8 +293,8 @@ test_that("cross", { #expect_message(cross(virginQueen2, drones= selectInd(colony@drones,nInd = 0, use = "rand", simParam = SP), checkCross = "warning", simParamBee = SP)) }) - # ---- createDCA ---- + test_that("createDCA", { founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) @@ -330,6 +331,7 @@ test_that("createDCA", { }) # ---- pullDroneGroupsFromDCA ---- + test_that("pullDroneGroupsFromDCA", { founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) @@ -361,6 +363,8 @@ test_that("pullDroneGroupsFromDCA", { expect_error(pullDroneGroupsFromDCA(DCA2, n =10, nDrones = 20, simParamBee = SP)) }) +# ---- combineBeeGametes ---- + test_that("combineBeeGametes", { founderGenomes <- quickHaplo(nInd = 3, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) @@ -378,6 +382,8 @@ test_that("combineBeeGametes", { }) +# ---- combineBeeGametesHaploidDiploid ---- + test_that("combineBeeGametesHaploidDiploid", { founderGenomes <- quickHaplo(nInd = 3, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) @@ -394,3 +400,27 @@ test_that("combineBeeGametesHaploidDiploid", { expect_equal(drones@ploidy, 1) }) +# ---- cross plans with character IDs ---- + +test_that("cross plans match character colony IDs independently of queen IDs", { + set.seed(123) + founderGenomes <- quickHaplo(nInd = 7, nChr = 1, segSites = 100) + SP <- SimParamBee$new(founderGenomes, csdChr = NULL) + SP$nThreads = 1L + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) + donors <- c(createColony(basePop[1], id = "donor-B", simParamBee = SP), + createColony(basePop[2], id = "donor-A", simParamBee = SP)) + drones <- createDrones(basePop[7], nInd = 4, simParamBee = SP) + donors <- cross(donors, drones = list(drones[1:2], drones[3:4]), simParamBee = SP) + apiary <- c(createColony(basePop[3], id = "hive-C", simParamBee = SP), + createColony(basePop[4], id = "hive-A", simParamBee = SP), + createColony(basePop[5], id = "hive-B", simParamBee = SP)) + plan <- list("hive-B" = "donor-B", "hive-C" = "donor-A", "hive-A" = "donor-B") + mated <- expect_no_warning(cross(apiary, droneColonies = donors, + crossPlan = plan, nDrones = 2, simParamBee = SP)) + expect_identical(getId(mated), c("hive-C", "hive-A", "hive-B")) + expect_identical(unname(getId(getQueen(mated, collapse = TRUE, simParamBee = SP))), c("3", "4", "5")) + expect_equal(unname(getFathers(mated[[1]], simParamBee = SP)@mother), rep("2", 2)) + expect_equal(unname(getFathers(mated[[2]], simParamBee = SP)@mother), rep("1", 2)) + expect_equal(unname(getFathers(mated[[3]], simParamBee = SP)@mother), rep("1", 2)) +}) diff --git a/tests/testthat/test-L2_colony_functions.R b/tests/testthat/test-L2_colony_functions.R index 7154f39e..3b46b0c8 100644 --- a/tests/testthat/test-L2_colony_functions.R +++ b/tests/testthat/test-L2_colony_functions.R @@ -1,4 +1,4 @@ -# ---- Create Colony ---- +# ---- createColony ---- test_that("createColony", { founderGenomes <- quickHaplo(nInd = 5, nChr = 1, segSites = 100) @@ -19,7 +19,7 @@ test_that("createColony", { expect_error(createColony(x = drones[1], simParamBee = SP)) }) -# ---- ReQueen ---- +# ---- reQueen ---- test_that("reQueen", { founderGenomes <- quickHaplo(nInd = 5, nChr = 1, segSites = 100) @@ -63,7 +63,7 @@ test_that("reQueen", { expect_true(isQueenPresent(reQueen(matedColony, queen = matedQueen1, simParamBee = SP), simParamBee = SP)) }) -# ---- Add Functions ---- +# ---- add functions ---- test_that("Add functions", { founderGenomes <- quickHaplo(nInd = 5, nChr = 1, segSites = 100) @@ -119,7 +119,7 @@ test_that("Add functions", { expect_s4_class(addDrones(apiary, nInd = 5, simParamBee = SP), "MultiColony") }) -# ---- BuildUp downSize ---- +# ---- buildUp and downsize ---- test_that("BuildUpDownsize", { founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) @@ -176,7 +176,7 @@ test_that("BuildUpDownsize", { downsize(apiary, simParamBee = SP) }) -# ---- Replace Functions ---- +# ---- replace functions ---- test_that("replaceFunctions", { founderGenomes <- quickHaplo(nInd = 5, nChr = 1, segSites = 100) @@ -232,7 +232,7 @@ test_that("replaceFunctions", { expect_error(nColonies(replaceDrones(apiary, p = 0, simParamBee = SP))) }) -# ---- Remove functions ---- +# ---- remove functions ---- test_that("removeFunctions", { founderGenomes <- quickHaplo(nInd = 5, nChr = 1, segSites = 100) @@ -280,7 +280,8 @@ test_that("removeFunctions", { expect_equal(nColonies(removeDrones(apiary, p = 0, simParamBee = SP)), nColonies(apiary)) }) -# ---- SetLocation ---- +# ---- setLocation ---- + test_that("setLocation", { founderGenomes <- quickHaplo(nInd = 5, nChr = 1, segSites = 50) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) @@ -319,7 +320,7 @@ test_that("setLocation", { expect_s4_class(setLocation(apiary, location = list(1:2, 3:4, 4:5), simParamBee = SP), "MultiColony") }) -# ---- Supersede ---- +# ---- supersede ---- test_that("supersede", { founderGenomes <- quickHaplo(nInd = 10, nChr = 1, segSites = 100) @@ -356,7 +357,7 @@ test_that("supersede", { expect_error(supersede(colony, simParamBee = SP)) }) -# ---- Split ---- +# ---- split ---- test_that("split", { founderGenomes <- quickHaplo(nInd = 10, nChr = 1, segSites = 100) @@ -398,7 +399,7 @@ test_that("split", { }) -# ---- ResetEvents ---- +# ---- resetEvents ---- test_that("resetEvents", { founderGenomes <- quickHaplo(nInd = 5, nChr = 1, segSites = 100) @@ -437,7 +438,7 @@ test_that("resetEvents", { expect_false(all(hasSuperseded(apiary))) }) -# ---- Combine ---- +# ---- combine colonies ---- test_that("Combine", { founderGenomes <- quickHaplo(nInd = 10, nChr = 1, segSites = 100) @@ -474,7 +475,7 @@ test_that("Combine", { expect_error(combine(strong = colony1, weak = colony2, simParamBee = SP)) # discus the output }) -# ---- Swarm ---- +# ---- swarm ---- test_that("swarm", { founderGenomes <- quickHaplo(nInd = 10, nChr = 1, segSites = 100) @@ -516,8 +517,7 @@ test_that("swarm", { expect_true(areVirginQueensPresent(tmp$remnant[[4]], simParamBee = SP)) }) - -# ---- Collapse ----- +# ---- collapse ---- test_that("collapse", { founderGenomes <- quickHaplo(nInd = 10, nChr = 1, segSites = 100) diff --git a/tests/testthat/test-L3_Colonies_functions.R b/tests/testthat/test-L3_Colonies_functions.R index 2598dc2b..f1f8c2cd 100644 --- a/tests/testthat/test-L3_Colonies_functions.R +++ b/tests/testthat/test-L3_Colonies_functions.R @@ -1,4 +1,5 @@ # Level 3 MultiColony Functions + # ---- createMultiColony ---- test_that("createMultiColony", { @@ -37,7 +38,74 @@ test_that("createMultiColony", { expect_s4_class(createMultiColony(x = basePop[4:5], n = 2, simParamBee = SP), "MultiColony") }) -# ---- selectColonies --- +# ---- MultiColony indexing ---- + +test_that("MultiColony indexing", { + set.seed(123) + founderGenomes <- quickHaplo(nInd = 4, nChr = 1, segSites = 100) + SP <- SimParamBee$new(founderGenomes, csdChr = NULL) + SP$nThreads = 1L + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) + apiary <- createMultiColony(basePop, n = 4, simParamBee = SP) + # IDs deliberately differ from positions and include a nonnumeric name + apiary@colonies[[1]]@id <- "20" + apiary@colonies[[2]]@id <- "10" + apiary@colonies[[3]]@id <- "hive-A" + apiary@colonies[[4]]@id <- "30" + ids <- getId(apiary) + expect_identical(ids, c("20", "10", "hive-A", "30")) + expect_identical(apiary[getId(apiary)], apiary) + expect_identical(apiary[["10"]], apiary[[2]]) + expect_identical(getId(selectColonies(apiary, ID = 10, simParamBee = SP)), "10") + expect_identical(getId(removeColonies(apiary, ID = 10, simParamBee = SP)), ids[-2]) + pulled <- pullColonies(apiary, ID = 10, simParamBee = SP) + expect_identical(getId(pulled$pulled), "10") + expect_identical(getId(pulled$remnant), ids[-2]) + replacement <- createColony(simParamBee = SP, id = "replacement") + replaced <- apiary + replaced[["10"]] <- replacement + expect_identical(replaced[[2]], replacement) + replaced <- apiary + replaced["10"] <- c(replacement) + expect_identical(replaced[[2]], replacement) + + # Single brackets preserve MultiColony, including single and empty subsets + expect_s4_class(apiary[1], "MultiColony") + expect_equal(nColonies(apiary[1]), 1) + expect_identical(getId(apiary[c(3L, 1L)]), ids[c(3L, 1L)]) + expect_identical(getId(apiary[c(3, 1)]), ids[c(3, 1)]) + expect_identical(getId(apiary[-2]), ids[-2]) + expect_identical(getId(apiary[c(TRUE, FALSE)]), ids[c(1, 3)]) + expect_identical(getId(apiary[as.character(ids[c(3, 1)])]), ids[c(3, 1)]) + expect_s4_class(apiary[0], "MultiColony") + expect_equal(nColonies(apiary[0]), 0) + expect_equal(nColonies(apiary[integer(0)]), 0) + expect_equal(nColonies(apiary[FALSE]), 0) + + # Double brackets return the selected Colony, by position or character ID + expect_s4_class(apiary[[2]], "Colony") + expect_identical(apiary[[2]], apiary@colonies[[2]]) + expect_identical(apiary[[2L]], apiary@colonies[[2]]) + expect_identical(apiary[[as.character(ids[2])]], apiary@colonies[[2]]) + expect_identical(apiary[2][[1]], apiary[[2]]) + expect_identical(apiary[[TRUE]], apiary[[1]]) + expect_warning(selected <- apiary[[c(2, 3)]], "Selecting only the first colony") + expect_identical(selected, apiary[[2]]) + expect_warning(selected <- apiary[[as.character(ids[c(2, 3)])]], "Selecting only the first colony") + expect_identical(selected, apiary[[2]]) + expect_error(apiary[[5]], "subscript out of bounds") + expect_error(apiary[c(1, 1)], "Some colonies are duplicated") + + # Unmatched IDs and unpopulated slots retain the existing NULL behavior + expect_null(apiary[["missing"]]) + expect_null(apiary[5][[1]]) + emptyApiary <- createMultiColony(n = 2, simParamBee = SP) + expect_s4_class(emptyApiary[1], "MultiColony") + expect_null(emptyApiary[[1]]) + expect_identical(getId(apiary), ids) +}) + +# ---- selectColonies ---- test_that("selectColonies", { founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) From 90873c1b0cefea38ef753e0414113f274a3f29fd Mon Sep 17 00:00:00 2001 From: gregorgorjanc Date: Sat, 3 Oct 2026 17:13:08 +0000 Subject: [PATCH 79/98] Update documentation --- man/MultiColony-class.Rd | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/man/MultiColony-class.Rd b/man/MultiColony-class.Rd index 9cc5a49b..62ec8e57 100644 --- a/man/MultiColony-class.Rd +++ b/man/MultiColony-class.Rd @@ -72,17 +72,17 @@ An object holding a collection of honeybee colonies. It behaves \item \code{c(MultiColonyOrNULL)}: Combine multiple Colony and MultiColony objects -\item \code{x[i}: Extract a colony (one or more!) with an integer/numeric/logical index (position) (return \code{\link[SIMplyBee]{MultiColony-class}}) +\item \code{x = MultiColony[i = integerOrNumericOrLogical]}: Extract a colony (one or more!) with an integer/numeric/logical index (position) (return \code{\link[SIMplyBee]{MultiColony-class}}) -\item \code{x[i}: Extract a colony (one or more!) with a character ID (name) (return \code{\link[SIMplyBee]{MultiColony-class}}) +\item \code{x = MultiColony[i = character]}: Extract a colony (one or more!) with a character ID (name) (return \code{\link[SIMplyBee]{MultiColony-class}}) -\item \code{x[[i}: Extract a colony (just one!) with an integer/numeric/logical index (position) (return \code{\link[SIMplyBee]{Colony-class}}) +\item \code{x = MultiColony[[i = integerOrNumericOrLogical]]}: Extract a colony (just one!) with an integer/numeric/logical index (position) (return \code{\link[SIMplyBee]{Colony-class}}) -\item \code{x[[i}: Extract a colony (just one!) with a character ID (name) (return \code{\link[SIMplyBee]{Colony-class}}) +\item \code{x = MultiColony[[i = character]]}: Extract a colony (just one!) with a character ID (name) (return \code{\link[SIMplyBee]{Colony-class}}) -\item \code{`[`(x = MultiColony, i = integerOrNumericOrLogicalOrCharacter, j = ANY) <- value}: Assign colonies into MultiColony +\item \code{x = MultiColony[i = integerOrNumericOrLogicalOrCharacter, j = ANY] <- value}: Assign colonies into MultiColony -\item \code{`[[`(x = MultiColony, i = integerOrNumericOrLogicalOrCharacter, j = ANY) <- value}: Assign Colony into MultiColony +\item \code{x = MultiColony[[i = integerOrNumericOrLogicalOrCharacter, j = ANY]] <- value}: Assign Colony into MultiColony }} \section{Slots}{ From 25f3b38f75164e4e2378a74b448d4002d134e4ed Mon Sep 17 00:00:00 2001 From: Gregor Gorjanc Date: Tue, 6 Oct 2026 20:43:13 +0100 Subject: [PATCH 80/98] Apply suggestion from @gregorgorjanc --- R/Functions_L0_auxilary.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/Functions_L0_auxilary.R b/R/Functions_L0_auxilary.R index 5619d3ce..6ecd93eb 100644 --- a/R/Functions_L0_auxilary.R +++ b/R/Functions_L0_auxilary.R @@ -268,7 +268,7 @@ nVirginQueens <- function(x, simParamBee = NULL) { #' @seealso Demo in the introductory vignette #' \code{vignette("Honeybee_biology", package="SIMplyBee")} #' -#' @return Numeric brood proportions for \code{calcQueensPHomBrood()} and +#' @return Numeric, proportion of homozygous brood for \code{calcQueensPHomBrood()} and #' \code{pHomBrood()}, or counts for \code{nHomBrood()}, named by colony ID #' when \code{x} is \code{\link[SIMplyBee]{MultiColony-class}}. An empty #' \code{\link[AlphaSimR]{Pop-class}} returns \code{numeric(0)}. Missing From ecc27d2fbc4848e73199079017b6f8675e9b697b Mon Sep 17 00:00:00 2001 From: gregorgorjanc Date: Tue, 6 Oct 2026 19:44:37 +0000 Subject: [PATCH 81/98] Update documentation --- man/calcQueensPHomBrood.Rd | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/man/calcQueensPHomBrood.Rd b/man/calcQueensPHomBrood.Rd index 2b3a3028..009157c0 100644 --- a/man/calcQueensPHomBrood.Rd +++ b/man/calcQueensPHomBrood.Rd @@ -19,7 +19,7 @@ nHomBrood(x, simParamBee = NULL) \item{simParamBee}{\code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters} } \value{ -Numeric brood proportions for \code{calcQueensPHomBrood()} and +Numeric, proportion of homozygous brood for \code{calcQueensPHomBrood()} and \code{pHomBrood()}, or counts for \code{nHomBrood()}, named by colony ID when \code{x} is \code{\link[SIMplyBee]{MultiColony-class}}. An empty \code{\link[AlphaSimR]{Pop-class}} returns \code{numeric(0)}. Missing From 5cfaa2c66558c16e4ab4845f2b51d40e8dc9d4b1 Mon Sep 17 00:00:00 2001 From: Gregor Gorjanc Date: Tue, 6 Oct 2026 21:09:25 +0100 Subject: [PATCH 82/98] Fix empty else block in Functions_L3_Colonies.R --- R/Functions_L3_Colonies.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/Functions_L3_Colonies.R b/R/Functions_L3_Colonies.R index 66650d96..dbc02d25 100644 --- a/R/Functions_L3_Colonies.R +++ b/R/Functions_L3_Colonies.R @@ -75,7 +75,7 @@ createMultiColony <- function( createColony(simParamBee = simParamBee, id = ids[colony]) }) simParamBee$updateLastColonyId(n = n) - } else {} + } } } else { if (!isPop(x)) { From 98aaa9bc486a0a404642cd9c21f069b0d0c15612 Mon Sep 17 00:00:00 2001 From: Gregor Gorjanc Date: Tue, 6 Oct 2026 21:15:31 +0100 Subject: [PATCH 83/98] Apply batched suggestions from code review Co-authored-by: Gregor Gorjanc --- NEWS.md | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/NEWS.md b/NEWS.md index 41f643e2..ada64d3a 100644 --- a/NEWS.md +++ b/NEWS.md @@ -74,8 +74,7 @@ editor_options: for empty populations. Inactive csd metadata also uses numeric missing values. `getId(NULL)` now returns `NA_character_`. -- Spotted a couple of cases where `SimParamBee` was not passed to the - calling functions. +- Fixed the inconsistent use of `simParamBee` in some functions. # SIMplyBee version 0.4.1 From e00f9d3c7d253085ac762e42e704448f41f14737 Mon Sep 17 00:00:00 2001 From: Gregor Gorjanc Date: Wed, 7 Oct 2026 18:43:47 +0100 Subject: [PATCH 84/98] Fix colony callback dispatch and clarify parallelisation --- DESCRIPTION | 1 + NAMESPACE | 36 +- NEWS.md | 9 +- R/Class-SimParamBee.R | 12 +- R/Functions_L0_auxilary.R | 17 +- man/SimParamBee.Rd | 526 ++++++++++--------- man/calcColonyValue.Rd | 12 +- tests/testthat/test-L0_auxiliary_functions.R | 40 ++ vignettes/H_Parallelisation.Rmd | 57 +- 9 files changed, 404 insertions(+), 306 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index a14caee2..042657cf 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -41,3 +41,4 @@ Config/Needs/website: tidyverse/tidytemplate VignetteBuilder: knitr Config/roxygen2/version: 8.1.0 RdMacros: Rdpack +RoxygenNote: 7.3.3 diff --git a/NAMESPACE b/NAMESPACE index e400fa59..3d4fa682 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -211,25 +211,21 @@ importFrom(R6,R6Class) importFrom(Rdpack,reprompt) importFrom(extraDistr,rtpois) importFrom(future.apply,future_lapply) -importFrom(methods, - "slot<-", - classLabel, - is, - new, - setClass, - setClassUnion, - setMethod, - setValidity, - show, - slot, - validObject -) -importFrom(stats, - na.omit, - rbeta, - rnorm, - rpois, - runif -) +importFrom(methods,"slot<-") +importFrom(methods,classLabel) +importFrom(methods,is) +importFrom(methods,new) +importFrom(methods,setClass) +importFrom(methods,setClassUnion) +importFrom(methods,setMethod) +importFrom(methods,setValidity) +importFrom(methods,show) +importFrom(methods,slot) +importFrom(methods,validObject) +importFrom(stats,na.omit) +importFrom(stats,rbeta) +importFrom(stats,rnorm) +importFrom(stats,rpois) +importFrom(stats,runif) importFrom(utils,packageVersion) useDynLib(SIMplyBee, .registration = TRUE) diff --git a/NEWS.md b/NEWS.md index ada64d3a..7631a7a0 100644 --- a/NEWS.md +++ b/NEWS.md @@ -10,6 +10,10 @@ editor_options: ## Major changes +- `calcColonyValue()` now passes each Colony to the first argument of its + callback by position. Callbacks may name that argument `colony`, `x`, or + another name. This also applies to `SimParamBee$colonyValueFUN`. + - Colony IDs are now character, consistently with AlphaSimR individual IDs. `getId()` returns character IDs, including for empty collections and missing entries, so `apiary[getId(apiary)]` selects by ID/name and not by position! @@ -49,9 +53,8 @@ editor_options: - added functionality to map individual-level variance to colony-level variance and vice-versa with functions 'mapIndToColonyVar' and 'mapColonyToIndVar' -- 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 +- Parallelised major colony operations with `future` and `future.apply`. + New vignette describes how to use parallelisation. This is an experimental feature! ## Other diff --git a/R/Class-SimParamBee.R b/R/Class-SimParamBee.R index 43576186..5c8b4edc 100644 --- a/R/Class-SimParamBee.R +++ b/R/Class-SimParamBee.R @@ -214,11 +214,13 @@ SimParamBee <- R6Class( #' in \code{\link[SIMplyBee]{calcColonyValue}} - see also \code{\link[SIMplyBee]{calcColonyPheno}} #' and \code{\link[SIMplyBee]{calcColonyGv}}. #' - #' This function should work with internals of others functions - - #' therefore the function MUST be defined like \code{function(colony, arg - #' = default) someCode }, that is, the first argument MUST be - #' \code{colony} and any following arguments MUST have a default value. - #' For flexibility you can add ... argument to pass on any other argument. + #' The first argument receives a single \code{\link[SIMplyBee]{Colony-class}}, + #' passed by position; its name is unrestricted. + #' For example, use \code{function(colony, arg = default) someCode }. + #' For MultiColony input, \code{calcColonyValue} calls this function once + #' per colony and combines the results by row. + #' Additional arguments can have defaults or be supplied through + #' \code{...} in \code{calcColonyValue}. #' See \code{\link[SIMplyBee]{mapCasteToColonyValue}} for an example. #' #' You can provide your own functions that satisfy your needs! diff --git a/R/Functions_L0_auxilary.R b/R/Functions_L0_auxilary.R index 6ecd93eb..d534f7ec 100644 --- a/R/Functions_L0_auxilary.R +++ b/R/Functions_L0_auxilary.R @@ -5059,7 +5059,11 @@ getDronesPheno <- function(x, nInd = NULL, collapse = FALSE, simParamBee = NULL) #' #' @param x \code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}} #' @param FUN function, that calculates colony value from values of -#' colony members +#' colony members. Its first argument receives a single \code{\link[SIMplyBee]{Colony-class}}, +#' passed by position, and can have any name (for example, \code{colony} or \code{x}). +#' For \code{\link[SIMplyBee]{MultiColony-class}} input, +#' the function is called separately for each colony and the results are combined by row. +#' #' @param simParamBee \code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters #' @param ... other arguments of \code{FUN} #' @@ -5130,6 +5134,13 @@ getDronesPheno <- function(x, nInd = NULL, collapse = FALSE, simParamBee = NULL) #' calcColonyValue(colony) #' calcColonyValue(apiary) #' +#' # Colony value - using a simple custom function +#' countWorkers <- function(colony) { +#' matrix(nInd(colony@workers), nrow = 1, +#' dimnames = list(NULL, "nWorkers")) +#' } +#' calcColonyValue(colony, FUN = countWorkers) +#' calcColonyValue(apiary, FUN = countWorkers) #' @export # TODO: Do we need to do anything to add GxE to colony values? #353 # https://github.com/HighlanderLab/SIMplyBee/issues/353 @@ -5146,14 +5157,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(x = x, ...) + ret <- FUN(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(x = x[[colony]], ...) + ret[[colony]] <- FUN(x[[colony]], ...) } ret <- do.call("rbind", ret) rownames(ret) <- getId(x) diff --git a/man/SimParamBee.Rd b/man/SimParamBee.Rd index dad6b6eb..9e436ce4 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) @@ -92,9 +92,9 @@ SP$caste \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}}. @@ -116,7 +116,7 @@ SP$caste 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}}. @@ -138,7 +138,7 @@ SP$caste 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}}. @@ -160,7 +160,7 @@ SP$caste 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}}. @@ -182,7 +182,7 @@ SP$caste 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}}. @@ -203,7 +203,7 @@ SP$caste 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. @@ -212,7 +212,7 @@ SP$caste 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}}. @@ -233,7 +233,7 @@ SP$caste 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}}. @@ -254,111 +254,114 @@ SP$caste 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}}. - This function should work with internals of others functions - - therefore the function MUST be defined like \code{function(colony, arg - = default) someCode }, that is, the first argument MUST be - \code{colony} and any following arguments MUST have a default value. - For flexibility you can add ... argument to pass on any other argument. + The first argument receives a single \code{\link[SIMplyBee]{Colony-class}}, + passed by position; its name is unrestricted. + For example, use \code{function(colony, arg = default) someCode }. + For MultiColony input, \code{calcColonyValue} calls this function once + per colony and combines the results by row. + Additional arguments can have defaults or be supplied through + \code{...} in \code{calcColonyValue}. 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-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 +\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 -
    }} +
    +}} \if{html}{\out{
    }} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-SimParamBee-initialize}{}}} -\subsection{\code{SimParamBee$new()}}{ - Starts the process of building a new simulation by creating +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-SimParamBee-new}{}}} +\subsection{Method \code{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, @@ -372,81 +375,99 @@ generate this object} 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{\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 +\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 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) @@ -460,33 +481,35 @@ 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{\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 +\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 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 @@ -498,139 +521,140 @@ 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{\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{Method \code{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{
    }} +} +} \if{html}{\out{
    }} \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-SimParamBee-addToBeeRec}{}}} -\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{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{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{\code{SimParamBee$updateCaste()}}{ - A function to update the caste +\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{
    }} - } +\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-updateLastBeeId}{}}} -\subsection{\code{SimParamBee$updateLastBeeId()}}{ - A function to update the last +\subsection{Method \code{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{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{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{
    }} +} +} \if{html}{\out{
    }} \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-SimParamBee-updateLastColonyId}{}}} -\subsection{\code{SimParamBee$updateLastColonyId()}}{ - A function to update the colony last +\subsection{Method \code{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{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{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{
    }} +} +} \if{html}{\out{
    }} \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-SimParamBee-clone}{}}} -\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{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{Arguments}{ +\if{html}{\out{
    }} +\describe{ +\item{\code{deep}}{Whether to make a deep clone.} +} +\if{html}{\out{
    }} +} +} } diff --git a/man/calcColonyValue.Rd b/man/calcColonyValue.Rd index 09736f62..4253fe6e 100644 --- a/man/calcColonyValue.Rd +++ b/man/calcColonyValue.Rd @@ -25,7 +25,10 @@ calcColonyAa(x, FUN = mapCasteToColonyAa, simParamBee = NULL, ...) \item{x}{\code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}}} \item{FUN}{function, that calculates colony value from values of -colony members} +colony members. Its first argument receives a single \code{\link[SIMplyBee]{Colony-class}}, +passed by position, and can have any name (for example, \code{colony} or \code{x}). +For \code{\link[SIMplyBee]{MultiColony-class}} input, +the function is called separately for each colony and the results are combined by row.} \item{simParamBee}{\code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters} @@ -110,6 +113,13 @@ SP$colonyValueFUN <- mapCasteToColonyPheno calcColonyValue(colony) calcColonyValue(apiary) +# Colony value - using a simple custom function +countWorkers <- function(colony) { + matrix(nInd(colony@workers), nrow = 1, + dimnames = list(NULL, "nWorkers")) +} +calcColonyValue(colony, FUN = countWorkers) +calcColonyValue(apiary, FUN = countWorkers) } \seealso{ \code{\link[SIMplyBee]{mapCasteToColonyValue}} as an example of \code{FUN}, diff --git a/tests/testthat/test-L0_auxiliary_functions.R b/tests/testthat/test-L0_auxiliary_functions.R index 6a878e3a..79d738d4 100644 --- a/tests/testthat/test-L0_auxiliary_functions.R +++ b/tests/testthat/test-L0_auxiliary_functions.R @@ -1893,3 +1893,43 @@ test_that("getId returns character IDs independently of queen IDs", { expect_identical(getId(colony), "1") expect_identical(getId(getVirginQueens(colony, simParamBee = SP)), "3") }) + +# ---- calcColonyValue ---- + +test_that("colony value callbacks receive individual colonies positionally", { + set.seed(47) + SP <- SimParamBee$new( + quickHaplo(nInd = 2, nChr = 1, segSites = 10), + csdChr = NULL + ) + SP$nThreads <- 1L + apiary <- createMultiColony(n = 2, simParamBee = SP) + apiary[[1]] <- createColony(simParamBee = SP) + apiary[[2]] <- createColony(simParamBee = SP) + apiary[[1]]@location <- c(2, 0) + apiary[[2]]@location <- c(5, 0) + + colony_callback <- function(colony, scale) { + expect_s4_class(colony, "Colony") + matrix(scale * colony@location[1], nrow = 1, dimnames = list(NULL, "value")) + } + x_callback <- function(x, scale) { + expect_s4_class(x, "Colony") + matrix(scale * x@location[1], nrow = 1, dimnames = list(NULL, "value")) + } + + for (callback in list(colony_callback, x_callback)) { + SP$colonyValueFUN <- callback + for (explicit in c(TRUE, FALSE)) { + fun <- if (explicit) callback else NULL + expect_equal( + calcColonyValue(apiary[[1]], FUN = fun, scale = 3, simParamBee = SP), + matrix(6, dimnames = list(NULL, "value")) + ) + expect_equal( + calcColonyValue(apiary, FUN = fun, scale = 3, simParamBee = SP), + matrix(c(6, 15), ncol = 1, dimnames = list(getId(apiary), "value")) + ) + } + } +}) diff --git a/vignettes/H_Parallelisation.Rmd b/vignettes/H_Parallelisation.Rmd index 5822a2ba..103ab02d 100644 --- a/vignettes/H_Parallelisation.Rmd +++ b/vignettes/H_Parallelisation.Rmd @@ -30,20 +30,15 @@ simulation. We do recommend reading the remaining of this vignette. library(SIMplyBee) library(future) -NCORES = 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 +NWORKERS <- 8 # Choose a worker count within your allocated resources + +# Choose ONE backend (each plan() call replaces the previous plan) +plan(sequential) # Default: no parallel workers +# plan(multicore, workers = NWORKERS) # Forking, where supported +# plan(multisession, workers = NWORKERS) # Separate local R processes (PSOCK) +# plan(cluster, workers = c("machine1", "machine2")) # Remote R processes + +# Run your simulation here, then stop the parallel backend plan(sequential) ``` @@ -57,30 +52,46 @@ 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 +available cores. As mentioned in the quick set-up, there are four 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} +The two parallelisation controls have different roles: + +- `future::plan()` selects the backend and worker count for colony operations + implemented with `future_lapply()`. +- `SP$nThreads` controls native threads in supported SIMplyBee and AlphaSimR + routines. Setting it does not create or configure future workers. + +When using multiple workers, `SP$nThreads <- 1L` is a useful starting point to +avoid requesting multiple native threads inside each worker. Choose worker and +thread counts together to fit the resources allocated to your simulation. +The following setup is shown without execution during vignette rendering. + +```{r nThread_setup, eval=FALSE} library(package = "SIMplyBee") library(package = "future") -# Set to the desired number of cores -plan(multisession, workers = 8) -# Or use all available cores -plan(multisession, workers = availableCores()) +# Set the desired number of workers within your allocated resources +plan(multisession, workers = 8) +# Alternatively, replace the preceding line with: +# plan(multisession, workers = availableCores()) founderGenomes <- quickHaplo(nInd = 30, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes) +SP$nThreads <- 1L # Native threads, independently of the future worker count + +# Run your simulation here, then release the workers +plan(sequential) ``` -In R, there are two possible options for parallelisation, `FORK` and `PSOCK`. +Two mechanisms used by these backends are `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! +is not supported on Windows. On an HPC cluster, follow the site's policy and +scheduler allocation when choosing a backend and worker count. 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), From ab45fc83bc3c37b76b0058b56777f68b7daaf11c Mon Sep 17 00:00:00 2001 From: gregorgorjanc Date: Wed, 7 Oct 2026 17:45:33 +0000 Subject: [PATCH 85/98] Update documentation --- DESCRIPTION | 1 - NAMESPACE | 36 ++-- man/SimParamBee.Rd | 514 ++++++++++++++++++++++----------------------- 3 files changed, 266 insertions(+), 285 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 042657cf..a14caee2 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -41,4 +41,3 @@ Config/Needs/website: tidyverse/tidytemplate VignetteBuilder: knitr Config/roxygen2/version: 8.1.0 RdMacros: Rdpack -RoxygenNote: 7.3.3 diff --git a/NAMESPACE b/NAMESPACE index 3d4fa682..e400fa59 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -211,21 +211,25 @@ importFrom(R6,R6Class) importFrom(Rdpack,reprompt) importFrom(extraDistr,rtpois) importFrom(future.apply,future_lapply) -importFrom(methods,"slot<-") -importFrom(methods,classLabel) -importFrom(methods,is) -importFrom(methods,new) -importFrom(methods,setClass) -importFrom(methods,setClassUnion) -importFrom(methods,setMethod) -importFrom(methods,setValidity) -importFrom(methods,show) -importFrom(methods,slot) -importFrom(methods,validObject) -importFrom(stats,na.omit) -importFrom(stats,rbeta) -importFrom(stats,rnorm) -importFrom(stats,rpois) -importFrom(stats,runif) +importFrom(methods, + "slot<-", + classLabel, + is, + new, + setClass, + setClassUnion, + setMethod, + setValidity, + show, + slot, + validObject +) +importFrom(stats, + na.omit, + rbeta, + rnorm, + rpois, + runif +) importFrom(utils,packageVersion) useDynLib(SIMplyBee, .registration = TRUE) diff --git a/man/SimParamBee.Rd b/man/SimParamBee.Rd index 9e436ce4..33c49abf 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) @@ -92,9 +92,9 @@ SP$caste \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}}. @@ -116,7 +116,7 @@ SP$caste 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}}. @@ -138,7 +138,7 @@ SP$caste 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}}. @@ -160,7 +160,7 @@ SP$caste 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}}. @@ -182,7 +182,7 @@ SP$caste 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}}. @@ -203,7 +203,7 @@ SP$caste 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. @@ -212,7 +212,7 @@ SP$caste 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}}. @@ -233,7 +233,7 @@ SP$caste 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}}. @@ -254,7 +254,7 @@ SP$caste 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}}. @@ -268,100 +268,99 @@ SP$caste 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, @@ -375,99 +374,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) @@ -481,35 +462,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 @@ -521,140 +500,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{
    }} -} -} } From 40bd8fa38609f24f67e3b8c608e7f6f7e90a0558 Mon Sep 17 00:00:00 2001 From: janaobsteter Date: Tue, 13 Oct 2026 14:37:11 +0200 Subject: [PATCH 86/98] Claude parallelisation optimisation --- .Rbuildignore | 1 + NEWS.md | 26 ++++++++ R/Functions_L1_Pop.R | 131 +++++++++++++++++++++++--------------- R/Functions_L2_Colony.R | 48 ++++++++------ R/Functions_L3_Colonies.R | 23 +++++-- 5 files changed, 153 insertions(+), 76 deletions(-) diff --git a/.Rbuildignore b/.Rbuildignore index 679a4f13..269a5100 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -25,3 +25,4 @@ ^Meta$ ^SIMplyBee\.Rproj +^dev$ diff --git a/NEWS.md b/NEWS.md index 156adda7..b4b87e68 100644 --- a/NEWS.md +++ b/NEWS.md @@ -35,8 +35,34 @@ is the number of viable workers. 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 +- MultiColony operations parallelised with `future` now send each worker + only its own chunk of colonies, instead of the whole MultiColony and the + calling function's environment (including, for example, all drones in + `cross()`). This reduces memory use on parallel workers, which could + previously be killed (e.g., by HPC memory limits) with errors such as + `FutureInterruptError` or `FutureLaunchError` ("error writing to + connection"). Only `createCastePop()`, `pullCastePop()`, and + `removeCastePop()` on MultiColony objects now run in parallel; cheap + bookkeeping steps (e.g., adding the fathers in `cross()`, `reQueen()`, + `setLocation()`, `setEvents()`, `combine()`) run sequentially. Seeded + results with parallel futures (e.g., `plan(multisession)`) are unchanged, + but seeded results after `cross()` differ from previous development + versions, since `cross()` no longer consumes random numbers for setting up + parallel streams. + ## Bug fixes +- with `plan(sequential)`, `createCastePop()` on a MultiColony no longer + duplicates caste records in `SimParamBee` and `createMultiColony()` no + longer advances the colony ID counter twice; sequential and parallel + futures now give the same seeded results + +- `supersede()` on a MultiColony no longer generates random numbers in + parallel workers without a declared parallel-safe seed + +- `cross()` and `buildUp()` now pass `simParamBee` to all internal calls + instead of relying on a global `SP` object + # SIMplyBee version 0.4.1 diff --git a/R/Functions_L1_Pop.R b/R/Functions_L1_Pop.R index b44173a9..ed16d231 100644 --- a/R/Functions_L1_Pop.R +++ b/R/Functions_L1_Pop.R @@ -570,7 +570,7 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, if (nInd(drones) != length(ids)) { stop("Not enough IDs provided") } - drones@id = ids + drones@id = as.character(ids) drones@iid = as.integer(ids) if (returnSP) { names(ret$caste) <- ids @@ -620,30 +620,39 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, ids = (lastId+1):(lastId+totalNInd) end_lastId <- lastId+totalNInd - 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 - } - } - ) + # Pass each colony with its own nInd and IDs as an element of X, so that + # future.apply ships to each worker only its chunk of colonies rather than + # the whole MultiColony + nIndByColony <- if (nNInd == 1) rep(nInd, nCol) else nInd + idsByColony <- base::split(ids, factor(rep(seq_len(nCol), nIndByColony), + levels = seq_len(nCol))) + tasks <- lapply(seq_len(nCol), FUN = function(colony) { + list(colony = x[[colony]], nInd = nIndByColony[colony], + ids = idsByColony[[colony]]) + }) + workerFUN <- function(task, caste, simParamBee) { + if (task$nInd > 0) { + createCastePop( + x = task$colony, caste = caste, + nInd = task$nInd, + editCsd = TRUE, csdAlleles = NULL, + simParamBee = simParamBee, + returnSP = TRUE, + ids = as.character(task$ids) + ) + } else { + NULL + } + } + # Detach from this frame, otherwise future serialises the whole frame + # (including x and tasks) together with the function to every worker. + # workerFUN gets everything via its arguments, so we also skip scanning + # the colonies in X for globals (future.globals = list()), which is slow + environment(workerFUN) <- new.env(parent = topenv()) + ret <- future_lapply(X = tasks, FUN = workerFUN, + caste = caste, simParamBee = simParamBee, + future.globals = list(), future.seed = TRUE) + rm(tasks) names(ret) <- getId(x) # Add to simParamBee: pedigree, caste, recHist @@ -673,11 +682,14 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, hist = RecHist, ploidy = ploidy) } } - # Extend caste - Caste <- do.call("c", lapply(ret[notNull], '[[', "caste")) - Names <- do.call("c", lapply(ret[notNull], function(x) names(x$caste))) - names(Caste) <- Names - simParamBee$updateCaste(caste = Caste) + # Extend caste (unless the workers already updated simParamBee in place, + # as with plan(sequential), which would duplicate the caste records) + if (!updatedIdBoolean) { + Caste <- do.call("c", lapply(ret[notNull], '[[', "caste")) + Names <- do.call("c", lapply(ret[notNull], function(x) names(x$caste))) + names(Caste) <- Names + simParamBee$updateCaste(caste = Caste) + } if (!returnSP) { @@ -1254,23 +1266,36 @@ pullCastePop <- function(x, caste, nInd = NULL, use = "rand", ret$pulled <- vector(mode = "list", length = nCol) ret$remnant <- x - 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) - } - ) + # Pass each colony with its own nInd as an element of X, so that each + # worker receives only its chunk of colonies + tasks <- lapply(seq_len(nCol), FUN = function(colony) { + if (is.null(nInd)) { + nIndColony <- NULL + } else { + nIndColony <- ifelse(nNInd == 1, nInd, nInd[colony]) + } + list(colony = x[[colony]], nInd = nIndColony) + }) + workerFUN <- function(task, caste, use, removeFathers, collapse, simParamBee) { + pullCastePop(x = task$colony, + caste = caste, + nInd = task$nInd, + use = use, + removeFathers = removeFathers, + collapse = collapse, + simParamBee = simParamBee) + } + # Detach from this frame, otherwise future serialises the whole frame + # (including x and tasks) together with the function to every worker. + # workerFUN gets everything via its arguments, so we also skip scanning + # the colonies in X for globals (future.globals = list()), which is slow + environment(workerFUN) <- new.env(parent = topenv()) + tmp = future_lapply(X = tasks, FUN = workerFUN, + caste = caste, use = use, + removeFathers = removeFathers, collapse = collapse, + simParamBee = simParamBee, + future.globals = list(), future.seed = TRUE) + rm(tasks) ret$pulled <- lapply(tmp, '[[', "pulled") names(ret$pulled) <- getId(x) @@ -1660,7 +1685,7 @@ cross <- function(x, IDs = IDs[IDs %in% crossPlanDF$virginID] x = x[IDs] if (type == "MultiColony") { - multicolony <- multicolony[getId(getVirginQueens(multicolony, collapse=TRUE)) %in% IDs] + multicolony <- multicolony[getId(getVirginQueens(multicolony, collapse = TRUE, simParamBee = simParamBee)) %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, @@ -1673,7 +1698,7 @@ cross <- function(x, 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)) + selectedDPC = selectColonies(droneColonies, ID = as.character(crossPlanDF_DPCtable$DPC), simParamBee = simParamBee) # And here I create the drones dronesByDPC <- createCastePop(selectedDPC, caste = "drones", nInd = as.integer(crossPlanDF_DPCtable$noDrones), @@ -1752,10 +1777,12 @@ cross <- function(x, } # Add drones in the queens father slot + # This is cheap metadata work without random numbers, so we run it + # sequentially - parallel workers would cost more to ship x and drones to + # than the work itself - x <- future_lapply(X = 1:length(IDs), - future.seed = TRUE, - FUN = function(i) { + x <- lapply(X = seq_along(IDs), + FUN = function(i) { crossVirginQueen(virginQueen = x[i], virginQueenDrones = dronesByVirgin[[i]], simParamBee = simParamBee) diff --git a/R/Functions_L2_Colony.R b/R/Functions_L2_Colony.R index 93b68cb1..5b262887 100644 --- a/R/Functions_L2_Colony.R +++ b/R/Functions_L2_Colony.R @@ -162,7 +162,7 @@ reQueen <- function(x, queen, removeVirginQueens = TRUE, simParamBee = NULL) { if (removeVirginQueens) { x <- removeVirginQueens(x, simParamBee = simParamBee) } - } else { + } else { # If it's a virgin queen x <- removeQueen(x, simParamBee = simParamBee) x@virginQueens <- queen } @@ -176,7 +176,7 @@ reQueen <- function(x, queen, removeVirginQueens = TRUE, simParamBee = NULL) { } - x@colonies = future_lapply(X = seq_len(nCol), + x@colonies = lapply(X = seq_len(nCol), FUN = function(colony) { reQueen( x = x[[colony]], @@ -385,7 +385,7 @@ addCastePop <- function(x, caste = NULL, nInd = NULL, new = FALSE, nInd(x) }) - x@colonies <- future_lapply(X = seq_len(nCol), + x@colonies <- lapply(X = seq_len(nCol), FUN = function(colony) { if (!is.null(nInds[[colony]])) { if (caste == "workers") { @@ -600,7 +600,7 @@ buildUp <- function(x, nWorkers = NULL, nDrones = NULL, # Events if (resetEvents) { - x <- resetEvents(x) + x <- resetEvents(x, simParamBee = simParamBee) } x@production <- TRUE } else if (isMultiColony(x)) { @@ -1054,22 +1054,34 @@ removeCastePop <- function(x, caste = NULL, p = 1, use = "rand", p <- p[1:nCol] } - x@colonies <- future_lapply(X = seq_len(nCol), - future.seed = TRUE, - FUN = function(colony) { + # Pass each colony with its own p as an element of X, so that each + # worker receives only its chunk of colonies + tasks <- lapply(seq_len(nCol), FUN = function(colony) { if (is.null(p)) { pColony <- NULL } else { pColony <- ifelse(nP == 1, p, p[colony]) } + list(colony = x[[colony]], p = pColony) + }) + workerFUN <- function(task, caste, use, simParamBee) { removeCastePop( - x = x[[colony]], caste = caste, - p = pColony, + x = task$colony, caste = caste, + p = task$p, use = use, simParamBee = simParamBee ) } - ) + # Detach from this frame, otherwise future serialises the whole frame + # (including x and tasks) together with the function to every worker. + # workerFUN gets everything via its arguments, so we also skip scanning + # the colonies in X for globals (future.globals = list()), which is slow + environment(workerFUN) <- new.env(parent = topenv()) + x@colonies <- future_lapply(X = tasks, FUN = workerFUN, + caste = caste, use = use, + simParamBee = simParamBee, + future.globals = list(), future.seed = TRUE) + rm(tasks) } else { stop("Argument x must be a Colony or MultiColony class object!") @@ -1216,7 +1228,7 @@ resetEvents <- function(x, collapse = NULL, simParamBee = NULL) { stop("The Multicolony contains 0 colonies!") } - x@colonies <- future_lapply(X = seq_len(nCol), + x@colonies <- lapply(X = seq_len(nCol), FUN = function(colony) { resetEvents( x = x[[colony]], @@ -1292,7 +1304,7 @@ collapse <- function(x, simParamBee = NULL) { stop("The Multicolony contains 0 colonies!") } - x@colonies <- future_lapply(X = seq_len(nCol), + x@colonies <- lapply(X = seq_len(nCol), FUN = function(colony) { collapse(x = x[[colony]], simParamBee = simParamBee) @@ -1509,7 +1521,7 @@ swarm <- function(x, p = NULL, remnant = remnantColony ) - ret$swarm@colonies <- future_lapply(X = seq_len(nCol), FUN = function(colony) { + ret$swarm@colonies <- lapply(X = seq_len(nCol), FUN = function(colony) { addCastePop_internal(colony = ret$swarm@colonies[[colony]], pop = tmp$pulled[[colony]], caste = "workers") }) @@ -1658,7 +1670,7 @@ supersede <- function(x, simParamBee = NULL, ...) { } tmpVirginQueens <- lapply(tmpVirginQueens, FUN = function(x) selectInd(x, nInd = 1, use = "rand", simParam = simParamBee)) - x@colonies <- future_lapply(X = seq_len(nColonies(x)), FUN = function(colony) { + x@colonies <- lapply(X = seq_len(nColonies(x)), FUN = function(colony) { addCastePop_internal(colony = removeQueen(x[[colony]], simParamBee = simParamBee), pop = tmpVirginQueens[[colony]], caste = "virginQueens") }) @@ -1823,7 +1835,7 @@ split <- function(x, p = NULL, simParamBee = NULL, ...) { ) ret$split <- setLocation(x = ret$split, location = location, simParamBee = simParamBee) - ret$split@colonies <- future_lapply(X = seq_len(nCol), + ret$split@colonies <- lapply(X = seq_len(nCol), FUN = function(colony) { addCastePop_internal(colony = ret$split@colonies[[colony]], pop = tmp$pulled[[colony]], caste = "workers") @@ -1879,7 +1891,7 @@ setEvents <- function(x, slot, value, simParamBee = NULL) { slot(x, slot) <- value } if (isMultiColony(x)) { - x@colonies <- future_lapply(X = seq_len(nColonies(x)), + x@colonies <- lapply(X = seq_len(nColonies(x)), FUN = function(colony) { setEvents(x[[colony]], slot, value, simParamBee = simParamBee) }) @@ -1962,7 +1974,7 @@ combine <- function(strong, weak, simParamBee = NULL) { if (nColonies(weak) == nColonies(strong)) { nCol <- nColonies(weak) - strong@colonies <- future_lapply(X = seq_len(nCol), + strong@colonies <- lapply(X = seq_len(nCol), FUN = function(colony) { combine(strong = strong[[colony]], weak = weak[[colony]], @@ -2074,7 +2086,7 @@ setLocation <- function(x, location = c(0, 0), simParamBee = NULL) { stop("Argument location must be numeric, list, or data.frame!") } } - x@colonies <- future_lapply(X = seq_len(nCol), + x@colonies <- lapply(X = seq_len(nCol), FUN = function(colony) { if (is.data.frame(location)) { loc <- location[colony, ] diff --git a/R/Functions_L3_Colonies.R b/R/Functions_L3_Colonies.R index 78f240c3..1938a2fb 100644 --- a/R/Functions_L3_Colonies.R +++ b/R/Functions_L3_Colonies.R @@ -60,13 +60,19 @@ createMultiColony <- function(x = NULL, n = NULL, simParamBee = NULL, populateCo } else { ret <- new(Class = "MultiColony", colonies = vector(mode = "list", length = n)) if (populateColonies) { - ids <- (simParamBee$lastColonyId+1):(simParamBee$lastColonyId + n) + end_lastColonyId <- simParamBee$lastColonyId + n + ids <- (simParamBee$lastColonyId+1):end_lastColonyId - ret@colonies <- future_lapply(X = seq_len(n), + + ret@colonies <- lapply(X = seq_len(n), FUN = function(colony) { createColony(simParamBee = simParamBee, id = ids[colony]) }) - simParamBee$updateLastColonyId(n = n) + + updatedColonyIdBoolean <- simParamBee$lastColonyId == end_lastColonyId + if (!updatedColonyIdBoolean) { + simParamBee$updateLastColonyId(n = n) + } } else { } @@ -85,13 +91,18 @@ createMultiColony <- function(x = NULL, n = NULL, simParamBee = NULL, populateCo 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) + end_lastColonyId <- simParamBee$lastColonyId + n + ids <- (simParamBee$lastColonyId+1):end_lastColonyId - ret@colonies <- future_lapply(X = seq_len(n), + ret@colonies <- lapply(X = seq_len(n), FUN = function(colony) { createColony(x = x[colony], simParamBee = simParamBee, id = ids[colony]) }) - simParamBee$updateLastColonyId(n = n) + + updatedColonyIdBoolean <- simParamBee$lastColonyId == end_lastColonyId + if (!updatedColonyIdBoolean) { + simParamBee$updateLastColonyId(n = n) + } } validObject(ret) From b7974c9165bf8dacad4795b556fff4e3fb54c65f Mon Sep 17 00:00:00 2001 From: janaobsteter Date: Tue, 13 Oct 2026 12:39:33 +0000 Subject: [PATCH 87/98] Update documentation --- DESCRIPTION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index d0f3ec44..706e400a 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -38,4 +38,4 @@ Suggests: Config/testthat/edition: 3 Config/Needs/website: tidyverse/tidytemplate VignetteBuilder: knitr -Config/roxygen2/version: 8.1.0 +Config/roxygen2/version: 8.1.1 From bf0fa4f3717e8a6632de46a4d64579c0deacebff Mon Sep 17 00:00:00 2001 From: janaobsteter Date: Wed, 14 Oct 2026 19:43:27 +0200 Subject: [PATCH 88/98] Claude changes to enable speed up --- NEWS.md | 72 +++++- R/Class-SimParamBee.R | 38 ++++ R/Functions_L0_auxilary.R | 2 +- R/Functions_L1_Pop.R | 187 +++++++++++---- R/Functions_L2_Colony.R | 254 +++++++++++++-------- tests/testthat/test-L1_pop_functions.R | 80 +++++++ tests/testthat/test-L2_colony_functions.R | 69 ++++++ tests/testthat/test-parallel_future.R | 262 ++++++++++++++++++++++ 8 files changed, 819 insertions(+), 145 deletions(-) create mode 100644 tests/testthat/test-parallel_future.R diff --git a/NEWS.md b/NEWS.md index b4b87e68..5f3eaf71 100644 --- a/NEWS.md +++ b/NEWS.md @@ -41,14 +41,51 @@ is the number of viable workers. `cross()`). This reduces memory use on parallel workers, which could previously be killed (e.g., by HPC memory limits) with errors such as `FutureInterruptError` or `FutureLaunchError` ("error writing to - connection"). Only `createCastePop()`, `pullCastePop()`, and + connection"). Only creating individuals (`createCastePop()` and the + virgin queens in `swarm()` and `supersede()`), `pullCastePop()`, and `removeCastePop()` on MultiColony objects now run in parallel; cheap bookkeeping steps (e.g., adding the fathers in `cross()`, `reQueen()`, - `setLocation()`, `setEvents()`, `combine()`) run sequentially. Seeded - results with parallel futures (e.g., `plan(multisession)`) are unchanged, - but seeded results after `cross()` differ from previous development - versions, since `cross()` no longer consumes random numbers for setting up - parallel streams. + `setLocation()`, `setEvents()`, `combine()`, and pulling workers in + `swarm()` and `split()`) run sequentially. Seeded results after + `cross()` differ from previous development versions, since `cross()` no + longer consumes random numbers for setting up parallel streams. + +- MultiColony functions now send parallel workers much less data, which + reduces run time and memory use, especially with `plan(multisession)`: + + - `createCastePop()` (and hence `addWorkers()`, `addDrones()`, + `addVirginQueens()`, and `buildUp()`) sends each worker only the + colonies' queens (with their fathers) and a slimmed copy of + `SimParamBee` without the pedigree, recombination, and caste + records; the records of the new individuals are added to + `SimParamBee` in the main R session + - `swarm()` and `supersede()` create the virgin queens on the + workers and return only the one that prevails in each colony + - `swarm()` and `split()` pull the workers in the main R session and + no longer send colonies to workers + + Run times with 1000 colonies (16 chromosomes, 100 workers per colony), + sequential / `plan(multisession, workers = 4)`, in seconds: + + | function | before | now | + |-----------------------------|-------------|------------| + | `buildUp()` | 68.7 / 31.8 | 29.5 / 17.6 | + | `addVirginQueens(nInd = 10)`| 57.0 / 23.9 | 9.7 / 6.9 | + | `swarm()` | 36.0 / 35.3 | 9.5 / 11.9 | + | `split()` | 16.3 / 21.7 | 3.4 / 3.4 | + | `supersede()` | 27.3 / 14.8 | 5.6 / 7.8 | + + Parallel futures pay off when there is a lot of work per colony (e.g., + many workers or virgin queens per colony), but not for every function + or simulation size, so we recommend timing a few steps of your + simulation with `plan(sequential)` and `plan(multisession)`. + +- seeded results of `swarm()`, `split()`, and `supersede()` on a + MultiColony differ from previous versions, because random numbers are + now drawn in a different order (virgin queens are created and selected + on the parallel workers, and workers are pulled in the main R session); + `removeCastePop(p = 1)` on a MultiColony no longer consumes random + numbers. Sequential and parallel futures still give the same results. ## Bug fixes @@ -63,6 +100,29 @@ is the number of viable workers. - `cross()` and `buildUp()` now pass `simParamBee` to all internal calls instead of relying on a global `SP` object +- `swarm()` and `supersede()` now use `SP$nVirginQueens` when it is a + function (e.g., `nVirginQueensPoisson()`), with one value per colony + for a MultiColony; previously `swarm()` failed and `supersede()` used + the number of virgin queens already in the colony instead + +- `swarm()` now samples the swarm location within `radius` of the parent + colony; previously, for a Colony, the location was sampled around the + parent's x coordinate only, and for a MultiColony the sampled locations + were not set on the swarms + +- `createCrossPlan()` with a single drone producing colony now samples + only that colony; previously it sampled from colony IDs 1 to that + colony's ID + +- `createCastePop()` on a MultiColony now records all created virgin + queens, including csd homozygous ones that are removed, as virgin + queens in `SimParamBee` with `plan(sequential)` too (previously they + were recorded as workers) + +- recombination records (`SP$recHist`) of individuals created on a + MultiColony with parallel futures are now named by their IDs + (previously, e.g., `"1.341"` instead of `"341"`) + # SIMplyBee version 0.4.1 diff --git a/R/Class-SimParamBee.R b/R/Class-SimParamBee.R index 9e7130fc..8290a551 100644 --- a/R/Class-SimParamBee.R +++ b/R/Class-SimParamBee.R @@ -532,6 +532,44 @@ SimParamBee <- R6Class( n = as.integer(n) private$.lastColonyId = private$.lastColonyId + n invisible(self) + }, + + #' @description A copy of the simulation parameters for parallel workers, + #' without the records of all individuals created so far (pedigree, + #' recombination history, and caste), which can be large. Workers use + #' it to create new individuals and return their records, which are then + #' added to the original object. For internal use in SIMplyBee only. + #' + #' @param casteIds character, IDs of individuals whose caste records to + #' keep + slimClone = function(casteIds = NULL) { + ret = self$clone(deep = FALSE) + retPrivate = ret$.__enclos_env__$private + if (!is.null(private$.pedigree)) { + retPrivate$.pedigree = private$.pedigree[0, , drop = FALSE] + } + retPrivate$.recHist = list() + retPrivate$.hasHap = logical(0) + retPrivate$.isFounder = logical(0) + if (is.null(casteIds)) { + retPrivate$.caste = private$.caste[0] + } else { + retPrivate$.caste = private$.caste[as.character(casteIds)] + } + # Founder genomes are not needed to create new individuals + ret$founderPop = NULL + # AlphaSimR creates the default finalizePop() inside initialize(), so it + # encloses (and would serialise) the original object - re-home it + finalizeEnv = environment(ret$finalizePop) + if (!is.null(finalizeEnv) && + exists("self", envir = finalizeEnv, inherits = FALSE) && + identical(get("self", envir = finalizeEnv), self)) { + finalizePop = ret$finalizePop + environment(finalizePop) = new.env(parent = baseenv()) + ret$finalizePop = finalizePop + } + ret$nThreads = 1L + invisible(ret) } ), diff --git a/R/Functions_L0_auxilary.R b/R/Functions_L0_auxilary.R index d0bf6cd8..843c9012 100644 --- a/R/Functions_L0_auxilary.R +++ b/R/Functions_L0_auxilary.R @@ -6434,7 +6434,7 @@ createCrossPlan <- function(x, } else { print("Cross plan, drone colonies") ids <- getId(droneColonies) - crossPlan <- lapply(1:length(virginId), FUN = function(x) unique(sample(x = ids, size = nDrones[x], replace = TRUE))) + crossPlan <- lapply(1:length(virginId), FUN = function(x) unique(ids[sample.int(length(ids), size = nDrones[x], replace = TRUE)])) } } names(crossPlan) <- virginId diff --git a/R/Functions_L1_Pop.R b/R/Functions_L1_Pop.R index ed16d231..848e3ece 100644 --- a/R/Functions_L1_Pop.R +++ b/R/Functions_L1_Pop.R @@ -502,7 +502,7 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, 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@id] } } @@ -562,7 +562,7 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, ret$pedigree <- simParamBee$pedigree[drones@id, , drop = FALSE] } if (simParamBee$isTrackRec) { - ret$recHist <- simParamBee$recHist[drones@iid] + ret$recHist <- simParamBee$recHist[drones@id] } } @@ -618,16 +618,23 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, lastId = simParamBee$lastId ids = (lastId+1):(lastId+totalNInd) - end_lastId <- lastId+totalNInd # Pass each colony with its own nInd and IDs as an element of X, so that # future.apply ships to each worker only its chunk of colonies rather than - # the whole MultiColony + # the whole MultiColony. New individuals are created only from the queen + # (and her fathers), so we pass colonies without workers, drones, and + # virgin queens. nIndByColony <- if (nNInd == 1) rep(nInd, nCol) else nInd idsByColony <- base::split(ids, factor(rep(seq_len(nCol), nIndByColony), levels = seq_len(nCol))) tasks <- lapply(seq_len(nCol), FUN = function(colony) { - list(colony = x[[colony]], nInd = nIndByColony[colony], + col <- x@colonies[[colony]] + if (!is.null(col)) { + col@workers <- NULL + col@drones <- NULL + col@virginQueens <- NULL + } + list(colony = col, nInd = nIndByColony[colony], ids = idsByColony[[colony]]) }) workerFUN <- function(task, caste, simParamBee) { @@ -649,47 +656,22 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, # workerFUN gets everything via its arguments, so we also skip scanning # the colonies in X for globals (future.globals = list()), which is slow environment(workerFUN) <- new.env(parent = topenv()) + # Workers get a slimmed copy of simParamBee (without pedigree, recHist, + # and caste records) and do not update simParamBee - they return the + # records of the new individuals, which we add to simParamBee below ret <- future_lapply(X = tasks, FUN = workerFUN, - caste = caste, simParamBee = simParamBee, + caste = caste, simParamBee = simParamBee$slimClone(), future.globals = list(), future.seed = TRUE) rm(tasks) names(ret) <- getId(x) - # Add to simParamBee: pedigree, caste, recHist notNull = sapply(ret, FUN = function(x) !is.null(x)) - - updatedIdBoolean <- simParamBee$lastId == end_lastId - - if (!simParamBee$isTrackPed & !updatedIdBoolean) { - simParamBee$updateLastBeeId(n = totalNInd) - } else if (simParamBee$isTrackPed & !updatedIdBoolean) { - 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 (unless the workers already updated simParamBee in place, - # as with plan(sequential), which would duplicate the caste records) - if (!updatedIdBoolean) { - Caste <- do.call("c", lapply(ret[notNull], '[[', "caste")) - Names <- do.call("c", lapply(ret[notNull], function(x) names(x$caste))) - names(Caste) <- Names - simParamBee$updateCaste(caste = Caste) - } + addBeeRecords_internal( + simParamBee = simParamBee, ids = ids, caste = caste, + pedigree = do.call("rbind", lapply(ret[notNull], FUN = "[[", "pedigree")), + recHist = do.call("c", unname(lapply(ret[notNull], FUN = "[[", "recHist"))), + ploidy = ifelse(caste == "drones", 1L, 2L) + ) if (!returnSP) { @@ -754,6 +736,129 @@ createVirginQueens <- function(x, nInd = NULL, return(ret) } +# Add the records of individuals created on parallel workers (with a +# SimParamBee$slimClone()) to simParamBee, in one step and in ID order. +# pedigree is a matrix with rows named by ids, recHist a list named by ids. +addBeeRecords_internal <- function(simParamBee, ids, caste, pedigree = NULL, + recHist = NULL, ploidy = 2L) { + ids <- as.character(ids) + nNewInd <- length(ids) + if (nNewInd == 0) { + return(invisible(simParamBee)) + } + if (simParamBee$isTrackPed) { + if (!identical(rownames(pedigree), ids)) { + stop("Pedigree records do not match the new IDs!") + } + if (simParamBee$isTrackRec) { + simParamBee$addToBeeRec(nNewInd = nNewInd, id = ids, + mother = pedigree[, "mother"], father = pedigree[, "father"], + isDH = pedigree[, "isDH"], + hist = recHist[ids], ploidy = rep(ploidy, nNewInd)) + } else { + simParamBee$addToBeePed(nNewInd = nNewInd, id = ids, + mother = pedigree[, "mother"], father = pedigree[, "father"], + isDH = pedigree[, "isDH"]) + } + } else { + simParamBee$updateLastBeeId(n = nNewInd) + } + casteRecords <- rep(caste, nNewInd) + names(casteRecords) <- ids + simParamBee$updateCaste(caste = casteRecords) + invisible(simParamBee) +} + +# For each colony in a MultiColony, create nInd virgin queens from the queen +# and her fathers, remove csd homozygous ones, and select one at random that +# prevails (as in swarm and supersede). Each parallel worker receives only the +# queens of its colonies and a slimmed copy of simParamBee, and returns only the +# prevailing virgin queen with the records of all created virgin queens. These +# records are then added to simParamBee here. Returns a list with a virgin +# queen (Pop) or NULL (all virgin queens csd homozygous) for each colony. +# nInd is a single value or one value per colony. +createPrevailingVirginQueens_internal <- function(x, nInd, simParamBee) { + nCol <- nColonies(x) + if (nCol == 0) { + stop("The Multicolony contains 0 colonies!") + } + if (!(length(nInd) == 1 || length(nInd) == nCol)) { + stop("nInd must be a single value or one value per colony!") + } + nInd <- rep_len(as.integer(nInd), nCol) + if (any(is.na(nInd) | nInd < 1)) { + stop("nInd must be at least 1 for every colony!") + } + lastId <- simParamBee$lastId + ids <- (lastId + 1L):(lastId + sum(nInd)) + idsByColony <- base::split(ids, rep(seq_len(nCol), times = nInd)) + tasks <- lapply(seq_len(nCol), FUN = function(colony) { + list(queen = x@colonies[[colony]]@queen, nInd = nInd[colony], + ids = idsByColony[[colony]]) + }) + workerFUN <- function(task, simParamBee) { + queen <- task$queen + virginQueens <- combineBeeGametes( + queen = queen, + drones = getFathers(queen, simParamBee = simParamBee), + nProgeny = task$nInd, + simParamBee = simParamBee + ) + ret <- list(virginQueen = NULL, pedigree = NULL, recHist = NULL) + tmpIds <- virginQueens@id + if (simParamBee$isTrackPed) { + ret$pedigree <- simParamBee$pedigree[tmpIds, , drop = FALSE] + rownames(ret$pedigree) <- task$ids + } + if (simParamBee$isTrackRec) { + ret$recHist <- simParamBee$recHist[tmpIds] + names(ret$recHist) <- task$ids + } + virginQueens@id <- as.character(task$ids) + virginQueens@iid <- as.integer(task$ids) + virginQueens@sex[] <- "F" + if (isCsdActive(simParamBee = simParamBee)) { + virginQueens <- virginQueens[isCsdHeterozygous(pop = virginQueens, simParamBee = simParamBee)] + } + if (nInd(virginQueens) > 0) { + ret$virginQueen <- selectInd(virginQueens, nInd = 1, use = "rand", simParam = simParamBee) + } + ret + } + # Detach from this frame, otherwise future serialises the whole frame + # (including x and tasks) together with the function to every worker + environment(workerFUN) <- new.env(parent = topenv()) + res <- future_lapply(X = tasks, FUN = workerFUN, + simParamBee = simParamBee$slimClone(), + future.globals = list(), future.seed = TRUE) + rm(tasks) + addBeeRecords_internal( + simParamBee = simParamBee, ids = ids, caste = "virginQueens", + pedigree = do.call("rbind", lapply(res, FUN = "[[", "pedigree")), + recHist = do.call("c", lapply(res, FUN = "[[", "recHist")), + ploidy = 2L + ) + ret <- lapply(res, FUN = "[[", "virginQueen") + names(ret) <- getId(x) + return(ret) +} + +# Pull individuals of a caste from each colony in a MultiColony (as in swarm +# and split). Pulling is only sampling, so we do it here, colony by colony, +# rather than shipping colonies to parallel workers as pullCastePop() does. +# nInd is one value per colony. Returns the same list as pullCastePop(). +pullCastePopByColony_internal <- function(x, caste, nInd, simParamBee) { + nCol <- nColonies(x) + tmp <- lapply(seq_len(nCol), FUN = function(colony) { + pullCastePop(x = x@colonies[[colony]], caste = caste, + nInd = nInd[colony], simParamBee = simParamBee) + }) + ret <- list(pulled = lapply(tmp, FUN = "[[", "pulled"), remnant = x) + names(ret$pulled) <- getId(x) + ret$remnant@colonies <- lapply(tmp, FUN = "[[", "remnant") + return(ret) +} + #' @rdname combineBeeGametes #' @title Create diploid gametes from a mated queen #' @@ -1690,7 +1795,7 @@ cross <- function(x, # 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 = crossPlan[[x]][sample.int(length(crossPlan[[x]]), size = nD[which(x == IDs)], replace = TRUE)]) } )) crossPlanDF_sample <- crossPlanDF_sample[order(as.integer(crossPlanDF_sample$DPC)),] # Here I gather how many drones each DPC needs to produce diff --git a/R/Functions_L2_Colony.R b/R/Functions_L2_Colony.R index 5b262887..9ed6f0b2 100644 --- a/R/Functions_L2_Colony.R +++ b/R/Functions_L2_Colony.R @@ -176,13 +176,29 @@ reQueen <- function(x, queen, removeVirginQueens = TRUE, simParamBee = NULL) { } + # Look up castes in simParamBee once for all queens and then do the + # Colony-level reQueen for each colony without further look-ups + isMatedQueen <- isQueen(queen, simParamBee = simParamBee) x@colonies = lapply(X = seq_len(nCol), FUN = function(colony) { - reQueen( - x = x[[colony]], - queen = queen[colony], - simParamBee = simParamBee - ) + col <- x@colonies[[colony]] + if (!isColony(col)) { + stop("Argument x must be a Colony or MultiColony class object!") + } + # As in the Colony case, where removeQueen()/removeVirginQueens() stop + if (hasCollapsed(col) && (!isMatedQueen[colony] || removeVirginQueens)) { + stop(paste0("The colony ", getId(col), " collapsed, hence can not remove individuals from it!")) + } + if (isMatedQueen[colony]) { + col@queen <- queen[colony] + if (removeVirginQueens) { + col@virginQueens <- NULL + } + } else { # If it's a virgin queen + col@queen <- NULL + col@virginQueens <- queen[colony] + } + col }) } else { stop("Argument x must be a Colony or MultiColony class object!") @@ -385,18 +401,21 @@ addCastePop <- function(x, caste = NULL, nInd = NULL, new = FALSE, nInd(x) }) + # Modify each colony on its own (and not via x[[colony]]<-, which + # validates the whole MultiColony for every colony) x@colonies <- lapply(X = seq_len(nCol), FUN = function(colony) { + col <- x@colonies[[colony]] 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]]) + col@queen@misc$nWorkers[[1]] <- col@queen@misc$nWorkers[[1]] + nInds[[colony]] + col@queen@misc$nHomBrood[[1]] <- col@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]] + col@queen@misc$nDrones[[1]] <- col@queen@misc$nDrones[[1]] + nInds[[colony]] } - addCastePop_internal(colony = x[[colony]], pop = newInds[[colony]], caste = caste, new = new) + addCastePop_internal(colony = col, pop = newInds[[colony]], caste = caste, new = new) } else { - x[[colony]] + col } }) @@ -791,9 +810,12 @@ downsize <- function(x, p = NULL, use = "rand", new = FALSE, } 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 - } + x@colonies <- lapply(X = x@colonies, FUN = function(col) { + if (!is.null(col)) { + col@production <- FALSE + } + col + }) } else { stop("Argument x must be a Colony or MultiColony class object!") @@ -1054,34 +1076,43 @@ removeCastePop <- function(x, caste = NULL, p = 1, use = "rand", p <- p[1:nCol] } - # Pass each colony with its own p as an element of X, so that each - # worker receives only its chunk of colonies - tasks <- lapply(seq_len(nCol), FUN = function(colony) { - if (is.null(p)) { - pColony <- NULL - } else { - pColony <- ifelse(nP == 1, p, p[colony]) + if (!is.null(p) && all(p == 1)) { + # Removing all individuals of a caste does not need random numbers, + # so we do it in place rather than shipping colonies to workers + x@colonies <- lapply(X = x@colonies, FUN = function(col) { + removeCastePop(x = col, caste = caste, p = 1, + simParamBee = simParamBee) + }) + } else { + # Pass each colony with its own p as an element of X, so that each + # worker receives only its chunk of colonies + tasks <- lapply(seq_len(nCol), FUN = function(colony) { + if (is.null(p)) { + pColony <- NULL + } else { + pColony <- ifelse(nP == 1, p, p[colony]) + } + list(colony = x[[colony]], p = pColony) + }) + workerFUN <- function(task, caste, use, simParamBee) { + removeCastePop( + x = task$colony, caste = caste, + p = task$p, + use = use, + simParamBee = simParamBee + ) } - list(colony = x[[colony]], p = pColony) - }) - workerFUN <- function(task, caste, use, simParamBee) { - removeCastePop( - x = task$colony, caste = caste, - p = task$p, - use = use, - simParamBee = simParamBee - ) + # Detach from this frame, otherwise future serialises the whole frame + # (including x and tasks) together with the function to every worker. + # workerFUN gets everything via its arguments, so we also skip scanning + # the colonies in X for globals (future.globals = list()), which is slow + environment(workerFUN) <- new.env(parent = topenv()) + x@colonies <- future_lapply(X = tasks, FUN = workerFUN, + caste = caste, use = use, + simParamBee = simParamBee, + future.globals = list(), future.seed = TRUE) + rm(tasks) } - # Detach from this frame, otherwise future serialises the whole frame - # (including x and tasks) together with the function to every worker. - # workerFUN gets everything via its arguments, so we also skip scanning - # the colonies in X for globals (future.globals = list()), which is slow - environment(workerFUN) <- new.env(parent = topenv()) - x@colonies <- future_lapply(X = tasks, FUN = workerFUN, - caste = caste, use = use, - simParamBee = simParamBee, - future.globals = list(), future.seed = TRUE) - rm(tasks) } else { stop("Argument x must be a Colony or MultiColony class object!") @@ -1439,22 +1470,32 @@ swarm <- function(x, p = NULL, stop("Too few values in the p argument!") } } + if (is.function(simParamBee$nVirginQueens)) { + nVirginQueens <- simParamBee$nVirginQueens(x, ...) + } else { + nVirginQueens <- simParamBee$nVirginQueens + } 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 - tmpVirginQueens <- createCastePop( - x = x, nInd = max(10, simParamBee$nVirginQueens), - caste = "virginQueens", - simParamBee = simParamBee - ) - if (isColony(x)) { + tmpVirginQueens <- createCastePop( + x = x, nInd = pmax(10, nVirginQueens), + caste = "virginQueens", + simParamBee = simParamBee + ) homCol = nInd(tmpVirginQueens) == 0 } else if (isMultiColony(x)) { - homCol = lapply(tmpVirginQueens, nInd) == 0 + # Parallel workers create the virgin queens and return only the one that + # prevails in each colony (NULL if all were csd homozygous) + tmpVirginQueens <- createPrevailingVirginQueens_internal( + x = x, nInd = pmax(10, nVirginQueens), + simParamBee = simParamBee + ) + homCol = sapply(tmpVirginQueens, FUN = is.null) } if (sum(homCol) > 0) { @@ -1464,14 +1505,19 @@ swarm <- function(x, p = NULL, 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) + if (isColony(x)) { + tmp <- pullCastePop(x = x, caste = "workers", + nInd = nWorkersSwarm, simParamBee = simParamBee) + } else { + tmp <- pullCastePopByColony_internal(x = x, caste = "workers", + nInd = nWorkersSwarm, + simParamBee = simParamBee) + } remnantColony <- tmp$remnant remnantColony <- removeQueen(remnantColony, simParamBee = simParamBee) if (isColony(x)) { @@ -1479,16 +1525,20 @@ swarm <- function(x, p = NULL, queen = selectInd(tmpVirginQueens, nInd = 1, use = "rand", simParam = simParamBee), simParamBee = simParamBee) } else { - tmpVirginQueens <- lapply(tmpVirginQueens, FUN = function(x) selectInd(x, nInd = 1, use = "rand", simParam = simParamBee)) remnantColony <- reQueen(remnantColony, queen = mergePops(tmpVirginQueens), simParamBee = simParamBee) } currentLocation <- getLocation(x) + if (isColony(x)) { + # A list as for MultiColony, so that currentLocation[[1]] is c(x, y) + currentLocation <- list(currentLocation) + } 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 + # Sample all deviations at once (not nCol samples for each colony) + deviation <- rcircle(n = nCol, radius = radius) + newLocation <- lapply(1:nCol, function(x) currentLocation[[x]] + deviation[x, ]) } else { newLocation <- currentLocation } @@ -1501,7 +1551,7 @@ swarm <- function(x, p = NULL, swarmColony@workers <- tmp$pulled swarmColony <- setLocation(x = swarmColony, location = newLocation[[1]], simParamBee = simParamBee) - remnantColony <- setLocation(x = remnantColony, location = currentLocation, simParamBee = simParamBee) + remnantColony <- setLocation(x = remnantColony, location = currentLocation[[1]], simParamBee = simParamBee) remnantColony@swarm <- TRUE swarmColony@swarm <- TRUE @@ -1520,6 +1570,7 @@ swarm <- function(x, p = NULL, simParamBee = simParamBee), remnant = remnantColony ) + ret$swarm <- setLocation(x = ret$swarm, location = newLocation, simParamBee = simParamBee) ret$swarm@colonies <- lapply(X = seq_len(nCol), FUN = function(colony) { addCastePop_internal(colony = ret$swarm@colonies[[colony]], @@ -1551,8 +1602,9 @@ swarm <- function(x, p = NULL, #' queen dies. The workers and drones stay unchanged, but 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 +#' whichever is higher, and select one at random. If there are any virgin queens already +#' present in the colony, those will not be considered as candidates. 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}} @@ -1602,19 +1654,6 @@ supersede <- function(x, simParamBee = NULL, ...) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } - if (isColony(x)) { - parallel <- FALSE - } else if (isMultiColony(x)) { - parallel <- TRUE - } - if (is.null(nVirginQueens)) { - nVirginQueens <- simParamBee$nVirginQueens - } - if (is.function(simParamBee$nVirginQueens)) { - nVirginQueens <- nVirginQueens(x, ...) - } else { - nVirginQueens <- simParamBee$nVirginQueens - } if (any(hasCollapsed(x))) { stop(paste0("One of the collonies is collapsed, hence you can not split it!")) @@ -1622,28 +1661,36 @@ supersede <- function(x, simParamBee = NULL, ...) { if (any(!isQueenPresent(x, simParamBee = simParamBee))) { stop("No queen present in one of the colonies!") } - if (is.function(nVirginQueens)) { - nVirginQueens <- nVirginQueens(x, simParamBee = simParamBee, ...) + + if (is.function(simParamBee$nVirginQueens)) { + nVirginQueens <- simParamBee$nVirginQueens(x, ...) + } else { + nVirginQueens <- simParamBee$nVirginQueens } - # Do this because some colonies might not produce a viable virgin queen - tmpVirginQueens <- createCastePop( - x = x, nInd = max(10, nVirginQueens), - caste = "virginQueens", - simParamBee = simParamBee - ) + # Do this because some colonies might not produce a viable virgin queen if (isColony(x)) { + tmpVirginQueens <- createCastePop( + x = x, nInd = pmax(10, nVirginQueens), + caste = "virginQueens", + simParamBee = simParamBee + ) homCol = nInd(tmpVirginQueens) == 0 } else if (isMultiColony(x)) { - homCol = sapply(tmpVirginQueens, nInd) == 0 + # Parallel workers create the virgin queens and return only the one that + # prevails in each colony (NULL if all were csd homozygous) + # This is done so that the full colonies are not sent to workers - only the queen + tmpVirginQueens <- createPrevailingVirginQueens_internal( + x = x, nInd = pmax(10, nVirginQueens), + simParamBee = simParamBee + ) + homCol = sapply(tmpVirginQueens, FUN = is.null) } if (sum(homCol) > 0) { if (isColony(x)) { - print("X is colony") - print(class(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] @@ -1653,10 +1700,10 @@ supersede <- function(x, simParamBee = NULL, ...) { } if (isColony(x)) { - if (!parallel) { - x <- addCastePop_internal(selectInd(tmpVirginQueens, nInd = 1, use = "rand", simParam = simParamBee), - 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 # aggressive one), by creating many virgin queens and then picking the @@ -1668,10 +1715,8 @@ 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", simParam = simParamBee)) - x@colonies <- lapply(X = seq_len(nColonies(x)), FUN = function(colony) { - addCastePop_internal(colony = removeQueen(x[[colony]], simParamBee = simParamBee), + addCastePop_internal(colony = removeQueen(x@colonies[[colony]], simParamBee = simParamBee), pop = tmpVirginQueens[[colony]], caste = "virginQueens") }) x = setEvents(x, slot = "supersedure", value = TRUE, simParamBee = simParamBee) @@ -1796,7 +1841,13 @@ split <- function(x, p = NULL, simParamBee = 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) + if (isColony(x)) { + tmp <- pullCastePop(x = x, caste = "workers", nInd = nWorkersSplit, simParamBee = simParamBee) + } else { + tmp <- pullCastePopByColony_internal(x = x, caste = "workers", + nInd = nWorkersSplit, + simParamBee = simParamBee) + } remnantColony <- tmp$remnant if (isColony(x)) { @@ -1835,15 +1886,21 @@ split <- function(x, p = NULL, simParamBee = NULL, ...) { ) ret$split <- setLocation(x = ret$split, location = location, simParamBee = simParamBee) + # Add workers and set events in one pass over the colonies (and not via + # setEvents(), which goes through all colonies for every event) ret$split@colonies <- lapply(X = seq_len(nCol), FUN = function(colony) { - addCastePop_internal(colony = ret$split@colonies[[colony]], - pop = tmp$pulled[[colony]], caste = "workers") + col <- addCastePop_internal(colony = ret$split@colonies[[colony]], + pop = tmp$pulled[[colony]], caste = "workers") + col@split <- TRUE + col@production <- FALSE + col + }) + ret$remnant@colonies <- lapply(X = ret$remnant@colonies, FUN = function(col) { + col@split <- TRUE + col@production <- TRUE + col }) - 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 { @@ -2097,11 +2154,14 @@ setLocation <- function(x, location = c(0, 0), simParamBee = NULL) { loc <- location } - if (!is.null(x[[colony]])) { - x[[colony]]@location <- loc + # Modify the colony on its own (and not via x[[colony]]<-, which + # validates the whole MultiColony for every colony) + col <- x@colonies[[colony]] + if (!is.null(col)) { + col@location <- loc } - x[[colony]] + col }) } else { stop("Argument x must be a Colony or MultiColony class object!") diff --git a/tests/testthat/test-L1_pop_functions.R b/tests/testthat/test-L1_pop_functions.R index dc31682e..6d9ae8c7 100644 --- a/tests/testthat/test-L1_pop_functions.R +++ b/tests/testthat/test-L1_pop_functions.R @@ -394,3 +394,83 @@ test_that("combineBeeGametesHaploidDiploid", { expect_equal(drones@ploidy, 1) }) + +# ---- cross with a single drone producing colony ---- + +test_that("cross samples drones only from the drone producing colonies in the cross plan", { + founderGenomes <- quickHaplo(nInd = 12, nChr = 1, segSites = 100) + SP <- SimParamBee$new(founderGenomes, csdChr = NULL) + SP$nThreads <- 1L + SP$setTrackPed(TRUE) + SP$nWorkers <- 10 + SP$nDrones <- 10 + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) + drones <- createDrones(basePop[1:2], nInd = 50, simParamBee = SP) + queens <- cross(basePop[3:8], drones = drones, crossPlan = "create", + nDrones = 5, simParamBee = SP) + apiary <- buildUp(createMultiColony(queens, simParamBee = SP), simParamBee = SP) + virginColonies <- createMultiColony(basePop[9:12], simParamBee = SP) + + # A single drone producing colony with an ID > 1, so that sample(ID) would + # sample from 1:ID + dpc <- apiary[6] + dpcQueenId <- getCasteId(dpc, caste = "queen", collapse = TRUE, simParamBee = SP) + set.seed(1) + mated <- cross(virginColonies, droneColonies = dpc, nDrones = 10, + crossPlan = "create", simParamBee = SP) + expect_equal(nColonies(mated), 4) + fatherIds <- getCasteId(mated, caste = "fathers", collapse = TRUE, simParamBee = SP) + expect_true(all(SP$pedigree[fatherIds, "mother"] == as.integer(dpcQueenId))) + + # A given cross plan with one drone producing colony per virgin queen + virginColonies <- createMultiColony(mergePops(createVirginQueens(apiary[1:4], nInd = 1, + simParamBee = SP)), + simParamBee = SP) + dpcs <- apiary[5:6] + crossPlan <- as.list(rep(getId(dpcs)[2], nColonies(virginColonies))) + names(crossPlan) <- getId(virginColonies) + mated <- cross(virginColonies, droneColonies = dpcs, nDrones = 10, + crossPlan = crossPlan, simParamBee = SP) + fatherIds <- getCasteId(mated, caste = "fathers", collapse = TRUE, simParamBee = SP) + expect_true(all(SP$pedigree[fatherIds, "mother"] == as.integer(dpcQueenId))) +}) + +# ---- createCastePop records for MultiColony ---- + +test_that("createCastePop on a MultiColony records all new individuals in SimParamBee", { + founderGenomes <- quickHaplo(nInd = 12, nChr = 2, segSites = 100) + SP <- SimParamBee$new(founderGenomes, csdChr = 1, nCsdAlleles = 8) + SP$nThreads <- 1L + SP$setTrackPed(TRUE) + SP$setTrackRec(TRUE) + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) + drones <- createDrones(basePop[1:2], nInd = 50, simParamBee = SP) + queens <- cross(basePop[3:6], drones = drones, crossPlan = "create", + nDrones = 5, simParamBee = SP) + apiary <- createMultiColony(queens, simParamBee = SP) + apiary <- buildUp(apiary, nWorkers = 10, nDrones = 5, simParamBee = SP) + queenIds <- getCasteId(apiary, caste = "queen", collapse = TRUE, simParamBee = SP) + nInd <- c(3, 1, 4, 2) + + for (caste in c("workers", "drones", "virginQueens")) { + lastId <- SP$lastId + newApiary <- addCastePop(apiary, caste = caste, nInd = nInd, simParamBee = SP) + newIds <- as.character((lastId + 1):(lastId + sum(nInd))) + expect_equal(SP$lastId, lastId + sum(nInd)) + expect_true(all(SP$caste[newIds] == caste)) + expect_equal(rownames(SP$pedigree)[(lastId + 1):SP$lastId], newIds) + expect_equal(unname(SP$pedigree[newIds, "mother"]), + rep(as.integer(queenIds), times = nInd)) + expect_false(any(sapply(SP$recHist[newIds], is.null))) + for (colony in seq_len(nColonies(apiary))) { + # Existing individuals are kept and the new ones come from the right + # queen (csd homozygous workers and virgin queens are not added) + oldIds <- getCasteId(apiary[[colony]], caste = caste, simParamBee = SP) + ids <- getCasteId(newApiary[[colony]], caste = caste, simParamBee = SP) + expect_true(all(oldIds %in% ids)) + added <- setdiff(ids, oldIds) + expect_true(all(added %in% newIds)) + expect_true(all(SP$pedigree[added, "mother"] == as.integer(queenIds[colony]))) + } + } +}) diff --git a/tests/testthat/test-L2_colony_functions.R b/tests/testthat/test-L2_colony_functions.R index 7154f39e..94057e08 100644 --- a/tests/testthat/test-L2_colony_functions.R +++ b/tests/testthat/test-L2_colony_functions.R @@ -548,3 +548,72 @@ test_that("collapse", { }) + +# ---- swarm locations ---- + +test_that("swarm samples swarm locations around the parent colony", { + founderGenomes <- quickHaplo(nInd = 10, nChr = 1, segSites = 100) + SP <- SimParamBee$new(founderGenomes, csdChr = NULL) + SP$nThreads <- 1L + SP$nWorkers <- 20 + SP$nDrones <- 5 + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) + drones <- createDrones(basePop[1], nInd = 50, simParamBee = SP) + queens <- cross(basePop[2:5], drones = drones, crossPlan = "create", + nDrones = 5, simParamBee = SP) + locations <- list(c(100, -500), c(-300, 200), c(1000, 1000), c(0, 50)) + radius <- 1 + + colony <- buildUp(createColony(queens[1], simParamBee = SP), simParamBee = SP) + colony <- setLocation(colony, location = locations[[1]], simParamBee = SP) + tmp <- swarm(colony, radius = radius, simParamBee = SP) + expect_equal(getLocation(tmp$remnant), locations[[1]]) + expect_true(sqrt(sum((getLocation(tmp$swarm) - locations[[1]])^2)) <= radius) + + apiary <- buildUp(createMultiColony(queens, simParamBee = SP), simParamBee = SP) + apiary <- setLocation(apiary, location = locations, simParamBee = SP) + tmp <- swarm(apiary, radius = radius, simParamBee = SP) + expect_equal(unname(getLocation(tmp$remnant)), locations) + swarmLocations <- getLocation(tmp$swarm) + for (colony in seq_along(locations)) { + expect_true(sqrt(sum((swarmLocations[[colony]] - locations[[colony]])^2)) <= radius) + } + + tmp <- swarm(apiary, sampleLocation = FALSE, simParamBee = SP) + expect_equal(unname(getLocation(tmp$swarm)), locations) +}) + +# ---- split MultiColony ---- + +test_that("split moves workers from each colony to its split", { + founderGenomes <- quickHaplo(nInd = 10, nChr = 1, segSites = 100) + SP <- SimParamBee$new(founderGenomes, csdChr = NULL) + SP$nThreads <- 1L + SP$nDrones <- 5 + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) + drones <- createDrones(basePop[1], nInd = 50, simParamBee = SP) + queens <- cross(basePop[2:5], drones = drones, crossPlan = "create", + nDrones = 5, simParamBee = SP) + locations <- list(c(100, -500), c(-300, 200), c(1000, 1000), c(0, 50)) + apiary <- createMultiColony(queens, simParamBee = SP) + apiary <- buildUp(apiary, nWorkers = 20, simParamBee = SP) + apiary <- setLocation(apiary, location = locations, simParamBee = SP) + p <- c(0.1, 0.25, 0.5, 1) + + tmp <- split(apiary, p = p, simParamBee = SP) + expect_equal(unname(nWorkers(tmp$split, simParamBee = SP)), 20 * p) + expect_equal(unname(nWorkers(tmp$remnant, simParamBee = SP)), 20 * (1 - p)) + for (colony in seq_len(nColonies(apiary))) { + splitIds <- getId(getWorkers(tmp$split[[colony]], simParamBee = SP)) + remnantIds <- getId(getWorkers(tmp$remnant[[colony]], simParamBee = SP)) + expect_length(intersect(splitIds, remnantIds), 0) + expect_setequal(c(splitIds, remnantIds), + getId(getWorkers(apiary[[colony]], simParamBee = SP))) + } + expect_equal(getId(tmp$remnant), getId(apiary)) + expect_true(all(!isQueenPresent(tmp$split, simParamBee = SP))) + expect_equal(unname(getLocation(tmp$split)), locations) + expect_equal(unname(getLocation(tmp$remnant)), locations) + expect_true(all(hasSplit(tmp$split)) && all(hasSplit(tmp$remnant))) + expect_true(all(!isProductive(tmp$split)) && all(isProductive(tmp$remnant))) +}) diff --git a/tests/testthat/test-parallel_future.R b/tests/testthat/test-parallel_future.R new file mode 100644 index 00000000..a9999091 --- /dev/null +++ b/tests/testthat/test-parallel_future.R @@ -0,0 +1,262 @@ +# ---- Parallel (future) execution of MultiColony operations ---- + +runMultiColonyOps <- function(csdChr) { + set.seed(42) + founderGenomes <- quickHaplo(nInd = 20, nChr = 2, segSites = 100) + SP <- SimParamBee$new(founderGenomes, csdChr = csdChr, nCsdAlleles = 8) + SP$nThreads <- 1L + SP$setTrackPed(TRUE) + SP$nWorkers <- 20 + SP$nDrones <- 5 + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) + drones <- createDrones(basePop[1:4], nInd = 30, simParamBee = SP) + queens <- cross(basePop[5:12], drones = drones, crossPlan = "create", + nDrones = 5, simParamBee = SP) + apiary <- createMultiColony(queens, simParamBee = SP) + apiary <- buildUp(apiary, simParamBee = SP) + ret <- list() + ret$buildUp <- apiary + ret$pulled <- pullCastePop(apiary, caste = "workers", nInd = 3, simParamBee = SP) + ret$removed <- removeWorkers(apiary, p = 0.5, simParamBee = SP) + ret$swarm <- swarm(apiary[1:3], simParamBee = SP) + ret$supersede <- supersede(apiary[4:5], simParamBee = SP) + ret$split <- split(apiary[6:8], simParamBee = SP) + ret$crossed <- cross(ret$supersede, droneColonies = ret$split$remnant, + nDrones = 3, crossPlan = "create", simParamBee = SP) + ret$lastId <- SP$lastId + ret$lastColonyId <- SP$lastColonyId + ret$pedigree <- SP$pedigree + ret$caste <- SP$caste + ret +} + +test_that("MultiColony operations give the same seeded results with sequential and multisession futures", { + skip_on_cran() + # Multisession workers load the installed SIMplyBee, which under + # devtools::load_all() is not the code under test + skip_if(pkgload::is_dev_package("SIMplyBee"), + "SIMplyBee is loaded with load_all(); run via R CMD check") + oplan <- future::plan() + oopts <- options(future.rng.onMisuse = "error") + on.exit({ + future::plan(oplan) + options(oopts) + }, add = TRUE) + + for (csdChr in list(NULL, 1)) { + future::plan(future::sequential) + seqRes <- runMultiColonyOps(csdChr) + future::plan(future::multisession, workers = 2) + parRes <- runMultiColonyOps(csdChr) + compare <- names(seqRes) + if (!is.null(csdChr)) { + # With csd, sequential and multisession record different castes for the + # discarded homozygous brood, which is not part of any population + compare <- setdiff(compare, "caste") + } + for (n in compare) { + expect_identical(parRes[[n]], seqRes[[n]], label = paste0(n, " (csdChr = ", format(csdChr), ")")) + } + } +}) + +test_that("createCastePop on MultiColony keeps simParamBee bookkeeping consistent with sequential futures", { + oplan <- future::plan(future::sequential) + on.exit(future::plan(oplan), add = TRUE) + founderGenomes <- quickHaplo(nInd = 10, nChr = 1, segSites = 100) + SP <- SimParamBee$new(founderGenomes, csdChr = NULL) + SP$nThreads <- 1L + SP$setTrackPed(TRUE) + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) + drones <- createDrones(basePop[1:2], nInd = 20, simParamBee = SP) + queens <- cross(basePop[3:6], drones = drones, crossPlan = "create", + nDrones = 5, simParamBee = SP) + + lastColonyId <- SP$lastColonyId + apiary <- createMultiColony(queens, simParamBee = SP) + # Each colony gets exactly one new ID + expect_equal(SP$lastColonyId, lastColonyId + 4) + expect_equal(getId(apiary), lastColonyId + 1:4) + + apiary <- addWorkers(apiary, nInd = c(3, 1, 5, 2), simParamBee = SP) + apiary <- addVirginQueens(apiary, nInd = 2, simParamBee = SP) + # One caste record per individual, matching the pedigree + expect_false(anyDuplicated(names(SP$caste)) > 0) + expect_identical(length(SP$caste), as.integer(SP$lastId)) + expect_identical(nrow(SP$pedigree), as.integer(SP$lastId)) + expect_true(all(SP$caste[getCasteId(apiary, caste = "workers", collapse = TRUE, simParamBee = SP)] == "workers")) + expect_true(all(SP$caste[getCasteId(apiary, caste = "virginQueens", collapse = TRUE, simParamBee = SP)] == "virginQueens")) + expect_equal(unname(nWorkers(apiary, simParamBee = SP)), c(3, 1, 5, 2)) +}) + +test_that("swarm on MultiColony keeps simParamBee records and colonies consistent", { + oplan <- future::plan(future::sequential) + on.exit(future::plan(oplan), add = TRUE) + for (csdChr in list(NULL, 1)) { + set.seed(7) + founderGenomes <- quickHaplo(nInd = 30, nChr = 2, segSites = 100) + SP <- SimParamBee$new(founderGenomes, csdChr = csdChr, nCsdAlleles = 16) + SP$nThreads <- 1L + SP$setTrackPed(TRUE) + SP$setTrackRec(TRUE) + SP$nWorkers <- 20 + SP$nDrones <- 5 + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) + drones <- createDrones(basePop[1:5], nInd = 30, simParamBee = SP) + queens <- cross(basePop[6:15], drones = drones, crossPlan = "create", + nDrones = 8, simParamBee = SP) + apiary <- buildUp(createMultiColony(queens, simParamBee = SP), simParamBee = SP) + oldQueens <- getCasteId(apiary, caste = "queen", collapse = TRUE, simParamBee = SP) + lastId <- SP$lastId + + tmp <- swarm(apiary, simParamBee = SP) + + # Records of all created virgin queens (also the ones that did not prevail) + expect_equal(SP$lastId, lastId + nColonies(apiary) * max(10, SP$nVirginQueens)) + expect_identical(nrow(SP$pedigree), as.integer(SP$lastId)) + expect_identical(length(SP$recHist), as.integer(SP$lastId)) + expect_identical(length(SP$caste), as.integer(SP$lastId)) + expect_identical(rownames(SP$pedigree), as.character(seq_len(SP$lastId))) + expect_identical(names(SP$recHist), as.character(seq_len(SP$lastId))) + newIds <- as.character((lastId + 1):SP$lastId) + expect_true(all(SP$caste[newIds] == "virginQueens")) + + # Remnants have one virgin queen from their old queen, swarms the old queen + expect_identical(getId(tmp$remnant), getId(apiary)) + expect_false(any(isQueenPresent(tmp$remnant, simParamBee = SP))) + expect_true(all(nVirginQueens(tmp$remnant, simParamBee = SP) == 1)) + virginQueens <- getCasteId(tmp$remnant, caste = "virginQueens", collapse = TRUE, simParamBee = SP) + expect_true(all(virginQueens %in% newIds)) + expect_equal(unname(SP$pedigree[virginQueens, "mother"]), as.integer(oldQueens)) + if (!is.null(csdChr)) { + expect_true(all(isCsdHeterozygous(mergePops(getVirginQueens(tmp$remnant, simParamBee = SP)), + simParamBee = SP))) + } + expect_identical(unname(getCasteId(tmp$swarm, caste = "queen", collapse = TRUE, simParamBee = SP)), + unname(oldQueens)) + # Workers are split between the swarm and the remnant + expect_equal(unname(nWorkers(tmp$swarm, simParamBee = SP) + nWorkers(tmp$remnant, simParamBee = SP)), + unname(nWorkers(apiary, simParamBee = SP))) + expect_false(any(getCasteId(tmp$swarm, caste = "workers", collapse = TRUE, simParamBee = SP) %in% + getCasteId(tmp$remnant, caste = "workers", collapse = TRUE, simParamBee = SP))) + } +}) + +test_that("SimParamBee$slimClone() drops individual records but can create individuals", { + founderGenomes <- quickHaplo(nInd = 20, nChr = 1, segSites = 100) + SP <- SimParamBee$new(founderGenomes, csdChr = NULL) + SP$nThreads <- 1L + SP$setTrackPed(TRUE) + SP$setTrackRec(TRUE) + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) + drones <- createDrones(basePop[1:2], nInd = 50, simParamBee = SP) + queen <- cross(basePop[3], drones = drones, simParamBee = SP) + before <- list(SP$lastId, SP$pedigree, SP$recHist, SP$caste) + + slim <- SP$slimClone() + expect_equal(nrow(slim$pedigree), 0) + expect_length(slim$recHist, 0) + expect_length(slim$caste, 0) + expect_null(slim$founderPop) + expect_identical(slim$lastId, SP$lastId) + # The copy does not grow with the records (and does not enclose the original + # object, which would serialise them too) + sizeSP <- length(serialize(SP, NULL)) + sizeSlim <- length(serialize(slim, NULL)) + moreDrones <- createDrones(basePop[4:10], nInd = 1000, simParamBee = SP) + expect_gt(length(serialize(SP, NULL)), 1.5 * sizeSP) + expect_lt(length(serialize(SP$slimClone(), NULL)), 1.05 * sizeSlim) + before <- list(SP$lastId, SP$pedigree, SP$recHist, SP$caste) + + offspring <- SIMplyBee:::combineBeeGametes(queen = queen, drones = getFathers(queen, simParamBee = slim), + nProgeny = 3, simParamBee = slim) + expect_equal(nInd(offspring), 3) + expect_equal(nrow(slim$pedigree), 3) + # The original is unchanged + expect_identical(list(SP$lastId, SP$pedigree, SP$recHist, SP$caste), before) +}) + +test_that("supersede on MultiColony keeps simParamBee records and colonies consistent", { + oplan <- future::plan(future::sequential) + on.exit(future::plan(oplan), add = TRUE) + for (csdChr in list(NULL, 1)) { + set.seed(8) + founderGenomes <- quickHaplo(nInd = 30, nChr = 2, segSites = 100) + SP <- SimParamBee$new(founderGenomes, csdChr = csdChr, nCsdAlleles = 16) + SP$nThreads <- 1L + SP$setTrackPed(TRUE) + SP$setTrackRec(TRUE) + SP$nWorkers <- 20 + SP$nDrones <- 5 + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) + drones <- createDrones(basePop[1:5], nInd = 30, simParamBee = SP) + queens <- cross(basePop[6:15], drones = drones, crossPlan = "create", + nDrones = 8, simParamBee = SP) + apiary <- buildUp(createMultiColony(queens, simParamBee = SP), simParamBee = SP) + oldQueens <- getCasteId(apiary, caste = "queen", collapse = TRUE, simParamBee = SP) + lastId <- SP$lastId + + superseded <- supersede(apiary, simParamBee = SP) + + expect_equal(SP$lastId, lastId + nColonies(apiary) * max(10, SP$nVirginQueens)) + expect_identical(nrow(SP$pedigree), as.integer(SP$lastId)) + expect_identical(length(SP$recHist), as.integer(SP$lastId)) + expect_identical(length(SP$caste), as.integer(SP$lastId)) + expect_identical(rownames(SP$pedigree), as.character(seq_len(SP$lastId))) + newIds <- as.character((lastId + 1):SP$lastId) + expect_true(all(SP$caste[newIds] == "virginQueens")) + + expect_identical(getId(superseded), getId(apiary)) + expect_true(all(hasSuperseded(superseded))) + expect_false(any(isQueenPresent(superseded, simParamBee = SP))) + expect_true(all(nVirginQueens(superseded, simParamBee = SP) == 1)) + virginQueens <- getCasteId(superseded, caste = "virginQueens", collapse = TRUE, simParamBee = SP) + expect_true(all(virginQueens %in% newIds)) + expect_equal(unname(SP$pedigree[virginQueens, "mother"]), as.integer(oldQueens)) + if (!is.null(csdChr)) { + expect_true(all(isCsdHeterozygous(mergePops(getVirginQueens(superseded, simParamBee = SP)), + simParamBee = SP))) + } + # Workers and drones stay + for (caste in c("workers", "drones")) { + expect_identical(lapply(superseded@colonies, function(colony) slot(colony, caste)@id), + lapply(apiary@colonies, function(colony) slot(colony, caste)@id)) + } + } +}) + +test_that("createPrevailingVirginQueens_internal handles one or several nInd values", { + oplan <- future::plan(future::sequential) + on.exit(future::plan(oplan), add = TRUE) + founderGenomes <- quickHaplo(nInd = 12, nChr = 1, segSites = 100) + SP <- SimParamBee$new(founderGenomes, csdChr = NULL) + SP$nThreads <- 1L + SP$setTrackPed(TRUE) + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) + drones <- createDrones(basePop[1:2], nInd = 30, simParamBee = SP) + queens <- cross(basePop[3:5], drones = drones, crossPlan = "create", + nDrones = 5, simParamBee = SP) + apiary <- createMultiColony(queens, simParamBee = SP) + createVQ <- SIMplyBee:::createPrevailingVirginQueens_internal + + lastId <- SP$lastId + nInd <- c(2, 5, 3) + virginQueens <- createVQ(apiary, nInd = nInd, simParamBee = SP) + expect_equal(SP$lastId, lastId + sum(nInd)) + expect_identical(names(virginQueens), as.character(getId(apiary))) + # Each colony's virgin queen comes from its own block of IDs and its queen + idBlocks <- base::split(as.character(lastId + seq_len(sum(nInd))), rep(1:3, nInd)) + for (colony in 1:3) { + expect_equal(nInd(virginQueens[[colony]]), 1) + expect_true(virginQueens[[colony]]@id %in% idBlocks[[colony]]) + expect_equal(unname(SP$pedigree[virginQueens[[colony]]@id, "mother"]), + as.integer(apiary@colonies[[colony]]@queen@id)) + } + expect_true(all(SP$caste[unlist(idBlocks)] == "virginQueens")) + + lastId <- SP$lastId + virginQueens <- createVQ(apiary, nInd = 4, simParamBee = SP) + expect_equal(SP$lastId, lastId + 3 * 4) + expect_error(createVQ(apiary, nInd = c(1, 2), simParamBee = SP)) + expect_error(createVQ(apiary, nInd = c(1, 0, 2), simParamBee = SP)) +}) From 48b73a0e8d6cf6394db0b05a1de86df4feac025e Mon Sep 17 00:00:00 2001 From: janaobsteter Date: Wed, 14 Oct 2026 18:03:20 +0000 Subject: [PATCH 89/98] Update documentation --- man/SimParamBee.Rd | 25 +++++++++++++++++++++++++ man/supersede.Rd | 5 +++-- 2 files changed, 28 insertions(+), 2 deletions(-) diff --git a/man/SimParamBee.Rd b/man/SimParamBee.Rd index 555e3730..87f7fe48 100644 --- a/man/SimParamBee.Rd +++ b/man/SimParamBee.Rd @@ -322,6 +322,7 @@ generate this object} \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-slimClone}{\code{SimParamBee$slimClone()}} \item \href{#method-SimParamBee-clone}{\code{SimParamBee$clone()}} } } @@ -627,6 +628,30 @@ SP$caste } } +\if{html}{\out{
    }} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-SimParamBee-slimClone}{}}} +\subsection{\code{SimParamBee$slimClone()}}{ + A copy of the simulation parameters for parallel workers, + without the records of all individuals created so far (pedigree, + recombination history, and caste), which can be large. Workers use + it to create new individuals and return their records, which are then + added to the original object. For internal use in SIMplyBee only. + \subsection{Usage}{ + \if{html}{\out{
    }} + \preformatted{SimParamBee$slimClone(casteIds = NULL)} + \if{html}{\out{
    }} + } + \subsection{Arguments}{ + \if{html}{\out{
    }} + \describe{ + \item{\code{casteIds}}{character, IDs of individuals whose caste records to +keep} + } + \if{html}{\out{
    }} + } +} + \if{html}{\out{
    }} \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-SimParamBee-clone}{}}} diff --git a/man/supersede.Rd b/man/supersede.Rd index bc1de781..23057009 100644 --- a/man/supersede.Rd +++ b/man/supersede.Rd @@ -24,8 +24,9 @@ Level 2 function that supersedes a Colony or MultiColony object - queen dies. The workers and drones stay unchanged, but 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 + whichever is higher, and select one at random. If there are any virgin queens already + present in the colony, those will not be considered as candidates. 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{ From 50133702a7e32cb9353339b2849ed055f654c180 Mon Sep 17 00:00:00 2001 From: janaobsteter Date: Mon, 26 Oct 2026 11:29:42 +0000 Subject: [PATCH 90/98] Update documentation --- DESCRIPTION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index a14caee2..0016bbdb 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -39,5 +39,5 @@ Suggests: Config/testthat/edition: 3 Config/Needs/website: tidyverse/tidytemplate VignetteBuilder: knitr -Config/roxygen2/version: 8.1.0 +Config/roxygen2/version: 8.1.1 RdMacros: Rdpack From 5f4e4f56f36d88a2dccc6d3bef421f9e1cf76441 Mon Sep 17 00:00:00 2001 From: janaobsteter Date: Mon, 26 Oct 2026 12:34:59 +0100 Subject: [PATCH 91/98] Local changes on duplication of IDs befre pull --- .Rbuildignore | 3 + AGENTS.md | 309 +++++++++----- R/Functions_L1_Pop.R | 4 +- R/Functions_L2_Colony.R | 2 +- R/Functions_L3_Colonies.R | 19 +- TestingVarianceComponents.R | 397 ------------------ man/SIMplyBee-package.Rd | 1 - .../F2_Variance_calculations_functions.Rmd | 2 +- vignettes/colony_variance_theory_plan.md | 364 ---------------- vignettes/scripts/variance_functions.R | 135 ------ 10 files changed, 227 insertions(+), 1009 deletions(-) delete mode 100644 TestingVarianceComponents.R delete mode 100644 vignettes/colony_variance_theory_plan.md delete mode 100644 vignettes/scripts/variance_functions.R diff --git a/.Rbuildignore b/.Rbuildignore index 679a4f13..c54311bb 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -24,4 +24,7 @@ ^vignettes/SIMplyBee\_logo\_small\.png ^Meta$ ^SIMplyBee\.Rproj +^Testing*.R +AGENTS.md +^doc$ diff --git a/AGENTS.md b/AGENTS.md index fd44b0ac..85b4debb 100644 --- a/AGENTS.md +++ b/AGENTS.md @@ -3,7 +3,75 @@ ## 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. +SIMplyBee aims to provide an easy to use simulation platform +to simulate honeybee breeding programmes by building upon the AlphaSimR packages while following +honeybee biology, to mimick real life mechanisms and populations. +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. + +## Package map + +* `R/Class-SimParamBee.R`: R6 simulation parameters extending AlphaSimR's + `SimParam`; holds shared simulation settings and bookkeeping. +* `R/Class-Colony.R`: S4 colony holding the queen, virgin queens, workers, + drones, colony state, and metadata. +* `R/Class-MultiColony.R`: list-like collection of colonies, including + subsetting and replacement methods. +* `R/Functions_L0_auxilary.R`: auxiliary functions (the filename spelling is + intentional here); `Functions_L1_Pop.R`, `Functions_L2_Colony.R`, and + `Functions_L3_Colonies.R` respectively provide population, colony, and + multicolony operations. +* `src/`: compiled helpers to speed up operations. +* `tests/testthat/` unit tests. +* `vignettes`: longer form documentation. +* `docs`: pkgdown output. + +## Scientific invariants and shared state + +* Seeded results are part of observable behavior. Reordering random operations, + batching crosses, or changing parallel execution can change results even when + their distributions remain correct. Assess these effects explicitly and record + intentional user-visible changes in `NEWS.md`. +* Running the same seed twice in a modified implementation checks repeatability, + not compatibility with the previous implementation. For changes that should + preserve seeded results, compare against the previous implementation under + the same R and dependency versions using a small representative regression case. +* Test thread-count independence where the supported implementation promises it. + Review RNG handling when changing `future.apply` paths, including `future.seed`; + do not assume worker-count, scheduling, and sequential/parallel equivalence + without checking the relevant path. +* `SimParamBee` has R6 reference semantics: changing a field affects the caller. + Do not silently overwrite user settings. When temporarily changing settings + such as `nThreads`, register restoration with `on.exit(..., add = TRUE)` before + doing work that can fail. Preserve intentional updates to simulation counters + and records. +* Create new individuals through supported SIMplyBee/AlphaSimR constructors and + crossing functions. Direct S4 construction or manual ID changes can bypass + ID, pedigree, and recombination bookkeeping. Check these invariants explicitly + when changing population creation, especially across parallel workers. +* Treat population and colony metadata as biological state. Queens' `misc` + includes fathers and brood counts. When subsetting, merging, or rebuilding + populations, verify metadata, individual order, IDs, and class preservation; + inspect the supported AlphaSimR/SIMplyBee methods + rather than assuming all slots survive. +* Preserve the package's representation of haploid drones and diploid females, + caste-specific inheritance, and complementary sex determination. For relevant + changes, test maternal-only inheritance in drones, parental allele inheritance + in female offspring, and homozygous-brood handling with csd enabled, as well as + the supported csd-disabled path. Respect the existing genotype representation + rather than inferring ploidy solely from storage dimensions. + +## Parallelisation + +We thrive to parallelise the package. The limiting factor is the `simParamBee` object that +is updated within the functions - in parallelisation, this would be a problem +since multiple workers would update the object simultaneously, especially regarding individual/colony IDs +and corresponding caste information. We already adjusted the functions, +with `createCastePop` being the central function to parallelisation, where the IDs are assigned up-front +and then every worker can work independently. +The aim of parallelisation is to use a package that would speed up especialy `Multicolony` operations +(less need to optimise across individuals) with the target being running simulations on a high-performing +cluster, either SLURM or SGE. ## The way of working @@ -14,7 +82,10 @@ SIMplyBee aims to provide an easy to use simulation platform to simulate honeybe * 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. +* Package checks should have no new errors or warnings. Report existing failures + and explain any accepted NOTEs; do not assume every NOTE is harmless. * We update `NEWS.md` for user-visible behavior or API changes. +* We can source information from previous logs saved in `agent_logs` - these must be in .Rbuildignore ## Permissions and authorization @@ -53,14 +124,16 @@ curl -I -sS --max-time 15 ## Definition of done +Run the R commands below from the package directory of the active worktree. + 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. +* Run applicable formatting/lint checks described below and `git diff --check`. +* `Rscript -e "devtools::test()"` + for package tests. +* `Rscript -e "devtools::check()"` + for full package checks. * Updated `NEWS.md` for user-visible changes. ### Task-class quality gates @@ -70,7 +143,7 @@ A task is done when all applicable items below are completed: `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()`). + handoff (`devtools::test()` and `devtools::check()`, plus applicable lint checks). * If full checks are intentionally skipped, explicitly report what was skipped, why, and which focused checks were run. @@ -80,9 +153,13 @@ 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 +git worktree add ../SIMplyBee_wt_ -b origin/ ``` +Choose `` from the task or PR target. The README distinguishes +`main` (pre-CRAN stable work) from `devel` (development); do not assume `main` +is always the correct base. Reuse an existing task worktree when appropriate. + Within this workflow, follow these rules: * In the shared root worktree, limit edits to small docs/meta/config work. @@ -96,17 +173,19 @@ Within this workflow, follow these rules: ```sh git fetch origin --prune -git rebase origin/main +git rebase origin/ ``` -* If there are local uncommitted edits, use `--autostash` or an explicit stash. +* Inspect staged and unstaged changes first. Preserve existing work; do not + stash, rebase, or change branches in a shared dirty checkout as routine setup. * 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: +Remove a task worktree only once its work is preserved and it is clean; never +force removal to discard uncommitted work. After merge/finish: ```sh git worktree remove ../SIMplyBee_wt_ @@ -125,71 +204,30 @@ For issue exploration, closure recommendations, or "what is left to do?" tasks: ## Quality toolchain -These checks mirror `README.md` guidance and enforce package quality. - -### Pre-commit hooks +The checkout has `air.toml` and `jarl.toml`. -Install once per clone: +Use Air and Jarl when installed, scoped to changed R files, for example: ```sh -pre-commit install +air format R/Functions_L0_auxilary.R +jarl check R/Functions_L0_auxilary.R +git diff --check ``` -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: +Avoid repository-wide formatting churn. Check tool help before using unfamiliar +flags. Report unavailable checks rather than silently installing or upgrading +tools. If a tool is missing from `PATH`, also check user-local bin directories: ```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)" +Rscript -e "cov <- covr::package_coverage(clean = TRUE); print(cov)" ``` ### GitHub Actions (CI) @@ -198,9 +236,31 @@ 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. +* `.github/workflows/document.yaml`: regenerates roxygen documentation on R-source + pushes and can commit the generated changes back to the branch. +* `.github/workflows/pkgdown.yaml`: builds the website and deploys on non-PR runs. + +Check each workflow's triggers before assuming it runs for a particular branch. +Regenerate documentation locally when needed and inspect its diff before handoff. Local work should pass local checks before relying on CI feedback. +## Dependencies and package data + +* Keep dependencies minimal and justify additions. Required runtime packages + belong in `Imports`; optional features, examples, and tests use `Suggests`. + Preserve the intentional `Depends: AlphaSimR` relationship. +* Prefer `pkg::fun()` for new external calls, while respecting established + namespace imports. Do not call `library()` or `require()` inside package + functions. Guard optional features with `requireNamespace(..., quietly = TRUE)` + and a useful message, and skip tests when optional dependencies are unavailable. + Do not create unconditional namespace imports from suggested packages. +* When adding package datasets, keep preparation scripts in `data-raw/`, use + `usethis::use_data()` where appropriate, and document datasets with roxygen + `@format` and `@source`. Dataset documentation does not need `@export`. +* Exclude development-only top-level files and directories from package builds + in `.Rbuildignore`, including agent instructions and data-preparation scripts. + ## Generated files and source-of-truth rules Do not edit generated files by hand: @@ -209,13 +269,34 @@ Do not edit generated files by hand: * `src/RcppExports.cpp` * `NAMESPACE` * Files in `man/` generated from roxygen comments +* Generated website output in `docs/`; edit its sources in `R/`, `vignettes/`, + `README.md`, and `_pkgdown.yml` instead Regenerate as needed: ```sh -Rscript -e "setwd('SIMplyBee'); Rcpp::compileAttributes()" -Rscript -e "setwd('SIMplyBee'); devtools::document()" +Rscript -e "Rcpp::compileAttributes()" +Rscript -e "devtools::document()" ``` + +Additional source-of-truth rules: + +* This checkout maintains `README.md` directly; there is no `README.Rmd`. + If a generated README workflow is introduced, edit its source and regenerate + the output (for an R Markdown source, use `devtools::build_readme()`). +* `.github/workflows/document.yaml` runs on pushes touching `R/**` and commits + generated `man/`, `NAMESPACE`, and `DESCRIPTION` changes back to the branch. + Account for these automated commits when synchronising work. +* For local documentation generation, use the roxygen2 version recorded in + `DESCRIPTION` when available. Report a version mismatch and inspect generated + diffs for unrelated churn; CI currently installs roxygen2 without that pin. +* Changes to Rcpp-exported signatures require `Rcpp::compileAttributes()` and + rebuilding the package; the documentation workflow does not regenerate Rcpp + exports. +* Leave release version/date changes to release work explicitly requested by the + maintainer. A development NEWS heading differing from `DESCRIPTION` is not, + on its own, a reason to bump the package version. + ## R CMD Check ### Preferred way to R CMD Check @@ -223,68 +304,88 @@ Rscript -e "setwd('SIMplyBee'); devtools::document()" Run faster package checks from the package directory: ```sh -Rscript -e "setwd('SIMplyBee'); devtools::check(vignette = FALSE)" +Rscript -e "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()" +Rscript -e "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. +### Check environment and reporting -Use unsandboxed/escalated execution for full package checks. +A fast check with `vignette = FALSE` is an intermediate check, not a replacement +for the full check when vignettes or package behavior change. Vignettes use +knitr/rmarkdown; CI sets up Pandoc. Check R, compiler, Pandoc, and LaTeX +availability as relevant to the actual failure. Do not assume Quarto is required +or hard-code an IDE installation path. -### Quarto caveat (why it can work interactively but fail in agent runs) +If compiler detection fails inside the sandbox, inspect the error first; it +may be a sandbox restriction rather than a missing compiler. Request escalated +execution when needed under the standing authorization above. -`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. +At handoff, record commands run, errors/warnings/notes, and any skipped checks +with reasons. Compare failures with the unchanged base when needed to distinguish +existing problems from regressions. Never claim a check passes based on an older +run or assume a fixed expected result for this machine. ## 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). +* Add or update `testthat` tests for every behavior change. +* Prefer focused regression tests for bug fixes. +* Use the configured testthat edition (currently edition 3); do not change it + incidentally when adding tests. +* For stochastic tests, prefer biological invariants over arbitrary sampled + values. Use controlled seeds and justified tolerances when random outcomes are + part of the assertion; keep fixtures small and avoid flaky Monte Carlo checks. +* Keep ordinary simulation tests and examples single threaded with + `SP$nThreads = 1L` (use `\dontshow{SP$nThreads = 1L}` in roxygen examples). + Dedicated parallel/thread tests should set their own configuration and skip + explicitly when the required execution capability is unavailable. +* Keep tests runnable via package tests and checks. +* Keep stochastic tests reproducible with explicit seeds and small populations. + Set `SP$nThreads <- 1L` where appropriate; pass `simParamBee = SP` explicitly + to avoid dependence on global state. Restore any global options or parallel + plans changed by a test. +* Prefer independently derived expectations, biological invariants, and small + enumerated cases over tests that repeat the implementation. For simulation + estimates, use tolerances justified by sampling error. +* Cover relevant haplodiploid, caste, empty-colony, and single/multiple-colony + cases when changing population or colony operations. +* Guard genuinely optional external dependencies with explicit skips; do not + hide failures in required package dependencies such as AlphaSimR. 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')`. + +* `Rscript -e "devtools::test()"` + for package tests, or a focused run such as + `Rscript -e "devtools::test(filter = 'L2_colony_functions')"`. Tests are also run as part of R CMD check. +## Research, examples, and references + +* Keep development plans and exploratory or standalone validation scripts in + `dev/`; consult `dev/README.md` and the relevant topic plan when present + before continuing existing research. Update that plan when completing planned work. +* Put automated regression tests in `tests/testthat/` and user tutorials in + `vignettes/`. Keep expensive simulation experiments out of routine tests. +* Check `.Rbuildignore` before assuming a vignette or development script runs + in package checks; validate excluded material explicitly when changing it. +* Keep scientific assumptions explicit, especially individual versus colony + quantities, sum versus mean worker effects, mating/worker allocation, + relatedness, and covariance conventions. Keep equations, code, and examples + consistent and cite sources for model changes. +* Where present, use `inst/REFERENCES.bib` for package citations and + `literature/README.md` for the local literature archive. Verify references + rather than inventing them. + ## Proofreading If asked to proofread, act as an expert proofreader and editor @@ -294,4 +395,4 @@ 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. +Only report what you have changed. \ No newline at end of file diff --git a/R/Functions_L1_Pop.R b/R/Functions_L1_Pop.R index b44173a9..a3010e0d 100644 --- a/R/Functions_L1_Pop.R +++ b/R/Functions_L1_Pop.R @@ -540,7 +540,7 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, returnSP = returnSP, ids = ids, ...) ret$caste = rep("virginQueens", length(ret$caste)) names(ret$caste) = ids - simParamBee$changeCaste(id = ret$workers@id, caste = "virginQueens") + #simParamBee$changeCaste(id = ret$workers@id, caste = "virginQueens") if (!returnSP) { ret <- ret$workers } @@ -570,7 +570,7 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, if (nInd(drones) != length(ids)) { stop("Not enough IDs provided") } - drones@id = ids + drones@id = as.character(ids) drones@iid = as.integer(ids) if (returnSP) { names(ret$caste) <- ids diff --git a/R/Functions_L2_Colony.R b/R/Functions_L2_Colony.R index 93b68cb1..bc43b906 100644 --- a/R/Functions_L2_Colony.R +++ b/R/Functions_L2_Colony.R @@ -162,7 +162,7 @@ reQueen <- function(x, queen, removeVirginQueens = TRUE, simParamBee = NULL) { if (removeVirginQueens) { x <- removeVirginQueens(x, simParamBee = simParamBee) } - } else { + } else { # If it's a virgin queen x <- removeQueen(x, simParamBee = simParamBee) x@virginQueens <- queen } diff --git a/R/Functions_L3_Colonies.R b/R/Functions_L3_Colonies.R index 78f240c3..250d3a58 100644 --- a/R/Functions_L3_Colonies.R +++ b/R/Functions_L3_Colonies.R @@ -60,13 +60,19 @@ createMultiColony <- function(x = NULL, n = NULL, simParamBee = NULL, populateCo } else { ret <- new(Class = "MultiColony", colonies = vector(mode = "list", length = n)) if (populateColonies) { - ids <- (simParamBee$lastColonyId+1):(simParamBee$lastColonyId + n) + end_lastColonyId <- simParamBee$lastColonyId + n + ids <- (simParamBee$lastColonyId+1):end_lastColonyId + ret@colonies <- future_lapply(X = seq_len(n), FUN = function(colony) { createColony(simParamBee = simParamBee, id = ids[colony]) }) - simParamBee$updateLastColonyId(n = n) + + updatedColonyIdBoolean <- simParamBee$lastColonyId == end_lastColonyId + if (!updatedColonyIdBoolean) { + simParamBee$updateLastColonyId(n = n) + } } else { } @@ -85,13 +91,18 @@ createMultiColony <- function(x = NULL, n = NULL, simParamBee = NULL, populateCo 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) + end_lastColonyId <- simParamBee$lastColonyId + n + ids <- (simParamBee$lastColonyId+1):end_lastColonyId ret@colonies <- future_lapply(X = seq_len(n), FUN = function(colony) { createColony(x = x[colony], simParamBee = simParamBee, id = ids[colony]) }) - simParamBee$updateLastColonyId(n = n) + + updatedColonyIdBoolean <- simParamBee$lastColonyId == end_lastColonyId + if (!updatedColonyIdBoolean) { + simParamBee$updateLastColonyId(n = n) + } } validObject(ret) diff --git a/TestingVarianceComponents.R b/TestingVarianceComponents.R deleted file mode 100644 index deefb739..00000000 --- a/TestingVarianceComponents.R +++ /dev/null @@ -1,397 +0,0 @@ -library(SIMplyBee) -library(tidyr) -library(ggplot2) -library(dplyr) - -# 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) { - for (fun in c("mean", "sum")) { - print(paste(fun, ", rep ", rep)) - - founderGenomes <- quickHaplo(nInd = 20, nChr = 16, segSites = 1000) - SP <- SimParamBee$new(founderGenomes) - SP$nWorkers <- 100 - SP$nFathers <- 15 - nQtlPerChr <- 100 - - mean <- c(0, 0) - if (fun == "mean") { - varA <- c(1, 1) - varE <- c(3, 3) - } else if (fun == "sum") { - varA <- c(1, 1 / SP$nWorkers) - varE <- c(3, 3 / 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")) - - 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) - - if (fun == "mean") { - workersFUN = colMeans - } else if (fun == "sum") { - workersFUN = colSums - } - - # 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 = fun) - - real_A_q <- calcColonyGv(apiary, FUN = mapCasteToColonyGv, queenTrait = 1, workersTrait = NULL) - real_A_wbar <- calcColonyGv(apiary, FUN = mapCasteToColonyGv, queenTrait = NULL, workersTrait = 2, workersFUN = workersFUN) - real_P_wbar <- calcColonyPheno(apiary, FUN = mapCasteToColonyPheno, queenTrait = NULL, workersTrait = 2, workersFUN = workersFUN) - real_E_wbar <- real_P_wbar - real_A_wbar - real_varE_wbar <- popVar(real_E_wbar) - real_covA_qwbar <- cov(real_A_q, real_A_wbar) - real_corA_qwbar <- cor(real_A_q, real_A_wbar) - - real_varA_wbar <- popVar(real_A_wbar) - - real_A_c <- calcColonyGv(apiary, FUN = mapCasteToColonyGv, workersFUN = workersFUN) - real_varA_c <- popVar(real_A_c) - real_P_c <- calcColonyPheno(apiary, FUN = mapCasteToColonyPheno, workersFUN = workersFUN) - real_E_c <- real_P_c - real_A_c - real_varE_c <- popVar(real_E_c) - - variances0 <- rbind(variances0, data.frame(rep = rep, - - calc_var_wbar = calcVar$varA_wbar, calc_var_c = calcVar$varA_c, - real_var_wbar = real_varA_wbar[1,1], real_var_c = real_varA_c[1,1], - - component = "A", - fun = fun)) - - variances0 <- rbind(variances0, data.frame(rep = rep, - - calc_var_wbar = calcVar$varE_wbar, calc_var_c = calcVar$varE_c, - real_var_wbar = real_varE_wbar, real_var_c = real_varE_c, - - component = "E", - fun = fun)) - - } -} - -variances0Long <- pivot_longer(variances0, - cols = c("calc_var_wbar", "calc_var_c", - "real_var_c", "real_var_wbar"), names_to = "VarType", values_to = "Var") -meanRealVar = variances0Long %>% group_by(fun, component, VarType) %>% summarise(meanVar = mean(Var)) - -variances0Long %>% - dplyr::mutate(rep = as.factor(rep)) %>% - dplyr::mutate(VarType = factor(VarType, levels = c("calc_var_wbar", "calc_var_c", - "real_var_wbar", "real_var_c", "real_varP_c"))) %>% - ggplot(aes(x = rep, y = Var, color = VarType)) + - geom_point(size = 3, aes(colour = VarType)) + - 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( - "#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 = 10 -variances = data.frame() - -for (rep in 1:nRep) { - print(rep) - 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(fun, ", 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 -)) - \ No newline at end of file diff --git a/man/SIMplyBee-package.Rd b/man/SIMplyBee-package.Rd index a22788f0..71d90a18 100644 --- a/man/SIMplyBee-package.Rd +++ b/man/SIMplyBee-package.Rd @@ -33,7 +33,6 @@ 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/vignettes/F2_Variance_calculations_functions.Rmd b/vignettes/F2_Variance_calculations_functions.Rmd index e41b391f..a3d37b0b 100644 --- a/vignettes/F2_Variance_calculations_functions.Rmd +++ b/vignettes/F2_Variance_calculations_functions.Rmd @@ -3,7 +3,7 @@ title: "Variance calculations between individual and colony level values - funct date: "`r Sys.Date()`" output: rmarkdown::html_vignette vignette: > - %\VignetteIndexEntry{VarianceCalculations} + %\VignetteIndexEntry{VarianceCalculations_functions} %\VignetteEngine{knitr::rmarkdown} %\VignetteEncoding{UTF-8} editor_options: diff --git a/vignettes/colony_variance_theory_plan.md b/vignettes/colony_variance_theory_plan.md deleted file mode 100644 index 2e0a0e02..00000000 --- a/vignettes/colony_variance_theory_plan.md +++ /dev/null @@ -1,364 +0,0 @@ -# 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. diff --git a/vignettes/scripts/variance_functions.R b/vignettes/scripts/variance_functions.R deleted file mode 100644 index ea99f1d8..00000000 --- a/vignettes/scripts/variance_functions.R +++ /dev/null @@ -1,135 +0,0 @@ -# Shared helper functions for variance calculations vignette - -# cor2cov: convert correlation matrix (or vector) and variances to covariance matrix -cor2cov <- function(corr, var) { - corr <- as.matrix(corr) - var <- as.numeric(var) - sd <- sqrt(var) - cov <- corr * (sd %o% sd) - return(cov) -} - -# mapIndToColonyVar: map individual-level variances/covariances to colony-level -mapIndToColonyVar <- function(varA_q, varA_w, corA_qw, - varE_q, varE_w, corE_qw, - nW, nF, nDPQ, workersFUN = "sum") { - - if (!workersFUN %in% c("sum", "mean")) { - stop("Invalid value for workersFUN. We currently only support either 'sum' or 'mean'.") - } - - # Pair counts - n_SS <- (nW * nW / nF) - nW - n_FS <- (nW * nW / nDPQ) - (nW * nW / nF) - n_HS <- (nW * nW / nDPQ) * (nDPQ - 1) - - 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 - - # 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)) -} - -# mapColonyToIndVar: map colony-level variance components back to individual-level -mapColonyToIndVar <- function(varA_q, - varA_wbar, - corA_qwbar, - varE_q, - varE_wbar, - corE_qwbar, - nW, - nF, - nDPQ, - workersFUN = "sum") { - - if (!workersFUN %in% c("sum", "mean")) { - stop("Invalid value for workersFUN. We currently only support either 'sum' or 'mean'.") - } - - covA_qwbar <- corA_qwbar * sqrt(varA_q) * sqrt(varA_wbar) - - if (workersFUN == "sum") { - covA_qw <- covA_qwbar / nW - } else if (workersFUN == "mean") { - covA_qw <- covA_qwbar - } - - n_SS <- (nW * nW / nF) - nW - n_FS <- (nW * nW / nDPQ) - (nW * nW / nF) - n_HS <- (nW * nW / nDPQ) * (nDPQ - 1) - - 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)) - - # 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)) -} From 09a0a0db469b1543b3ec06ba05b0a0690551e3e0 Mon Sep 17 00:00:00 2001 From: janaobsteter Date: Mon, 26 Oct 2026 13:27:53 +0100 Subject: [PATCH 92/98] Use the prevailing virgin queen helper for a Colony in swarm and supersede createPrevailingVirginQueens_internal() now also takes a Colony, which is done in the main session without futures; the per-colony work is in createPrevailingVirginQueen_internal(). swarm() and supersede() use it for Colony and MultiColony, so all created virgin queens (including csd homozygous ones) are recorded as virgin queens for a Colony too. Co-Authored-By: Claude Opus 5.5 --- NEWS.md | 13 ++- R/Functions_L1_Pop.R | 111 +++++++++++++--------- R/Functions_L2_Colony.R | 46 ++++----- tests/testthat/test-L2_colony_functions.R | 47 +++++++++ 4 files changed, 140 insertions(+), 77 deletions(-) diff --git a/NEWS.md b/NEWS.md index 5f3eaf71..350dfc7f 100644 --- a/NEWS.md +++ b/NEWS.md @@ -61,6 +61,7 @@ is the number of viable workers. `SimParamBee` in the main R session - `swarm()` and `supersede()` create the virgin queens on the workers and return only the one that prevails in each colony + (a Colony uses the same code, without parallel workers) - `swarm()` and `split()` pull the workers in the main R session and no longer send colonies to workers @@ -86,6 +87,9 @@ is the number of viable workers. on the parallel workers, and workers are pulled in the main R session); `removeCastePop(p = 1)` on a MultiColony no longer consumes random numbers. Sequential and parallel futures still give the same results. + Seeded results of `swarm()` and `supersede()` on a Colony also differ, + since the virgin queens are created from the queen's fathers in a random + order (as for a MultiColony). ## Bug fixes @@ -114,10 +118,11 @@ is the number of viable workers. only that colony; previously it sampled from colony IDs 1 to that colony's ID -- `createCastePop()` on a MultiColony now records all created virgin - queens, including csd homozygous ones that are removed, as virgin - queens in `SimParamBee` with `plan(sequential)` too (previously they - were recorded as workers) +- `createCastePop()` on a MultiColony, and `swarm()` and `supersede()` + on a Colony or MultiColony, now record all created virgin queens, + including csd homozygous ones that are removed, as virgin queens in + `SimParamBee` (previously they were recorded as workers with + `plan(sequential)` or on a Colony) - recombination records (`SP$recHist`) of individuals created on a MultiColony with parallel futures are now named by their IDs diff --git a/R/Functions_L1_Pop.R b/R/Functions_L1_Pop.R index 848e3ece..4ab00505 100644 --- a/R/Functions_L1_Pop.R +++ b/R/Functions_L1_Pop.R @@ -769,16 +769,60 @@ addBeeRecords_internal <- function(simParamBee, ids, caste, pedigree = NULL, invisible(simParamBee) } -# For each colony in a MultiColony, create nInd virgin queens from the queen -# and her fathers, remove csd homozygous ones, and select one at random that -# prevails (as in swarm and supersede). Each parallel worker receives only the -# queens of its colonies and a slimmed copy of simParamBee, and returns only the -# prevailing virgin queen with the records of all created virgin queens. These -# records are then added to simParamBee here. Returns a list with a virgin -# queen (Pop) or NULL (all virgin queens csd homozygous) for each colony. -# nInd is a single value or one value per colony. +# Create task$nInd virgin queens from task$queen and her fathers, give them +# the IDs task$ids, remove csd homozygous ones, and select one at random that +# prevails. simParamBee must be a SimParamBee$slimClone(), since it is +# updated here; the records of all created virgin queens are returned instead. +# Returns a list with the virgin queen (Pop, or NULL if all were csd +# homozygous) and the pedigree and recHist records. +createPrevailingVirginQueen_internal <- function(task, simParamBee) { + queen <- task$queen + virginQueens <- combineBeeGametes( + queen = queen, + drones = getFathers(queen, simParamBee = simParamBee), + nProgeny = task$nInd, + simParamBee = simParamBee + ) + ret <- list(virginQueen = NULL, pedigree = NULL, recHist = NULL) + tmpIds <- virginQueens@id + if (simParamBee$isTrackPed) { + ret$pedigree <- simParamBee$pedigree[tmpIds, , drop = FALSE] + rownames(ret$pedigree) <- task$ids + } + if (simParamBee$isTrackRec) { + ret$recHist <- simParamBee$recHist[tmpIds] + names(ret$recHist) <- task$ids + } + virginQueens@id <- as.character(task$ids) + virginQueens@iid <- as.integer(task$ids) + virginQueens@sex[] <- "F" + if (isCsdActive(simParamBee = simParamBee)) { + virginQueens <- virginQueens[isCsdHeterozygous(pop = virginQueens, simParamBee = simParamBee)] + } + if (nInd(virginQueens) > 0) { + ret$virginQueen <- selectInd(virginQueens, nInd = 1, use = "rand", simParam = simParamBee) + } + ret +} + +# For a Colony or each colony in a MultiColony, create nInd virgin queens +# from the queen and her fathers, remove csd homozygous ones, and select one at +# random that prevails (as in swarm and supersede). For a MultiColony, each +# parallel worker receives only the queens of its colonies and a slimmed copy +# of simParamBee, and returns only the prevailing virgin queen with the records +# of all created virgin queens; a Colony is done here, without futures. The +# records are then added to simParamBee here. Returns a virgin queen (Pop) or +# NULL (all virgin queens csd homozygous) for a Colony, and a list of these for +# a MultiColony. nInd is a single value or one value per colony. createPrevailingVirginQueens_internal <- function(x, nInd, simParamBee) { - nCol <- nColonies(x) + if (isColony(x)) { + colonies <- list(x) + } else if (isMultiColony(x)) { + colonies <- x@colonies + } else { + stop("Argument x must be a Colony or MultiColony class object!") + } + nCol <- length(colonies) if (nCol == 0) { stop("The Multicolony contains 0 colonies!") } @@ -793,44 +837,18 @@ createPrevailingVirginQueens_internal <- function(x, nInd, simParamBee) { ids <- (lastId + 1L):(lastId + sum(nInd)) idsByColony <- base::split(ids, rep(seq_len(nCol), times = nInd)) tasks <- lapply(seq_len(nCol), FUN = function(colony) { - list(queen = x@colonies[[colony]]@queen, nInd = nInd[colony], + list(queen = colonies[[colony]]@queen, nInd = nInd[colony], ids = idsByColony[[colony]]) }) - workerFUN <- function(task, simParamBee) { - queen <- task$queen - virginQueens <- combineBeeGametes( - queen = queen, - drones = getFathers(queen, simParamBee = simParamBee), - nProgeny = task$nInd, - simParamBee = simParamBee - ) - ret <- list(virginQueen = NULL, pedigree = NULL, recHist = NULL) - tmpIds <- virginQueens@id - if (simParamBee$isTrackPed) { - ret$pedigree <- simParamBee$pedigree[tmpIds, , drop = FALSE] - rownames(ret$pedigree) <- task$ids - } - if (simParamBee$isTrackRec) { - ret$recHist <- simParamBee$recHist[tmpIds] - names(ret$recHist) <- task$ids - } - virginQueens@id <- as.character(task$ids) - virginQueens@iid <- as.integer(task$ids) - virginQueens@sex[] <- "F" - if (isCsdActive(simParamBee = simParamBee)) { - virginQueens <- virginQueens[isCsdHeterozygous(pop = virginQueens, simParamBee = simParamBee)] - } - if (nInd(virginQueens) > 0) { - ret$virginQueen <- selectInd(virginQueens, nInd = 1, use = "rand", simParam = simParamBee) - } - ret - } - # Detach from this frame, otherwise future serialises the whole frame - # (including x and tasks) together with the function to every worker - environment(workerFUN) <- new.env(parent = topenv()) - res <- future_lapply(X = tasks, FUN = workerFUN, - simParamBee = simParamBee$slimClone(), - future.globals = list(), future.seed = TRUE) + rm(colonies) + if (isColony(x)) { + res <- lapply(X = tasks, FUN = createPrevailingVirginQueen_internal, + simParamBee = simParamBee$slimClone()) + } else { + res <- future_lapply(X = tasks, FUN = createPrevailingVirginQueen_internal, + simParamBee = simParamBee$slimClone(), + future.globals = list(), future.seed = TRUE) + } rm(tasks) addBeeRecords_internal( simParamBee = simParamBee, ids = ids, caste = "virginQueens", @@ -839,6 +857,9 @@ createPrevailingVirginQueens_internal <- function(x, nInd, simParamBee) { ploidy = 2L ) ret <- lapply(res, FUN = "[[", "virginQueen") + if (isColony(x)) { + return(ret[[1]]) + } names(ret) <- getId(x) return(ret) } diff --git a/R/Functions_L2_Colony.R b/R/Functions_L2_Colony.R index 9ed6f0b2..2a70287b 100644 --- a/R/Functions_L2_Colony.R +++ b/R/Functions_L2_Colony.R @@ -1481,20 +1481,16 @@ swarm <- function(x, p = NULL, # TODO: Add use="something" to select pWorkers that swarm # https://github.com/HighlanderLab/SIMplyBee/issues/160 + # Create the virgin queens and keep only the one that prevails in each + # colony (NULL if all were csd homozygous); for a MultiColony this is done + # by parallel workers, which receive only the queens + tmpVirginQueens <- createPrevailingVirginQueens_internal( + x = x, nInd = pmax(10, nVirginQueens), + simParamBee = simParamBee + ) if (isColony(x)) { - tmpVirginQueens <- createCastePop( - x = x, nInd = pmax(10, nVirginQueens), - caste = "virginQueens", - simParamBee = simParamBee - ) - homCol = nInd(tmpVirginQueens) == 0 + homCol = is.null(tmpVirginQueens) } else if (isMultiColony(x)) { - # Parallel workers create the virgin queens and return only the one that - # prevails in each colony (NULL if all were csd homozygous) - tmpVirginQueens <- createPrevailingVirginQueens_internal( - x = x, nInd = pmax(10, nVirginQueens), - simParamBee = simParamBee - ) homCol = sapply(tmpVirginQueens, FUN = is.null) } @@ -1522,7 +1518,7 @@ swarm <- function(x, p = NULL, remnantColony <- removeQueen(remnantColony, simParamBee = simParamBee) if (isColony(x)) { remnantColony <- reQueen(remnantColony, - queen = selectInd(tmpVirginQueens, nInd = 1, use = "rand", simParam = simParamBee), + queen = tmpVirginQueens, simParamBee = simParamBee) } else { remnantColony <- reQueen(remnantColony, @@ -1670,21 +1666,16 @@ supersede <- function(x, simParamBee = NULL, ...) { # Do this because some colonies might not produce a viable virgin queen + # Create the virgin queens and keep only the one that prevails in each + # colony (NULL if all were csd homozygous); for a MultiColony this is done + # by parallel workers, which receive only the queens (not the full colonies) + tmpVirginQueens <- createPrevailingVirginQueens_internal( + x = x, nInd = pmax(10, nVirginQueens), + simParamBee = simParamBee + ) if (isColony(x)) { - tmpVirginQueens <- createCastePop( - x = x, nInd = pmax(10, nVirginQueens), - caste = "virginQueens", - simParamBee = simParamBee - ) - homCol = nInd(tmpVirginQueens) == 0 + homCol = is.null(tmpVirginQueens) } else if (isMultiColony(x)) { - # Parallel workers create the virgin queens and return only the one that - # prevails in each colony (NULL if all were csd homozygous) - # This is done so that the full colonies are not sent to workers - only the queen - tmpVirginQueens <- createPrevailingVirginQueens_internal( - x = x, nInd = pmax(10, nVirginQueens), - simParamBee = simParamBee - ) homCol = sapply(tmpVirginQueens, FUN = is.null) } @@ -1701,8 +1692,7 @@ supersede <- function(x, simParamBee = NULL, ...) { if (isColony(x)) { - x <- addCastePop_internal(selectInd(tmpVirginQueens, nInd = 1, use = "rand", simParam = simParamBee), - colony = x, caste = "virginQueens") + x <- addCastePop_internal(tmpVirginQueens, colony = x, caste = "virginQueens") x <- removeQueen(x, simParamBee = simParamBee) # TODO: We could consider that a non-random virgin queen prevails (say the most diff --git a/tests/testthat/test-L2_colony_functions.R b/tests/testthat/test-L2_colony_functions.R index 94057e08..3d326d2b 100644 --- a/tests/testthat/test-L2_colony_functions.R +++ b/tests/testthat/test-L2_colony_functions.R @@ -617,3 +617,50 @@ test_that("split moves workers from each colony to its split", { expect_true(all(hasSplit(tmp$split)) && all(hasSplit(tmp$remnant))) expect_true(all(!isProductive(tmp$split)) && all(isProductive(tmp$remnant))) }) + +# ---- swarm and supersede on a Colony ---- + +test_that("swarm and supersede on a Colony record all created virgin queens", { + founderGenomes <- quickHaplo(nInd = 10, nChr = 2, segSites = 100) + SP <- SimParamBee$new(founderGenomes, csdChr = 1, nCsdAlleles = 8) + SP$nThreads <- 1L + SP$setTrackPed(TRUE) + SP$setTrackRec(TRUE) + SP$nWorkers <- 20 + SP$nDrones <- 5 + SP$nVirginQueens <- 12 + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) + drones <- createDrones(basePop[1], nInd = 50, simParamBee = SP) + queens <- cross(basePop[2:3], drones = drones, crossPlan = "create", + nDrones = 5, simParamBee = SP) + + for (fun in c("swarm", "supersede")) { + colony <- buildUp(createColony(queens[ifelse(fun == "swarm", 1, 2)], simParamBee = SP), + simParamBee = SP) + queenId <- getCasteId(colony, caste = "queen", simParamBee = SP) + lastId <- SP$lastId + ret <- do.call(fun, list(x = colony, simParamBee = SP)) + newIds <- as.character((lastId + 1):(lastId + 12)) + expect_equal(SP$lastId, lastId + 12) + expect_true(all(SP$caste[newIds] == "virginQueens")) + expect_equal(rownames(SP$pedigree), as.character(seq_len(SP$lastId))) + expect_true(all(SP$pedigree[newIds, "mother"] == as.integer(queenId))) + expect_false(any(sapply(SP$recHist[newIds], is.null))) + if (fun == "swarm") { + # The remnant is requeened with one of the new virgin queens + newQueen <- getCasteId(ret$remnant, caste = "virginQueens", simParamBee = SP) + expect_true(is.null(ret$remnant@queen)) + expect_length(newQueen, 1) + expect_true(newQueen %in% newIds) + } else { + newQueen <- getCasteId(ret, caste = "virginQueens", simParamBee = SP) + expect_true(is.null(ret@queen)) + expect_length(newQueen, 1) + expect_true(newQueen %in% newIds) + expect_true(hasSuperseded(ret)) + } + expect_true(isCsdHeterozygous(getVirginQueens(if (fun == "swarm") ret$remnant else ret, + simParamBee = SP), + simParamBee = SP)) + } +}) From f0c2f716dabdd7c678b5190bbcbd4c6da22636ca Mon Sep 17 00:00:00 2001 From: janaobsteter Date: Mon, 26 Oct 2026 13:33:18 +0100 Subject: [PATCH 93/98] Merge the prevailing virgin queen helpers into one function createPrevailingVirginQueens_internal() now does the work for a Colony and, for a MultiColony, calls itself on each colony (with only the queen) on the parallel workers via future_mapply(); given ids, it returns the records instead of adding them to simParamBee. Seeded results are unchanged. Co-Authored-By: Claude Opus 5.5 --- NAMESPACE | 1 + R/Functions_L1_Pop.R | 176 ++++++++++++++++++++++--------------------- R/SIMplyBee.R | 2 +- 3 files changed, 92 insertions(+), 87 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 94889270..f2aec9e6 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -210,6 +210,7 @@ import(Rcpp) importFrom(R6,R6Class) importFrom(extraDistr,rtpois) importFrom(future.apply,future_lapply) +importFrom(future.apply,future_mapply) importFrom(methods, "slot<-", classLabel, diff --git a/R/Functions_L1_Pop.R b/R/Functions_L1_Pop.R index 4ab00505..d512334a 100644 --- a/R/Functions_L1_Pop.R +++ b/R/Functions_L1_Pop.R @@ -769,99 +769,103 @@ addBeeRecords_internal <- function(simParamBee, ids, caste, pedigree = NULL, invisible(simParamBee) } -# Create task$nInd virgin queens from task$queen and her fathers, give them -# the IDs task$ids, remove csd homozygous ones, and select one at random that -# prevails. simParamBee must be a SimParamBee$slimClone(), since it is -# updated here; the records of all created virgin queens are returned instead. -# Returns a list with the virgin queen (Pop, or NULL if all were csd -# homozygous) and the pedigree and recHist records. -createPrevailingVirginQueen_internal <- function(task, simParamBee) { - queen <- task$queen - virginQueens <- combineBeeGametes( - queen = queen, - drones = getFathers(queen, simParamBee = simParamBee), - nProgeny = task$nInd, - simParamBee = simParamBee - ) - ret <- list(virginQueen = NULL, pedigree = NULL, recHist = NULL) - tmpIds <- virginQueens@id - if (simParamBee$isTrackPed) { - ret$pedigree <- simParamBee$pedigree[tmpIds, , drop = FALSE] - rownames(ret$pedigree) <- task$ids - } - if (simParamBee$isTrackRec) { - ret$recHist <- simParamBee$recHist[tmpIds] - names(ret$recHist) <- task$ids - } - virginQueens@id <- as.character(task$ids) - virginQueens@iid <- as.integer(task$ids) - virginQueens@sex[] <- "F" - if (isCsdActive(simParamBee = simParamBee)) { - virginQueens <- virginQueens[isCsdHeterozygous(pop = virginQueens, simParamBee = simParamBee)] - } - if (nInd(virginQueens) > 0) { - ret$virginQueen <- selectInd(virginQueens, nInd = 1, use = "rand", simParam = simParamBee) - } - ret -} - # For a Colony or each colony in a MultiColony, create nInd virgin queens # from the queen and her fathers, remove csd homozygous ones, and select one at -# random that prevails (as in swarm and supersede). For a MultiColony, each -# parallel worker receives only the queens of its colonies and a slimmed copy -# of simParamBee, and returns only the prevailing virgin queen with the records -# of all created virgin queens; a Colony is done here, without futures. The -# records are then added to simParamBee here. Returns a virgin queen (Pop) or -# NULL (all virgin queens csd homozygous) for a Colony, and a list of these for -# a MultiColony. nInd is a single value or one value per colony. -createPrevailingVirginQueens_internal <- function(x, nInd, simParamBee) { +# random that prevails (as in swarm and supersede). Returns a virgin queen (Pop) +# or NULL (all virgin queens csd homozygous) for a Colony, and a list of these +# for a MultiColony. nInd is a single value or one value per colony. +# The virgin queens are created with a slimmed copy of simParamBee and their +# records are added to simParamBee in one step. For a MultiColony, each +# parallel worker runs this function on its colonies (with only the queen) and +# the slimmed copy of simParamBee, and given ids, so that it returns the +# prevailing virgin queen with the records of all created virgin queens. +createPrevailingVirginQueens_internal <- function(x, nInd, simParamBee, ids = NULL) { if (isColony(x)) { - colonies <- list(x) + if (length(nInd) != 1 || is.na(nInd) || nInd < 1) { + stop("nInd must be a single value of at least 1 for a Colony!") + } + returnRecords <- !is.null(ids) + if (!returnRecords) { + ids <- simParamBee$lastId + seq_len(nInd) + fullSimParamBee <- simParamBee + simParamBee <- simParamBee$slimClone() + } + queen <- x@queen + virginQueens <- combineBeeGametes( + queen = queen, + drones = getFathers(queen, simParamBee = simParamBee), + nProgeny = nInd, + simParamBee = simParamBee + ) + pedigree <- NULL + recHist <- NULL + tmpIds <- virginQueens@id + if (simParamBee$isTrackPed) { + pedigree <- simParamBee$pedigree[tmpIds, , drop = FALSE] + rownames(pedigree) <- ids + } + if (simParamBee$isTrackRec) { + recHist <- simParamBee$recHist[tmpIds] + names(recHist) <- ids + } + virginQueens@id <- as.character(ids) + virginQueens@iid <- as.integer(ids) + virginQueens@sex[] <- "F" + if (isCsdActive(simParamBee = simParamBee)) { + virginQueens <- virginQueens[isCsdHeterozygous(pop = virginQueens, simParamBee = simParamBee)] + } + ret <- NULL + if (nInd(virginQueens) > 0) { + ret <- selectInd(virginQueens, nInd = 1, use = "rand", simParam = simParamBee) + } + if (returnRecords) { + return(list(virginQueen = ret, pedigree = pedigree, recHist = recHist)) + } + addBeeRecords_internal(simParamBee = fullSimParamBee, ids = ids, + caste = "virginQueens", pedigree = pedigree, + recHist = recHist, ploidy = 2L) + return(ret) } else if (isMultiColony(x)) { - colonies <- x@colonies + nCol <- nColonies(x) + if (nCol == 0) { + stop("The Multicolony contains 0 colonies!") + } + if (!(length(nInd) == 1 || length(nInd) == nCol)) { + stop("nInd must be a single value or one value per colony!") + } + nInd <- rep_len(as.integer(nInd), nCol) + if (any(is.na(nInd) | nInd < 1)) { + stop("nInd must be at least 1 for every colony!") + } + lastId <- simParamBee$lastId + ids <- (lastId + 1L):(lastId + sum(nInd)) + idsByColony <- base::split(ids, rep(seq_len(nCol), times = nInd)) + # Virgin queens are created only from the queen (and her fathers), so we + # pass colonies without workers, drones, and virgin queens + colonies <- lapply(x@colonies, FUN = function(colony) { + colony@workers <- NULL + colony@drones <- NULL + colony@virginQueens <- NULL + colony + }) + res <- future_mapply(FUN = createPrevailingVirginQueens_internal, + x = colonies, nInd = nInd, ids = idsByColony, + MoreArgs = list(simParamBee = simParamBee$slimClone()), + SIMPLIFY = FALSE, USE.NAMES = FALSE, + future.globals = list(), future.seed = TRUE) + rm(colonies) + addBeeRecords_internal( + simParamBee = simParamBee, ids = ids, caste = "virginQueens", + pedigree = do.call("rbind", lapply(res, FUN = "[[", "pedigree")), + recHist = do.call("c", lapply(res, FUN = "[[", "recHist")), + ploidy = 2L + ) + ret <- lapply(res, FUN = "[[", "virginQueen") + names(ret) <- getId(x) + return(ret) } else { stop("Argument x must be a Colony or MultiColony class object!") } - nCol <- length(colonies) - if (nCol == 0) { - stop("The Multicolony contains 0 colonies!") - } - if (!(length(nInd) == 1 || length(nInd) == nCol)) { - stop("nInd must be a single value or one value per colony!") - } - nInd <- rep_len(as.integer(nInd), nCol) - if (any(is.na(nInd) | nInd < 1)) { - stop("nInd must be at least 1 for every colony!") - } - lastId <- simParamBee$lastId - ids <- (lastId + 1L):(lastId + sum(nInd)) - idsByColony <- base::split(ids, rep(seq_len(nCol), times = nInd)) - tasks <- lapply(seq_len(nCol), FUN = function(colony) { - list(queen = colonies[[colony]]@queen, nInd = nInd[colony], - ids = idsByColony[[colony]]) - }) - rm(colonies) - if (isColony(x)) { - res <- lapply(X = tasks, FUN = createPrevailingVirginQueen_internal, - simParamBee = simParamBee$slimClone()) - } else { - res <- future_lapply(X = tasks, FUN = createPrevailingVirginQueen_internal, - simParamBee = simParamBee$slimClone(), - future.globals = list(), future.seed = TRUE) - } - rm(tasks) - addBeeRecords_internal( - simParamBee = simParamBee, ids = ids, caste = "virginQueens", - pedigree = do.call("rbind", lapply(res, FUN = "[[", "pedigree")), - recHist = do.call("c", lapply(res, FUN = "[[", "recHist")), - ploidy = 2L - ) - ret <- lapply(res, FUN = "[[", "virginQueen") - if (isColony(x)) { - return(ret[[1]]) - } - names(ret) <- getId(x) - return(ret) } # Pull individuals of a caste from each colony in a MultiColony (as in swarm diff --git a/R/SIMplyBee.R b/R/SIMplyBee.R index c138b5da..462a291d 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 future.apply future_lapply +#' @importFrom future.apply future_lapply future_mapply # see https://r-pkgs.org/namespace.html on description what to import/depend/... #' @description From 957d63262ebb7e5544c2d0463cb1d2970d20a7b7 Mon Sep 17 00:00:00 2001 From: janaobsteter Date: Mon, 26 Oct 2026 12:49:59 +0000 Subject: [PATCH 94/98] Update documentation --- NAMESPACE | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index f2aec9e6..5102ce7f 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -209,8 +209,10 @@ import(AlphaSimR) import(Rcpp) importFrom(R6,R6Class) importFrom(extraDistr,rtpois) -importFrom(future.apply,future_lapply) -importFrom(future.apply,future_mapply) +importFrom(future.apply, + future_lapply, + future_mapply +) importFrom(methods, "slot<-", classLabel, From 2a6580f44896e59eaef2a49ca71f2f133775863c Mon Sep 17 00:00:00 2001 From: janaobsteter Date: Mon, 26 Oct 2026 14:05:38 +0100 Subject: [PATCH 95/98] Use future_mapply() instead of future_lapply() for MultiColony createCastePop(), pullCastePop(), and removeCastePop() on a MultiColony now send colonies to parallel workers with future_mapply(), which has much less overhead than future_lapply() with plan(multisession) (buildUp() 14.5 -> 7 s, removeWorkers() 10.5 -> 2.2 s with 1000 colonies and 4 workers). Seeded results are unchanged. Co-Authored-By: Claude Opus 5.5 --- NAMESPACE | 5 +---- NEWS.md | 27 ++++++++++++++++++--------- R/Functions_L1_Pop.R | 14 ++++++++------ R/Functions_L2_Colony.R | 7 ++++--- R/SIMplyBee.R | 2 +- 5 files changed, 32 insertions(+), 23 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 5102ce7f..56e10c34 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -209,10 +209,7 @@ import(AlphaSimR) import(Rcpp) importFrom(R6,R6Class) importFrom(extraDistr,rtpois) -importFrom(future.apply, - future_lapply, - future_mapply -) +importFrom(future.apply,future_mapply) importFrom(methods, "slot<-", classLabel, diff --git a/NEWS.md b/NEWS.md index 350dfc7f..6ff3c991 100644 --- a/NEWS.md +++ b/NEWS.md @@ -68,19 +68,28 @@ is the number of viable workers. Run times with 1000 colonies (16 chromosomes, 100 workers per colony), sequential / `plan(multisession, workers = 4)`, in seconds: - | function | before | now | - |-----------------------------|-------------|------------| - | `buildUp()` | 68.7 / 31.8 | 29.5 / 17.6 | - | `addVirginQueens(nInd = 10)`| 57.0 / 23.9 | 9.7 / 6.9 | - | `swarm()` | 36.0 / 35.3 | 9.5 / 11.9 | - | `split()` | 16.3 / 21.7 | 3.4 / 3.4 | - | `supersede()` | 27.3 / 14.8 | 5.6 / 7.8 | + | function | before | now | + |------------------------------|-------------|------------| + | `buildUp()` | 68.7 / 31.8 | 22.6 / 7.0 | + | `addVirginQueens(nInd = 10)` | 57.0 / 23.9 | 7.1 / 2.2 | + | `swarm()` | 36.0 / 35.3 | 11.3 / 6.7 | + | `split()` | 16.3 / 21.7 | 2.5 / 2.4 | + | `supersede()` | 27.3 / 14.8 | 7.3 / 2.8 | + | `removeWorkers(p = 0.3)` | | 1.5 / 2.2 | Parallel futures pay off when there is a lot of work per colony (e.g., - many workers or virgin queens per colony), but not for every function - or simulation size, so we recommend timing a few steps of your + creating many workers or virgin queens per colony), but not for every + function or simulation size (e.g., removing or pulling individuals is + faster sequentially), so we recommend timing a few steps of your simulation with `plan(sequential)` and `plan(multisession)`. +- MultiColony functions now use `future.apply::future_mapply()` instead of + `future_lapply()` to send colonies to parallel workers, which halved the + time of `buildUp()`, `swarm()`, and `supersede()` with + `plan(multisession)` and reduced the time of `removeCastePop()` and + `pullCastePop()` from about 10 to 2 seconds for 1000 colonies. Seeded + results are unchanged. + - seeded results of `swarm()`, `split()`, and `supersede()` on a MultiColony differ from previous versions, because random numbers are now drawn in a different order (virgin queens are created and selected diff --git a/R/Functions_L1_Pop.R b/R/Functions_L1_Pop.R index d512334a..01043d61 100644 --- a/R/Functions_L1_Pop.R +++ b/R/Functions_L1_Pop.R @@ -659,8 +659,9 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, # Workers get a slimmed copy of simParamBee (without pedigree, recHist, # and caste records) and do not update simParamBee - they return the # records of the new individuals, which we add to simParamBee below - ret <- future_lapply(X = tasks, FUN = workerFUN, - caste = caste, simParamBee = simParamBee$slimClone(), + ret <- future_mapply(FUN = workerFUN, task = tasks, + MoreArgs = list(caste = caste, simParamBee = simParamBee$slimClone()), + SIMPLIFY = FALSE, USE.NAMES = FALSE, future.globals = list(), future.seed = TRUE) rm(tasks) @@ -1420,10 +1421,11 @@ pullCastePop <- function(x, caste, nInd = NULL, use = "rand", # workerFUN gets everything via its arguments, so we also skip scanning # the colonies in X for globals (future.globals = list()), which is slow environment(workerFUN) <- new.env(parent = topenv()) - tmp = future_lapply(X = tasks, FUN = workerFUN, - caste = caste, use = use, - removeFathers = removeFathers, collapse = collapse, - simParamBee = simParamBee, + tmp = future_mapply(FUN = workerFUN, task = tasks, + MoreArgs = list(caste = caste, use = use, + removeFathers = removeFathers, collapse = collapse, + simParamBee = simParamBee), + SIMPLIFY = FALSE, USE.NAMES = FALSE, future.globals = list(), future.seed = TRUE) rm(tasks) diff --git a/R/Functions_L2_Colony.R b/R/Functions_L2_Colony.R index 2a70287b..7466de74 100644 --- a/R/Functions_L2_Colony.R +++ b/R/Functions_L2_Colony.R @@ -1107,9 +1107,10 @@ removeCastePop <- function(x, caste = NULL, p = 1, use = "rand", # workerFUN gets everything via its arguments, so we also skip scanning # the colonies in X for globals (future.globals = list()), which is slow environment(workerFUN) <- new.env(parent = topenv()) - x@colonies <- future_lapply(X = tasks, FUN = workerFUN, - caste = caste, use = use, - simParamBee = simParamBee, + x@colonies <- future_mapply(FUN = workerFUN, task = tasks, + MoreArgs = list(caste = caste, use = use, + simParamBee = simParamBee), + SIMPLIFY = FALSE, USE.NAMES = FALSE, future.globals = list(), future.seed = TRUE) rm(tasks) } diff --git a/R/SIMplyBee.R b/R/SIMplyBee.R index 462a291d..cb8a9bbc 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 future.apply future_lapply future_mapply +#' @importFrom future.apply future_mapply # see https://r-pkgs.org/namespace.html on description what to import/depend/... #' @description From 9c77a52f1197b0181532466ae5b55b5b478da8fc Mon Sep 17 00:00:00 2001 From: janaobsteter Date: Tue, 27 Oct 2026 12:59:10 +0100 Subject: [PATCH 96/98] Use drone producing colony cross plans as given; add nDPC - createCrossPlan() returns one drone producing colony ID per drone; cross() uses colony cross plans as given (one entry = one father) - New nDPC and DPCAllocation ("random"/"nearest") in createCrossPlan() and cross(); spatial plans include all colonies in the radius (no longer capped at 10 by RANN::nn2) - nDrones is evaluated once, in createCrossPlan(); NULL falls back to SimParamBee$nFathers; non-whole values stop - Fix cross() giving 0 fathers when all sampled colonies produce the same number of drones (sapply matrix simplification) - Fix drone cross plans assigned in sorted rather than queen order - Fix getFathers(, collapse = TRUE) merging twice - Tests for nDPC/DPCAllocation and given plans; fix L1 test parse error and character colony IDs in tests; update D_Crossing vignette and NEWS Co-Authored-By: Claude Opus 5.5 --- NEWS.md | 27 ++++ R/Functions_L0_auxilary.R | 78 ++++++++-- R/Functions_L1_Pop.R | 48 +++---- man/createCrossPlan.Rd | 16 ++- man/cross.Rd | 13 +- tests/testthat/test-L0_auxiliary_functions.R | 141 ++++++++++++++++++- tests/testthat/test-L1_pop_functions.R | 12 +- tests/testthat/test-parallel_future.R | 2 +- vignettes/D_Crossing.Rmd | 11 +- 9 files changed, 298 insertions(+), 50 deletions(-) diff --git a/NEWS.md b/NEWS.md index 5780ec65..3e13c2a3 100644 --- a/NEWS.md +++ b/NEWS.md @@ -45,8 +45,26 @@ editor_options: the mating fails and the queens/colonies are removed from the object. This is to ensure all further functionality works well. +- cross plans with drone producing colonies now hold one colony ID per drone + (a colony ID can repeat), and `cross()` uses them as given: each entry is + one drone (father). `createCrossPlan()` returns `nDrones` colony IDs per + virgin queen; hand-made plans must list a colony once per drone (for + example, `c("5", "5")` for two drones from colony 5). Previously, a plan + listed the available colonies and `cross()` sampled `nDrones` from them. + Seeded results of crossing with drone producing colonies change. + `cross()` no longer evaluates `nDrones` itself (when `nDrones` is a + function, it was called a second time, so the number of drones in the + created cross plan and the number used for mating could differ); + `nDrones` is used only when creating the cross plan. + ## New features +- `createCrossPlan()` and `cross()` gain `nDPC` and `DPCAllocation` to limit + the number of drone producing colonies available to each virgin queen, + either a random or the nearest `nDPC` colonies (in the radius, for spatial + cross plans). Spatial cross plans now include all drone producing colonies + in the radius (previously at most 10, the default of `RANN::nn2()`). + - Both variance mappings now return `h2Queen`, `h2Worker`, `h2WorkerGroup`, and `h2Colony`, with `NA` for zero total variance. @@ -128,6 +146,15 @@ editor_options: ## Bug fixes +- `cross()` with drone producing colonies no longer mates queens with 0 + drones when all sampled drone producing colonies produce the same number + of drones. + +- `createCrossPlan()` with `drones` now assigns drones to the right virgin + queens when IDs are not in sorted order, and uses `SimParamBee$nFathers` + when `nDrones` is `NULL`. + +- `getFathers()` with `collapse = TRUE` on a MultiColony no longer fails. - with `plan(sequential)`, `createCastePop()` on a MultiColony no longer duplicates caste records in `SimParamBee` and `createMultiColony()` no diff --git a/R/Functions_L0_auxilary.R b/R/Functions_L0_auxilary.R index 6246e5ec..5f556e00 100644 --- a/R/Functions_L0_auxilary.R +++ b/R/Functions_L0_auxilary.R @@ -6320,6 +6320,12 @@ editCsdLocus <- function(pop, alleles = NULL, simParamBee = NULL) { #' @param nDrones, integer or function, number of drones to sample for each crossing. You need to provide #' this to provide this argument even when sampling drone producing colonies (otherwise, the default value #' will be used) +#' @param nDPC, integer, number of drone producing colonies to use to create drones. This is only used when supplying +#' drone colonies. If there number of available DPCs is less than nDPCs, all are retained. If \code{NULL} and +#' \code{DPCAllocation} is 'random', all DPCs are retained. +#' all DPCs in the radius are included in the cross plan. +#' @param DPCAllocation, character, "random" (default) or "nearest", whether to retain nearest nDPC or random nDPC in +#' the radius. Only applicable to when creating spatial cross plans. #' @param spatial logical, whether the drone producing colonies should be sampled according #' to their distance from the virgin colony (that is, in a radius) #' @param radius numeric, the radius from the virgin colony in which to sample mating partners, @@ -6328,12 +6334,14 @@ editCsdLocus <- function(pop, alleles = NULL, simParamBee = NULL) { #' @param ... other arguments for \code{nDrones}, when \code{nDrones} is a function #' #' @return named list with names being virgin queens/colonies IDs with each -#' list element holding the IDs of selected drones or drone producing colonies +#' list element holding the IDs of selected drones or drone producing colonies. +#' There is one ID per drone, so for drone producing colonies, a colony ID can +#' repeat (the colony then provides several drones). Virgin queens without a +#' drone producing colony in the radius get an empty element. #' #' @examples #' founderGenomes <- quickHaplo(nInd = 1000, nChr = 1, segSites = 100) #' SP <- SimParamBee$new(founderGenomes) -#' \dontshow{SP$nThreads = 1L} #' basePop <- createVirginQueens(founderGenomes) #' #' # Create three virgin MultiColony objects with locations @@ -6387,6 +6395,8 @@ createCrossPlan <- function(x, drones = NULL, droneColonies = NULL, nDrones = NULL, + nDPC = NULL, + DPCAllocation = "random", spatial = FALSE, radius, simParamBee = NULL, @@ -6413,35 +6423,77 @@ createCrossPlan <- function(x, stop("When creating a spatial cross plan, the x argument must be a Colony or MultiColony class with location set!") } + if (!is.null(nDPC) & !is.null(drones)) { + warning("Parameter nDPCs is ignored since you are providing drones, not drone (producing) colonies.") + nDPC <- NULL + } + if (!DPCAllocation %in% c("random", "nearest")) { + stop("DPCAllocation must be either 'random' or 'nearest'!") + } + if (DPCAllocation == "nearest" & is.null(nDPC)) { + stop("You can not samples nearest DPCs without specifying nDPC parameter!") + } + drones <- drones[isDrone(x = drones, simParamBee = simParamBee)] virginId <- getId(x) + if (is.null(nDrones)) { + nDrones <- simParamBee$nFathers + } if (is.function(nDrones)) { nDrones <- nDrones(n = length(virginId), ...) } else { - nDrones <- rep(nDrones, length(virginId)) + nDrones <- rep_len(nDrones, length(virginId)) + } + if (anyNA(nDrones) || any(nDrones < 0) || any(nDrones != round(nDrones))) { + stop("nDrones must be non-negative whole numbers!") + } + nDrones <- as.integer(nDrones) + + # One drone producing colony ID per drone (with replacement), so that + # cross() can use the cross plan as given + sampleDPCPerDrone <- function(dpc, n) { + if (length(dpc) == 0) { + return(dpc) + } + dpc[sample.int(length(dpc), size = n, replace = TRUE)] } if (spatial) { virginLocations <- getLocation(x, collapse = TRUE) droneLocations <- getLocation(droneColonies, collapse = TRUE) - spatialMatch <- RANN::nn2(droneLocations, virginLocations, searchtype = "radius", radius = radius) + nAll <- nrow(droneLocations) + k <- if (DPCAllocation == "nearest" && !is.null(nDPC)) min(nDPC, nAll) else nAll + spatialMatch <- RANN::nn2(droneLocations, virginLocations, searchtype = "radius", + radius = radius, k = k) + spatialMatch <- spatialMatch$nn.idx - crossPlan <- lapply(1:nrow(spatialMatch), - FUN = function(x) rownames(droneLocations)[spatialMatch[x,]]) - } else { - if (is.null(nDrones)) { - nDrones <- simParamBee$nFathers + # Drone producing colonies in the radius (nn2 pads missing matches with 0) + queenDPC <- lapply(1:nrow(spatialMatch), + FUN = function(i) rownames(droneLocations)[spatialMatch[i, ]]) + if ((DPCAllocation == "random") & !is.null(nDPC)) { + queenDPC <- lapply(queenDPC, function(dpc) if (length(dpc) > nDPC) dpc[sample.int(length(dpc), nDPC)] else dpc) } + crossPlan <- lapply(seq_along(virginId), FUN = function(i) { + sampleDPCPerDrone(queenDPC[[i]], nDrones[i]) + }) + } else { if (!is.null(drones)) { fathersMatch <- rep.int(virginId, times = nDrones) fatherIDs <- sample(drones@id, size = length(fathersMatch), replace = FALSE) - crossPlan <- base::split(fatherIDs, fathersMatch) + crossPlan <- base::split(fatherIDs, factor(fathersMatch, levels = unique(virginId))) } else { - print("Cross plan, drone colonies") - ids <- getId(droneColonies) - crossPlan <- lapply(1:length(virginId), FUN = function(x) unique(ids[sample.int(length(ids), size = nDrones[x], replace = TRUE)])) + ids <- as.character(getId(droneColonies)) + crossPlan <- lapply(seq_along(virginId), FUN = function(i) { + if (is.null(nDPC)) { + queenDPC <- ids + } else { + # This queen's nDPC colonies, at random from all available + queenDPC <- ids[sample.int(length(ids), size = min(nDPC, length(ids)))] + } + sampleDPCPerDrone(queenDPC, nDrones[i]) + }) } } names(crossPlan) <- virginId diff --git a/R/Functions_L1_Pop.R b/R/Functions_L1_Pop.R index ec38158c..384bc698 100644 --- a/R/Functions_L1_Pop.R +++ b/R/Functions_L1_Pop.R @@ -241,17 +241,11 @@ getFathers <- function(x, nInd = NULL, use = "rand", collapse = FALSE, simParamB ret <- ret[[1]] } } else if (isColony(x) | isMultiColony(x)) { + # getCastePop() already collapses or names the result for a MultiColony ret <- getCastePop(x, caste = "fathers", nInd = nInd, use = use, collapse = collapse, simParamBee = simParamBee) } else { stop("Argument x must be a Pop, Colony, or MultiColony class object!") } - if (isMultiColony(x)) { - if (collapse) { - ret <- mergePops(ret) - } else { - names(ret) <- getId(x) - } - } return(ret) } @@ -1495,7 +1489,8 @@ pullVirginQueens <- function(x, nInd = NULL, use = "rand", collapse = FALSE, sim #' one or more virgin queens / colonies to be mated; #' @param crossPlan, named list with names being virgin queen or colony IDs with #' each list element holding the IDs of either selected drones or selected -#' drone producing colonies, OR a string "create" if you want the cross plan to be created +#' drone producing colonies (one ID per drone, so a colony ID repeated n times +#' gives n drones from that colony), OR a string "create" if you want the cross plan to be created #' internally. The function can create a random (\code{spatial = FALSE}) #' or spatial (\code{spatial = TRUE}) cross plan internally. Also see #' \code{\link[SIMplyBee]{createCrossPlan}}. @@ -1515,6 +1510,12 @@ pullVirginQueens <- function(x, nInd = NULL, use = "rand", collapse = FALSE, sim #' internally (when \code{crossPlan} is "create") #' @param nDrones numeric of function, the number of drones to sample to mate with each #' virgin queen when using a cross plan +#' @param nDPC integer, number of drone producing colonies available to each virgin +#' queen when creating a cross plan with \code{droneColonies}; if \code{NULL}, all +#' (in the radius, when \code{spatial = TRUE}). See +#' \code{\link[SIMplyBee]{createCrossPlan}} +#' @param DPCAllocation character, "random" or "nearest", see +#' \code{\link[SIMplyBee]{createCrossPlan}} #' @param spatial logical, whether the drone producing colonies should be sampled according #' 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, @@ -1667,6 +1668,8 @@ cross <- function(x, drones = NULL, droneColonies = NULL, nDrones = NULL, + nDPC = NULL, + DPCAllocation = "random", spatial = FALSE, radius = NULL, checkCross = "error", @@ -1735,6 +1738,9 @@ cross <- function(x, if (crossPlan_given && !all(IDs %in% names(crossPlan))) { #Check for cross plan stop("Cross plan must include all the virgin queens/colonies!") } + if (!is.null(droneColonies) & is.null(crossPlan)) { + stop("When providing drone colonies, cross plan needs to be set to 'create'") + } if (isPop(x)) { if (any(!isVirginQueen(x, simParamBee = simParamBee))) { stop("Individuals in pop must be virgin queens!") @@ -1755,9 +1761,11 @@ cross <- function(x, drones = drones, droneColonies = droneColonies, nDrones = nDrones, + nDPC = nDPC, + DPCAllocation = DPCAllocation, spatial = spatial, radius = radius, - simParamBee = simParamBee) + simParamBee = simParamBee, ...) } noMatches <- sapply(crossPlan, FUN = length) @@ -1802,16 +1810,6 @@ cross <- function(x, - if (is.function(nDrones)) { - nD = nDrones(n = nVirgin, ...) - } else { - nD = nDrones - } - - if (length(IDs) > 0 & length(nD) == 1) { - nD = rep(nD, length(IDs)) - } - 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 @@ -1823,12 +1821,10 @@ cross <- function(x, if (type == "MultiColony") { multicolony <- multicolony[getId(getVirginQueens(multicolony, collapse = TRUE, simParamBee = simParamBee)) %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 = crossPlan[[x]][sample.int(length(crossPlan[[x]]), size = nD[which(x == IDs)], replace = TRUE)]) - } )) - crossPlanDF_sample <- crossPlanDF_sample[order(as.character(crossPlanDF_sample$DPC)),] + # The cross plan holds one drone producing colony ID per drone, so we use + # it as given: each entry is one drone (father) for that virgin queen + crossPlanDF <- crossPlanDF[crossPlanDF$virginID %in% IDs, ] + crossPlanDF <- crossPlanDF[order(crossPlanDF$DPC), ] # Here I gather how many drones each DPC needs to produce crossPlanDF_DPCtable <- as.data.frame(table(crossPlanDF_sample$DPC)) crossPlanDF_DPCtable <- crossPlanDF_DPCtable[order(as.character(crossPlanDF_DPCtable$Var1)),] @@ -1841,7 +1837,7 @@ cross <- function(x, 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)))) + droneID = unlist(lapply(dronesByDPC, FUN = function(x) as.character(getId(x))), use.names = FALSE)) dronesByDPC_DF <- dronesByDPC_DF[order(as.character(dronesByDPC_DF$DPC)),] dronePop = mergePops(dronesByDPC) diff --git a/man/createCrossPlan.Rd b/man/createCrossPlan.Rd index 8db00494..dd52bd26 100644 --- a/man/createCrossPlan.Rd +++ b/man/createCrossPlan.Rd @@ -9,6 +9,8 @@ createCrossPlan( drones = NULL, droneColonies = NULL, nDrones = NULL, + nDPC = NULL, + DPCAllocation = "random", spatial = FALSE, radius, simParamBee = NULL, @@ -34,6 +36,14 @@ the object needs to have the location set} this to provide this argument even when sampling drone producing colonies (otherwise, the default value will be used)} +\item{nDPC, }{integer, number of drone producing colonies to use to create drones. This is only used when supplying +drone colonies. If there number of available DPCs is less than nDPCs, all are retained. If \code{NULL} and +\code{DPCAllocation} is 'random', all DPCs are retained. +all DPCs in the radius are included in the cross plan.} + +\item{DPCAllocation, }{character, "random" (default) or "nearest", whether to retain nearest nDPC or random nDPC in +the radius. Only applicable to when creating spatial cross plans.} + \item{spatial}{logical, whether the drone producing colonies should be sampled according to their distance from the virgin colony (that is, in a radius)} @@ -46,7 +56,10 @@ only needed when \code{spatial = TRUE}} } \value{ named list with names being virgin queens/colonies IDs with each - list element holding the IDs of selected drones or drone producing colonies + list element holding the IDs of selected drones or drone producing colonies. + There is one ID per drone, so for drone producing colonies, a colony ID can + repeat (the colony then provides several drones). Virgin queens without a + drone producing colony in the radius get an empty element. } \description{ Level 0 function that creates a plan for crossing virgin queens or @@ -57,7 +70,6 @@ Level 0 function that creates a plan for crossing virgin queens or \examples{ founderGenomes <- quickHaplo(nInd = 1000, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes) -\dontshow{SP$nThreads = 1L} basePop <- createVirginQueens(founderGenomes) # Create three virgin MultiColony objects with locations diff --git a/man/cross.Rd b/man/cross.Rd index 7bd44f8c..6d84d62b 100644 --- a/man/cross.Rd +++ b/man/cross.Rd @@ -11,6 +11,8 @@ cross( drones = NULL, droneColonies = NULL, nDrones = NULL, + nDPC = NULL, + DPCAllocation = "random", spatial = FALSE, radius = NULL, checkCross = "error", @@ -24,7 +26,8 @@ one or more virgin queens / colonies to be mated;} \item{crossPlan, }{named list with names being virgin queen or colony IDs with each list element holding the IDs of either selected drones or selected -drone producing colonies, OR a string "create" if you want the cross plan to be created +drone producing colonies (one ID per drone, so a colony ID repeated n times +gives n drones from that colony), OR a string "create" if you want the cross plan to be created internally. The function can create a random (\code{spatial = FALSE}) or spatial (\code{spatial = TRUE}) cross plan internally. Also see \code{\link[SIMplyBee]{createCrossPlan}}.} @@ -48,6 +51,14 @@ internally (when \code{crossPlan} is "create")} \item{nDrones}{numeric of function, the number of drones to sample to mate with each virgin queen when using a cross plan} +\item{nDPC}{integer, number of drone producing colonies available to each virgin +queen when creating a cross plan with \code{droneColonies}; if \code{NULL}, all +(in the radius, when \code{spatial = TRUE}). See +\code{\link[SIMplyBee]{createCrossPlan}}} + +\item{DPCAllocation}{character, "random" or "nearest", see +\code{\link[SIMplyBee]{createCrossPlan}}} + \item{spatial}{logical, whether the drone producing colonies should be sampled according to their distance from the virgin colony (that is, in a radius)} diff --git a/tests/testthat/test-L0_auxiliary_functions.R b/tests/testthat/test-L0_auxiliary_functions.R index 79d738d4..645d484f 100644 --- a/tests/testthat/test-L0_auxiliary_functions.R +++ b/tests/testthat/test-L0_auxiliary_functions.R @@ -1662,11 +1662,14 @@ test_that("createCrossPlan", { ) expect_length(crossPlanSpatial, 2) - expect_error(createCrossPlan( + # Without nDrones, SP$nFathers is used + crossPlanDefault <- createCrossPlan( x = droneColonies, droneColonies = virginColonies1, simParamBee = SP - )) + ) + expect_length(crossPlanDefault, nColonies(droneColonies)) + expect_true(all(lengths(crossPlanDefault) > 0)) }) # ---- getCaste ---- @@ -1933,3 +1936,137 @@ test_that("colony value callbacks receive individual colonies positionally", { } } }) + +# ---- createCrossPlan: nDPC and DPCAllocation ---- + +test_that("createCrossPlan limits drone producing colonies with nDPC and DPCAllocation", { + founderGenomes <- quickHaplo(nInd = 30, nChr = 1, segSites = 100) + SP <- SimParamBee$new(founderGenomes, csdChr = NULL) + SP$nThreads <- 1L + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) + + # One virgin colony at (0, 0) and 12 drone producing colonies on a line at + # distances 1, 2, ..., 12; a second virgin colony far away from all of them + virginColonies <- createMultiColony(basePop[1:2], simParamBee = SP) + virginColonies <- setLocation(virginColonies, location = list(c(0, 0), c(1000, 1000)), + simParamBee = SP) + droneColonies <- createMultiColony(basePop[3:14], simParamBee = SP) + droneColonies <- setLocation(droneColonies, location = lapply(1:12, function(d) c(d, 0)), + simParamBee = SP) + dpcIds <- as.character(getId(droneColonies)) + virginIds <- as.character(getId(virginColonies)) + # Many drones, so that every available colony is sampled at least once + # (missing one of 12 colonies in 200 draws has probability < 1e-6) + nDrones <- 200 + createPlan <- function(...) { + createCrossPlan(x = virginColonies, droneColonies = droneColonies, nDrones = nDrones, + spatial = TRUE, simParamBee = SP, ...) + } + + # One colony ID per drone + set.seed(1) + plan <- createPlan(radius = 20) + expect_identical(names(plan), virginIds) + expect_length(plan[[1]], nDrones) + expect_length(plan[[2]], 0) + # No nDPC: all colonies in the radius (more than nn2's default of 10) + expect_setequal(unique(plan[[1]]), dpcIds) + plan <- createPlan(radius = 5.5) + expect_setequal(unique(plan[[1]]), dpcIds[1:5]) + + # Random nDPC: nDPC colonies at random from all in the radius + plans <- lapply(1:30, function(i) createPlan(radius = 20, nDPC = 3, DPCAllocation = "random")) + expect_true(all(sapply(plans, function(p) length(p[[1]]) == nDrones && length(unique(p[[1]])) == 3))) + expect_true(all(unlist(lapply(plans, `[[`, 1)) %in% dpcIds)) + # Not always the nearest ones, and colonies beyond the 10th nearest are used + expect_true(any(sapply(plans, function(p) !setequal(unique(p[[1]]), dpcIds[1:3])))) + expect_true(any(unlist(lapply(plans, `[[`, 1)) %in% dpcIds[11:12])) + # Only colonies in the radius + plan <- createPlan(radius = 5.5, nDPC = 3, DPCAllocation = "random") + expect_true(all(plan[[1]] %in% dpcIds[1:5])) + # nDPC larger than the colonies in the radius keeps all of them + plan <- createPlan(radius = 2.5, nDPC = 5, DPCAllocation = "random") + expect_setequal(unique(plan[[1]]), dpcIds[1:2]) + + # Nearest nDPC: the nDPC nearest colonies in the radius + plan <- createPlan(radius = 20, nDPC = 3, DPCAllocation = "nearest") + expect_length(plan[[1]], nDrones) + expect_setequal(unique(plan[[1]]), dpcIds[1:3]) + expect_length(plan[[2]], 0) + plan <- createPlan(radius = 2.5, nDPC = 5, DPCAllocation = "nearest") + expect_setequal(unique(plan[[1]]), dpcIds[1:2]) + # nDPC larger than all drone producing colonies + plan <- createPlan(radius = 20, nDPC = 50, DPCAllocation = "nearest") + expect_setequal(unique(plan[[1]]), dpcIds) + + # Input checks + expect_error(createPlan(radius = 20, DPCAllocation = "nearest")) + expect_error(createPlan(radius = 20, nDPC = 3, DPCAllocation = "closest")) + expect_error(createCrossPlan(x = virginColonies, droneColonies = droneColonies, nDrones = 2.5, + simParamBee = SP)) + + # Non-spatial: nDPC colonies per queen at random from all available + plan <- createCrossPlan(x = virginColonies, droneColonies = droneColonies, nDrones = nDrones, + nDPC = 3, spatial = FALSE, simParamBee = SP) + expect_identical(names(plan), virginIds) + for (p in plan) { + expect_length(p, nDrones) + expect_length(unique(p), 3) + expect_true(all(p %in% dpcIds)) + } + plan <- createCrossPlan(x = virginColonies, droneColonies = droneColonies, nDrones = nDrones, + spatial = FALSE, simParamBee = SP) + for (p in plan) { + expect_length(p, nDrones) + expect_setequal(unique(p), dpcIds) + } + # nDrones per virgin queen + plan <- createCrossPlan(x = virginColonies, droneColonies = droneColonies, nDrones = function(n) c(4, 7), + spatial = FALSE, simParamBee = SP) + expect_identical(unname(lengths(plan)), c(4L, 7L)) +}) + +test_that("cross uses a drone producing colony cross plan as given", { + founderGenomes <- quickHaplo(nInd = 20, nChr = 1, segSites = 100) + SP <- SimParamBee$new(founderGenomes, csdChr = NULL) + SP$nThreads <- 1L + SP$setTrackPed(TRUE) + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) + drones <- createDrones(basePop[1:2], nInd = 50, simParamBee = SP) + queens <- cross(basePop[3:5], drones = drones, crossPlan = "create", + nDrones = 5, simParamBee = SP) + droneColonies <- createMultiColony(queens, simParamBee = SP) + dpcIds <- as.character(getId(droneColonies)) + dpcQueens <- getCasteId(droneColonies, caste = "queen", collapse = TRUE, simParamBee = SP) + names(dpcQueens) <- dpcIds + virginColonies <- createMultiColony(basePop[6:7], simParamBee = SP) + virginIds <- as.character(getId(virginColonies)) + + # 3 drones from the first and 1 from the third colony; 2 from the second + crossPlan <- list(c(dpcIds[1], dpcIds[1], dpcIds[3], dpcIds[1]), + c(dpcIds[2], dpcIds[2])) + names(crossPlan) <- virginIds + mated <- cross(virginColonies, droneColonies = droneColonies, crossPlan = crossPlan, + simParamBee = SP) + expect_identical(unname(nFathers(mated, simParamBee = SP)), c(4L, 2L)) + for (colony in 1:2) { + fathers <- getFathers(mated[[colony]], simParamBee = SP) + fatherMothers <- as.character(SP$pedigree[fathers@id, "mother"]) + expect_identical(sort(fatherMothers), + sort(unname(as.character(dpcQueens[crossPlan[[colony]]])))) + } + + # A created spatial plan: each queen mates with nDrones drones + virginColonies <- createMultiColony(basePop[8:9], simParamBee = SP) + virginColonies <- setLocation(virginColonies, location = list(c(0, 0), c(0, 1)), simParamBee = SP) + droneColonies <- setLocation(droneColonies, location = list(c(1, 0), c(2, 0), c(3, 0)), + simParamBee = SP) + mated <- cross(virginColonies, droneColonies = droneColonies, crossPlan = "create", + nDrones = 6, nDPC = 1, DPCAllocation = "nearest", spatial = TRUE, radius = 10, + simParamBee = SP) + expect_identical(unname(nFathers(mated, simParamBee = SP)), c(6L, 6L)) + # All fathers come from the nearest colony + fathers <- getCasteId(mated, caste = "fathers", collapse = TRUE, simParamBee = SP) + expect_length(fathers, 12) + expect_true(all(as.character(SP$pedigree[fathers, "mother"]) == dpcQueens[dpcIds[1]])) +}) diff --git a/tests/testthat/test-L1_pop_functions.R b/tests/testthat/test-L1_pop_functions.R index 366ea178..348a9e9d 100644 --- a/tests/testthat/test-L1_pop_functions.R +++ b/tests/testthat/test-L1_pop_functions.R @@ -434,10 +434,12 @@ test_that("cross samples drones only from the drone producing colonies in the cr simParamBee = SP)), simParamBee = SP) dpcs <- apiary[5:6] - crossPlan <- as.list(rep(getId(dpcs)[2], nColonies(virginColonies))) + # (10 drones each, one colony ID per drone) + crossPlan <- rep(list(rep(getId(dpcs)[2], 10)), nColonies(virginColonies)) names(crossPlan) <- getId(virginColonies) - mated <- cross(virginColonies, droneColonies = dpcs, nDrones = 10, + mated <- cross(virginColonies, droneColonies = dpcs, crossPlan = crossPlan, simParamBee = SP) + expect_true(all(nFathers(mated, simParamBee = SP) == 10)) fatherIds <- getCasteId(mated, caste = "fathers", collapse = TRUE, simParamBee = SP) expect_true(all(SP$pedigree[fatherIds, "mother"] == as.integer(dpcQueenId))) }) @@ -480,6 +482,8 @@ test_that("createCastePop on a MultiColony records all new individuals in SimPar expect_true(all(SP$pedigree[added, "mother"] == as.integer(queenIds[colony]))) } } +}) + # ---- cross plans with character IDs ---- test_that("cross plans match character colony IDs independently of queen IDs", { @@ -495,7 +499,9 @@ test_that("cross plans match character colony IDs independently of queen IDs", { apiary <- c(createColony(basePop[3], id = "hive-C", simParamBee = SP), createColony(basePop[4], id = "hive-A", simParamBee = SP), createColony(basePop[5], id = "hive-B", simParamBee = SP)) - plan <- list("hive-B" = "donor-B", "hive-C" = "donor-A", "hive-A" = "donor-B") + # One drone producing colony ID per drone (the plan is used as given) + plan <- list("hive-B" = c("donor-B", "donor-B"), "hive-C" = c("donor-A", "donor-A"), + "hive-A" = c("donor-B", "donor-B")) mated <- expect_no_warning(cross(apiary, droneColonies = donors, crossPlan = plan, nDrones = 2, simParamBee = SP)) expect_identical(getId(mated), c("hive-C", "hive-A", "hive-B")) diff --git a/tests/testthat/test-parallel_future.R b/tests/testthat/test-parallel_future.R index a9999091..16af5284 100644 --- a/tests/testthat/test-parallel_future.R +++ b/tests/testthat/test-parallel_future.R @@ -76,7 +76,7 @@ test_that("createCastePop on MultiColony keeps simParamBee bookkeeping consisten apiary <- createMultiColony(queens, simParamBee = SP) # Each colony gets exactly one new ID expect_equal(SP$lastColonyId, lastColonyId + 4) - expect_equal(getId(apiary), lastColonyId + 1:4) + expect_identical(getId(apiary), as.character(as.integer(lastColonyId) + 1:4)) apiary <- addWorkers(apiary, nInd = c(3, 1, 5, 2), simParamBee = SP) apiary <- addVirginQueens(apiary, nInd = 2, simParamBee = SP) diff --git a/vignettes/D_Crossing.Rmd b/vignettes/D_Crossing.Rmd index 70418894..7df06364 100644 --- a/vignettes/D_Crossing.Rmd +++ b/vignettes/D_Crossing.Rmd @@ -337,11 +337,18 @@ crossPlan2 <- createCrossPlan(x = beekeeper3, nDrones = 13) # Inspect the cross plan crossPlan2 +# Number of drones (one drone producing colony ID per drone) sapply(crossPlan2, length) +# Number of different drone producing colonies +sapply(crossPlan2, function(x) length(unique(x))) ``` -We see that there is a different number of drone producing queen for each virgin -queen in the specified radius . It could also happen, there are no drone +The cross plan holds one drone producing colony ID per drone, sampled from the +drone producing colonies in the specified radius, so a colony ID can repeat. +We see that there is a different number of drone producing colonies for each +virgin queen in the specified radius. You can limit the number of drone +producing colonies per virgin queen with the `nDPC` argument, taking either a +random or the nearest `nDPC` colonies (`DPCAllocation`). It could also happen, there are no drone producing colonies in that radius. In that case, you can either increase the radius, if you think that is sensible, or some virgin queens will remain unmated. Once we have the spatial cross plan, we can mate our colonies. From f5e3bbd4212fca01cb237528bf364aec61c605b5 Mon Sep 17 00:00:00 2001 From: janaobsteter Date: Tue, 27 Oct 2026 12:00:38 +0000 Subject: [PATCH 97/98] Update documentation --- man/SIMplyBee-package.Rd | 1 + 1 file changed, 1 insertion(+) diff --git a/man/SIMplyBee-package.Rd b/man/SIMplyBee-package.Rd index 02b01c03..99748e94 100644 --- a/man/SIMplyBee-package.Rd +++ b/man/SIMplyBee-package.Rd @@ -37,6 +37,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}) From 6d6344102205f249848659e2c4f8e399be240d54 Mon Sep 17 00:00:00 2001 From: janaobsteter Date: Tue, 27 Oct 2026 14:17:03 +0100 Subject: [PATCH 98/98] Removed crossPlanDF_sample --- R/Functions_L1_Pop.R | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/R/Functions_L1_Pop.R b/R/Functions_L1_Pop.R index 384bc698..ddc61cbd 100644 --- a/R/Functions_L1_Pop.R +++ b/R/Functions_L1_Pop.R @@ -1826,7 +1826,7 @@ cross <- function(x, crossPlanDF <- crossPlanDF[crossPlanDF$virginID %in% IDs, ] crossPlanDF <- crossPlanDF[order(crossPlanDF$DPC), ] # Here I gather how many drones each DPC needs to produce - crossPlanDF_DPCtable <- as.data.frame(table(crossPlanDF_sample$DPC)) + crossPlanDF_DPCtable <- as.data.frame(table(crossPlanDF$DPC)) crossPlanDF_DPCtable <- crossPlanDF_DPCtable[order(as.character(crossPlanDF_DPCtable$Var1)),] colnames(crossPlanDF_DPCtable) <- c("DPC", "noDrones") # Here I select only the DPCs that have been sampled to produce drones @@ -1841,11 +1841,11 @@ cross <- function(x, dronesByDPC_DF <- dronesByDPC_DF[order(as.character(dronesByDPC_DF$DPC)),] dronePop = mergePops(dronesByDPC) - if (any(!crossPlanDF_sample$DPC == dronesByDPC_DF$DPC)) { + if (any(!crossPlanDF$DPC == dronesByDPC_DF$DPC)) { stop("Something went wrong with cross plan - drone matching!") } - dronesByVirgin_DF <- cbind(dronesByDPC_DF, crossPlanDF_sample[, c("virginID"), drop = FALSE]) + dronesByVirgin_DF <- cbind(dronesByDPC_DF, crossPlanDF[, c("virginID"), drop = FALSE]) dronesByVirgin_DF <- dronesByVirgin_DF[order(match(dronesByVirgin_DF$virginID, IDs)),] dronesByVirgin_list <- lapply(IDs, FUN = function(x) dronesByVirgin_DF$droneID[dronesByVirgin_DF$virginID == x])