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/.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")' 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 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 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/ 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. diff --git a/DESCRIPTION b/DESCRIPTION index 5ac2bc7d..2f7b3eb1 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,10 +26,9 @@ 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) -Depends: R (>= 3.3.0), AlphaSimR (>= 1.5.3) +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/NAMESPACE b/NAMESPACE index 231169a0..9e20e95b 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -2,6 +2,7 @@ export(SimParamBee) export(addCastePop) +export(addCastePop_internal) export(addDrones) export(addVirginQueens) export(addWorkers) @@ -32,6 +33,7 @@ export(createMultiColony) export(createVirginQueens) export(createWorkers) export(cross) +export(crossVirginQueen) export(downsize) export(downsizePUnif) export(getCaste) @@ -69,13 +71,11 @@ export(getGv) export(getIbdHaplo) export(getId) export(getLocation) -export(getMisc) export(getPheno) export(getPooledGeno) export(getQtlGeno) export(getQtlHaplo) export(getQueen) -export(getQueenAge) export(getQueenCsdAlleles) export(getQueenCsdGeno) export(getQueenGv) @@ -87,7 +87,6 @@ export(getQueenSegSiteGeno) export(getQueenSegSiteHaplo) export(getQueenSnpGeno) export(getQueenSnpHaplo) -export(getQueenYearOfBirth) export(getSegSiteGeno) export(getSegSiteHaplo) export(getSnpGeno) @@ -145,6 +144,9 @@ export(mapCasteToColonyGv) export(mapCasteToColonyPheno) export(mapCasteToColonyValue) export(nCaste) +export(nCasteColonyPhenotype) +export(nCastePoisson) +export(nCasteTruncPoisson) export(nColonies) export(nCsdAlleles) export(nDrones) @@ -192,8 +194,6 @@ export(replaceWorkers) export(resetEvents) export(selectColonies) export(setLocation) -export(setMisc) -export(setQueensYearOfBirth) export(simulateHoneyBeeGenomes) export(split) export(splitPColonyStrength) @@ -207,6 +207,7 @@ import(AlphaSimR) import(Rcpp) importFrom(R6,R6Class) importFrom(extraDistr,rtpois) +importFrom(future.apply,future_lapply) importFrom(methods,"slot<-") importFrom(methods,classLabel) importFrom(methods,is) diff --git a/NEWS.md b/NEWS.md index d72a41ac..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 @@ -57,8 +84,6 @@ which caused an error. We now read in the locations from a csv file. - 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/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 5ca066c3..9e7130fc 100644 --- a/R/Class-SimParamBee.R +++ b/R/Class-SimParamBee.R @@ -425,13 +425,112 @@ SimParamBee <- R6Class( invisible(self) }, + #' @description For internal use only. + #' + #' @param nNewInd Number of newly created individuals + #' @param id the name of each individual + #' @param mother vector of mother iids + #' @param father vector of father iids + #' @param isDH indicator for DH lines + addToBeePed = function(nNewInd,id,mother,father,isDH) { + stopifnot(nNewInd>0) + if(length(isDH)==1) isDH = rep(isDH,nNewInd) + mother = as.integer(mother) + father = as.integer(father) + isDH = as.integer(isDH) + stopifnot(length(mother)==nNewInd, + length(father)==nNewInd, + length(isDH)==nNewInd) + tmp = cbind(mother,father,isDH) + rownames(tmp) = id + private$.pedigree = rbind(private$.pedigree,tmp) + private$.lastId = private$.lastId + as.integer(nNewInd) + invisible(self) + }, + + + #' @description For internal use only. + #' + #' @param nNewInd Number of newly created individuals + #' @param id the name of each individual + #' @param mother vector of mother iids + #' @param father vector of father iids + #' @param isDH indicator for DH lines + #' @param hist new recombination history + #' @param ploidy ploidy level + addToBeeRec = function(nNewInd,id,mother,father,isDH, + hist,ploidy){ + stopifnot(nNewInd>0) + if(length(isDH)==1) isDH = rep(isDH,nNewInd) + mother = as.integer(mother) + father = as.integer(father) + isDH = as.integer(isDH) + stopifnot(length(mother)==nNewInd, + length(father)==nNewInd, + length(isDH)==nNewInd) + tmp = cbind(mother,father,isDH) + rownames(tmp) = id + if(is.null(hist)){ + newRecHist = vector("list",nNewInd) + tmpLastHaplo = private$.lastHaplo + if(all(isDH==1L)){ + for(i in seq_len(nNewInd)){ + tmpLastHaplo = tmpLastHaplo + 1L + newRecHist[[i]] = rep(tmpLastHaplo, ploidy) + } + }else{ + for(i in seq_len(nNewInd)){ + newRecHist[[i]] = (tmpLastHaplo+1L):(tmpLastHaplo+ploidy) + tmpLastHaplo = tmpLastHaplo + ploidy + } + } + private$.hasHap = c(private$.hasHap, rep(FALSE, nNewInd)) + private$.isFounder = c(private$.isFounder, rep(TRUE, nNewInd)) + #names(newRecHist) = id + private$.recHist = c(private$.recHist, newRecHist) + private$.lastHaplo = tmpLastHaplo + }else{ + # Add hist to recombination history + private$.hasHap = c(private$.hasHap, rep(FALSE, nNewInd)) + private$.isFounder = c(private$.isFounder, rep(FALSE, nNewInd)) + #names(hist) = id + private$.recHist = c(private$.recHist, hist) + } + private$.pedigree = rbind(private$.pedigree, tmp) + private$.lastId = private$.lastId + as.integer(nNewInd) + + invisible(self) + }, + + #' @description A function to update the caste + #' For internal use only. + #' + #' @param caste vector, named vector of castes to be added + updateCaste = function(caste) { + private$.caste = c(private$.caste, caste) + invisible(self) + }, + + #' @description A function to update the last + #' ID everytime we create an individual + #' For internal use in SIMplyBee only. + #' + #' @param lastId integer, last colony ID assigned + #' @param n integer, how many individuals to add + updateLastBeeId = function(n = 1L) { + private$.lastId = private$.lastId + as.integer(n) + invisible(self) + }, + #' @description A function to update the colony last #' ID everytime we create a Colony-class with createColony. #' For internal use only. #' #' @param lastColonyId integer, last colony ID assigned - updateLastColonyId = function() { - private$.lastColonyId = private$.lastColonyId + 1L + #' @param n integer, how many colonies to add + updateLastColonyId = function(n = 1) { + n = as.integer(n) + private$.lastColonyId = private$.lastColonyId + n invisible(self) } ), @@ -459,7 +558,7 @@ SimParamBee <- R6Class( #' created caste = function(value) { if (missing(value)) { - x = private$.caste + x = private$.caste } else { stop("`$caste` is read only", call. = FALSE) } @@ -469,7 +568,7 @@ SimParamBee <- R6Class( #' created with \code{\link[SIMplyBee]{createColony}} lastColonyId = function(value) { if (missing(value)) { - private$.lastColonyId + private$.lastColonyId } else { stop("`$lastColonyId` is read only", call. = FALSE) } @@ -571,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 @@ -596,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} @@ -641,327 +739,160 @@ 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 = 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 + } else if (isMultiColony(x)) { + n <- nColonies(x) + } return(rpois(n = n, lambda = average)) } -#' @describeIn nWorkersFun Sample a non-zero number of workers +#' @title nVirginQueensPoisson +#' @describeIn nCasteFun Sample the number of virgin queens +#' from a Poisson distribution #' @export -nWorkersTruncPoisson <- function(colony, n = 1, average = 100, lowerLimit = 0) { - return(extraDistr::rtpois(n = n, lambda = average, a = lowerLimit)) +nVirginQueensPoisson <- function(x = NULL, n = 1, average = 10) { + nCastePoisson(x = x, n = n, average = average) +} +#' @title nFathersPoisson +#' @describeIn nCasteFun Sample the number of fathers +#' from a Poisson distribution +#' @export +nFathersPoisson <- function(x = NULL, n = 1, average = 15) { + nCastePoisson(x = x, n = n, average = average) +} +#' @title nWorkersPoisson +#' @describeIn nCasteFun Sample the number of workers +#' from a Poisson distribution +#' @export +nWorkersPoisson <- function(x = NULL, n = 1, average = 100) { + nCastePoisson(x = x, n = n, average = average) +} +#' @title nDronesPoisson +#' @describeIn nCasteFun Sample the number of drones +#' from a Poisson distribution +#' @export +nDronesPoisson <- function(x = NULL, 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 +#' @title nCasteTruncPoisson +#' @describeIn nCasteFun Sample a non-zero number of caste individuals from a Poisson +#' distribution #' @export -nWorkersColonyPhenotype <- function(colony, queenTrait = 1, workersTrait = NULL, - checkProduction = FALSE, lowerLimit = 0, - simParamBee = NULL, - ...) { - if (is.null(simParamBee)) { - simParamBee <- get(x = "SP", envir = .GlobalEnv) +nCasteTruncPoisson <- function(x = NULL, n = 1, average = 100, lowerLimit = 0) { + if (isColony(x)) { + n <- 1 + } else if (isMultiColony(x)) { + n <- nColonies(x) } - ret <- round(mapCasteToColonyPheno( - colony = colony, - queenTrait = queenTrait, - workersTrait = workersTrait, - checkProduction = checkProduction, - simParamBee = simParamBee, - ... - )) - if (ret < (lowerLimit + 1)) { - ret <- lowerLimit + 1 - } - 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) +#' @title nVirginQueensTruncPoisson +#' @describeIn nCasteFun Sample a non-zero number of virgin queens +#' from a Poisson distribution #' @export -nDronesPoisson <- function(x, n = 1, average = 100) { - return(rpois(n = n, lambda = average)) +nVirginQueensTruncPoisson <- function(x = NULL, n = 1, average = 10, lowerLimit = 0) { + nCasteTruncPoisson(x = x, n = n, average = average, lowerLimit = lowerLimit) } -#' @describeIn nDronesFun Sample a non-zero number of drones +#' @title nFathersTruncPoisson +#' @describeIn nCasteFun Sample a non-zero number of fathers +#' from a Poisson distribution #' @export -nDronesTruncPoisson <- function(x, n = 1, average = 100, lowerLimit = 0) { - return(extraDistr::rtpois(n = n, lambda = average, a = lowerLimit)) +nFathersTruncPoisson <- function(x = NULL, n = 1, average = 15, lowerLimit = 0) { + nCasteTruncPoisson(x = x, n = n, average = average, lowerLimit = lowerLimit) +} +#' @title nWorkersTruncPoisson +#' @describeIn nCasteFun Sample a non-zero number of workers +#' from a Poisson distribution +#' @export +nWorkersTruncPoisson <- function(x = NULL, n = 1, average = 100, lowerLimit = 0) { + nCasteTruncPoisson(x = x, n = n, average = average, lowerLimit = lowerLimit) +} +#' @title nDronesTruncPoisson +#' @describeIn nCasteFun Sample a non-zero number of drones +#' from a Poisson distribution +#' @export +nDronesTruncPoisson <- function(x = NULL, n = 1, average = 100, lowerLimit = 0) { + nCasteTruncPoisson(x = x, n = n, average = average, lowerLimit = lowerLimit) } -#' @describeIn nDronesFun Sample a non-zero number of drones based on +#' @title nCasteColonyPhenotype +#' @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 -#' @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 +#' @title nVirginQueensColonyPhenotype +#' @describeIn nCasteFun Sample a non-zero number of virgin queens based on +#' colony phenotype, say queen's fecundity #' @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) +#' @title nWorkersColonyPhenotype +#' @describeIn nCasteFun Sample a non-zero number of workers based on +#' colony phenotype, say queen's fecundity #' @export -nFathersPoisson <- function(n = 1, average = 15) { - return(rpois(n = n, lambda = average)) +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 nFathersFun Sample a non-zero number of fathers +#' @title nDronesColonyPhenotype +#' @describeIn nCasteFun Sample a non-zero number of drones based on +#' colony phenotype, say queen's fecundity #' @export -nFathersTruncPoisson <- function(n = 1, average = 15, lowerLimit = 0) { - return(extraDistr::rtpois(n = n, lambda = average, a = lowerLimit)) +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, + ...) } # pFunctions ---- @@ -975,7 +906,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} @@ -998,7 +929,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 = NULL, 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)) } @@ -1013,7 +949,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} @@ -1079,14 +1015,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 = NULL, 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, @@ -1107,7 +1053,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} @@ -1122,7 +1068,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 = NULL, 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)) } @@ -1146,21 +1097,24 @@ 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 -#' \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 @@ -1191,7 +1145,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) @@ -1245,7 +1200,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, @@ -1267,95 +1222,129 @@ mapCasteToColonyValue <- function(colony, if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } - 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] - } - 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 (isColony(x)) { + if (is.null(queenTrait)) { + queenEff <- 0 + } else { + 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 + } } - 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 (is.null(workersTrait)) { + workersEff <- 0 + } else { + 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 + } } - dronesEff <- dronesFUN(tmp) - } - 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 28e56689..fbbb20b5 100644 --- a/R/Functions_L0_auxilary.R +++ b/R/Functions_L0_auxilary.R @@ -359,11 +359,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) @@ -952,150 +952,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 #' @@ -1769,7 +1625,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) #' @@ -2342,6 +2198,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, @@ -2359,6 +2218,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, @@ -2378,6 +2240,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, @@ -2396,6 +2261,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, @@ -2414,6 +2282,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, @@ -2545,7 +2416,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)) { @@ -2581,6 +2452,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, @@ -2596,6 +2470,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", @@ -2613,6 +2490,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", @@ -2629,6 +2509,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", @@ -2646,6 +2529,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", @@ -2679,7 +2565,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 @@ -2881,10 +2768,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) #' @@ -2894,13 +2781,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)) @@ -2912,6 +2799,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! #' @@ -2926,6 +2815,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) @@ -5226,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) @@ -6338,7 +6230,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)) { @@ -6406,10 +6298,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]) @@ -6429,58 +6317,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, @@ -6548,93 +6401,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 005fe4fd..f69c365c 100644 --- a/R/Functions_L1_Pop.R +++ b/R/Functions_L1_Pop.R @@ -1,4 +1,8 @@ # ---- Level 1 Pop Functions ---- +utils::globalVariables("colony") +utils::globalVariables("i") +utils::globalVariables("cl") + #' @rdname getCastePop #' @title Access individuals of a caste @@ -218,18 +222,18 @@ 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, - 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 (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) + } + } ) if (nInd(x) == 1) { ret <- ret[[1]] @@ -295,11 +299,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 #' locus (to get viable virgin queens); see \code{csdAlleles} @@ -313,6 +312,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 (used internally +#' for parallel computing) #' @param ... additional arguments passed to \code{nInd} when this argument is a function #' #' @return when \code{x} is \code{\link[AlphaSimR]{MapPop-class}} returns @@ -327,7 +330,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 @@ -345,7 +348,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 @@ -398,13 +401,15 @@ 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, - exact = TRUE, year = NULL, editCsd = TRUE, csdAlleles = NULL, simParamBee = NULL, + returnSP = FALSE, + ids = NULL, ...) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } + if (is.null(nInd)) { if (caste == "virginQueens") { nInd <- simParamBee$nVirginQueens @@ -417,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 @@ -430,9 +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) - } + } else if (isPop(x)) { if (caste != "drones") { # Creating drones if input is a Pop stop("Pop-class can only be used to create drones!") @@ -453,73 +459,151 @@ 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 (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) + if (!isQueenPresent(x, simParamBee = simParamBee)) { + stop("Missing queen!") + } + + 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 = 5) + names(ret) <- c("workers", "nHomBrood", "pedigree", "caste", "recHist") + } + simParamBee$nThreads <- 1 + 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$caste <- simParamBee$caste[ret$workers@id, drop = FALSE] + if (simParamBee$isTrackPed) { + ret$pedigree <- simParamBee$pedigree[ret$workers@id, , drop = FALSE] + } + if (simParamBee$isTrackRec) { + ret$recHist <- simParamBee$recHist[ret$workers@iid] + } + } + + 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 <- as.character(ids) + ret$workers@iid <- as.integer(ids) + if (returnSP) { + names(ret$caste) <- as.character(ids) + if (simParamBee$isTrackPed) { + rownames(ret$pedigree) <- ids + } + if (simParamBee$isTrackRec) { + names(ret$recHist) <- ids } } } - } 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) + + if (isCsdActive(simParamBee = simParamBee)) { + sel <- isCsdHeterozygous(pop = ret$workers, simParamBee = simParamBee) + ret$nHomBrood <- nInd(ret$workers) - sum(sel) + ret$workers <- ret$workers[sel] + } else { + ret$nHomBrood <- NA + } + + } else if (caste == "virginQueens") { + ret <- createCastePop(x = x, caste = "workers", + 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 + } + + } else if (caste == "drones") { + 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) { + ret <- vector(mode = "list", length = 4) + names(ret) <- c("drones", "pedigree", "caste", "recHist") + ret$caste <- simParamBee$caste[drones@id, drop = FALSE] + if (simParamBee$isTrackPed) { + ret$pedigree <- simParamBee$pedigree[drones@id, , drop = FALSE] + } + if (simParamBee$isTrackRec) { + ret$recHist <- simParamBee$recHist[drones@iid] + } + } + + if (!is.null(ids)) { + if (nInd(drones) != length(ids)) { + stop("Not enough IDs provided") + } + drones@id = ids + drones@iid = as.integer(ids) + if (returnSP) { + names(ret$caste) <- ids + if (simParamBee$isTrackPed) { + rownames(ret$pedigree) <- ids + } + if (simParamBee$isTrackRec) { + names(ret$recHist) <- ids + } + } + } + + if (returnSP) { + ret$drones <-drones + } else { + ret <- drones + } } - } 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 { + ret <- NULL } + simParamBee$nThreads <- originalThreads } else if (isMultiColony(x)) { + if (is.null(nInd)) { + string = paste0("n", toupper(substr(caste, 1, 1)), substr(caste, 2, nchar(caste))) + nInd <- simParamBee[[string]] + } + nCol <- nColonies(x) nNInd <- length(nInd) + if (nNInd > 1 && nNInd < nCol) { stop("Too few values in the nInd argument!") } @@ -527,56 +611,133 @@ createCastePop <- function(x, caste = NULL, nInd = NULL, 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 + + 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) + + 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 + } + } + ) + + 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 { - nIndColony <- ifelse(nNInd == 1, nInd, nInd[colony]) + 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) } - 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 { + # 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) + + + 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", "recHist")][[1]] + }) + } else { + ret <- lapply(ret, FUN = function(x) { + if (is.null(x)) return(NULL) + x[!names(x) %in% c("pedigree", "caste", "recHist")] + }) + } + } + } + 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, 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) } #' @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, ...) { ret <- createCastePop(x, caste = "drones", nInd = nInd, - simParamBee = simParamBee, ...) + simParamBee = simParamBee, + returnSP = returnSP, + ids = ids, ...) return(ret) } #' @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, - csdAlleles = csdAlleles, simParamBee = simParamBee, ...) + editCsd = editCsd, + csdAlleles = csdAlleles, simParamBee = simParamBee, + returnSP = returnSP, + ids = ids, ...) return(ret) } @@ -817,7 +978,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 @@ -1011,12 +1172,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 @@ -1092,24 +1253,28 @@ pullCastePop <- function(x, caste, nInd = NULL, use = "rand", 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 - } + + 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") + if (collapse) { ret$pulled <- mergePops(ret$pulled) } @@ -1195,7 +1360,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 ... other arguments for \code{nDrones}, when \code{nDrones} is a function #' @@ -1224,7 +1390,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) @@ -1347,14 +1513,20 @@ cross <- function(x, if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } + + 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 } - if (is.function(nDrones)) { - nD <- nDrones(...) - } else { - nD <- nDrones - } IDs <- as.character(getId(x)) oneColony <- (isPop(drones)) && (length(IDs) == 1) && (is.null(crossPlan)) @@ -1366,6 +1538,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!") } @@ -1382,6 +1558,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!") } @@ -1408,195 +1587,222 @@ 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) + } - 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 (all(noMatches == 0)) { + stop("All crossings failed!") + } 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 (checkCross == "warning") { + message("Crossing failed, unmated virgin queens will be removed!") + ret <- x + } else if (checkCross == "error") { + stop("Crossing failed!") + } } } - 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) - } + # Convert everything to a Pop + if (isColony(x) | isMultiColony(x)) { + inputId <- getId(x) + if (isColony(x)) { + colony <- x + 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, simParamBee = simParamBee)$pulled + ID_by_input <- data.frame(inputId = inputId, + 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))] + } + } - virginQueen@misc$fathers[[1]] <- virginQueenDrones + IDs <- as.character(getId(x)) + #Now x is always a Pop + ret <- list() + nVirgin = nInd(x) - 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 + + 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 + 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 + IDs = IDs[IDs %in% crossPlanDF$virginID] + x = x[IDs] + if (type == "MultiColony") { + 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, + 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)),] + # 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))),] + 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 + 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)))) + 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]) + 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 <- lapply(IDs, function(i) { + dronePop[as.character(dronesByVirgin_list[[i]])] } - 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 + ) + } else if (crossPlan_droneID) { + dronesByVirgin <- lapply(IDs, function(i) { + drones[as.character(crossPlan[[i]])] } - } + ) } - if (isPop(x)) { - ret <- mergePops(ret) + } + # 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") + } + + 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 } - } else if (isMultiColony(x)) { - nCol <- nColonies(x) - if (nCol == 0) { - ret <- createMultiColony(simParamBee = simParamBee) + + virginQueen@misc[["pHomBrood"]] <- val + return(virginQueen) + } + + # Add drones in the queens father slot + + 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[[1]] } 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 - ) - } + 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") { + x <- mergePops(x) + ret <- reQueen(x = multicolony, queen = x, simParamBee = simParamBee) + ret <- removeCastePop(ret, caste = "virginQueens", simParamBee = simParamBee) } + validObject(ret) 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) + + +#' @rdname crossVirginQueen +#' @title Internal function to cross a virgin queen #' -#' queen1 <- getQueen(colony) -#' queen1 <- setQueensYearOfBirth(queen1, year = 2022) -#' getQueenYearOfBirth(queen1) +#' @description Internal function to cross a virgin queen #' -#' colony <- setQueensYearOfBirth(colony, year = 2022) -#' getQueenYearOfBirth(colony) +#' @param virginQueen \code{\link[AlphaSimR]{Pop-class}} +#' @param virginQueenDrones, list with drones +#' @param simParamBee, SimParamBee object #' -#' 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 - ) - } +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 { - stop("Argument x must be a Pop, Colony or MultiColony class object!") + val <- NA } - return(x) + + virginQueen@misc[["pHomBrood"]] <- val + return(virginQueen) } diff --git a/R/Functions_L2_Colony.R b/R/Functions_L2_Colony.R index 390e76f5..4bb61098 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}} #' @@ -31,15 +32,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,13 +65,13 @@ createColony <- function(x = NULL, simParamBee = NULL) { colony <- new( Class = "Colony", - id = simParamBee$lastColonyId, + id = id, queen = queen, location = c(0, 0), virginQueens = virginQueens ) } - colony <- resetEvents(colony) + colony <- resetEvents(colony, simParamBee = simParamBee) validObject(colony) return(colony) } @@ -107,7 +112,7 @@ createColony <- function(x = NULL, simParamBee = 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 @@ -158,21 +163,27 @@ reQueen <- function(x, queen, removeVirginQueens = TRUE, simParamBee = NULL) { 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)) { nCol <- nColonies(x) + if (nCol == 0) { + stop("The Multicolony contains 0 colonies!") + } if (nInd(queen) < nCol) { stop("Not enough queens provided!") } - for (colony in seq_len(nCol)) { - x[[colony]] <- reQueen( + + + 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!") } @@ -180,6 +191,33 @@ reQueen <- function(x, queen, removeVirginQueens = TRUE, simParamBee = NULL) { 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 #' @@ -197,10 +235,6 @@ reQueen <- function(x, queen, removeVirginQueens = TRUE, simParamBee = NULL) { #' 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 ... additional arguments passed to \code{nInd} when this argument is a function #' @@ -222,7 +256,7 @@ reQueen <- function(x, queen, removeVirginQueens = TRUE, 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]) #' #' #Here we show an example for workers, but same holds for drones and virgin queens! @@ -249,7 +283,7 @@ reQueen <- function(x, queen, removeVirginQueens = TRUE, simParamBee = NULL) { #' # 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) @@ -258,7 +292,7 @@ reQueen <- function(x, queen, removeVirginQueens = TRUE, simParamBee = NULL) { #' #' @export addCastePop <- function(x, caste = NULL, nInd = NULL, new = FALSE, - exact = FALSE, year = NULL, simParamBee = NULL, ...) { + simParamBee = NULL, ...) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } @@ -293,16 +327,22 @@ addCastePop <- function(x, caste = NULL, nInd = NULL, new = FALSE, 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] + } if (0 < nInd) { newInds <- createCastePop(x, nInd, - caste = caste, exact = exact, - year = year, simParamBee = simParamBee + caste = caste, + 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) @@ -317,27 +357,49 @@ addCastePop <- function(x, caste = NULL, nInd = NULL, new = FALSE, } } else if (isMultiColony(x)) { nCol <- nColonies(x) - nNInd <- length(nInd) - if (nNInd > 1 && nNInd < nCol) { - stop("Too few values in the nInd argument!") + if (nCol == 0) { + stop("The Multicolony contains 0 colonies!") } - if (nNInd > 1 && nNInd > nCol) { - warning(paste0("Too many values in the nInd argument, taking only the first ", nCol, "values!")) - nInd <- nInd[1:nCol] + if (any(hasCollapsed(x))) { + stop(paste0("The colony ", getId(x), " collapsed, hence you can not add individuals (from the queen) to it!")) } - for (colony in seq_len(nCol)) { - if (is.null(nInd)) { - nIndColony <- NULL + + newInds <- createCastePop(x, nInd, + caste = caste, + simParamBee = simParamBee, + 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 <- 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]] + 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 { - nIndColony <- ifelse(nNInd == 1, nInd, nInd[colony]) + x[[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!") } @@ -348,17 +410,18 @@ addCastePop <- function(x, caste = NULL, nInd = NULL, new = FALSE, #' @describeIn addCastePop Add workers to a colony #' @export addWorkers <- function(x, nInd = NULL, new = FALSE, - exact = FALSE, simParamBee = NULL, ...) { + simParamBee = NULL, ...) { ret <- addCastePop( x = x, caste = "workers", nInd = nInd, new = new, - exact = exact, simParamBee = simParamBee, ... + simParamBee = simParamBee, ... ) 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, ... @@ -369,10 +432,10 @@ addDrones <- function(x, nInd = NULL, new = FALSE, simParamBee = NULL, ...) { #' @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) } @@ -398,9 +461,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 @@ -440,7 +500,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) #' @@ -472,11 +532,12 @@ 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, exact = FALSE, resetEvents = FALSE, - simParamBee = NULL, ...) { + new = TRUE, resetEvents = FALSE, + simParamBee = NULL, ...) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } @@ -494,7 +555,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!")) @@ -512,7 +573,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) } else if (n < 0) { x@workers <- getWorkers(x, nInd = nWorkers, simParamBee = simParamBee) } @@ -543,7 +604,14 @@ buildUp <- function(x, nWorkers = NULL, nDrones = NULL, } x@production <- TRUE } else if (isMultiColony(x)) { + + if (any(hasCollapsed(x))) { + 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) { @@ -560,27 +628,32 @@ buildUp <- function(x, nWorkers = NULL, nDrones = NULL, 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, ... - ) + + if (is.function(nWorkers)) { + nWorkers <- nWorkers(x = x,...) + } + + if (new) { + n <- nWorkers + } else { + n <- nWorkers - nWorkers(x, simParamBee = simParamBee) + } + + if (sum(nWorkers) > 0) { + x <- addWorkers( + x = x, nInd = n, new = new, + 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) + } + } else { stop("Argument x must be a Colony or MultiColony class object!") } @@ -589,7 +662,6 @@ 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 @@ -627,7 +699,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) #' @@ -642,6 +714,7 @@ buildUp <- function(x, nWorkers = NULL, nDrones = NULL, #' 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, ...) { if (is.null(simParamBee)) { @@ -681,6 +754,19 @@ downsize <- function(x, p = NULL, use = "rand", new = FALSE, } else if (isMultiColony(x)) { nCol <- nColonies(x) nP <- length(p) + if (nCol == 0) { + stop("The Multicolony contains 0 colonies!") + } + + if (any(hasCollapsed(x))) { + stop("Some of the 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!") } @@ -688,20 +774,20 @@ downsize <- 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) + } 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) + for (colony in 1:nCol) { + x[[colony]]@production <- FALSE } + } else { stop("Argument x must be a Colony or MultiColony class object!") } @@ -710,6 +796,8 @@ downsize <- function(x, p = NULL, use = "rand", new = FALSE, return(x) } + + #' @rdname replaceCastePop #' @title Replace a proportion of caste individuals with new ones #' @@ -726,12 +814,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 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 #' #' @return \code{\link[SIMplyBee]{Colony-class}} or or \code{\link[SIMplyBee]{MultiColony-class}} with @@ -749,7 +831,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 @@ -768,8 +850,8 @@ 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, - year = NULL, simParamBee = NULL) { +replaceCastePop <- function(x, caste = NULL, p = 1, use = "rand", + simParamBee = NULL) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } @@ -781,71 +863,49 @@ replaceCastePop <- function(x, caste = NULL, p = 1, use = "rand", exact = TRUE, } 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 (isColony(x) | isMultiColony(x)) { + nP <- length(p) + if (isColony(x)) { + nCol <- 1 + } else if (isMultiColony(x)) { + nCol <- nColonies(x) } - if (!isQueenPresent(x, simParamBee = simParamBee)) { - stop("Missing queen!") + if (nCol == 0) { + stop("The Multicolony contains 0 colonies!") } - if (length(p) > 1) { - warning("More than one value in the p argument, taking only the first value!") - p <- p[1] + if (any(hasCollapsed(x))) { + stop(paste0("The colony or some of the colonies have collapsed, hence you can not replace individuals in it!")) } - 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 - ) - } + if (any(!isQueenPresent(x, simParamBee = simParamBee))) { + stop("Missing queen in at least one colony!") } - } 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 (length(p) > nCol) { + warning(paste0("More than one value in the p argument, taking only the first ", nCol, " values!")) + p <- p[nCol] } - for (colony in seq_len(nCol)) { - if (is.null(p)) { - pColony <- NULL + nInd <- nCaste(x, caste, simParamBee = simParamBee) + if (any(nInd > 0)) { + nIndReplaced <- round(nInd * p) + if (any(nIndReplaced < nInd)) { + + x <- removeCastePop(x, + caste = caste, + p = p, simParamBee = simParamBee) + nIndAdd <- nInd - nCaste(x, caste, simParamBee = simParamBee) + x <- addCastePop(x, + caste = caste, + nInd = nIndAdd, + simParamBee = simParamBee + ) } else { - pColony <- ifelse(nP == 1, p, p[colony]) + x <- addCastePop( + x = x, caste = caste, nInd = nIndReplaced, new = TRUE, + simParamBee = simParamBee + ) } - 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!") @@ -856,10 +916,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) { +replaceWorkers <- function(x, p = 1, use = "rand", simParamBee = NULL) { ret <- replaceCastePop( x = x, caste = "workers", p = p, - use = use, exact = exact, + use = use, simParamBee = simParamBee ) return(ret) @@ -885,6 +945,7 @@ replaceVirginQueens <- function(x, p = 1, use = "rand", simParamBee = NULL) { return(ret) } + #' @rdname removeCastePop #' @title Remove a proportion of caste individuals from a colony #' @@ -898,13 +959,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 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 #' #' @return \code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}} without virgin queens @@ -922,7 +977,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) #' @@ -943,8 +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", - addVirginQueens = FALSE, nVirginQueens = NULL, - year = NULL, simParamBee = NULL) { + simParamBee = NULL) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } @@ -964,14 +1018,6 @@ removeCastePop <- function(x, caste = NULL, p = 1, use = "rand", 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 { @@ -990,6 +1036,9 @@ removeCastePop <- function(x, caste = NULL, p = 1, use = "rand", } else if (isMultiColony(x)) { 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!") } @@ -997,19 +1046,24 @@ 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] } - for (colony in seq_len(nCol)) { + + x@colonies <- future_lapply(X = seq_len(nCol), + future.seed = TRUE, + FUN = function(colony) { if (is.null(p)) { pColony <- NULL } else { pColony <- ifelse(nP == 1, p, p[colony]) } - x[[colony]] <- removeCastePop( + removeCastePop( x = x[[colony]], caste = caste, p = pColony, use = use, simParamBee = simParamBee ) } + ) + } else { stop("Argument x must be a Colony or MultiColony class object!") } @@ -1019,12 +1073,13 @@ removeCastePop <- 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) { - ret <- removeCastePop(x = x, caste = "queen", p = 1, addVirginQueens = addVirginQueens, - nVirginQueens = nVirginQueens, year = year, simParamBee = simParamBee) +#' +removeQueen <- function(x, simParamBee = NULL) { + ret <- removeCastePop(x = x, caste = "queen", p = 1, simParamBee = simParamBee) return(ret) } + #' @describeIn removeCastePop Remove workers from a colony #' @export removeWorkers <- function(x, p = 1, use = "rand", simParamBee = NULL) { @@ -1032,6 +1087,8 @@ removeWorkers <- function(x, p = 1, use = "rand", simParamBee = NULL) { return(ret) } + + #' @describeIn removeCastePop Remove workers from a colony #' @export removeDrones <- function(x, p = 1, use = "rand", simParamBee = NULL) { @@ -1039,6 +1096,8 @@ removeDrones <- function(x, p = 1, use = "rand", simParamBee = NULL) { return(ret) } + + #' @describeIn removeCastePop Remove virgin queens from a colony #' @export removeVirginQueens <- function(x, p = 1, use = "rand", simParamBee = NULL) { @@ -1059,6 +1118,7 @@ removeVirginQueens <- function(x, p = 1, use = "rand", simParamBee = 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}) +#' @param simParamBee \code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters #' #' @return \code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}} with #' events reset @@ -1075,7 +1135,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 @@ -1125,7 +1185,10 @@ removeVirginQueens <- function(x, p = 1, use = "rand", simParamBee = NULL) { #' hasSplit(remnants[[1]]) #' resetEvents(remnants)[[1]] #' @export -resetEvents <- function(x, collapse = NULL) { +resetEvents <- function(x, collapse = NULL, simParamBee = NULL) { + if (is.null(simParamBee)) { + simParamBee <- get(x = "SP", envir = .GlobalEnv) + } if (isColony(x)) { x@swarm <- FALSE x@split <- FALSE @@ -1142,12 +1205,19 @@ resetEvents <- function(x, collapse = NULL) { validObject(x) } else if (isMultiColony(x)) { nCol <- nColonies(x) - for (colony in seq_len(nCol)) { - x[[colony]] <- resetEvents( + if (nCol == 0) { + stop("The Multicolony contains 0 colonies!") + } + + x@colonies <- future_lapply(X = seq_len(nCol), + FUN = function(colony) { + resetEvents( x = x[[colony]], - collapse = collapse + collapse = collapse, + simParamBee = simParamBee ) - } + } + ) validObject(x) } else { stop("Argument x must be a Colony or MultiColony class object!") @@ -1166,6 +1236,8 @@ resetEvents <- function(x, collapse = 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 +#' #' #' @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 @@ -1178,13 +1250,13 @@ resetEvents <- function(x, collapse = 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 @@ -1200,15 +1272,25 @@ resetEvents <- function(x, collapse = NULL) { #' apiaryLeft <- tmp$remnant #' hasCollapsed(apiaryLeft) #' @export -collapse <- function(x) { +collapse <- function(x, simParamBee = NULL) { + if (is.null(simParamBee)) { + simParamBee <- get(x = "SP", envir = .GlobalEnv) + } 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]]) + if (nCol == 0) { + stop("The Multicolony contains 0 colonies!") } + + 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!") } @@ -1223,7 +1305,11 @@ collapse <- function(x) { #' 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. #' @@ -1233,11 +1319,6 @@ collapse <- function(x) { #' 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 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}} @@ -1255,6 +1336,8 @@ collapse <- function(x) { #' @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) @@ -1264,7 +1347,7 @@ collapse <- function(x) { #' 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) #' @@ -1288,150 +1371,172 @@ 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, sampleLocation = TRUE, radius = NULL, simParamBee = NULL, ...) { if (is.null(simParamBee)) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } + if (isMultiColony(x)) { + parallel <- TRUE + } 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 (isColony(x) | isMultiColony(x)) { + if (isColony(x)) { + nCol <- 1 + } else if (isMultiColony(x)) { + nCol <- nColonies(x) } - if (!isQueenPresent(x, simParamBee = simParamBee)) { - stop("No queen present in the colony!") + nP <- length(p) + if (nCol == 0) { + stop("The Multicolony contains 0 colonies!") } - if (!isWorkersPresent(x, simParamBee = simParamBee)) { - stop("No workers present in the colony!") + + 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) { + if (any(p < 0) | any(1 < p)) { stop("p must be between 0 and 1 (inclusive)!") } - if (length(p) > 1) { + if (length(p) > nCol) { warning("More than one value in the p argument, taking only the first value!") - p <- p[1] + 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 - tmp <- pullWorkers(x = x, nInd = nWorkersSwarm, simParamBee = simParamBee) + + tmpVirginQueens <- createCastePop( + x = x, nInd = max(10, simParamBee$nVirginQueens), + 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 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] + 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, simParamBee = simParamBee) + if (isColony(x)) { + remnantColony <- reQueen(remnantColony, + 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 (sampleLocation) { - newLocation <- c(currentLocation + rcircle(radius = radius)) + 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 } - 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) + if (isColony(x)) { + swarmColony <- createColony(x = x@queen, simParamBee = simParamBee) + # It's not re-queening, but the function also sets the colony id - tmpVirginQueen <- createVirginQueens( - x = x, nInd = nVirginQueens, - year = year, - simParamBee = simParamBee - ) - tmpVirginQueen <- selectInd(tmpVirginQueen, nInd = 1, use = "rand", simParam = simParamBee) + swarmColony@workers <- tmp$pulled + swarmColony <- setLocation(x = swarmColony, location = newLocation[[1]], 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, simParamBee = simParamBee) - remnantColony <- setLocation(x = remnantColony, location = currentLocation) + remnantColony@swarm <- TRUE + swarmColony@swarm <- TRUE - remnantColony@swarm <- TRUE - swarmColony@swarm <- TRUE - remnantColony@production <- FALSE - swarmColony@production <- FALSE + remnantColony@production <- FALSE + swarmColony@production <- FALSE + + ret <- list(swarm = swarmColony, remnant = remnantColony) + } else if (isMultiColony(x)) { + if (nCol == 0) { + stop("The Multicolony contains 0 colonies!") + } - 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) + swarm = createMultiColony(x = getQueen(x, collapse = TRUE, simParamBee = simParamBee), + simParamBee = simParamBee), + remnant = remnantColony ) - 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$swarm[[colony]] <- tmp$swarm - ret$remnant[[colony]] <- tmp$remnant - } + + 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) + 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 { + } + else { stop("Argument x must be a Colony or MultiColony class object!") } - validObject(ret$swarmColony) validObject(ret$remnantColony) return(ret) } + + #' @rdname supersede #' @title Supersede #' #' @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 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 ... additional arguments passed to \code{nVirginQueens} when this #' argument is a function @@ -1474,26 +1579,61 @@ 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, 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 (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, simParamBee = simParamBee, ...) + } + + # Do this because some colonies might not produce a viable virgin queen + tmpVirginQueens <- createCastePop( + x = x, nInd = max(10, simParamBee$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!") + 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 (is.function(nVirginQueens)) { - nVirginQueens <- nVirginQueens(x, ...) + } + + if (isColony(x)) { + if (!parallel) { + x <- addCastePop_internal(selectInd(tmpVirginQueens, nInd = 1, use = "rand", simParam = simParamBee), + colony = x, caste = "virginQueens") } - x <- removeQueen(x, addVirginQueens = TRUE, nVirginQueens = nVirginQueens, - year = year, simParamBee = simParamBee) - x@virginQueens <- selectInd(x@virginQueens, nInd = 1, use = "rand", simParam = 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 @@ -1502,17 +1642,17 @@ supersede <- function(x, year = NULL, nVirginQueens = NULL, simParamBee = NULL, } 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, ... - ) - } + stop("The Multicolony contains 0 colonies!") } - } else { + 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) { + addCastePop_internal(colony = removeQueen(x[[colony]], simParamBee = simParamBee), + pop = tmpVirginQueens[[colony]], caste = "virginQueens") + }) + x = setEvents(x, slot = "supersedure", value = TRUE, simParamBee = simParamBee) + } + else { stop("Argument x must be a Colony or MultiColony class object!") } validObject(x) @@ -1526,8 +1666,9 @@ supersede <- function(x, year = NULL, nVirginQueens = NULL, 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 @@ -1535,7 +1676,6 @@ supersede <- function(x, year = NULL, nVirginQueens = 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 @@ -1580,109 +1720,162 @@ supersede <- function(x, year = NULL, nVirginQueens = 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) } 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 (isMultiColony(x)) { + parallel <- TRUE + } + + if (isColony(x) | isMultiColony(x)) { + if (isColony(x)) { + nCol <- 1 + } else if (isMultiColony(x)) { + nCol <- nColonies(x) } - if (!isQueenPresent(x, simParamBee = simParamBee)) { - stop("No queen present in the colony!") + if (nCol == 0) { + stop("The Multicolony contains 0 colonies!") + } + 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 (!isWorkersPresent(x, simParamBee = simParamBee)) { - stop("No workers present in the colony!") + 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) { + if (any(p < 0) | any(1 < p)) { stop("p must be between 0 and 1 (inclusive)!") } - if (length(p) > 1) { + if (length(p) > nCol) { warning("More than one value in the p argument, taking only the first value!") - p <- p[1] + 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 <- pullWorkers(x = x, nInd = nWorkersSplit, simParamBee = simParamBee) + tmp <- pullCastePop(x = x, caste = "workers", 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)) + if (isColony(x)) { - remnantColony@split <- TRUE - splitColony@split <- TRUE + # 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 - remnantColony@production <- TRUE - splitColony@production <- FALSE + splitColony <- createColony(simParamBee = simParamBee) + splitColony <- setLocation(x = splitColony, location = location, simParamBee = simParamBee) + + 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) { + stop("The Multicolony contains 0 colonies!") + } - 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) + split = createMultiColony(n = nCol, + simParamBee = simParamBee, + populateColonies = TRUE), + remnant = remnantColony + ) - 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 - } + ret$split <- setLocation(x = ret$split, location = location, simParamBee = simParamBee) + + 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) + ret$remnant <- setEvents(ret$remnant, slot = "production", value = TRUE, simParamBee = simParamBee) } - } 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) } +#' @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 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, simParamBee = NULL) { + if (is.null(simParamBee)) { + simParamBee <- get(x = "SP", envir = .GlobalEnv) + } + if (isColony(x)) { + slot(x, slot) <- value + } + if (isMultiColony(x)) { + x@colonies <- future_lapply(X = seq_len(nColonies(x)), + FUN = function(colony) { + setEvents(x[[colony]], slot, value, simParamBee = simParamBee) + }) + } + return(x) +} + + #' @rdname combine #' @title Combine two colony objects #' @@ -1695,6 +1888,7 @@ split <- function(x, p = NULL, year = 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 #' #' @return a combined \code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}} #' @@ -1702,8 +1896,9 @@ split <- function(x, p = NULL, year = 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 @@ -1732,27 +1927,35 @@ split <- function(x, p = NULL, year = 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) { +combine <- function(strong, weak, simParamBee = NULL) { + if (is.null(simParamBee)) { + simParamBee <- get(x = "SP", envir = .GlobalEnv) + } + 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 (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]]) - } + + 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!") } @@ -1762,6 +1965,7 @@ combine <- function(strong, weak) { return(strong) } + #' @rdname setLocation #' @title Set colony location #' @@ -1774,6 +1978,7 @@ combine <- function(strong, weak) { #' \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 #' #' @return \code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}} with set #' location @@ -1812,7 +2017,10 @@ combine <- function(strong, weak) { #' apiary <- setLocation(apiary, location = locDF) #' getLocation(apiary) #' @export -setLocation <- function(x, location = c(0, 0)) { +setLocation <- function(x, location = c(0, 0), simParamBee = NULL) { + if (is.null(simParamBee)) { + simParamBee <- get(x = "SP", envir = .GlobalEnv) + } 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!") @@ -1822,21 +2030,24 @@ setLocation <- function(x, location = c(0, 0)) { } x@location <- location } else if (isMultiColony(x)) { - n <- nColonies(x) + nCol <- nColonies(x) + if (nCol == 0 | all(isNULLColonies(x))) { + 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) @@ -1851,7 +2062,8 @@ setLocation <- function(x, location = c(0, 0)) { stop("Argument location must be numeric, list, or data.frame!") } } - for (colony in seq_len(n)) { + 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) @@ -1860,10 +2072,13 @@ setLocation <- function(x, location = c(0, 0)) { } 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!") } diff --git a/R/Functions_L3_Colonies.R b/R/Functions_L3_Colonies.R index b8dbc191..78f240c3 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 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. @@ -32,15 +33,15 @@ #' 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) -#' drones <- createDrones(x = basePop[3], n = 30) +#' 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) #' apiary @@ -48,15 +49,27 @@ #' apiary[[2]] #' #' @export -createMultiColony <- function(x = NULL, n = NULL, simParamBee = NULL) { +createMultiColony <- function(x = NULL, n = NULL, simParamBee = NULL, populateColonies = FALSE) { 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)) + if (populateColonies) { + ids <- (simParamBee$lastColonyId+1):(simParamBee$lastColonyId + n) + + ret@colonies <- future_lapply(X = seq_len(n), + FUN = function(colony) { + createColony(simParamBee = simParamBee, id = ids[colony]) + }) + simParamBee$updateLastColonyId(n = n) + } else { + + } } } else { if (!isPop(x)) { @@ -72,10 +85,15 @@ createMultiColony <- function(x = NULL, n = NULL, simParamBee = NULL) { 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) - } + 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]) + }) + simParamBee$updateLastColonyId(n = n) } + validObject(ret) return(ret) } diff --git a/R/SIMplyBee.R b/R/SIMplyBee.R index ce9260f8..c138b5da 100644 --- a/R/SIMplyBee.R +++ b/R/SIMplyBee.R @@ -7,6 +7,7 @@ #' @importFrom stats rnorm rbeta runif rpois na.omit #' @importFrom extraDistr rtpois #' @importFrom utils packageVersion +#' @importFrom future.apply future_lapply # see https://r-pkgs.org/namespace.html on description what to import/depend/... #' @description 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 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 664475f4..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,96 +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-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, @@ -382,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) @@ -488,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 @@ -528,45 +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{\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{
}} + } } +\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{
}} + } } + +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-SimParamBee-updateCaste}{}}} +\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{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 + 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{
}} + } +} + \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()}\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{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/addCastePop.Rd b/man/addCastePop.Rd index 89e896e3..87e1f727 100644 --- a/man/addCastePop.Rd +++ b/man/addCastePop.Rd @@ -7,29 +7,13 @@ \alias{addVirginQueens} \title{Add caste individuals to the colony} \usage{ -addCastePop( - x, - caste = NULL, - nInd = NULL, - new = FALSE, - exact = FALSE, - year = NULL, - simParamBee = NULL, - ... -) - -addWorkers(x, nInd = NULL, new = FALSE, exact = FALSE, 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}}} @@ -45,12 +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{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} @@ -90,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! @@ -117,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/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/buildUp.Rd b/man/buildUp.Rd index 5e280a04..650d8169 100644 --- a/man/buildUp.Rd +++ b/man/buildUp.Rd @@ -9,7 +9,6 @@ buildUp( nWorkers = NULL, nDrones = NULL, new = TRUE, - exact = FALSE, resetEvents = FALSE, simParamBee = NULL, ... @@ -34,10 +33,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} @@ -86,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) @@ -118,5 +113,6 @@ nWorkers(apiary) nDrones(apiary) # Queen's counters -getMisc(getQueen(buildUp(colony))) +getQueen(buildUp(colony))@misc + } diff --git a/man/collapse.Rd b/man/collapse.Rd index e00a37b2..34326080 100644 --- a/man/collapse.Rd +++ b/man/collapse.Rd @@ -4,10 +4,12 @@ \alias{collapse} \title{Collapse} \usage{ -collapse(x) +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} } \value{ \code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}} with the collapse @@ -30,13 +32,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 c14a3a67..9e98b85b 100644 --- a/man/combine.Rd +++ b/man/combine.Rd @@ -4,12 +4,14 @@ \alias{combine} \title{Combine two colony objects} \usage{ -combine(strong, weak) +combine(strong, weak, simParamBee = NULL) } \arguments{ \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} } \value{ a combined \code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}} @@ -26,8 +28,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 +59,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 4766cbd1..5913ca00 100644 --- a/man/createCastePop.Rd +++ b/man/createCastePop.Rd @@ -11,25 +11,40 @@ createCastePop( x, caste = NULL, nInd = NULL, - exact = TRUE, - year = NULL, editCsd = TRUE, csdAlleles = NULL, simParamBee = NULL, + returnSP = FALSE, + ids = NULL, ... ) -createWorkers(x, nInd = NULL, exact = FALSE, simParamBee = NULL, ...) +createWorkers( + x, + nInd = NULL, + simParamBee = NULL, + returnSP = FALSE, + ids = NULL, + ... +) -createDrones(x, nInd = NULL, simParamBee = NULL, ...) +createDrones( + x, + nInd = NULL, + simParamBee = NULL, + returnSP = FALSE, + ids = NULL, + ... +) createVirginQueens( x, nInd = NULL, - year = NULL, editCsd = TRUE, csdAlleles = NULL, simParamBee = NULL, + returnSP = FALSE, + ids = NULL, ... ) } @@ -47,13 +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{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}}), whether the csd locus should be edited to ensure heterozygosity at the csd locus (to get viable virgin queens); see \code{csdAlleles}} @@ -70,6 +78,12 @@ 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 (used internally +for parallel computing)} + \item{...}{additional arguments passed to \code{nInd} when this argument is a function} } \value{ @@ -100,7 +114,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 @@ -118,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/createColony.Rd b/man/createColony.Rd index a8a96649..d1707f07 100644 --- a/man/createColony.Rd +++ b/man/createColony.Rd @@ -4,12 +4,14 @@ \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)} \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/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 21f2bc14..4298fe31 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) +createMultiColony( + x = NULL, + n = NULL, + simParamBee = NULL, + populateColonies = FALSE +) } \arguments{ \item{x}{\code{\link[AlphaSimR]{Pop-class}}, virgin queens or queens for the colonies @@ -16,6 +21,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{populateColonies}{boolean, whether to create n empty Colony objects within with assigned ID} } \value{ \code{\link[SIMplyBee]{MultiColony-class}} @@ -41,15 +48,15 @@ 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) -drones <- createDrones(x = basePop[3], n = 30) +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) apiary diff --git a/man/cross.Rd b/man/cross.Rd index 8b4ee5fe..8d34e3a6 100644 --- a/man/cross.Rd +++ b/man/cross.Rd @@ -54,7 +54,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} @@ -95,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/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/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/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/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/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/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/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/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..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,38 +25,41 @@ 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}} \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} @@ -85,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/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/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 9acecac0..cbe9c2ec 100644 --- a/man/removeCastePop.Rd +++ b/man/removeCastePop.Rd @@ -8,24 +8,9 @@ \alias{removeVirginQueens} \title{Remove a proportion of caste individuals from a colony} \usage{ -removeCastePop( - x, - caste = NULL, - p = 1, - use = "rand", - addVirginQueens = FALSE, - nVirginQueens = NULL, - year = NULL, - simParamBee = NULL -) - -removeQueen( - x, - addVirginQueens = FALSE, - nVirginQueens = NULL, - year = NULL, - simParamBee = NULL -) +removeCastePop(x, caste = NULL, p = 1, use = "rand", simParamBee = NULL) + +removeQueen(x, simParamBee = NULL) removeWorkers(x, p = 1, use = "rand", simParamBee = NULL) @@ -45,16 +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{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{year}{numeric, only relevant when adding virgin queens - year of birth for virgin queens} - \item{simParamBee}{\code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters} } \value{ @@ -88,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 bd2c3756..44fd8728 100644 --- a/man/replaceCastePop.Rd +++ b/man/replaceCastePop.Rd @@ -7,17 +7,9 @@ \alias{replaceVirginQueens} \title{Replace a proportion of caste individuals with new ones} \usage{ -replaceCastePop( - x, - caste = NULL, - p = 1, - use = "rand", - exact = TRUE, - year = NULL, - simParamBee = NULL -) +replaceCastePop(x, caste = NULL, p = 1, use = "rand", simParamBee = NULL) -replaceWorkers(x, p = 1, use = "rand", exact = TRUE, simParamBee = NULL) +replaceWorkers(x, p = 1, use = "rand", simParamBee = NULL) replaceDrones(x, p = 1, use = "rand", simParamBee = NULL) @@ -36,14 +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{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} } \value{ @@ -77,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 2e8b6642..27836670 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) } \arguments{ \item{x}{\code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}}} @@ -13,6 +13,8 @@ resetEvents(x, collapse = 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} } \value{ \code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}} with @@ -36,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/setEvents.Rd b/man/setEvents.Rd new file mode 100644 index 00000000..5035cd70 --- /dev/null +++ b/man/setEvents.Rd @@ -0,0 +1,40 @@ +% 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, 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{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 a9ee600d..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)) +setLocation(x, location = c(0, 0), simParamBee = NULL) } \arguments{ \item{x}{\code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}}} @@ -14,6 +14,8 @@ 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} } \value{ \code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}} with set 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/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/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/supersede.Rd b/man/supersede.Rd index 04291135..bc1de781 100644 --- a/man/supersede.Rd +++ b/man/supersede.Rd @@ -4,18 +4,11 @@ \alias{supersede} \title{Supersede} \usage{ -supersede(x, year = NULL, nVirginQueens = 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{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 @@ -29,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 e178fe26..6c6293f1 100644 --- a/man/swarm.Rd +++ b/man/swarm.Rd @@ -7,8 +7,6 @@ swarm( x, p = NULL, - year = NULL, - nVirginQueens = NULL, sampleLocation = TRUE, radius = NULL, simParamBee = NULL, @@ -24,13 +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{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}}} @@ -54,13 +45,19 @@ 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. } \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) @@ -70,7 +67,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) 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 b9883b0a..7d7f11b4 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,13 +141,14 @@ 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) 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) @@ -150,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)) @@ -159,6 +166,8 @@ test_that("calcQueensPHomBrood", { colony@virginQueens <- NULL expect_error(calcQueensPHomBrood(colony, simParamBee = SP)) expect_equal((length(calcQueensPHomBrood(apiary, simParamBee = SP))), 0) + + }) # ---- pHomBrood ---- @@ -167,6 +176,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 +209,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) @@ -215,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) }) @@ -231,6 +241,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 +270,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 +301,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 +336,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 +361,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,9 +385,14 @@ test_that("getCsdAlleles", { founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes) 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 @@ -387,6 +407,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 +423,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 +451,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 +471,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) @@ -464,39 +489,34 @@ 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 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) 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 ---- @@ -505,6 +525,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 +544,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 +560,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 +586,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 +640,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 +655,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 +693,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 +719,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 +748,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,9 +774,18 @@ 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))) + 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 @@ -776,6 +816,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 +845,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 +875,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 +905,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 +935,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 +946,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 +1008,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") @@ -1023,5 +1073,59 @@ 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) + }) + + +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/tests/testthat/test-L1_pop_functions.R b/tests/testthat/test-L1_pop_functions.R index 7cabd2b8..dc31682e 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))) @@ -65,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))) @@ -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) @@ -190,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")) @@ -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) @@ -282,47 +288,17 @@ 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)) }) -# ---- 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] @@ -414,3 +393,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..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) @@ -109,9 +112,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") @@ -124,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) @@ -154,7 +156,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 +171,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) }) @@ -180,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) @@ -201,9 +204,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 +214,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 +222,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 ---- @@ -235,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) @@ -256,9 +260,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") @@ -281,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) @@ -290,29 +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_s4_class(setLocation(emptyApiary, location = c(1,2)), "MultiColony") - 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") + 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 ---- @@ -321,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) @@ -357,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) @@ -398,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) @@ -421,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))) @@ -436,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) @@ -456,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 ---- @@ -472,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) @@ -514,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) @@ -526,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)) 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 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 00000000..23aa9b67 Binary files /dev/null and b/vignettes/582-5827311_reindeer-clipart-cartoon-hd-png-download.png differ diff --git a/vignettes/A_Honeybee_biology.Rmd b/vignettes/A_Honeybee_biology.Rmd index bfc770d6..de6ae180 100644 --- a/vignettes/A_Honeybee_biology.Rmd +++ b/vignettes/A_Honeybee_biology.Rmd @@ -343,7 +343,7 @@ either on the queen (`Pop` class) or colony (`Colony` class) directly. You can obtain the entire `misc` slot with the `getMisc()` function. ```{r misc} -getMisc(getQueen(colony)) +getQueen(colony)@misc ``` Technically, in SIMplyBee we represent the *CSD* locus as a series of bi-allelic @@ -412,7 +412,7 @@ population as well as the cumulative number of workers, drones, homozygous brood, and the expected proportion of homozygous brood. ```{r queens counters} -getMisc(getQueen(inbredColony)) +getQueen(inbredColony)@misc ``` # References diff --git a/vignettes/Colony_locations.csv b/vignettes/Colony_locations.csv index 0ac2a90d..443bd664 100644 --- a/vignettes/Colony_locations.csv +++ b/vignettes/Colony_locations.csv @@ -1,36 +1,101 @@ 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 -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 +1,0.30246876180172,13.5680265678093 +2,0.328660267405212,0.230694911442697 +3,0.532931350171566,6.89345428720117 +4,0.554551710374653,4.68558953609318 +5,0.629156911745667,0.279240505769849 +6,0.671967742964625,17.1117002982646 +7,0.795799111947417,9.97861184645444 +8,0.889007914811373,18.0744510842487 +9,1.08249292243272,4.18142573907971 +10,1.76398073323071,19.3510066857561 +11,2.06587394233793,4.89467685110867 +12,2.22358959726989,10.42424893938 +13,2.41654846817255,17.1935720648617 +14,2.61507376562804,5.09964525699615 +15,3.18207403644919,18.4958416642621 +16,3.47847714554518,15.3918297309428 +17,3.66037802770734,17.2304466227069 +18,3.74132486991584,7.91927644517273 +19,3.97427225019783,15.3488130960613 +20,4.19678919482976,9.55652902834117 +21,4.2837427277118,17.7206097915769 +22,4.62615274824202,11.513376631774 +23,4.83518063556403,15.8491191500798 +24,4.85130980610847,4.47302039712667 +25,5.16881859861314,6.28163623157889 +26,5.19831704907119,6.9121059961617 +27,5.26363757904619,13.8959817355499 +28,5.45809471514076,4.69870080705732 +29,5.51655640359968,1.40742801595479 +30,5.68633042741567,2.30602155905217 +31,5.71348829194903,16.0174032766372 +32,5.89949000626802,16.1237397324294 +33,5.94707132317126,8.77102635800838 +34,6.52549914084375,10.9276177594438 +35,6.64702823851258,3.34596386644989 +36,6.76982532721013,3.69761612731963 +37,6.9422508077696,16.4812337094918 +38,7.01209335122257,8.44147069379687 +39,7.06726936157793,3.98196509107947 +40,7.15269854757935,0.942593486979604 +41,7.59615723509341,2.06106903962791 +42,7.60692864656448,0.246548759751022 +43,7.79631066136062,8.82288652937859 +44,7.80182282906026,8.72040851507336 +45,8.13581576570868,12.335317065008 +46,8.32452747039497,4.27113793324679 +47,8.34376669023186,0.651969611644745 +48,8.49635017570108,0.836413488723338 +49,8.5975763015449,2.3530611442402 +50,9.50357185211033,16.2676147790626 +51,9.61287333164364,16.9935433985665 +52,9.61347470991313,3.23382373899221 +53,9.88090057857335,1.64770697243512 +54,10.0166122242808,3.30901465378702 +55,10.158522631973,4.36188969761133 +56,10.3639576584101,3.76523439306766 +57,10.3782365657389,14.6457815961912 +58,10.4552760208026,19.4050138443708 +59,10.4559582751244,1.86300801113248 +60,10.6637138035148,0.421456126496196 +61,10.7791617000476,13.6921494081616 +62,11.1490270169452,15.7337884651497 +63,11.540995426476,8.0075244884938 +64,11.7663353541866,9.72485895268619 +65,11.8653199728578,4.22352631110698 +66,12.3205161234364,12.2498733829707 +67,12.7045208076015,15.4077621595934 +68,13.0099443718791,11.6953312419355 +69,13.1850015791133,2.81174765899777 +70,13.3533105300739,1.69277373235673 +71,13.4748032409698,18.4217299660668 +72,13.8676447514445,12.9880055924878 +73,13.9608838129789,7.24800200667232 +74,13.9657207438722,12.0809442177415 +75,14.4978069979697,13.5346562089399 +76,14.6812073001638,5.97479528281838 +77,15.086920466274,19.1412157425657 +78,15.2499006735161,0.0964592350646853 +79,15.4063926683739,4.43654011934996 +80,15.5607084650546,4.51118238270283 +81,15.690461457707,15.9257507044822 +82,15.7422301871702,0.413396516814828 +83,15.8097428595647,9.61102602537721 +84,15.9182216692716,17.1141409641132 +85,16.2850567884743,16.6348816081882 +86,16.7025210754946,13.1810147548094 +87,16.7408970743418,16.8664436554536 +88,16.8189784511924,5.44885457959026 +89,17.0996031770483,1.48409378249198 +90,17.5897324690595,17.4150753160939 +91,17.7121019735932,5.33572813030332 +92,17.7660484751686,9.86570597160608 +93,17.7955863019451,9.08471441362053 +94,18.0510748038068,18.6848957650363 +95,18.1303640268743,19.3045887723565 +96,18.6754721216857,18.5012276284397 +97,18.74611643143,15.5949999345466 +98,18.8989109545946,18.1048372155055 +99,19.5480148447677,13.1747700739652 +100,19.9809777038172,2.85514499526471 diff --git a/vignettes/D_Crossing.Rmd b/vignettes/D_Crossing.Rmd index 7c25f075..79c65132 100644 --- a/vignettes/D_Crossing.Rmd +++ b/vignettes/D_Crossing.Rmd @@ -333,7 +333,7 @@ mating with the queen, which follows the believe that drones aggregate in a DCA. crossPlan2 <- createCrossPlan(x = beekeeper3, droneColonies = c(beekeeper1, beekeeper2), spatial = TRUE, - radius = 3, + radius = 5, nDrones = 13) # Inspect the cross plan crossPlan2 @@ -406,7 +406,7 @@ beekeeper5 <- cross(x = beekeeper5, droneColonies = c(beekeeper1, beekeeper2, beekeeper3), crossPlan = "create", spatial = TRUE, - radius = 3, + radius = 8, nDrones = 12, checkCross = "warning") nFathers(beekeeper5) diff --git a/vignettes/F2_Variance_calculations.Rmd b/vignettes/F2_Variance_calculations.Rmd index 5daf390e..d49037dd 100644 --- a/vignettes/F2_Variance_calculations.Rmd +++ b/vignettes/F2_Variance_calculations.Rmd @@ -45,8 +45,7 @@ colony <- addWorkers(x = colony, nInd = 50) colony <- buildUp(colony) apiary <- createMultiColony(basePop[7:20]) drones <- createDrones(basePop[1:5], nInd = 100) -droneGroups <- pullDroneGroupsFromDCA(drones, n = 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) colonyGv <- calcColonyGv(apiary) colonyPheno <- calcColonyPheno(apiary) @@ -75,7 +74,7 @@ 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 aobut 1/2! +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;) :( @@ -116,23 +115,34 @@ 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 unrelated -honeybees +$\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 -$\sigma_{g_w}^2=0.32$ - this is their $\sigma_{\bar{A}_w}^2=0.32$ among averages -of groups of honeybees? +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^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_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$ @@ -143,13 +153,14 @@ $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 WHAT WE WORK WITH HERE SO WHAT IS -NOVEL IN OUR WORK? I think its about providing a tool and demonstrate it -clearly. Also, they work with average, while we work with the sum? +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 @@ -244,9 +255,12 @@ C) covariance between the two $2Cov(g_{q,q}, \Sigma_{i=1}^{n_w}(g_{i,w}))$. ```{r check_queen_variances} varA[1] -var(getQueenGv(apiary, collapse = TRUE)[, "queenTrait"]) +x = getQueenGv(apiary, collapse = TRUE)[, "queenTrait"] +var(x) # ... note that R's var() divides by n-1, which matters with small n -sum((getQueenGv(apiary, collapse = TRUE)[, "queenTrait"] - mean[1])^2) / nColonies(apiary) +popVar(x) +sum((x - mean[1])^2) / nColonies(apiary) + ``` Anyway, quite close! @@ -282,6 +296,7 @@ g <- calcColonyGv(apiary, mapCasteToColonyGv, queenTrait = NULL, 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 @@ -323,6 +338,7 @@ g <- calcColonyGv(apiary, mapCasteToColonyGv, queenTrait = NULL, 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 @@ -371,6 +387,7 @@ nW * nW (a <- nW * nW / nF) (b <- (nF - 1) * nW * nW / nF) a+b +#TODO define nDPQ ``` Looks like! @@ -381,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 +(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 @@ -439,40 +456,63 @@ $2Cov(g_{q,q}, \Sigma_{i=1}^{n_w}(g_{i,w})) = 2 n_w \frac{1}{2}Cov(g_{q,q}, g_{q $2Cov(g_{q,q}, \Sigma_{i=1}^{n_w}(g_{i,w})) = n_w \sigma_{g_{q},g_{w}}$ ```{r check_workers_variances4} -(varQueen <- varA[1]) # A - -(varSumWorkers <- nW * varA[2]) # B1 -(covSumWorkersSuperSisters <- (nW * nW / nF) * 0.50 * varA[2]) # B2 in super-sisters -(covSumWorkersHalfSisters <- ((nF - 1) * nW * nW / nF) * 0.25 * varA[2]) # B2 in half-sisters -(varSumWorkers <- varSumWorkers + covSumWorkersSuperSisters + covSumWorkersHalfSisters) # B - -(covQueenSumWorkers <- nW * covA[1, 2]) # C - -varQueen + varSumWorkers + covQueenSumWorkers - +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) -sum((g - 20)^2) / nColonies(apiary) +popVar(g) +sum((g - (mean(g)))^2) / nColonies(apiary) +``` +Bingo for genetic variance. -(varQueen <- varP[1]) # A +```{r} -(varSumWorkers <- nW * varP[2]) # B1 -(covSumWorkersSuperSisters <- (nW * nW / nF) * 0.50 * varA[2]) # B2 in super-sisters - only genetic cov here, I think TODO!? -(covSumWorkersSisters <- ((nF - 1) * nW * nW / nF) * 0.25 * varA[2]) # B2 in sisters - only genetic cov here, I think TODO!? -(varSumWorkers <- varSumWorkers + covSumWorkersSuperSisters + covSumWorkersSisters) # B -(covQueenSumWorkers <- nW * covP[1, 2]) # C - pheno or genetic only here - TODO!? +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 -varQueen + varSumWorkers + covQueenSumWorkers +print("Part A + B + C f") +varQueen_A + varCovSumWorkers_A + covQueenSumWorkers_A + varQueen_E + varSumWorkers_E + covQueenSumWorkers_E p <- colonyPheno var(p) -sum((p - 20)^2) / nColonies(apiary) +popVar(p) +sum((p - (mean(p)))^2) / nColonies(apiary) ``` -Bingo for genetic variance and very close for phenotypic too, but we need to -check some part above! +And very close for phenotypic too, but we need to check some part above! # What now? @@ -491,9 +531,11 @@ $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}$ +$B2ss_g = (\frac{n^2_w}{n_f} - {n_w}) \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}$ +$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}}$ @@ -549,3 +591,213 @@ 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! diff --git a/vignettes/F2_Variance_calculations_functions.Rmd b/vignettes/F2_Variance_calculations_functions.Rmd new file mode 100644 index 00000000..63668904 --- /dev/null +++ b/vignettes/F2_Variance_calculations_functions.Rmd @@ -0,0 +1,498 @@ +--- +title: "Variance calculations between individual and colony level values - functions" +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 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) +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 ExpectedAndRealisedVariances} +corA +(covA <- corA * outer(X = sqrt(varA), Y = sqrt(varA), FUN = "*")) + +# Trait environmental variation - on a per honeybee level +(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 + + +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] + +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 AdjustingWorkerVariance} +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 CovariancesBetweenWorkers} +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)) +} +``` + +```{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) +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("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(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")) +``` + +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, + 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)) +} +``` + +```{r testMapColonyToIndFunction} +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) + + +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) + + +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) + +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) +``` 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/H_Parallelisation.Rmd b/vignettes/H_Parallelisation.Rmd new file mode 100644 index 00000000..2f7cde27 --- /dev/null +++ b/vignettes/H_Parallelisation.Rmd @@ -0,0 +1,160 @@ +--- +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 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(future) + +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 + +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 `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 = "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) +``` + +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, 8, or 16. All options were tested on an HPC cluster. + +```{r parallelisation_options, eval=F, echo=T} + +# First one - sequential +plan(sequential) +create_bee_colonies() + +# Second one - use forking +plan(multicore, workers = nCores) +create_bee_colonies() + + +# Third one - use PSOCK parallelisation +plan(multisession, workers = nCores) +create_bee_colonies() +``` + +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 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 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") +``` diff --git a/vignettes/PCPU_mean.png b/vignettes/PCPU_mean.png new file mode 100644 index 00000000..5b3949aa Binary files /dev/null and b/vignettes/PCPU_mean.png differ diff --git a/vignettes/Profiling_parallelised_functions_Unix.png b/vignettes/Profiling_parallelised_functions_Unix.png new file mode 100644 index 00000000..b3111150 Binary files /dev/null and b/vignettes/Profiling_parallelised_functions_Unix.png differ diff --git a/vignettes/RSS_mean.png b/vignettes/RSS_mean.png new file mode 100644 index 00000000..2d2f5975 Binary files /dev/null and b/vignettes/RSS_mean.png differ diff --git a/vignettes/Time_mean.png b/vignettes/Time_mean.png new file mode 100644 index 00000000..7bad43bc Binary files /dev/null and b/vignettes/Time_mean.png differ 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.