diff --git a/.Rbuildignore b/.Rbuildignore index 2e0fc2b0..47f82f82 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -1,11 +1,21 @@ -^\.Rhistory -^\.Rproj\.user -^\.git -^\.github +^.*\.Rproj$ +^\.Rproj\.user$ +^\.Rhistory$ +^\.git$ +^\.github$ ^\.gitignore +^[.]?air[.]toml$ +^[.]?jarl[.]toml$ +^AGENTS\.md$ ^_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 +23,9 @@ ^vignettes/SIMplyBee\_logo\_hex\.R ^vignettes/SIMplyBee\_logo\_hex\.png ^vignettes/SIMplyBee\_logo\_small\.png -^.*\.Rproj$ -^\.Rproj\.user$ -^doc$ ^Meta$ +^SIMplyBee\.Rproj + +^literature$ +^dev$ +^TestingVarianceComponents\.R$ 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 7a82f371..736032a2 100644 --- a/.gitignore +++ b/.gitignore @@ -7,22 +7,48 @@ # User-specific files .Ruserdata +Rplots.pdf # Example code in package build process *-Ex.R # Output files from R CMD build /*.tar.gz +src/*.o +src/*.so # Output files from R CMD check /*.Rcheck/ -# RStudio files +# Local IDE state .Rproj.user/ +.idea/ +.vscode/ + +# Compiled code and coverage output +/src/**/*.o +/src/**/*.so +/src/**/*.dll +/src/**/*.dylib +/src/**/*.gcda +/src/**/*.gcno +/covr/ + +# Binary package builds +/SIMplyBee_*.tgz +/SIMplyBee_*.zip + +# Installed documentation and rendered development documents +/inst/doc/ +/README.html +/README_files/ +/cran-comments.html +/cran-comments_files/ # produced vignettes vignettes/*.html vignettes/*.pdf +vignettes/*_files/ # OAuth2 token, see https://github.com/hadley/httr/releases/tag/v0.3 .httr-oauth @@ -30,6 +56,7 @@ vignettes/*.pdf # knitr and R markdown default cache directories *_cache/ /cache/ +.quarto/ # Temporary files created by R markdown *.utf8.md @@ -40,5 +67,7 @@ vignettes/*.pdf # Other .DS_Store -src/*.o -src/*.so +/doc/ +/Meta/ + +literature/*.pdf diff --git a/AGENTS.md b/AGENTS.md new file mode 100644 index 00000000..2080bcda --- /dev/null +++ b/AGENTS.md @@ -0,0 +1,384 @@ +# 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. + +## Package map + +* `R/Class-SimParamBee.R`: R6 simulation parameters extending AlphaSimR's + `SimParam`; holds shared simulation settings and bookkeeping. +* `R/Class-Colony.R`: S4 colony holding the queen, virgin queens, workers, + drones, colony state, and metadata. +* `R/Class-MultiColony.R`: list-like collection of colonies, including + subsetting and replacement methods. +* `R/Functions_L0_auxilary.R`: auxiliary functions (the filename spelling is + intentional here); `Functions_L1_Pop.R`, `Functions_L2_Colony.R`, and + `Functions_L3_Colonies.R` respectively provide population, colony, and + multicolony operations. +* `src/`: compiled helpers to speed up operations. +* `tests/testthat/` unit tests. +* `vignettes`: longer form documentation. +* `docs`: pkgdown output. + +## Scientific invariants and shared state + +* Seeded results are part of observable behavior. Reordering random operations, + batching crosses, or changing parallel execution can change results even when + their distributions remain correct. Assess these effects explicitly and record + intentional user-visible changes in `NEWS.md`. +* Running the same seed twice in a modified implementation checks repeatability, + not compatibility with the previous implementation. For changes that should + preserve seeded results, compare against the previous implementation under + the same R and dependency versions using a small representative regression case. +* Test thread-count independence where the supported implementation promises it. + Review RNG handling when changing `future.apply` paths, including `future.seed`; + do not assume worker-count, scheduling, and sequential/parallel equivalence + without checking the relevant path. +* `SimParamBee` has R6 reference semantics: changing a field affects the caller. + Do not silently overwrite user settings. When temporarily changing settings + such as `nThreads`, register restoration with `on.exit(..., add = TRUE)` before + doing work that can fail. Preserve intentional updates to simulation counters + and records. +* Create new individuals through supported SIMplyBee/AlphaSimR constructors and + crossing functions. Direct S4 construction or manual ID changes can bypass + ID, pedigree, and recombination bookkeeping. Check these invariants explicitly + when changing population creation, especially across parallel workers. +* Treat population and colony metadata as biological state. Queens' `misc` + includes fathers and brood counts. When subsetting, merging, or rebuilding + populations, verify metadata, individual order, IDs, and class preservation; + inspect the supported AlphaSimR/SIMplyBee methods + rather than assuming all slots survive. +* Preserve the package's representation of haploid drones and diploid females, + caste-specific inheritance, and complementary sex determination. For relevant + changes, test maternal-only inheritance in drones, parental allele inheritance + in female offspring, and homozygous-brood handling with csd enabled, as well as + the supported csd-disabled path. Respect the existing genotype representation + rather than inferring ploidy solely from storage dimensions. + +## The way of working + +* 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. +* Package checks should have no new errors or warnings. Report existing failures + and explain any accepted NOTEs; do not assume every NOTE is harmless. +* We update `NEWS.md` for user-visible behavior or API changes. + +## Permissions and authorization + +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 + +Run the R commands below from the package directory of the active worktree. + +A task is done when all applicable items below are completed: + +* Added/updated user-facing examples and tests for new functionality. +* Run applicable formatting/lint checks described below and `git diff --check`. +* `Rscript -e "devtools::test()"` + for package tests. +* `Rscript -e "devtools::check()"` + for full package checks. +* Updated `NEWS.md` for user-visible changes. + +### Task-class quality gates + +* 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 (`devtools::test()` and `devtools::check()`, plus applicable lint checks). +* If full checks are intentionally skipped, explicitly report what was skipped, + why, and which focused checks were run. + +## 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/ +``` + +Choose `` from the task or PR target. The README distinguishes +`main` (pre-CRAN stable work) from `devel` (development); do not assume `main` +is always the correct base. Reuse an existing task worktree when appropriate. + +Within this workflow, follow these rules: + +* In the shared root worktree, limit edits to small docs/meta/config work. +* 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/ +``` + +* Inspect staged and unstaged changes first. Preserve existing work; do not + stash, rebase, or change branches in a shared dirty checkout as routine setup. +* If conflicts occur, preserve local edits, resolve conflicts carefully, and + report conflicted files plus the chosen resolution. +* By default, edit files freely but do not run `git add`, `git commit`, + or `git push` unless explicitly requested. +* If a command leaves files staged unintentionally, report that in handoff. + +Remove a task worktree only once its work is preserved and it is clean; never +force removal to discard uncommitted work. After merge/finish: + +```sh +git worktree remove ../SIMplyBee_wt_ +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 + +The checkout has `air.toml` and `jarl.toml`. + +Use Air and Jarl when installed, scoped to changed R files, for example: + +```sh +air format R/Functions_L0_auxilary.R +jarl check R/Functions_L0_auxilary.R +git diff --check +``` + +Avoid repository-wide formatting churn. Check tool help before using unfamiliar +flags. Report unavailable checks rather than silently installing or upgrading +tools. If a tool is missing from `PATH`, also check user-local bin directories: + +```sh +which || PATH="$HOME/.local/bin:$HOME/bin:$PATH" which +``` + +### Coverage with covr + +Use `covr` for test-coverage checks on behavior-changing work: + +```sh +Rscript -e "cov <- covr::package_coverage(clean = TRUE); print(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. +* `.github/workflows/document.yaml`: regenerates roxygen documentation on R-source + pushes and can commit the generated changes back to the branch. +* `.github/workflows/pkgdown.yaml`: builds the website and deploys on non-PR runs. + +Check each workflow's triggers before assuming it runs for a particular branch. +Regenerate documentation locally when needed and inspect its diff before handoff. + +Local work should pass local checks before relying on CI feedback. + +## Dependencies and package data + +* Keep dependencies minimal and justify additions. Required runtime packages + belong in `Imports`; optional features, examples, and tests use `Suggests`. + Preserve the intentional `Depends: AlphaSimR` relationship. +* Prefer `pkg::fun()` for new external calls, while respecting established + namespace imports. Do not call `library()` or `require()` inside package + functions. Guard optional features with `requireNamespace(..., quietly = TRUE)` + and a useful message, and skip tests when optional dependencies are unavailable. + Do not create unconditional namespace imports from suggested packages. +* When adding package datasets, keep preparation scripts in `data-raw/`, use + `usethis::use_data()` where appropriate, and document datasets with roxygen + `@format` and `@source`. Dataset documentation does not need `@export`. +* Exclude development-only top-level files and directories from package builds + in `.Rbuildignore`, including agent instructions and data-preparation scripts. + +## Generated files and source-of-truth rules + +Do not edit generated files by hand: + +* `R/RcppExports.R` +* `src/RcppExports.cpp` +* `NAMESPACE` +* Files in `man/` generated from roxygen comments +* Generated website output in `docs/`; edit its sources in `R/`, `vignettes/`, + `README.md`, and `_pkgdown.yml` instead + +Regenerate as needed: + +```sh +Rscript -e "Rcpp::compileAttributes()" +Rscript -e "devtools::document()" +``` + +Additional source-of-truth rules: + +* This checkout maintains `README.md` directly; there is no `README.Rmd`. + If a generated README workflow is introduced, edit its source and regenerate + the output (for an R Markdown source, use `devtools::build_readme()`). +* `.github/workflows/document.yaml` runs on pushes touching `R/**` and commits + generated `man/`, `NAMESPACE`, and `DESCRIPTION` changes back to the branch. + Account for these automated commits when synchronising work. +* For local documentation generation, use the roxygen2 version recorded in + `DESCRIPTION` when available. Report a version mismatch and inspect generated + diffs for unrelated churn; CI currently installs roxygen2 without that pin. +* Changes to Rcpp-exported signatures require `Rcpp::compileAttributes()` and + rebuilding the package; the documentation workflow does not regenerate Rcpp + exports. +* Leave release version/date changes to release work explicitly requested by the + maintainer. A development NEWS heading differing from `DESCRIPTION` is not, + on its own, a reason to bump the package version. + +## R CMD Check + +### Preferred way to R CMD Check + +Run faster package checks from the package directory: + +```sh +Rscript -e "devtools::check(vignette = FALSE)" +``` + +Run this for every code change so changes are evaluated +in the same package context (build, docs, and tests). + +Run slower package checks from the package directory: + +```sh +Rscript -e "devtools::check()" +``` + +### Check environment and reporting + +A fast check with `vignette = FALSE` is an intermediate check, not a replacement +for the full check when vignettes or package behavior change. Vignettes use +knitr/rmarkdown; CI sets up Pandoc. Check R, compiler, Pandoc, and LaTeX +availability as relevant to the actual failure. Do not assume Quarto is required +or hard-code an IDE installation path. + +If compiler detection fails inside the sandbox, inspect the error first; it +may be a sandbox restriction rather than a missing compiler. Request escalated +execution when needed under the standing authorization above. + +At handoff, record commands run, errors/warnings/notes, and any skipped checks +with reasons. Compare failures with the unchanged base when needed to distinguish +existing problems from regressions. Never claim a check passes based on an older +run or assume a fixed expected result for this machine. + +## Testing + +We strive for very good testing with `testthat`. + +* Add or update `testthat` tests for every behavior change. +* Prefer focused regression tests for bug fixes. +* Use the configured testthat edition (currently edition 3); do not change it + incidentally when adding tests. +* For stochastic tests, prefer biological invariants over arbitrary sampled + values. Use controlled seeds and justified tolerances when random outcomes are + part of the assertion; keep fixtures small and avoid flaky Monte Carlo checks. +* Keep ordinary simulation tests and examples single threaded with + `SP$nThreads = 1L` (use `\dontshow{SP$nThreads = 1L}` in roxygen examples). + Dedicated parallel/thread tests should set their own configuration and skip + explicitly when the required execution capability is unavailable. +* Keep tests runnable via package tests and checks. +* Keep stochastic tests reproducible with explicit seeds and small populations. + Set `SP$nThreads <- 1L` where appropriate; pass `simParamBee = SP` explicitly + to avoid dependence on global state. Restore any global options or parallel + plans changed by a test. +* Prefer independently derived expectations, biological invariants, and small + enumerated cases over tests that repeat the implementation. For simulation + estimates, use tolerances justified by sampling error. +* Cover relevant haplodiploid, caste, empty-colony, and single/multiple-colony + cases when changing population or colony operations. +* Guard genuinely optional external dependencies with explicit skips; do not + hide failures in required package dependencies such as AlphaSimR. + +For testing use: + +* `Rscript -e "devtools::test()"` + for package tests, or a focused run such as + `Rscript -e "devtools::test(filter = 'L2_colony_functions')"`. + +Tests are also run as part of R CMD check. + +## Research, examples, and references + +* Keep development plans and exploratory or standalone validation scripts in + `dev/`; consult `dev/README.md` and the relevant topic plan when present + before continuing existing research. Update that plan when completing planned work. +* Put automated regression tests in `tests/testthat/` and user tutorials in + `vignettes/`. Keep expensive simulation experiments out of routine tests. +* Check `.Rbuildignore` before assuming a vignette or development script runs + in package checks; validate excluded material explicitly when changing it. +* Keep scientific assumptions explicit, especially individual versus colony + quantities, sum versus mean worker effects, mating/worker allocation, + relatedness, and covariance conventions. Keep equations, code, and examples + consistent and cite sources for model changes. +* Where present, use `inst/REFERENCES.bib` for package citations and + `literature/README.md` for the local literature archive. Verify references + rather than inventing them. + +## Proofreading + +If asked to proofread, act as an expert proofreader and editor +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 94b58e24..0016bbdb 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,15 +1,15 @@ Package: SIMplyBee Type: Package Title: 'AlphaSimR' Extension for Simulating Honeybee Populations and Breeding Programmes -Version: 0.4.2 +Version: 0.5.0 Authors@R: c( person("Jana", "Obšteter", email = "obsteter.jana@gmail.com", role = c("aut", "cre"), comment = c(ORCID = "0000-0003-1511-3916")), - person("Laura", "Strachan", role = "aut", + person("Laura", "Strachan", role = "aut", comment = c(ORCID = "0000-0002-2569-0250")), - person("Jernej", "Bubnič", role = "aut", + person("Jernej", "Bubnič", role = "aut", comment = c(ORCID = "0000-0003-1362-3736")), - person("Gregor", "Gorjanc", role = c("aut"), + person("Gregor", "Gorjanc", role = c("aut"), comment = c(ORCID = "0000-0001-8008-2787"))) Description: An extension of the 'AlphaSimR' package () for stochastic simulations of @@ -26,11 +26,11 @@ 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.6.1) +Imports: methods, R6, stats, utils, extraDistr (>= 1.9.1), RANN, Rcpp (>= 0.12.7), Rdpack, 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: +Suggests: + future, rmarkdown, knitr, ggplot2, @@ -39,3 +39,5 @@ Suggests: Config/testthat/edition: 3 Config/Needs/website: tidyverse/tidytemplate VignetteBuilder: knitr +Config/roxygen2/version: 8.1.1 +RdMacros: Rdpack diff --git a/NAMESPACE b/NAMESPACE index 07ec9e03..e400fa59 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) @@ -74,7 +76,6 @@ export(getPooledGeno) export(getQtlGeno) export(getQtlHaplo) export(getQueen) -export(getQueenAge) export(getQueenCsdAlleles) export(getQueenCsdGeno) export(getQueenGv) @@ -86,7 +87,6 @@ export(getQueenSegSiteGeno) export(getQueenSegSiteHaplo) export(getQueenSnpGeno) export(getQueenSnpHaplo) -export(getQueenYearOfBirth) export(getSegSiteGeno) export(getSegSiteHaplo) export(getSnpGeno) @@ -143,7 +143,12 @@ export(isWorkersPresent) export(mapCasteToColonyGv) export(mapCasteToColonyPheno) export(mapCasteToColonyValue) +export(mapColonyToIndVar) +export(mapIndToColonyVar) export(nCaste) +export(nCasteColonyPhenotype) +export(nCastePoisson) +export(nCasteTruncPoisson) export(nColonies) export(nCsdAlleles) export(nDrones) @@ -191,7 +196,6 @@ export(replaceWorkers) export(resetEvents) export(selectColonies) export(setLocation) -export(setQueensYearOfBirth) export(simulateHoneyBeeGenomes) export(split) export(splitPColonyStrength) @@ -204,22 +208,28 @@ exportClasses(MultiColony) import(AlphaSimR) import(Rcpp) importFrom(R6,R6Class) +importFrom(Rdpack,reprompt) importFrom(extraDistr,rtpois) -importFrom(methods,"slot<-") -importFrom(methods,classLabel) -importFrom(methods,is) -importFrom(methods,new) -importFrom(methods,setClass) -importFrom(methods,setClassUnion) -importFrom(methods,setMethod) -importFrom(methods,setValidity) -importFrom(methods,show) -importFrom(methods,slot) -importFrom(methods,validObject) -importFrom(stats,na.omit) -importFrom(stats,rbeta) -importFrom(stats,rnorm) -importFrom(stats,rpois) -importFrom(stats,runif) +importFrom(future.apply,future_lapply) +importFrom(methods, + "slot<-", + classLabel, + is, + new, + setClass, + setClassUnion, + setMethod, + setValidity, + show, + slot, + validObject +) +importFrom(stats, + na.omit, + rbeta, + rnorm, + rpois, + runif +) importFrom(utils,packageVersion) useDynLib(SIMplyBee, .registration = TRUE) diff --git a/NEWS.md b/NEWS.md index 33dbee69..7631a7a0 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,98 +1,150 @@ --- -editor_options: - markdown: +editor_options: + markdown: wrap: 72 --- -# SIMplyBee version 0.4.2 +# SIMplyBee version 0.5.0 -- 20??-??-?? +- 2026-29-09 ## Major changes -- TODO + +- `calcColonyValue()` now passes each Colony to the first argument of its + callback by position. Callbacks may name that argument `colony`, `x`, or + another name. This also applies to `SimParamBee$colonyValueFUN`. + +- Colony IDs are now character, consistently with AlphaSimR individual IDs. + `getId()` returns character IDs, including for empty collections and missing + entries, so `apiary[getId(apiary)]` selects by ID/name and not by position! + Colony IDs are independent of queen IDs and remain unchanged when queens + are removed or replaced. Crossing plans now support non-numeric donor-colony IDs and + correctly map reordered colony names to queen IDs. + +- 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 + +- we no longer support creating an exact number of workers with the csd + functionality turned on. Due to inbreeding at the csd locus, some workers + are not viable. Previous funcionality re-ran the creation of workers until + a required number was available. We no longer support this, so the number of + returned workers is the number of viable workers. + +- the 'cross' function now removes unsuccessfully mated queens. + This can primarily happen when creating a spatial cross plan. + If there are no drone producing colonies in the specified radius, + the mating fails and the queens/colonies are removed from the object. + This is to ensure all further functionality works well. ## New features -- TODO + +- Both variance mappings now return `h2Queen`, `h2Worker`, + `h2WorkerGroup`, and `h2Colony`, with `NA` for zero total variance. + +- added functionality to map individual-level variance to colony-level variance and vice-versa + with functions 'mapIndToColonyVar' and 'mapColonyToIndVar' + +- Parallelised major colony operations with `future` and `future.apply`. + New vignette describes how to use parallelisation. This is an experimental feature! + +## Other + +- Added a shared `inst/REFERENCES.bib` bibliography for package help and + vignettes. ## Bug fixes -- editCsdLocus() works now also with just 2 alleles #591 -## Backgrond/package/etc. work -- calcBeeGRMIbs() can now return centred genotype matrix, allele frequencies, -and scale factor used to calculate the GRM #594 -- Improved default for getPooledGeno() (to type="mean"") and added an example -on how to collect pooled workers' genotype accross colonies (but pooling is -done within a colony!) #592 -- We now removed setMisc() and getMisc() because we now use the new AlphaSimR -structure of the misc slot that is much easier to use. #584 +- Moved `future` to Suggests because it is used by the parallelisation vignette; + package functions use `future.apply`. This removes the unused-import NOTE. + +- `calcQueensPHomBrood()`, `pHomBrood()`, and `nHomBrood()` now warn and + return `NA_real_` for queenless colonies, allowing `MultiColony` summaries + to continue. + +- `nFathers()` now lists all supported classes, including `Pop`, in its + invalid-input error message and documents queen population input. + +- Brood summaries now use numeric missing values and return `numeric(0)` + for empty populations. Inactive csd metadata also uses numeric missing + values. `getId(NULL)` now returns `NA_character_`. + +- Fixed the inconsistent use of `simParamBee` in some functions. # SIMplyBee version 0.4.1 -- 2024-09-19 +- 2024-09-19 ## Bug fixes -- locations of the colonies in the D_Crossing vignettes were previously +- locations of the colonies in the D_Crossing vignettes were previously sampled by random. This caused that on some runs some queens were left unmated, which caused an error. We now read in the locations from a csv file. - # SIMplyBee version 0.4.0 -- 2024-08-23 +- 2024-08-23 ## Major changes -- createColony() and createMultiColony() do not have the location +- createColony() and createMultiColony() do not have the location argument anymore; use setLocation() instead; by default, location is now c(0, 0) PR#500 - ## New features -- In setLocation(MultiColony) we can set one location (numeric) or + +- In setLocation(MultiColony) we can set one location (numeric) or multiple (list or data.frame) PR#500 -- getLocation(MultiColony) got the collapse argument +- getLocation(MultiColony) got the collapse argument Commit#f4e629c3e8920948ad576eae3615a86b26300790 -- We can now sample location of a swarm - see sampleLocation and +- We can now sample location of a swarm - see sampleLocation and radius arguments in swarm() PR#500 PR#502 -- New function rcircle() to sample a random point within a circle with +- New function rcircle() to sample a random point within a circle with a given radius PR#502 -- Removed the function createRandomCrossPlan() - that option is now +- Removed the function createRandomCrossPlan() - that option is now included in the newly added createCrossPlan() fuction -- Added the **functionality for spatially-aware mating** of honeybee +- Added the **functionality for spatially-aware mating** of honeybee colonies. The new functionality is included in the createCrossPlan(), that allows to create the cross plan according to the colonies' locations, and in the cross() function, that crosses bees according to their location. This did not break the old functionality of the cross function. - -- Unified setMisc and getMisc behaviour to comply with the new AlphaSimR behaviour -- Added new C++ function isHeterozygous() to speed up the SIMplyBee function isCsdHeterozygous() +- Unified setMisc and getMisc behaviour to comply with the new AlphaSimR behaviour + +- Added new C++ function isHeterozygous() to speed up the SIMplyBee function isCsdHeterozygous() ## Bug fixes -- Bug fix - get\*Haplo() functions were returning diploid drones when +- Bug fix - get\*Haplo() functions were returning diploid drones when input was a Pop-class # SIMplyBee version 0.3.0 -- 2022-12-05 First public/CRAN version of the package +- 2022-12-05 First public/CRAN version of the package ## Major changes -- \~2 years of work went into this first public version! +- \~2 years of work went into this first public version! ## New features -- Many;) See the vignettes and help pages. +- Many;) See the vignettes and help pages. ## Bug fixes -- Many bugs and issues squashed - see +- Many bugs and issues squashed - see . Please contribute to the development of this package. diff --git a/R/Class-Colony.R b/R/Class-Colony.R index 7bdd2595..9d29c784 100644 --- a/R/Class-Colony.R +++ b/R/Class-Colony.R @@ -1,3 +1,4 @@ + # ---- Class Colony ---- setClassUnion("characterOrNULL", c("character", "NULL")) @@ -7,14 +8,17 @@ setClassUnion("logicalOrNULL", c("logical", "NULL")) setClassUnion("listOrNULL", c("list", "NULL")) setClassUnion("PopOrNULL", c("Pop", "NULL")) setClassUnion("NULLOrPop", c("NULL", "Pop")) -setClassUnion("integerOrNumericOrLogicalOrCharacter", c("integer", "numeric", "logical", "character")) +setClassUnion( + "integerOrNumericOrLogicalOrCharacter", + c("integer", "numeric", "logical", "character") +) #' @rdname Colony-class #' @title Honeybee colony #' #' @description An object holding honeybee colony #' -#' @slot id integer, unique ID of the colony +#' @slot id character, unique ID of the colony, independent of its queen ID #' @slot location numeric, location of the colony (x, y) #' @slot queen \code{\link[AlphaSimR]{Pop-class}}, the queen of the colony (we use #' its misc slot for queen's age and drones (fathers) she mated with) @@ -68,7 +72,7 @@ setClassUnion("integerOrNumericOrLogicalOrCharacter", c("integer", "numeric", "l setClass( Class = "Colony", slots = c( - id = "integer", + id = "character", location = "numeric", queen = "PopOrNULL", workers = "PopOrNULL", @@ -94,7 +98,9 @@ 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) { @@ -168,7 +174,7 @@ setMethod( signature(x = "NULLOrPop"), definition = function(x, ...) { if (is.null(x)) { - nList = length(list(...)) + nList <- length(list(...)) pop <- list(...)[[1]] if (nList > 1) { for (y in list(...)[[2:nList]]) { diff --git a/R/Class-MultiColony.R b/R/Class-MultiColony.R index 271b1fd5..bcdb2c1a 100644 --- a/R/Class-MultiColony.R +++ b/R/Class-MultiColony.R @@ -1,14 +1,20 @@ + # ---- Class MultiColony ---- setClassUnion("integerOrNumeric", c("integer", "numeric")) setClassUnion("integerOrNumericOrLogical", c("integer", "numeric", "logical")) -setClassUnion("integerOrNumericOrLogicalOrCharacter", c("integer", "numeric", "logical", "character")) +setClassUnion( + "integerOrNumericOrLogicalOrCharacter", + c("integer", "numeric", "logical", "character") +) #' @rdname MultiColony-class #' @title Honeybee multicolony object #' #' @description An object holding a collection of honeybee colonies. It behaves -#' like a list. +#' like a list. Numeric indices select positions; character indices select +#' colony by their IDs/names. Single bracket indexing returns a MultiColony, +#' while double brackets return one Colony (or NULL for an unpopulated entry). #' #' @slot colonies list, a collection of \code{\link[SIMplyBee]{Colony-class}} objects #' @@ -33,7 +39,7 @@ setClassUnion("integerOrNumericOrLogicalOrCharacter", c("integer", "numeric", "l #' \dontshow{SP$nThreads = 1L} #' basePop <- createVirginQueens(founderGenomes) #' -#' drones <- createDrones(x = basePop[1], nInd = 1000) +#' drones <- createDrones(x = basePop[1], nInd = 200) #' droneGroups <- pullDroneGroupsFromDCA(drones, n = 10, nDrones = nFathersPoisson) #' apiary <- createMultiColony(basePop[1:6], n = 6) #' apiary <- cross(apiary, drones = droneGroups[1:6]) @@ -43,27 +49,23 @@ setClassUnion("integerOrNumericOrLogicalOrCharacter", c("integer", "numeric", "l #' isMultiColony(apiary) #' #' getId(apiary) -#' apiary[1] #' getId(apiary[1]) #' getId(apiary["2"]) #' getId(apiary[2]) #' getId(apiary[-1]) #' getId(apiary[5]) #' -#' getId(apiary) #' getId(apiary[c(1, 3)]) #' getId(apiary[c("2", "4")]) #' getId(apiary[c(TRUE, FALSE, TRUE, FALSE)]) #' getId(apiary[c(TRUE, FALSE)]) # beware of recycling! -#' getId(apiary[c(5, 6)]) +#' getId(apiary[c(6, 7)]) #' getId(apiary[c("6", "7")]) #' +#' apiary[1] #' apiary[[1]] #' apiary[["2"]] -#' apiary[[3]] -#' apiary[["4"]] -#' try(apiary[[6]]) -#' apiary[["7"]] +#' try(apiary[[7]]) #' #' getId(c(apiary[c(1, 3)], apiary[2])) #' getId(c(apiary[2], apiary[c(1, 3)])) @@ -209,7 +211,12 @@ setMethod( #' @describeIn MultiColony-class Extract a colony (one or more!) with an integer/numeric/logical index (position) (return \code{\link[SIMplyBee]{MultiColony-class}}) setMethod( f = "[", - signature(x = "MultiColony", i = "integerOrNumericOrLogical", j = "ANY", drop = "ANY"), + signature( + x = "MultiColony", + i = "integerOrNumericOrLogical", + j = "ANY", + drop = "ANY" + ), definition = function(x, i, j, drop) { x@colonies <- x@colonies[i] validObject(x) @@ -237,7 +244,11 @@ setMethod( definition = function(x, i) { n <- length(i) if (n > 1) { - warning(paste("Selecting only the first colony out of ", n, " requested\n")) + warning(paste( + "Selecting only the first colony out of ", + n, + " requested\n" + )) } # ...@colonies[[i[1L]]] is to get just one colony ret <- x@colonies[[i[1L]]] @@ -253,7 +264,11 @@ setMethod( definition = function(x, i) { n <- length(i) if (n > 1) { - warning(paste("Selecting only the first colony out of ", n, " requested\n")) + warning(paste( + "Selecting only the first colony out of ", + n, + " requested\n" + )) } # x[i[1L]] calls x[character] # ...@colonies[[1L]] is to get just one colony @@ -269,25 +284,33 @@ setMethod( setReplaceMethod( f = "[", signature( - x = "MultiColony", i = "integerOrNumericOrLogicalOrCharacter", - j = "ANY", value = "MultiColony" + x = "MultiColony", + i = "integerOrNumericOrLogicalOrCharacter", + j = "ANY", + value = "MultiColony" ), definition = function(x, i, j, value) { nCol <- nColonies(value) if (is.numeric(i)) { if (length(i) != nCol) { - stop("Length of i (position index) does not match the number of assigned colonies!") + stop( + "Length of i (position index) does not match the number of assigned colonies!" + ) } x@colonies[i] <- value@colonies } else if (is.logical(i)) { if (sum(i) != nCol) { - stop("Number of TRUE values in i (position index) does not match the number of assigned colonies!") + stop( + "Number of TRUE values in i (position index) does not match the number of assigned colonies!" + ) } x@colonies[i] <- value@colonies } else if (is.character(i)) { matches <- getId(x) %in% i if (sum(matches) != nCol) { - stop("Number of matched colony names in x from i (name index) does not match the number of assigned colonies!") + stop( + "Number of matched colony names in x from i (name index) does not match the number of assigned colonies!" + ) } x@colonies[matches] <- value@colonies } @@ -301,27 +324,37 @@ setReplaceMethod( setReplaceMethod( f = "[[", signature( - x = "MultiColony", i = "integerOrNumericOrLogicalOrCharacter", - j = "ANY", value = "Colony" + x = "MultiColony", + i = "integerOrNumericOrLogicalOrCharacter", + j = "ANY", + value = "Colony" ), definition = function(x, i, j, value) { if (is.numeric(i)) { if (length(i) > 1) { - stop("Length of numeric i (position index) must be 1 when value (assignment) is a Colony class object!") + stop( + "Length of numeric i (position index) must be 1 when value (assignment) is a Colony class object!" + ) } x@colonies[[i]] <- value } else if (is.logical(i)) { if (sum(i) != 1) { - stop("Number of TRUE values in i (position index) must be equal to 1 when value (assignment) is a Colony class object!") + stop( + "Number of TRUE values in i (position index) must be equal to 1 when value (assignment) is a Colony class object!" + ) } x@colonies[i][[1L]] <- value } else if (is.character(i)) { if (length(i) > 1) { - stop("Length of character i (name index) must be 1 when value (assignment) is a Colony class object!") + stop( + "Length of character i (name index) must be 1 when value (assignment) is a Colony class object!" + ) } match <- getId(x) %in% i if (sum(match) != 1) { - stop("Number of matched colony names in x from i (name index) must be equal to 1 when value (assignment) is a Colony class object!") + stop( + "Number of matched colony names in x from i (name index) must be equal to 1 when value (assignment) is a Colony class object!" + ) } x@colonies[match][[1L]] <- value } diff --git a/R/Class-SimParamBee.R b/R/Class-SimParamBee.R index 5ca066c3..5c8b4edc 100644 --- a/R/Class-SimParamBee.R +++ b/R/Class-SimParamBee.R @@ -1,3 +1,4 @@ + # ---- Class SimParamBee ---- setClassUnion("numericOrFunction", c("numeric", "function")) @@ -213,11 +214,13 @@ SimParamBee <- R6Class( #' in \code{\link[SIMplyBee]{calcColonyValue}} - see also \code{\link[SIMplyBee]{calcColonyPheno}} #' and \code{\link[SIMplyBee]{calcColonyGv}}. #' - #' This function should work with internals of others functions - - #' therefore the function MUST be defined like \code{function(colony, arg - #' = default) someCode }, that is, the first argument MUST be - #' \code{colony} and any following arguments MUST have a default value. - #' For flexibility you can add ... argument to pass on any other argument. + #' The first argument receives a single \code{\link[SIMplyBee]{Colony-class}}, + #' passed by position; its name is unrestricted. + #' For example, use \code{function(colony, arg = default) someCode }. + #' For MultiColony input, \code{calcColonyValue} calls this function once + #' per colony and combines the results by row. + #' Additional arguments can have defaults or be supplied through + #' \code{...} in \code{calcColonyValue}. #' See \code{\link[SIMplyBee]{mapCasteToColonyValue}} for an example. #' #' You can provide your own functions that satisfy your needs! @@ -254,23 +257,10 @@ SimParamBee <- R6Class( #' @param colonyValueFUN see \code{\link[SIMplyBee]{SimParamBee}} field \code{colonyValueFUN} #' #' @references - #' Bovo et al. (2021) Application of Next Generation Semiconductor-Based - #' Sequencing for the Identification of Apis mellifera Complementary Sex - #' Determiner (csd) Alleles from Honey DNA. Insects, 12(10), 868. - #' \doi{10.3390/insects12100868} - #' - #' Lechner et al. (2014) Nucleotide variability at its limit? Insights into - #' the number and evolutionary dynamics of the sex-determining specificities - #' of the honey bee Apis mellifera Molecular Biology and Evolution, 31, - #' 272-287. \doi{10.1093/molbev/mst207} - #' - #' Seeley (2019) The Lives of Bees: The Untold Story of the Honey - #' Bee in the Wild. Princeton: Princeton University Press. - #' \doi{10.1515/9780691189383} - #' - #' Zareba et al. (2017) Uneven distribution of complementary sex determiner - #' (csd) alleles in Apis mellifera population. Scientific Reports, 7, 2317. - #' \doi{10.1038/s41598-017-02629-9} + #' \insertRef{bovo2021Application}{SIMplyBee} + #' \insertRef{lechner2014Nucleotide}{SIMplyBee} + #' \insertRef{seeley2019Lives}{SIMplyBee} + #' \insertRef{zareba2017Uneven}{SIMplyBee} #' #' @examples #' founderGenomes <- quickHaplo(nInd = 10, nChr = 3, segSites = 10) @@ -425,13 +415,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 +548,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 +558,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 +660,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 +684,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 +729,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) - } - ret <- round(mapCasteToColonyPheno( - colony = colony, - queenTrait = queenTrait, - workersTrait = workersTrait, - checkProduction = checkProduction, - simParamBee = simParamBee, - ... - )) - if (ret < (lowerLimit + 1)) { - ret <- lowerLimit + 1 +nCasteTruncPoisson <- function(x = NULL, n = 1, average = 100, lowerLimit = 0) { + if (isColony(x)) { + n <- 1 + } else if (isMultiColony(x)) { + n <- nColonies(x) } - return(ret) + return(extraDistr::rtpois(n = n, lambda = average, a = lowerLimit)) } -#' @rdname nDronesFun -#' @title Sample a number of drones -#' -#' @description Sample a number of drones - used when \code{nDrones = NULL} -#' (see \code{\link[SIMplyBee]{SimParamBee}$nDrones}). -#' -#' This is just an example. You can provide your own functions that satisfy -#' your needs! -#' -#' @param x \code{\link[AlphaSimR]{Pop-class}} or \code{\link[SIMplyBee]{Colony-class}} -#' @param n integer, number of samples -#' @param average numeric, average number of drones -#' @param lowerLimit numeric, returned numbers will be above this value -#' @param queenTrait numeric (column position) or character (column name), trait -#' that represents queen's effect on the colony phenotype (defined in -#' \code{\link[SIMplyBee]{SimParamBee}} - see examples); if \code{0} then this effect is 0 -#' @param workersTrait numeric (column position) or character (column name), trait -#' that represents workers's effect on the colony phenotype (defined in -#' \code{\link[SIMplyBee]{SimParamBee}} - see examples); if \code{0} then this effect is 0 -#' @param checkProduction logical, does the phenotype depend on the production -#' status of colony; if yes and production is not \code{TRUE}, the result is -#' above \code{lowerLimit} -#' @param simParamBee \code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters -#' @param ... other arguments of \code{\link[SIMplyBee]{mapCasteToColonyPheno}} -#' -#' @details \code{nDronesPoisson} samples from a Poisson distribution with a -#' given average, which can return a value 0. -#' -#' \code{nDronesTruncPoisson} samples from a zero truncated Poisson -#' distribution. -#' -#' \code{nDronesColonyPhenotype} returns a number (above \code{lowerLimit}) as -#' a function of colony phenotype, say queen's fecundity. Colony phenotype is -#' provided by \code{\link[SIMplyBee]{mapCasteToColonyPheno}}. You need to set up -#' traits influencing the colony phenotype and their parameters (mean and -#' variances) via \code{\link[SIMplyBee]{SimParamBee}} (see examples). -#' -#' When \code{x} is \code{\link[AlphaSimR]{Pop-class}}, only \code{workersTrait} is not -#' used, that is, only \code{queenTrait} is used. -#' -#' @seealso \code{\link[SIMplyBee]{SimParamBee}} field \code{nDrones} and -#' \code{vignette(topic = "QuantitativeGenetics", package = "SIMplyBee")} -#' -#' @return numeric, number of drones -#' -#' @examples -#' nDronesPoisson() -#' nDronesPoisson() -#' n <- nDronesPoisson(n = 1000) -#' hist(n, breaks = seq(from = min(n), to = max(n)), xlim = c(0, 200)) -#' table(n) -#' -#' nDronesTruncPoisson() -#' nDronesTruncPoisson() -#' n <- nDronesTruncPoisson(n = 1000) -#' hist(n, breaks = seq(from = min(n), to = max(n)), xlim = c(0, 200)) -#' table(n) -#' -#' # Example for nDronesColonyPhenotype() -#' founderGenomes <- quickHaplo(nInd = 3, nChr = 1, segSites = 100) -#' SP <- SimParamBee$new(founderGenomes) -#' \dontshow{SP$nThreads = 1L} -#' average <- 100 -#' h2 <- 0.1 -#' SP$addTraitA(nQtlPerChr = 100, mean = average, var = average * h2) -#' SP$setVarE(varE = average * (1 - h2)) -#' basePop <- createVirginQueens(founderGenomes) -#' drones <- createDrones(x = basePop[1], nInd = 50) -#' droneGroups <- pullDroneGroupsFromDCA(drones, n = 2, nDrones = 15) -#' colony1 <- createColony(x = basePop[2]) -#' colony2 <- createColony(x = basePop[3]) -#' colony1 <- cross(colony1, drones = droneGroups[[1]]) -#' colony2 <- cross(colony2, drones = droneGroups[[2]]) -#' colony1@queen@pheno -#' colony2@queen@pheno -#' createDrones(colony1, nInd = nDronesColonyPhenotype) -#' createDrones(colony2, nInd = nDronesColonyPhenotype) +#' @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 +896,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 +919,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,13 +939,15 @@ 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} #' @param nWorkersFull numeric, average number of workers in a full/strong #' colony for \code{splitPColonyStrength} (actual number can go beyond this #' value) +#' @param simParamBee \code{\link[SIMplyBee]{SimParamBee}}, simulation parameters +#' for \code{splitPColonyStrength} #' @param scale numeric, scaling of numbers in \code{splitPColonyStrength} #' to avoid to narrow range when colonies have a large number of bees (in that #' case change \code{nWorkersFull} too!) @@ -1079,15 +1007,26 @@ 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) { - nW <- nWorkers(colony) +splitPColonyStrength <- function(x, n = 1, nWorkersFull = 100, scale = 1, + simParamBee = NULL) { + if (isColony(x)) { + n <- 1 + } else if (isMultiColony(x)) { + n <- nColonies(x) + } + nW <- nWorkers(x, simParamBee = simParamBee) pKeep <- rbeta( n = n, shape1 = (nW + nWorkersFull) / scale, @@ -1107,7 +1046,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 +1061,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 +1090,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 +1138,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 +1193,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 +1215,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, simParamBee = simParamBee)) { + if (value %in% c("pheno", "gv")) { + tmp <- valueFUN(x@queen)[, queenTrait, drop = FALSE] + } else { # bv, dd, and aa: leaving this in for future use! + 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, simParamBee = simParamBee) != 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, simParamBee = simParamBee) != 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 3e774144..d534f7ec 100644 --- a/R/Functions_L0_auxilary.R +++ b/R/Functions_L0_auxilary.R @@ -1,3 +1,4 @@ + # ---- Level 0 Auxiliary Functions ---- # n* ---- @@ -81,7 +82,9 @@ nEmptyColonies <- function(multicolony) { #' #' @description Returns the number of individuals of a caste in a colony #' -#' @param x \code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}} +#' @param x \code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}}. +#' For \code{nFathers()}, also a \code{\link[AlphaSimR]{Pop-class}} +#' containing queens. #' @param caste character, "queen", "fathers", "workers", "drones", #' "virginQueens", or "all" #' @param simParamBee \code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters @@ -94,7 +97,8 @@ nEmptyColonies <- function(multicolony) { #' \code{caste != "all"} or list for \code{caste == "all"} with nodes named #' by caste; when \code{x} is \code{\link[SIMplyBee]{MultiColony-class}} return is named #' integer for \code{caste != "all"} or named list of lists for -#' \code{caste == "all"} +#' \code{caste == "all"}. For \code{nFathers()} with a queen population, +#' returns a numeric vector with one father count per queen. #' #' @examples #' founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) @@ -214,8 +218,10 @@ nFathers <- function(x, simParamBee = NULL) { ret[ind] <- nInd(x@misc$fathers[[ind]]) } } - } else { + } else if (isColony(x) || isMultiColony(x)) { ret <- nCaste(x, caste = "fathers", simParamBee = simParamBee) + } else { + stop("Argument x must be a Pop, Colony, or MultiColony class object!") } return(ret) } @@ -262,9 +268,13 @@ nVirginQueens <- function(x, simParamBee = NULL) { #' @seealso Demo in the introductory vignette #' \code{vignette("Honeybee_biology", package="SIMplyBee")} #' -#' @return numeric, expected csd homozygosity named by colony id when \code{x} -#' is \code{\link[SIMplyBee]{MultiColony-class}} -#' +#' @return Numeric, proportion of homozygous brood for \code{calcQueensPHomBrood()} and +#' \code{pHomBrood()}, or counts for \code{nHomBrood()}, named by colony ID +#' when \code{x} is \code{\link[SIMplyBee]{MultiColony-class}}. An empty +#' \code{\link[AlphaSimR]{Pop-class}} returns \code{numeric(0)}. Missing +#' brood proportions and counts are represented by \code{NA_real_}. +#' All three functions warn and return \code{NA_real_} for a colony without +#' a queen. #' #' @examples #' # This is a bit long example - the key is at the end! @@ -313,7 +323,7 @@ calcQueensPHomBrood <- function(x, simParamBee = NULL) { simParamBee <- get(x = "SP", envir = .GlobalEnv) } if (isPop(x)) { - ret <- rep(x = NA, times = nInd(x)) + ret <- rep(x = NA_real_, times = nInd(x)) for (ind in seq_len(nInd(x))) { if (!(all(isQueen(x, simParamBee = simParamBee)))) { stop("calcQueensPHomBrood can only be used with queens!") @@ -331,9 +341,14 @@ calcQueensPHomBrood <- function(x, simParamBee = NULL) { } } } else if (isColony(x)) { - ret <- calcQueensPHomBrood(x = x@queen) + if (is.null(x@queen) || nInd(x@queen) == 0L) { + warning("Colony has no queen - returning NA!") + ret <- NA_real_ + } else { + ret <- calcQueensPHomBrood(x = x@queen, simParamBee = simParamBee) + } } else if (isMultiColony(x)) { - ret <- sapply(X = x@colonies, FUN = calcQueensPHomBrood) + ret <- sapply(X = x@colonies, FUN = calcQueensPHomBrood, simParamBee = simParamBee) names(ret) <- getId(x) } else { stop("Argument x must be a Pop, Colony, or MultiColony class object!") @@ -341,7 +356,7 @@ calcQueensPHomBrood <- function(x, simParamBee = NULL) { return(ret) } -#' @describeIn calcQueensPHomBrood Expected percentage of csd homozygous brood +#' @describeIn calcQueensPHomBrood Expected proportion of csd homozygous brood #' of a queen / colony #' @export pHomBrood <- function(x, simParamBee = NULL) { @@ -352,23 +367,29 @@ pHomBrood <- function(x, simParamBee = NULL) { if (any(!isQueen(x, simParamBee = simParamBee))) { stop("Individuals in x must be queens!") } - ret <- rep(x = NA, times = nInd(x)) + ret <- rep(x = NA_real_, times = nInd(x)) for (ind in seq_len(nInd(x))) { if (!is.null(x@misc$pHomBrood[[ind]])) { ret[ind] <- x@misc$pHomBrood[[ind]] } } } else if (isColony(x)) { + if (is.null(x@queen) || nInd(x@queen) == 0L) { + warning("Colony has no queen - returning NA!") + ret <- NA_real_ + } else { if (is.null(x@queen@misc$pHomBrood[[1]])) { - ret <- NA + ret <- NA_real_ } else { ret <- x@queen@misc$pHomBrood[[1]] } + } + } else if (isMultiColony(x)) { - ret <- sapply(X = x@colonies, FUN = pHomBrood) + ret <- sapply(X = x@colonies, FUN = pHomBrood, simParamBee = simParamBee) names(ret) <- getId(x) } else { - stop("Argument x must be a Colony or MultiColony class object!") + stop("Argument x must be a Pop, Colony, or MultiColony class object!") } return(ret) } @@ -384,23 +405,26 @@ nHomBrood <- function(x, simParamBee = NULL) { if (any(!isQueen(x, simParamBee = simParamBee))) { stop("Individuals in x must be queens!") } - ret <- rep(x = NA, times = nInd(x)) + ret <- rep(x = NA_real_, times = nInd(x)) for (ind in seq_len(nInd(x))) { if (!is.null(x@misc$nHomBrood[[ind]])) { ret[ind] <- x@misc$nHomBrood[[ind]] } } } else if (isColony(x)) { - if (is.null(x@queen@misc$nHomBrood[[1]])) { - ret <- NA + if (is.null(x@queen) || nInd(x@queen) == 0L) { + warning("Colony has no queen - returning NA!") + ret <- NA_real_ + } else if (is.null(x@queen@misc$nHomBrood[[1]])) { + ret <- NA_real_ } else { ret <- x@queen@misc$nHomBrood[[1]] } } else if (isMultiColony(x)) { - ret <- sapply(X = x@colonies, FUN = nHomBrood) + ret <- sapply(X = x@colonies, FUN = nHomBrood, simParamBee = simParamBee) names(ret) <- getId(x) } else { - stop("Argument x must be a Colony or MultiColony class object!") + stop("Argument x must be a Pop, Colony, or MultiColony class object!") } return(ret) } @@ -952,155 +976,24 @@ 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)) { - ret <- currentYear - x@queen@misc$yearOfBirth[[1]] - } 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 +#' @title Get individual or colony IDs #' -#' @description Level 0 function that returns the colony ID. This is by -#' definition the ID of the queen. +#' @description Level 0 function that returns individual IDs for a Pop or +#' colony IDs for a Colony or MultiColony. Colony IDs are independent of +#' queen IDs and are retained when a queen is removed or replaced. #' -#' @param x \code{\link[AlphaSimR]{Pop-class}}, \code{\link[SIMplyBee]{Colony-class}}, or \code{\link[SIMplyBee]{MultiColony-class}} +#' @param x \code{NULL}, \code{\link[AlphaSimR]{Pop-class}}, +#' \code{\link[SIMplyBee]{Colony-class}}, or \code{\link[SIMplyBee]{MultiColony-class}} #' -#' @return character, \code{NA} when queen not present +#' @return character, \code{NA_character_} for NULL entries or a Colony without +#' an assigned ID, and \code{character(0)} for an empty Pop or MultiColony. +#' +#' @details A NULL entry represents a missing colony or individual, +#' so it contributes one missing ID and preserves alignment with the MultiColony's entries. +#' An empty Pop or MultiColony contains no individuals or entries to identify. +#' An empty colony created with \code{createColony()} still has an assigned ID; +#' an uninitialised \code{new("Colony")} has no assigned ID. #' #' @examples #' founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) @@ -1126,13 +1019,13 @@ getQueenAge <- function(x, currentYear, simParamBee = NULL) { #' @export getId <- function(x) { if (is.null(x)) { - id <- NA + id <- NA_character_ } else if (isPop(x)) { id <- x@id } else if (isColony(x)) { - id <- ifelse(is.null(x@id), NA, x@id) + id <- if (length(x@id) == 0L) NA_character_ else x@id } else if (isMultiColony(x)) { - id <- sapply(x@colonies, FUN = getId) + id <- vapply(x@colonies, FUN = getId, FUN.VALUE = character(1)) } else { stop("Argument x must be a NULL, Pop, Colony, or MultiColony class object!") } @@ -1589,11 +1482,8 @@ getLocation <- function(x, collapse = FALSE) { #' @return matrix with two columns for the x and y coordinates of the points. #' #' @references -#' nubDotDev (2021) The BEST Way to Find a Random Point in a Circle -#' https://youtu.be/4y_nmpv-9lI -#' -#' Wolfram MathWorld (2023) Disk Point Picking -#' https://mathworld.wolfram.com/DiskPointPicking.html +#' \insertRef{nubdotdev2021Best}{SIMplyBee} +#' \insertRef{wolfram2023Disk}{SIMplyBee} #' #' @examples #' x <- rcircle(n = 500) @@ -1763,7 +1653,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) #' @@ -1961,23 +1851,10 @@ isProductive <- function(x) { #' @return \code{\link[AlphaSimR]{MapPop-class}} #' #' @references -#' Wallberg, A., Bunikis, I., Pettersson, O.V. et al. -#' A hybrid de novo genome assembly of the honeybee, Apis mellifera, -#' with chromosome-length scaffolds. 2019, BMC Genomics 20:275. -#' \doi{10.1186/s12864-019-5642-0} -#' -#' Beye M, Gattermeier I, Hasselmann M, et al. Exceptionally high levels -#' of recombination across the honey bee genome. -#' 2006, Genome Res 16(11):1339-1344. \doi{10.1101/gr.5680406} -#' -#' Wallberg, A., Han, F., Wellhagen, G. et al. A worldwide survey of -#' genome sequence variation provides insight into the evolutionary -#' history of the honeybee Apis mellifera. -#' 2014, Nat Genet 46:1081–1088. \doi{10.1038/ng.3077} -#' -#' Yang S, Wang L, Huang J, Zhang X, Yuan Y, Chen JQ, Hurst LD, Tian D. -#' Parent-progeny sequencing indicates higher mutation rates in heterozygotes. -#' 2015, Nature 523(7561):463-7. \doi{10.1038/nature14649}. +#' \insertRef{beye2006Exceptionally}{SIMplyBee} +#' \insertRef{yang2015Parent}{SIMplyBee} +#' \insertRef{wallberg2014Worldwide}{SIMplyBee} +#' \insertRef{wallberg2019Hybrid}{SIMplyBee} #' #' @seealso Due to the computational time and resources required to run this function, #' we do not include an example here, but we demonstrate @@ -2336,6 +2213,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, @@ -2353,6 +2233,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, @@ -2372,6 +2255,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, @@ -2390,6 +2276,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, @@ -2408,6 +2297,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, @@ -2539,7 +2431,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)) { @@ -2575,6 +2467,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, @@ -2590,6 +2485,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", @@ -2607,6 +2505,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", @@ -2623,6 +2524,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", @@ -2640,6 +2544,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", @@ -2673,7 +2580,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 @@ -2875,10 +2783,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) #' @@ -2888,13 +2796,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)) @@ -2906,6 +2814,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! #' @@ -2920,6 +2830,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) @@ -4697,9 +4610,8 @@ getPooledGeno <- function(x, type = "mean", sex = NULL) { #' scaling factor used to scale the crossproduct of centred genotype matrix #' to get the GRM. #' -#' @references Druet and Legarra (2020) Theoretical and empirical comparisons of -#' expected and realized relationships for the X-chromosome. Genetics -#' Selection Evolution, 52:50 \doi{10.1186/s12711-020-00570-6} +#' @references +#' \insertRef{druet2020Theoretical}{SIMplyBee} #' #' @examples #' founderGenomes <- quickHaplo(nInd = 3, nChr = 1, segSites = 100) @@ -4846,25 +4758,11 @@ calcBeeAlleleFreq <- function(x, sex) { #' a matrix of individual relatedness coefficients (indiv) #' #' @references -#' Grossman and Eisen (1989) Inbreeding, coancestry, and covariance between -#' relatives for X-chromosomal loci. The Journal of Heredity, -#' \doi{10.1093/oxfordjournals.jhered.a110812} -#' -#' Fernando and Grossman (1989) Covariance between relatives for X-chromosomal -#' loci in a population in disequilibrium. Theoretical and Applied Genetics, -#' \doi{10.1007/bf00305821} -#' -#' Fernando and Grossman (1990) Genetic evaluation with autosomal -#' and X-chromosomal inheritance. Theoretical and Applied Genetics, -#' \doi{10.1007/bf00224018} -#' -#' Van Arendonk, Tier, and Kinghorn (1994) Use of multiple genetic markers in -#' prediction of breeding values. Genetics, -#' \doi{10.1093/genetics/137.1.319} -#' -#' Hill and Weir (2011) Variation in actual relationship as a consequence of -#' Mendelian sampling and linkage. Genetics Research, -#' \doi{10.1017/s0016672310000480} +#' \insertRef{fernando1989Covariance}{SIMplyBee} +#' \insertRef{fernando1990Genetic}{SIMplyBee} +#' \insertRef{grossman1989Inbreeding}{SIMplyBee} +#' \insertRef{hill2011Variation}{SIMplyBee} +#' \insertRef{vanarendonk1994Use}{SIMplyBee} #' #' @examples #' founderGenomes <- quickHaplo(nInd = 3, nChr = 1, segSites = 100) @@ -5161,7 +5059,11 @@ getDronesPheno <- function(x, nInd = NULL, collapse = FALSE, simParamBee = NULL) #' #' @param x \code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}} #' @param FUN function, that calculates colony value from values of -#' colony members +#' colony members. Its first argument receives a single \code{\link[SIMplyBee]{Colony-class}}, +#' passed by position, and can have any name (for example, \code{colony} or \code{x}). +#' For \code{\link[SIMplyBee]{MultiColony-class}} input, +#' the function is called separately for each colony and the results are combined by row. +#' #' @param simParamBee \code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters #' @param ... other arguments of \code{FUN} #' @@ -5232,6 +5134,13 @@ getDronesPheno <- function(x, nInd = NULL, collapse = FALSE, simParamBee = NULL) #' calcColonyValue(colony) #' calcColonyValue(apiary) #' +#' # Colony value - using a simple custom function +#' countWorkers <- function(colony) { +#' matrix(nInd(colony@workers), nrow = 1, +#' dimnames = list(NULL, "nWorkers")) +#' } +#' calcColonyValue(colony, FUN = countWorkers) +#' calcColonyValue(apiary, FUN = countWorkers) #' @export # TODO: Do we need to do anything to add GxE to colony values? #353 # https://github.com/HighlanderLab/SIMplyBee/issues/353 @@ -5248,14 +5157,14 @@ calcColonyValue <- function(x, FUN = NULL, simParamBee = NULL, ...) { stop("You must provide FUN or set it in the SimParamBee object!") } if (isColony(x)) { - ret <- FUN(colony = x, ...) + ret <- FUN(x, ...) } else if (isMultiColony(x)) { nCol <- nColonies(x) # We could create a matrix output container here, BUT we don't know the output # dimension of FUN() so we create list and row bind the list nodes later ret <- vector(mode = "list", length = nCol) for (colony in seq_len(nCol)) { - ret[[colony]] <- FUN(colony = x[[colony]], ...) + ret[[colony]] <- FUN(x[[colony]], ...) } ret <- do.call("rbind", ret) rownames(ret) <- getId(x) @@ -5304,9 +5213,7 @@ calcColonyPheno <- function(x, FUN = mapCasteToColonyPheno, simParamBee = NULL, #' \code{vignette(topic = "QuantitativeGenetics", package = "SIMplyBee")} #' #' @references -#' Du, M., et al. (2021) Short-term effects of controlled mating and selection -#' on the genetic variance of honeybee populations. Heredity 126, 733–747. -#' \doi{10.1038/s41437-021-00411-2} +#' \insertRef{du2021Short}{SIMplyBee} #' #' @examples #' founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) @@ -5367,10 +5274,10 @@ calcInheritanceCriterion <- function(x, queenTrait = 1, workersTrait = 2, use = if(!isQueenPresent(x, simParamBee = simParamBee)) { stop("No queen in the Colony!") } - ret <- calcInheritanceCriterion(getQueen(colony, simParamBee = simParamBee), + ret <- calcInheritanceCriterion(getQueen(x, simParamBee = simParamBee), queenTrait = queenTrait, workersTrait = workersTrait, - use = use) + use = use, simParamBee = simParamBee) } else if (isMultiColony(x)) { nCol <- nColonies(x) ret <- vector(mode = "list", length = nCol) @@ -5379,7 +5286,7 @@ calcInheritanceCriterion <- function(x, queenTrait = 1, workersTrait = 2, use = ret[[colony]] <- calcInheritanceCriterion(x[[colony]], queenTrait = queenTrait, workersTrait = workersTrait, - use = use) + use = use, simParamBee = simParamBee) } else { ret[colony] <- list(NULL) } @@ -5422,9 +5329,7 @@ calcInheritanceCriterion <- function(x, queenTrait = 1, workersTrait = 2, use = #' \code{\link[SIMplyBee]{MultiColony-class}}, where names are colony IDs #' #' @references -#' Du, M., et al. (2021) Short-term effects of controlled mating and selection -#' on the genetic variance of honeybee populations. Heredity 126, 733–747. -#' \doi{10.1038/s41437-021-00411-2} +#' \insertRef{du2021Short}{SIMplyBee} #' #' @examples #' founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) @@ -5544,9 +5449,7 @@ calcPerformanceCriterion <- function(x, queenTrait = 1, workersTrait = 2, #' \code{\link[SIMplyBee]{MultiColony-class}}, where names are colony IDs #' #' @references -#' Du, M., et al. (2021) Short-term effects of controlled mating and selection -#' on the genetic variance of honeybee populations. Heredity 126, 733–747. -#' \doi{10.1038/s41437-021-00411-2} +#' \insertRef{du2021Short}{SIMplyBee} #' #' @examples #' founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) @@ -6370,6 +6273,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(X = seq_len(pop@nInd), FUN = function(x) { list(alleles[sample(nAlleles, size = 2, replace = FALSE), , drop = FALSE]) @@ -6441,10 +6345,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]) @@ -6464,58 +6364,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, @@ -6587,7 +6452,9 @@ createCrossPlan <- function(x, #' @title Finds loci on a genetic map and return a list of positions #' #' @description Finds loci on a genetic map and return a list of positions. -#' This function is adopted from AlphaSimR (Gaynor et al., 2021) +#' This function is adopted from AlphaSimR (Gaynor et al., 2021). +#' @references +#' \insertRef{gaynor2021AlphaSimR}{SIMplyBee} #' #' @param markers character, vector of marker positions as "chr_position" #' @param genMap list, genetic map @@ -6620,3 +6487,447 @@ mapLoci = function(markers, genMap){ return(list(lociPerChr=lociPerChr, lociLoc=lociLoc)) } + + +#' @rdname cor2cov +#' @title Convert correlation matrix to covariance matrix +#' +#' @description Convert correlation matrix to covariance matrix +#' This function is adopted from AlphaSimR (Gaynor et al., 2021). +#' @references +#' \insertRef{gaynor2021AlphaSimR}{SIMplyBee} +#' +#' @param corr correlation matrix +#' @param var vector of variances +#' @return covariance matrix +cor2cov <- function(corr, var) { + corr <- as.matrix(corr) + var <- as.numeric(var) + sd <- sqrt(var) + cov <- corr * (sd %o% sd) + return(cov) +} + +#' Calculate coefficients to map across individual and colony variances +#' +#' Calculate the coefficients used to map variances in a fixed colony design. +#' Forward mappings in \code{mapIndToColonyVar} multiply individual components. +#' Inverse mappings in \code{mapColonyToIndVar} divide aggregate components. +#' +#' @param nW Positive integer scalar, number of workers in the colony. +#' @param nF Positive integer scalar, number of distinct mating fathers available +#' to sire workers. With random allocation, some fathers may sire no workers. +#' @param nDPQ Positive integer scalar, number of distinct drone-producing queens +#' (DPQs) represented among the mating fathers. Equal numbers of fathers per +#' DPQ are assumed; nF must be divisible by nDPQ. +#' @param workersFUN Character scalar, "sum" or "mean", specifying aggregation +#' of the workers' worker-effect trait values. +#' @param workerAllocation Character scalar, "random" for independent uniform +#' sampling of a father for each worker, or "balanced" for exactly nW/nF +#' workers per father. Balanced allocation requires nW divisible by nF. +#' +#' @return A list of three coefficients: +#' \itemize{ +#' \item \code{worker}: multiplier converting individual worker-effect additive +#' genetic variance to variance of the worker-group sum or mean. +#' \item \code{queenWorker}: multiplier converting within-individual genetic +#' covariance between queen-effect and worker-effect traits to covariance +#' between the colony queen's queen-effect contribution and the worker-group +#' worker-effect contribution. This coefficient does not include the factor +#' of two used when calculating total colony variance. +#' \item \code{environment}: multiplier converting individual worker-effect +#' environmental variance to variance of the worker-group sum or mean, +#' assuming environmental deviations are independent between workers. +#' } +#' +#' @details The model assumes non-inbred colony queens and DPQs, mutually +#' unrelated across those parents. Distinct fathers from the same DPQ may be +#' brothers. The queen-effect variance multiplier is one and is not returned. +#' +#' Let w be 1 for sums or 1/nW for means. +#' Ordered distinct-worker pairs are partitioned into +#' same father giving super-sisters with additive relationship of 3/4, +#' distinct fathers from the same DPQ giving full-sisters with additive relationship of 1/2, and +#' different DPQs giving half-sisters with additive relationship of 1/4. +#' The worker coefficient is w^2 * (nW + relationship-weighted pair counts). +#' Random allocation uses expected pair counts; +#' balanced allocation uses exact pair counts. +#' The queenWorker coefficient is nW*w/2, and +#' the environment coefficient is nW*w^2. +#' +#' Divisibility checks establish that the assumed equal allocation is possible; +#' totals alone cannot verify actual family composition. +#' These coefficients describe marginal colony components, +#' not sample variances across colonies sharing relatives. +#' Unequal contributions, general ancestry, and random colony sizes +#' require a more general model. +#' @seealso \code{\link{mapIndToColonyVar}}, \code{\link{mapColonyToIndVar}} +#' @keywords internal +calcColonyAndIndCoefficients <- function(nW, nF, nDPQ, workersFUN, + workerAllocation) { + for (name in c("nW", "nF", "nDPQ")) { + value <- get(name) + if (!is.numeric(value) || length(value) != 1L || !is.finite(value) || + value < 1 || value != floor(value)) { + stop(name, " must be a positive integer scalar.") + } + } + if (length(workersFUN) != 1L || is.na(workersFUN) || + !workersFUN %in% c("sum", "mean")) { + stop("workersFUN must be 'sum' or 'mean'.") + } + if (length(workerAllocation) != 1L || is.na(workerAllocation) || + !workerAllocation %in% c("random", "balanced")) { + stop("workerAllocation must be 'random' or 'balanced'.") + } + # Equal father counts per DPQ are assumed. + # Check that the supplied totals permit that allocation. + if (nF %% nDPQ != 0) { + stop("Equal fathers per DPQ requires nF divisible by nDPQ.") + } + if (workerAllocation == "balanced") { + if (nW %% nF != 0) { + stop("Balanced worker allocation requires nW divisible by nF.") + } + sameFather <- nW^2 / nF - nW + sameDPQ <- nW^2 / nDPQ - nW^2 / nF + differentDPQ <- nW^2 * (1 - 1 / nDPQ) + } else { + sameFather <- nW * (nW - 1) / nF + sameDPQ <- nW * (nW - 1) * (1 / nDPQ - 1 / nF) + differentDPQ <- nW * (nW - 1) * (1 - 1 / nDPQ) + } + weight <- if (workersFUN == "mean") 1 / nW else 1 + list(worker = weight^2 * (nW + 0.75 * sameFather + + 0.5 * sameDPQ + 0.25 * differentDPQ), + queenWorker = nW * weight / 2, + environment = nW * weight^2) +} + +#' Validate variance and correlation inputs +#' +#' Check named collections of scalar variance and correlation parameters used +#' by the individual/colony variance mappings. Invalid inputs raise an error. +#' +#' @param variances Named list of numeric, finite, nonnegative variance scalars. +#' @param correlations Named list of numeric, finite correlation scalars in +#' the interval [-1, 1]. +#' @return Invisibly returns \code{NULL} when all checked inputs are valid; +#' otherwise stops with an error. +#' @keywords internal +validateVarsAndCors <- function(variances, correlations) { + for (name in names(variances)) { + value <- variances[[name]] + if (!is.numeric(value) || length(value) != 1L || !is.finite(value) || value < 0) { + stop(name, " must be a finite nonnegative scalar.") + } + } + for (name in names(correlations)) { + value <- correlations[[name]] + if (!is.numeric(value) || length(value) != 1L || !is.finite(value) || + abs(value) > 1) { + stop(name, " must be a finite correlation in [-1, 1].") + } + } +} + +#' Stable conversion of a covariance and two variances to a correlation +#' +#' Divide a covariance by the product of the corresponding standard deviations, +#' but return \code{NA} when either variance (standard deviation) are zero. +#' +#' @param covariance Numeric scalar covariance between the two variables. +#' @param variance1 Numeric scalar variance of the first variable. +#' @param variance2 Numeric scalar variance of the second variable. +#' @return Numeric scalar correlation, or \code{NA_real_} +#' if either variance is zero and the correlation is therefore undefined. +#' @keywords internal +covVar2Cor <- function(covariance, variance1, variance2) { + if (variance1 == 0 || variance2 == 0) return(NA_real_) + covariance / (sqrt(variance1) * sqrt(variance2)) +} + +#' @rdname mapIndToColonyVar +#' @title Map variance components between individuals and colonies +#' +#' @description Map individual queen-effect and worker-effect variance components +#' to colony variance components, or recover individual variance components from +#' separate queen and worker-group colony variance components. +#' +#' @param varAQueen Numeric scalar, additive genetic variance of +#' the queen-effect trait among individual diploid bees in a base population. +#' @param varAWorker Numeric scalar, additive genetic variance of +#' the worker-effect trait among individual diploid bees in a base population. +#' @param corAQueenWorker Numeric scalar, additive genetic correlation between +#' the queen-effect trait and the worker-effect trait +#' among individual diploid bees in a base population. +#' This is the within-individual cross-trait correlation among individuals. +#' @param varEQueen Numeric scalar, environmental variance of +#' the queen-effect trait among individual bees in a base population. +#' @param varEWorker Numeric scalar, environmental variance of +#' the worker-effect trait among individual bees in a base population. +#' @param corEQueenWorker Numeric scalar, environmental correlation between +#' the queen-effect trait and the worker-effect trait +#' among individual diploid bees in a base population. +#' This is the within-individual cross-trait correlation among individuals. +#' @param varAWorkerGroup Numeric scalar, additive genetic variance of +#' the aggregated worker-effect trait among colonies in a base population. +#' @param corAQueenWorkerGroup Numeric scalar, additive genetic correlation between +#' the queen's queen-effect trait and +#' the aggregated workers' worker-effect trait +#' among colonies in a base population. +#' This is the cross-caste and cross-trait correlation among colonies. +#' @param varEWorkerGroup Numeric scalar, environmental variance of +#' the aggregated worker-effect trait among colonies in a base population. +#' @param corEQueenWorkerGroup Numeric scalar, environmental correlation between +#' the queen's queen-effect trait and +#' the aggregated workers' worker-effect trait +#' among colonies in a base population. +#' This is the cross-caste and cross-trait correlation among colonies. +#' @param nW numeric, number of workers in the colony +#' @param nF numeric, number of fathers of the workers +#' @param nDPQ numeric, number of drone producing queens (DPQs) +#' represented among the mating fathers +#' @param workersFUN character, either "sum" or "mean", +#' indicating whether the workers' contributions are summed or averaged +#' when forming the aggregated worker-effect contribution to colony value. +#' @param workerAllocation character, either "random" (default) or "balanced". +#' +#' @return Both functions return a flat list with the same named components. +#' +#' \strong{Components already described as inputs} +#' All components listed below are returned by both functions; the function +#' labels indicate which inputs they correspond to. +#' \itemize{ +#' \item Both functions: \code{varAQueen}, \code{varEQueen}, \code{nW}, +#' \code{nF}, \code{nDPQ}, \code{workersFUN}, and \code{workerAllocation}. +#' \item \code{mapIndToColonyVar}: \code{varAWorker}, \code{varEWorker}, +#' \code{corAQueenWorker}, and \code{corEQueenWorker}. +#' \item \code{mapColonyToIndVar}: \code{varAWorkerGroup}, +#' \code{varEWorkerGroup}, \code{corAQueenWorkerGroup}, and +#' \code{corEQueenWorkerGroup}. The returned group correlations are +#' \code{NA} if either corresponding variance is zero, even if zero +#' was supplied as the correlation. +#' } +#' +#' \strong{Additional components} +#' \itemize{ +#' \item \code{covAQueenWorker}: additive genetic covariance between +#' the queen-effect trait and the worker-effect trait +#' among individual diploid bees in a base population. +#' \item \code{covAQueenWorkerGroup}: additive genetic covariance between +#' the queen's queen-effect trait and +#' the aggregated workers' worker-effect trait +#' among colonies in a base population. +#' \item \code{covEQueenWorker}: environmental covariance between +#' the queen-effect trait and the worker-effect trait +#' among individual diploid bees in a base population. +#' \item \code{covEQueenWorkerGroup}: environmental covariance between +#' the queen's queen-effect trait and +#' the aggregated workers' worker-effect trait +#' among colonies in a base population. +#' Zero under the assumption of independent environmental deviations between bees. +#' \item \code{varAColony} and \code{varEColony}: additive genetic +#' and environmental variance of colony values. +#' Each is the sum of the queen and worker-group variances plus twice their covariance. +#' \item \code{h2Queen}: \code{varAQueen / (varAQueen + varEQueen)}, +#' heritability of the queen-effect trait among individual bees. +#' \item \code{h2Worker}: \code{varAWorker / (varAWorker + varEWorker)}, +#' heritability of the worker-effect trait among individual bees. +#' \item \code{h2WorkerGroup}: \code{varAWorkerGroup / (varAWorkerGroup + varEWorkerGroup)}, +#' heritability of the aggregated worker-effect trait among colonies. +#' \item \code{h2Colony}: \code{varAColony / (varAColony + varEColony)}, +#' heritability of colony values, including genetic covariance between +#' queen's queen trait and worker-group's worker trait in \code{varAColony}. +#' All four heritabilities are \code{NA} when their denominator is zero. +#' } +#' +#' Covariances are not multiplied by two. +#' Calculated correlations are \code{NA} if either corresponding variance is zero. +#' In \code{mapColonyToIndVar}, \code{covEQueenWorker} and \code{corEQueenWorker} +#' are both returned as \code{NA}, +#' because colony components do not identify +#' within-individual environmental covariance or correlation. +#' +#' @details These mappings describe marginal variances under an additive model +#' with non-inbred, mutually unrelated colony queens and drone-producing +#' queens (DPQs), distinct fathers, and equal numbers of fathers per DPQ. +#' They do not predict sample variance across colonies sharing relatives. +#' Each diploid bee has genetic values for both the queen-effect and +#' worker-effect traits. A colony value combines the queen's value for the +#' queen-effect trait with the aggregated workers' values for the +#' worker-effect trait. Thus Queen and Worker identify trait roles as well as +#' their expressing castes; WorkerGroup always denotes an aggregate. +#' +#' With random worker allocation, +#' each worker independently samples a father uniformly. +#' With balanced allocation, +#' each father has exactly \code{nW/nF} workers, +#' which requires \code{nW} to be divisible by \code{nF}. +#' Both require \code{nF} divisible by \code{nDPQ}. +#' The distinct-worker relationship is 3/4 for a shared father, +#' 1/2 for distinct fathers from the same DPQ, and 1/4 otherwise. +#' Queen-offspring relationship is 1/2. +#' Environmental deviations are independent between bees. +#' Calculated correlations are \code{NA} when either variance is zero; +#' individual correlations supplied to the forward mapping are retained. +#' +#' The inverse divides worker-group variances and queen-worker-group +#' covariance by the corresponding design coefficients. +#' Both directions must use the same colony design and aggregation. +#' A nonzero \code{corEQueenWorkerGroup} raises an error, +#' as do colony components implying an individual genetic correlation outside [-1, 1]. +#' If either genetic component variance is zero, +#' the inverse accepts \code{NA} or zero for \code{corAQueenWorkerGroup}. +#' Similarly, \code{NA} or zero can be supplied for \code{corEQueenWorkerGroup} +#' when either environmental component variance is zero. +#' The zero-correlation restriction between bees does not apply to \code{corEQueenWorker}, +#' which describes environmental association between traits within the same bee. +#' +#' Both results are flat lists. To pass a result to either mapping function, +#' select the entries named in \code{names(formals(fun))} before using +#' \code{do.call(fun, ...)}; the full result contains extra components. +#' Before mapping an inverse result forward, supply an explicit +#' \code{corEQueenWorker}, which the inverse cannot identify. +#' +#' @references +#' \insertRef{brascamp2014Methods}{SIMplyBee} +#' \insertRef{brascamp2019Note}{SIMplyBee} +#' +#' @examples +#' nW <- 100 +#' nF <- 15 +#' nDPQ <- 5 +#' +#' # Mapping individual vars to colony with worker group mean +#' (colonyVars <- mapIndToColonyVar( +#' varAQueen = 2, varAWorker = 0.01, corAQueenWorker = -0.5, +#' varEQueen = 3, varEWorker = 0.02, corEQueenWorker = 0.3, +#' nW = nW, nF = nF, nDPQ = nDPQ, workersFUN = "mean")) +#' # ... and inverse +#' (indVars <- do.call(mapColonyToIndVar, +#' colonyVars[names(formals(mapColonyToIndVar))])) +#' +#' # Mapping colony vars with worker group sum to individual vars +#' (indVars <- mapColonyToIndVar( +#' varAQueen = 2, varAWorkerGroup = 0.01, corAQueenWorkerGroup = -0.5, +#' varEQueen = 3, varEWorkerGroup = 0.02, corEQueenWorkerGroup = 0.0, +#' nW = nW, nF = nF, nDPQ = nDPQ, workersFUN = "sum")) +#' # ... and back to colony components, assuming zero within-bee +#' # environmental correlation (not identified by the inverse mapping). +#' indArgs <- indVars[names(formals(mapIndToColonyVar))] +#' indArgs$corEQueenWorker <- 0 +#' (colonyVars <- do.call(mapIndToColonyVar, indArgs)) +#' @export +mapIndToColonyVar <- function(varAQueen, varAWorker, corAQueenWorker, + varEQueen, varEWorker, corEQueenWorker, + nW, nF, nDPQ, workersFUN = "sum", + workerAllocation = "random") { + validateVarsAndCors(list(varAQueen = varAQueen, varAWorker = varAWorker, + varEQueen = varEQueen, varEWorker = varEWorker), + list(corAQueenWorker = corAQueenWorker, corEQueenWorker = corEQueenWorker)) + k <- calcColonyAndIndCoefficients(nW, nF, nDPQ, workersFUN, workerAllocation) + varAWorkerGroup <- k$worker * varAWorker + covAQueenWorkerGroup <- k$queenWorker * corAQueenWorker * sqrt(varAQueen) * sqrt(varAWorker) + corAQueenWorkerGroup <- covVar2Cor(covAQueenWorkerGroup, varAQueen, varAWorkerGroup) + varAColony <- varAQueen + varAWorkerGroup + 2 * covAQueenWorkerGroup + varEWorkerGroup <- k$environment * varEWorker + covEQueenWorkerGroup <- 0 + # Correlation is zero unless either variance is zero, when it is undefined. + corEQueenWorkerGroup <- covVar2Cor(covEQueenWorkerGroup, varEQueen, varEWorkerGroup) + varEColony <- varEQueen + varEWorkerGroup + covAQueenWorker <- corAQueenWorker * sqrt(varAQueen) * sqrt(varAWorker) + covEQueenWorker <- corEQueenWorker * sqrt(varEQueen) * sqrt(varEWorker) + list( + varAQueen = varAQueen, + varAWorker = varAWorker, + covAQueenWorker = covAQueenWorker, + corAQueenWorker = corAQueenWorker, + varAWorkerGroup = varAWorkerGroup, + covAQueenWorkerGroup = covAQueenWorkerGroup, + corAQueenWorkerGroup = corAQueenWorkerGroup, + varAColony = varAColony, + varEQueen = varEQueen, + varEWorker = varEWorker, + covEQueenWorker = covEQueenWorker, + corEQueenWorker = corEQueenWorker, + varEWorkerGroup = varEWorkerGroup, + covEQueenWorkerGroup = covEQueenWorkerGroup, + corEQueenWorkerGroup = corEQueenWorkerGroup, + varEColony = varEColony, + h2Queen = if (varAQueen + varEQueen == 0) NA_real_ else varAQueen / (varAQueen + varEQueen), + h2Worker = if (varAWorker + varEWorker == 0) NA_real_ else varAWorker / (varAWorker + varEWorker), + h2WorkerGroup = if (varAWorkerGroup + varEWorkerGroup == 0) NA_real_ else varAWorkerGroup / (varAWorkerGroup + varEWorkerGroup), + h2Colony = if (varAColony + varEColony == 0) NA_real_ else varAColony / (varAColony + varEColony), + nW = nW, + nF = nF, + nDPQ = nDPQ, + workersFUN = workersFUN, + workerAllocation = workerAllocation + ) +} + +#' @describeIn mapIndToColonyVar Recover individual variance components from +#' separate queen and worker-group colony components. +#' @export +mapColonyToIndVar <- function(varAQueen, varAWorkerGroup, corAQueenWorkerGroup, + varEQueen, varEWorkerGroup, corEQueenWorkerGroup, + nW, nF, nDPQ, workersFUN = "sum", + workerAllocation = "random") { + # A correlation is undefined if either component has zero variance + if (length(corAQueenWorkerGroup) == 1L && is.na(corAQueenWorkerGroup) && + (isTRUE(varAQueen == 0) || isTRUE(varAWorkerGroup == 0))) corAQueenWorkerGroup <- 0 + if (length(corEQueenWorkerGroup) == 1L && is.na(corEQueenWorkerGroup) && + (isTRUE(varEQueen == 0) || isTRUE(varEWorkerGroup == 0))) corEQueenWorkerGroup <- 0 + validateVarsAndCors(list(varAQueen = varAQueen, varAWorkerGroup = varAWorkerGroup, + varEQueen = varEQueen, varEWorkerGroup = varEWorkerGroup), + list(corAQueenWorkerGroup = corAQueenWorkerGroup, corEQueenWorkerGroup = corEQueenWorkerGroup)) + if (corEQueenWorkerGroup != 0) { + stop("Nonzero corEQueenWorkerGroup requires a shared environment model; environments are assumed independent between bees.") + } + k <- calcColonyAndIndCoefficients(nW, nF, nDPQ, workersFUN, workerAllocation) + varAWorker <- varAWorkerGroup / k$worker + covAQueenWorkerGroup <- corAQueenWorkerGroup * sqrt(varAQueen) * sqrt(varAWorkerGroup) + covAQueenWorker <- covAQueenWorkerGroup / k$queenWorker + corAQueenWorker <- covVar2Cor(covAQueenWorker, varAQueen, varAWorker) + if (!is.na(corAQueenWorker) && abs(corAQueenWorker) > 1 + 1e-10) { + stop("Colony genetic components imply an infeasible individual correlation outside [-1, 1].") + } + if (!is.na(corAQueenWorker)) corAQueenWorker <- max(-1, min(1, corAQueenWorker)) + varEWorker <- varEWorkerGroup / k$environment + corAQueenWorkerGroup <- covVar2Cor(covAQueenWorkerGroup, varAQueen, varAWorkerGroup) + covEQueenWorkerGroup <- 0 + # Correlation is zero unless either variance is zero, when it is undefined. + corEQueenWorkerGroup <- covVar2Cor(covEQueenWorkerGroup, varEQueen, varEWorkerGroup) + varAColony <- varAQueen + varAWorkerGroup + 2 * covAQueenWorkerGroup + varEColony <- varEQueen + varEWorkerGroup + covEQueenWorker <- NA_real_ + corEQueenWorker <- NA_real_ + list( + varAQueen = varAQueen, + varAWorker = varAWorker, + covAQueenWorker = covAQueenWorker, + corAQueenWorker = corAQueenWorker, + varAWorkerGroup = varAWorkerGroup, + covAQueenWorkerGroup = covAQueenWorkerGroup, + corAQueenWorkerGroup = corAQueenWorkerGroup, + varAColony = varAColony, + varEQueen = varEQueen, + varEWorker = varEWorker, + covEQueenWorker = covEQueenWorker, + corEQueenWorker = corEQueenWorker, + varEWorkerGroup = varEWorkerGroup, + covEQueenWorkerGroup = covEQueenWorkerGroup, + corEQueenWorkerGroup = corEQueenWorkerGroup, + varEColony = varEColony, + h2Queen = if (varAQueen + varEQueen == 0) NA_real_ else varAQueen / (varAQueen + varEQueen), + h2Worker = if (varAWorker + varEWorker == 0) NA_real_ else varAWorker / (varAWorker + varEWorker), + h2WorkerGroup = if (varAWorkerGroup + varEWorkerGroup == 0) NA_real_ else varAWorkerGroup / (varAWorkerGroup + varEWorkerGroup), + h2Colony = if (varAColony + varEColony == 0) NA_real_ else varAColony / (varAColony + varEColony), + nW = nW, + nF = nF, + nDPQ = nDPQ, + workersFUN = workersFUN, + workerAllocation = workerAllocation + ) +} diff --git a/R/Functions_L1_Pop.R b/R/Functions_L1_Pop.R index c5b823ce..3d74bbf2 100644 --- a/R/Functions_L1_Pop.R +++ b/R/Functions_L1_Pop.R @@ -1,5 +1,11 @@ + # ---- Level 1 Pop Functions ---- +utils::globalVariables("colony") +utils::globalVariables("i") +utils::globalVariables("cl") + + #' @rdname getCastePop #' @title Access individuals of a caste #' @@ -218,18 +224,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]] @@ -276,7 +282,6 @@ getVirginQueens <- function(x, nInd = NULL, use = "rand", collapse = FALSE, simP return(ret) } - #' @rdname createCastePop #' @title Creates caste population individuals from the colony #' @@ -295,11 +300,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 +313,10 @@ getVirginQueens <- function(x, nInd = NULL, use = "rand", collapse = FALSE, simP #' in \code{\link[SIMplyBee]{SimParamBee}}. The two csd alleles must be different to #' ensure heterozygosity at the csd locus. #' @param simParamBee \code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters +#' @param returnSP logical, whether to return the pedigree, caste, and recHist information +#' for each created population (used internally for parallel computing) +#' @param ids character, IDs of the individuals that are going to be created (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 +331,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 +349,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 +402,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 +423,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 @@ -428,9 +437,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!") @@ -451,73 +458,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_real_ + } + + } 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!") } @@ -525,56 +610,136 @@ 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) + end_lastId <- lastId+totalNInd + + ret <- future_lapply(X = seq_len(nCol), + future.seed = TRUE, + FUN = function(colony) { + nIndColony <- ifelse(nNInd == 1, nInd, nInd[colony]) + if (nIndColony > 0) { + if (nNInd == 1) { + colonyIds = ids[((colony-1)*nIndColony+1):(colony*nIndColony)] + } else { + colonyIds = base::split(ids, rep(seq_along(nInd), nInd))[[as.character(colony)]] + } + + createCastePop( + x = x[[colony]], caste = caste, + nInd = nIndColony, + editCsd = TRUE, csdAlleles = NULL, + simParamBee = simParamBee, + returnSP = TRUE, + ids = as.character(colonyIds) + ) + } else { + NULL + } + } + ) + + names(ret) <- getId(x) + # Add to simParamBee: pedigree, caste, recHist + notNull = sapply(ret, FUN = function(x) !is.null(x)) + + updatedIdBoolean <- simParamBee$lastId == end_lastId + + if (!simParamBee$isTrackPed & !updatedIdBoolean) { + simParamBee$updateLastBeeId(n = totalNInd) + } else if (simParamBee$isTrackPed & !updatedIdBoolean) { + Pedigree <- do.call("rbind", lapply(ret[notNull], '[[', "pedigree")) + if (!simParamBee$isTrackRec) { + simParamBee$addToBeePed(nNewInd = totalNInd, id = rownames(Pedigree), + mother = Pedigree[, 'mother'], father = Pedigree[, 'father'], + isDH = Pedigree[, 'isDH']) + #simParamBee$updatePedigree(pedigree = Pedigree) } else { - 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) } @@ -815,7 +980,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 @@ -1009,12 +1174,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 @@ -1088,26 +1253,30 @@ pullCastePop <- function(x, caste, nInd = NULL, use = "rand", ret <- vector(mode = "list", length = 2) names(ret) <- c("pulled", "remnant") ret$pulled <- vector(mode = "list", length = nCol) - names(ret$pulled) <- getId(x) ret$remnant <- x - 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") + names(ret$pulled) <- getId(x) + ret$remnant@colonies <- lapply(tmp, '[[', "remnant") + if (collapse) { ret$pulled <- mergePops(ret$pulled) } @@ -1193,7 +1362,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 #' @@ -1214,15 +1384,18 @@ pullVirginQueens <- function(x, nInd = NULL, use = "rand", collapse = FALSE, sim #' queen. For more examples for mating with either externally or internally created cross plan, #' please see \code{\link[SIMplyBee]{createCrossPlan}} #' -#' @return \code{\link[AlphaSimR]{Pop-class}} with mated queen(s). The misc slot of the -#' queens contains additional information about the number of workers, drones, -#' and homozygous brood produced, and the expected percentage of csd homozygous -#' brood. +#' @return A \code{\link[AlphaSimR]{Pop-class}}, +#' \code{\link[SIMplyBee]{Colony-class}}, or +#' \code{\link[SIMplyBee]{MultiColony-class}} with mated queen(s), matching +#' the input type. The queens' \code{misc} slots contain worker, drone, and +#' homozygous brood counts, initially zero, and the expected proportion of +#' csd homozygous brood (\code{pHomBrood}). When csd is inactive, +#' \code{pHomBrood} is \code{NA_real_}. #' #' @examples #' founderGenomes <- quickHaplo(nInd = 30, nChr = 1, segSites = 100) #' SP <- SimParamBee$new(founderGenomes) -#' \dontshow{SP$nThreads = 1L} +#' SP$nThreads = 1L #' basePop <- createVirginQueens(founderGenomes) #' #' drones <- createDrones(x = basePop[1], nInd = 1000) @@ -1345,14 +1518,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)) @@ -1364,6 +1543,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!") } @@ -1380,6 +1563,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!") } @@ -1399,199 +1585,232 @@ cross <- function(x, } if (isColony(x) | isMultiColony(x)) { if (any(isQueenPresent(x, simParamBee = simParamBee))) { - stop("Queen already present in the colony!") + stop("Queen already present in a colony!") } if (any(!isVirginQueensPresent(x, simParamBee = simParamBee))) { stop("No virgin queen(s) in the colony to cross!") } } + 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(names(crossPlan), ID_by_input$inputId)] + } + } - 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@misc$nWorkers <- 0 - virginQueen@misc$nDrones <- 0 - virginQueen@misc$nHomBrood <- 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, simParamBee = simParamBee)) %in% IDs] + } + # Here we sample from the DPC in the cross plan to get the needed number of drones (nD) + crossPlanDF_sample <- do.call("rbind", lapply(IDs, + FUN = function(x) { + data.frame(virginID = x, DPC = sample(crossPlan[[x]], size = nD[which(x == IDs)], replace = TRUE)) + } )) + crossPlanDF_sample <- crossPlanDF_sample[order(as.character(crossPlanDF_sample$DPC)),] + # Here I gather how many drones each DPC needs to produce + crossPlanDF_DPCtable <- as.data.frame(table(crossPlanDF_sample$DPC)) + crossPlanDF_DPCtable <- crossPlanDF_DPCtable[order(as.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), simParamBee = simParamBee) + # 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.character(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(match(dronesByVirgin_DF$virginID, IDs)),] + 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@misc$pHomBrood <- 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_real_ } - } 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) +#' @rdname crossVirginQueen +#' @title Internal function to cross a virgin queen #' -#' drones <- createDrones(x = basePop[1], nInd = 1000) -#' droneGroups <- pullDroneGroupsFromDCA(drones, n = 10, nDrones = nFathersPoisson) +#' @description Internal function to cross a virgin queen #' -#' # 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)]) +#' @param virginQueen \code{\link[AlphaSimR]{Pop-class}} +#' @param virginQueenDrones, list with drones +#' @param simParamBee, SimParamBee object #' -#' # Example on Colony class -#' getQueenYearOfBirth(colony) -#' getQueenYearOfBirth(apiary) +#' @return The supplied queen \code{\link[AlphaSimR]{Pop-class}} with fathers +#' stored in \code{misc}, worker, drone, and homozygous brood counts set to +#' zero, and \code{pHomBrood} set to the expected proportion of csd homozygous +#' brood, or \code{NA_real_} when csd is inactive. #' -#' queen1 <- getQueen(colony) -#' queen1 <- setQueensYearOfBirth(queen1, year = 2022) -#' getQueenYearOfBirth(queen1) -#' -#' colony <- setQueensYearOfBirth(colony, year = 2022) -#' getQueenYearOfBirth(colony) -#' -#' apiary <- setQueensYearOfBirth(apiary, year = 2022) -#' getQueenYearOfBirth(apiary) #' @export -setQueensYearOfBirth <- function(x, year, simParamBee = NULL) { - if (is.null(simParamBee)) { - simParamBee <- get(x = "SP", envir = .GlobalEnv) - } - if (isPop(x)) { - if (any(!(isVirginQueen(x, simParamBee = simParamBee) | isQueen(x, simParamBee = simParamBee)))) { - stop("Individuals in x must be virgin queens or queens!") - } - nInd <- nInd(x) - x@misc$yearOfBirth <- year - } else if (isColony(x)) { - if (isQueenPresent(x, simParamBee = simParamBee)) { - x@queen@misc$yearOfBirth <- year - } else { - stop("Missing queen!") - } - } else if (isMultiColony(x)) { - nCol <- nColonies(x) - for (colony in seq_len(nCol)) { - x[[colony]]@queen@misc$yearOfBirth <- 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_real_ } - return(x) + + virginQueen@misc[["pHomBrood"]] <- val + return(virginQueen) } diff --git a/R/Functions_L2_Colony.R b/R/Functions_L2_Colony.R index fcab0499..22b5f524 100644 --- a/R/Functions_L2_Colony.R +++ b/R/Functions_L2_Colony.R @@ -1,3 +1,4 @@ + # ---- Level 2 Colony Functions ---- #' @rdname createColony @@ -8,6 +9,8 @@ #' #' @param x \code{\link[AlphaSimR]{Pop-class}}, one queen or virgin queen(s) #' @param simParamBee \code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters +#' @param id character, ID of the colony that is going to be created (used internally for parallel computing). +#' Numeric IDs are converted to character. #' #' @return new \code{\link[SIMplyBee]{Colony-class}} #' @@ -31,15 +34,21 @@ #' 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 + } + + id <- as.character(id) + if (is.null(x)) { colony <- new( Class = "Colony", - id = simParamBee$lastColonyId + id = id ) } else { if (!isPop(x)) { @@ -60,13 +69,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) } @@ -76,7 +85,7 @@ createColony <- function(x = NULL, simParamBee = NULL) { #' #' @description Level 2 function that re-queens a Colony or #' MultiColony object by adding a mated or a virgin queen, removing the -#' previous queen, and changing the colony id to the new mated queen. +#' previous queen, while preserving the colony ID. #' #' @param x \code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}} #' @param queen \code{\link[AlphaSimR]{Pop-class}} with one individual that will be the @@ -107,7 +116,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 +167,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 +195,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 +239,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 +260,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! @@ -258,7 +296,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 +331,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 +361,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 +414,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 +436,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 +465,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 +504,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) #' @@ -473,10 +537,11 @@ addVirginQueens <- function(x, nInd = NULL, new = FALSE, #' #' # Queen's counters #' 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 +559,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 +577,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) } @@ -539,11 +604,18 @@ buildUp <- function(x, nWorkers = NULL, nDrones = NULL, # Events if (resetEvents) { - x <- resetEvents(x) + x <- resetEvents(x, simParamBee = simParamBee) } x@production <- TRUE } else if (isMultiColony(x)) { + + 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 +632,39 @@ 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 (new) { + n <- nDrones + } else { + n <- nDrones - nDrones(x, simParamBee = simParamBee) + } + if (sum(nDrones) > 0) { + x <- addDrones( + x = x, nInd = n, new = new, + simParamBee = simParamBee) + } + + x <- setEvents(x, slot = "production", value = TRUE, simParamBee = simParamBee) + if (resetEvents) { + x <- resetEvents(x, simParamBee = simParamBee) } + } else { stop("Argument x must be a Colony or MultiColony class object!") } @@ -589,7 +673,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 +710,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 +725,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 +765,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 +785,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 +807,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 +825,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 +842,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 +861,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 +874,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 +927,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 +956,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 +970,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 +988,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 +1009,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 +1029,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 +1047,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 +1057,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 +1084,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 +1098,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 +1107,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 +1129,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 +1146,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 +1196,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 +1216,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 +1247,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 +1261,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 +1283,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 +1316,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 +1330,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 +1347,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 +1358,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 +1382,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 (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!") } - } - 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) + # The swarm receives a new colony ID, independent of its queen 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 +1590,66 @@ 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 (is.function(simParamBee$nVirginQueens)) { + nVirginQueens <- nVirginQueens(x, ...) + } else { + nVirginQueens <- simParamBee$nVirginQueens + } + + if (any(hasCollapsed(x))) { + stop(paste0("One of the collonies is collapsed, hence you can not split it!")) + } + 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, 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 +1658,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 +1682,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 +1692,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 +1736,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 +1904,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 +1912,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 +1943,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 +1981,7 @@ combine <- function(strong, weak) { return(strong) } + #' @rdname setLocation #' @title Set colony location #' @@ -1774,6 +1994,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 +2033,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 +2046,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 +2078,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 +2088,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..dbc02d25 100644 --- a/R/Functions_L3_Colonies.R +++ b/R/Functions_L3_Colonies.R @@ -1,3 +1,4 @@ + # ---- Level 3 MultiColony Functions ---- #' @rdname createMultiColony @@ -13,6 +14,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 +34,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,21 +50,43 @@ #' 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)) + 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 { if (!isPop(x)) { stop("Argument x must be a Pop class object!") } - if (any(!(isVirginQueen(x, simParamBee = simParamBee) | isQueen(x, simParamBee = simParamBee)))) { + if ( + any( + !(isVirginQueen(x, simParamBee = simParamBee) | + isQueen(x, simParamBee = simParamBee)) + ) + ) { stop("Individuals in x must be virgin queens or queens!") } if (is.null(n)) { @@ -71,11 +95,18 @@ createMultiColony <- function(x = NULL, n = NULL, simParamBee = NULL) { if (nInd(x) < n) { stop("Not enough individuals in the x to create n colonies!") } - ret <- new(Class = "MultiColony", colonies = vector(mode = "list", length = n)) - for (colony in seq_len(n)) { - ret[[colony]] <- createColony(x = x[colony], simParamBee = simParamBee) - } + ret <- new( + Class = "MultiColony", + colonies = vector(mode = "list", length = n) + ) + ids <- (simParamBee$lastColonyId + 1):(simParamBee$lastColonyId + n) + + ret@colonies <- future_lapply(X = seq_len(n), FUN = function(colony) { + createColony(x = x[colony], simParamBee = simParamBee, id = ids[colony]) + }) + simParamBee$updateLastColonyId(n = n) } + validObject(ret) return(ret) } @@ -163,8 +194,15 @@ createMultiColony <- function(x = NULL, n = NULL, simParamBee = NULL) { #' selectColonies(apiary, n = 1, by = queenGv) #' #' @export -selectColonies <- function(multicolony, ID = NULL, n = NULL, p = NULL, - by = NULL, selectTop = TRUE, simParamBee = NULL) { +selectColonies <- function( + multicolony, + ID = NULL, + n = NULL, + p = NULL, + by = NULL, + selectTop = TRUE, + simParamBee = NULL +) { if (!isMultiColony(multicolony)) { stop("Argument multicolony must be a MultiColony class object!") } @@ -293,8 +331,15 @@ selectColonies <- function(multicolony, ID = NULL, n = NULL, p = NULL, #' colonyGv <- calcColonyGv(apiary) #' pullColonies(apiary, n = 1, by = colonyGv) #' @export -pullColonies <- function(multicolony, ID = NULL, n = NULL, p = NULL, - by = NULL, pullTop = TRUE, simParamBee = NULL) { +pullColonies <- function( + multicolony, + ID = NULL, + n = NULL, + p = NULL, + by = NULL, + pullTop = TRUE, + simParamBee = NULL +) { if (!isMultiColony(multicolony)) { stop("Argument multicolony must be a MultiColony class object!") } @@ -302,13 +347,15 @@ pullColonies <- function(multicolony, ID = NULL, n = NULL, p = NULL, simParamBee <- get(x = "SP", envir = .GlobalEnv) } if (!is.null(ID)) { + if (!(is.character(ID) | is.numeric(ID))) { + stop("ID must be character or numeric!") + } trueID <- ID %in% getId(multicolony) if (!all(trueID)) { ID <- ID[trueID] warning("ID parameter contains come invalid IDs!") } - pulled <- selectColonies(multicolony, ID, - simParamBee = simParamBee) # selectColonies does the checking of the IDs + pulled <- selectColonies(multicolony, ID, simParamBee = simParamBee) # selectColonies does the checking of the IDs remnant <- removeColonies(multicolony, ID, simParamBee = simParamBee) } else if (!is.null(n) | !is.null(p)) { nCol <- nColonies(multicolony) @@ -406,8 +453,15 @@ pullColonies <- function(multicolony, ID = NULL, n = NULL, p = NULL, #' removeColonies(apiary, n = 1, by = colonyPheno) #' #' @export -removeColonies <- function(multicolony, ID = NULL, n = NULL, p = NULL, - by = NULL, removeTop = FALSE, simParamBee = NULL) { +removeColonies <- function( + multicolony, + ID = NULL, + n = NULL, + p = NULL, + by = NULL, + removeTop = FALSE, + simParamBee = NULL +) { if (!isMultiColony(multicolony)) { stop("Argument multicolony must be a MultiColony class object!") } @@ -415,14 +469,19 @@ removeColonies <- function(multicolony, ID = NULL, n = NULL, p = NULL, simParamBee <- get(x = "SP", envir = .GlobalEnv) } if (!is.null(ID)) { + if (!(is.character(ID) | is.numeric(ID))) { + stop("ID must be character or numeric!") + } trueID <- ID %in% getId(multicolony) if (!all(trueID)) { ID <- ID[trueID] warning("ID parameter contains come invalid IDs!") } - ret <- selectColonies(multicolony, - ID = getId(multicolony)[!getId(multicolony) %in% ID], - simParamBee = simParamBee) + ret <- selectColonies( + multicolony, + ID = getId(multicolony)[!getId(multicolony) %in% ID], + simParamBee = simParamBee + ) } else if (!is.null(n) | !is.null(p)) { nCol <- nColonies(multicolony) if (!is.null(p)) { diff --git a/R/SIMplyBee.R b/R/SIMplyBee.R index ce9260f8..0215d08f 100644 --- a/R/SIMplyBee.R +++ b/R/SIMplyBee.R @@ -1,5 +1,6 @@ #' @useDynLib SIMplyBee, .registration = TRUE #' @import Rcpp +#' @importFrom Rdpack reprompt #' @import AlphaSimR #' @importFrom methods classLabel is new setClass setClassUnion setValidity #' @importFrom methods setMethod show slot slot<- validObject @@ -7,6 +8,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 @@ -25,5 +27,9 @@ #' See the introductory vignette on using this package by running: #' \code{vignette("Honeybee_biology", package="SIMplyBee")} #' +#' @references +#' \insertRef{obsteter2023SIMplyBee}{SIMplyBee} +#' \insertRef{gaynor2021AlphaSimR}{SIMplyBee} +#' #' @keywords internal "_PACKAGE" diff --git a/README.md b/README.md index 1c17e7d8..839fc28c 100644 --- a/README.md +++ b/README.md @@ -13,7 +13,7 @@ http://simplybee.info ## Download -SIMplyBee is available on CRAN. You can install it with +SIMplyBee is available on CRAN. You can install it with install.packages(pkg = "SIMplyBee") diff --git a/TestingVarianceComponents.R b/TestingVarianceComponents.R new file mode 100644 index 00000000..deefb739 --- /dev/null +++ b/TestingVarianceComponents.R @@ -0,0 +1,397 @@ +library(SIMplyBee) +library(tidyr) +library(ggplot2) +library(dplyr) + +# Create a function that maps individual to colony variance +mapIndToColonyVar <- function(varA_q, varA_w, corA_qw, + varE_q, varE_w, corE_qw, + nW, nF, nDPQ, workersFUN = "sum") { + + # First handle the genetic part + # Determine how many pairs of each you have + nW = nW + n_SS = (nW * nW / nF) - nW + n_FS = (nW * nW / nDPQ) - (nW * nW / nF) + n_HS = (nW * nW / nDPQ) * (nDPQ - 1) + + varA_q <- varA_q + if (workersFUN == "mean") { + B1 = 1 / nW * varA_w + } else if (workersFUN == "sum") { + B1 = nW * varA_w + } + + B2_ss <- n_SS * 0.75 * varA_w + B2_fs <- n_FS * 0.50 * varA_w + B2_hs <- n_HS * 0.25 * varA_w + + if (workersFUN == "mean") { + varA_wbar = B1 + 1/nW^2 * (B2_ss + B2_fs + B2_hs) + } else if (workersFUN == "sum") { + varA_wbar = B1 + B2_ss + B2_fs + B2_hs + } + + covA_qw = corA_qw * sqrt(varA_q) * sqrt(varA_w) + + if (workersFUN == "mean") { + covA_qwbar <- covA_qw + } else if (workersFUN == "sum") { + covA_qwbar <- nW * covA_qw + } + corA_qwbar <- covA_qwbar / (sqrt(varA_q) * sqrt(varA_wbar)) + + varA_c <- varA_q + varA_wbar + 2*covA_qwbar + + # Next handle the environmental part + if (workersFUN == "mean") { + varE_wbar = 1 / nW * varE_w + } else if (workersFUN == "sum") { + varE_wbar = nW * varE_w + } + + covE_qw = corE_qw * sqrt(varE_q) * sqrt(varE_w) + + if (workersFUN == "mean") { + covE_qwbar <- covE_qw + } else if (workersFUN == "sum") { + covE_qwbar <- nW * covE_qw + } + corE_qwbar <- covE_qwbar / (sqrt(varE_q) * sqrt(varE_wbar)) + + varE_c <- varE_q + varE_wbar + 2*covE_qwbar + + return(list(varA_q = varA_q, varA_wbar = varA_wbar, covA_qwbar = covA_qwbar, corA_qwbar = corA_qwbar, varA_c = varA_c, + varE_q = varE_q, varE_wbar = varE_wbar, covE_qwbar = covE_qwbar, corE_qwbar = corE_qwbar, varE_c = varE_c)) +} + +# Test the function through reps +nRep = 10 +variances0 = data.frame() + +for (rep in 1:nRep) { + for (fun in c("mean", "sum")) { + print(paste(fun, ", rep ", rep)) + + founderGenomes <- quickHaplo(nInd = 20, nChr = 16, segSites = 1000) + SP <- SimParamBee$new(founderGenomes) + SP$nWorkers <- 100 + SP$nFathers <- 15 + nQtlPerChr <- 100 + + mean <- c(0, 0) + if (fun == "mean") { + varA <- c(1, 1) + varE <- c(3, 3) + } else if (fun == "sum") { + varA <- c(1, 1 / SP$nWorkers) + varE <- c(3, 3 / SP$nWorkers) + } + + corA <- matrix(data = c( 1.0, -0.5, + -0.5, 1.0), nrow = 2, byrow = TRUE) + SP$addTraitA(nQtlPerChr = nQtlPerChr, mean = mean, var = varA, corA = corA, + name = c("queenTrait", "workersTrait")) + + corE <- matrix(data = c(1.0, 0.3, + 0.3, 1.0), nrow = 2, byrow = TRUE) + SP$setVarE(varE = varE, corE = corE) + basePop <- createVirginQueens(founderGenomes, n = 20) + head(basePop@gv) + head(basePop@pheno) + drones <- createDrones(x = basePop[1:5], nInd = 3) + colony <- createColony(x = basePop[6]) + colony <- cross(x = colony, drones = drones, checkCross = "warning") + colony <- addWorkers(x = colony, nInd = 50) + colony <- buildUp(colony) + apiary <- createMultiColony(basePop[7:20]) + drones <- createDrones(basePop[1:5], nInd = 100) + apiary <- cross(x = apiary, drones = drones, crossPlan = "create", checkCross = "warning") + apiary <- buildUp(apiary) + colonyGv <- calcColonyGv(apiary) + + # Get the real number of fathers and DPQs + nW = round(mean(nWorkers(apiary)), 0) + nF = round(mean(nFathers(apiary)), 0) + nDPQ <- round(mean(sapply(getFathers(apiary), function(x) length(unique(x@mother)))), 0) + + if (fun == "mean") { + workersFUN = colMeans + } else if (fun == "sum") { + workersFUN = colSums + } + + # When the function to summarise worker effects is SUM + calcVar <- mapIndToColonyVar(varA_q = varA[1], + varA_w= varA[2], + corA_qw = corA[1,2], + varE_q = varE[1], + varE_w = varE[2], + corE_qw = corE[1,2], + nW = nW, nF = nF, + nDPQ = nDPQ, + workersFUN = fun) + + real_A_q <- calcColonyGv(apiary, FUN = mapCasteToColonyGv, queenTrait = 1, workersTrait = NULL) + real_A_wbar <- calcColonyGv(apiary, FUN = mapCasteToColonyGv, queenTrait = NULL, workersTrait = 2, workersFUN = workersFUN) + real_P_wbar <- calcColonyPheno(apiary, FUN = mapCasteToColonyPheno, queenTrait = NULL, workersTrait = 2, workersFUN = workersFUN) + real_E_wbar <- real_P_wbar - real_A_wbar + real_varE_wbar <- popVar(real_E_wbar) + real_covA_qwbar <- cov(real_A_q, real_A_wbar) + real_corA_qwbar <- cor(real_A_q, real_A_wbar) + + real_varA_wbar <- popVar(real_A_wbar) + + real_A_c <- calcColonyGv(apiary, FUN = mapCasteToColonyGv, workersFUN = workersFUN) + real_varA_c <- popVar(real_A_c) + real_P_c <- calcColonyPheno(apiary, FUN = mapCasteToColonyPheno, workersFUN = workersFUN) + real_E_c <- real_P_c - real_A_c + real_varE_c <- popVar(real_E_c) + + variances0 <- rbind(variances0, data.frame(rep = rep, + + calc_var_wbar = calcVar$varA_wbar, calc_var_c = calcVar$varA_c, + real_var_wbar = real_varA_wbar[1,1], real_var_c = real_varA_c[1,1], + + component = "A", + fun = fun)) + + variances0 <- rbind(variances0, data.frame(rep = rep, + + calc_var_wbar = calcVar$varE_wbar, calc_var_c = calcVar$varE_c, + real_var_wbar = real_varE_wbar, real_var_c = real_varE_c, + + component = "E", + fun = fun)) + + } +} + +variances0Long <- pivot_longer(variances0, + cols = c("calc_var_wbar", "calc_var_c", + "real_var_c", "real_var_wbar"), names_to = "VarType", values_to = "Var") +meanRealVar = variances0Long %>% group_by(fun, component, VarType) %>% summarise(meanVar = mean(Var)) + +variances0Long %>% + dplyr::mutate(rep = as.factor(rep)) %>% + dplyr::mutate(VarType = factor(VarType, levels = c("calc_var_wbar", "calc_var_c", + "real_var_wbar", "real_var_c", "real_varP_c"))) %>% + ggplot(aes(x = rep, y = Var, color = VarType)) + + geom_point(size = 3, aes(colour = VarType)) + + geom_hline(data = meanRealVar, aes(yintercept = meanVar, colour = VarType), linewidth = 3) + + facet_wrap(. ~fun+component, scales = "free") + + theme_bw(base_size = 20) + + scale_colour_manual(values = c( + "#D55E00", # vermillion + "#084159", # blue + "#32c237", + "#b560b4", + "#a80805", # reddish purple + "#0f77a3", # bluish green + "#1a5e1d", + "#610b60" + )) + +variances0 |> filter(rep == 1) + +pivot_longer(variances0 |> select(c(rep, fun, real_covA_qwbar, real_corA_qwbar)), cols = c("real_covA_qwbar", "real_corA_qwbar"), names_to = "CovType", values_to = "Cov") |> + mutate(rep = as.factor(rep)) %>% + ggplot(aes(x = rep, y = Cov, color = CovType)) + + geom_point(size = 3) + + facet_wrap(. ~fun+CovType, scales = "free") + + theme_bw(base_size = 20) + +########################################################################################3 +# The other way around +# Create a function that maps colony level variance to individual level variance +######################################################################################## +mapColonyToIndVar <- function(varA_q, + varA_wbar, + corA_qwbar, + varE_q, + varE_wbar, + corE_qwbar, + nW, + nF, + nDPQ, + workersFUN = "sum") { + + # First handle the genetic part + covA_qwbar <- corA_qwbar * sqrt(varA_q) * sqrt(varA_wbar) + + # scaling factor + if (workersFUN == "sum") { + covA_qw <- covA_qwbar / nW + } else if (workersFUN == "mean") { + covA_qw <- covA_qwbar + } + + # pair counts + n_SS <- (nW * nW / nF) - nW + n_FS <- (nW * nW / nDPQ) - (nW * nW / nF) + n_HS <- (nW * nW / nDPQ) * (nDPQ - 1) + + # worker variance coefficient + if (workersFUN == "sum") { + K <- nW + + n_SS * 0.75 + + n_FS * 0.50 + + n_HS * 0.25 + } else if (workersFUN == "mean") { + K <- 1 / nW + ((n_SS * 0.75 + + n_FS * 0.50 + + n_HS * 0.25) / nW^2) + } + + varA_w <- varA_wbar / K + + corA_qw <- covA_qw / (sqrt(varA_q) * sqrt(varA_w)) + + # Next handle the environmental part + covE_qwbar <- corE_qwbar * sqrt(varE_q) * sqrt(varE_wbar) + + if (workersFUN == "sum") { + varE_w <- varE_wbar / nW + covE_qw <- covE_qwbar / nW + } else if (workersFUN == "mean") { + varE_w <- varE_wbar * nW + covE_qw <- covE_qwbar + } + + corE_qw <- covE_qw / (sqrt(varE_q) * sqrt(varE_w)) + + + return(list(varA_q = varA_q, varA_wbar = varA_wbar, varA_w = varA_w, + covA_qwbar = covA_qwbar, covA_qw = covA_qw, corA_qw = corA_qw, + varE_q = varE_q, varE_wbar = varE_wbar, varE_w = varE_w, + covE_qwbar = covE_qwbar, covE_qw = covE_qw, corE_qw = corE_qw)) +} + +# Test the function through reps +nRep = 10 +variances = data.frame() + +for (rep in 1:nRep) { + print(rep) + varA_q <- 5 + varA_wbar <- 10 + corA_qwbar <- -0.5 + + varE_q <- 10 + varE_wbar <- 20 + corE_qwbar <- 0.3 + + nW <- 100 + nF <- 15 + nDPQ <- 5 + + for (fun in c("mean", "sum")) { + indVarComp <- mapColonyToIndVar(varA_q = varA_q, varA_wbar = varA_wbar, corA_qwbar = corA_qwbar, + varE_q = varE_q, varE_wbar = varE_wbar, corE_qwbar = corE_qwbar, + nW = nW, nF = nF, nDPQ = nDPQ, workersFUN = fun) + calc_var_c <- mapIndToColonyVar(varA_q = indVarComp$varA_q, varA_w = indVarComp$varA_w, corA_qw = indVarComp$corA_qw, + varE_q = indVarComp$varE_q, varE_w = indVarComp$varE_w, corE_qw = indVarComp$corE_qw, + nW = nW, nF = nF, nDPQ = nDPQ, workersFUN = fun) + + print(paste0(fun, ", rep ", rep)) + founderGenomes <- quickHaplo(nInd = 20, nChr = 16, segSites = 1000) + SP <- SimParamBee$new(founderGenomes) + SP$nWorkers = nW + SP$nFathers = nF + nQtlPerChr <- 100 + mean <- c(0, 0) + varA <- c(indVarComp$varA_q, indVarComp$varA_w) + corA <- matrix(data = c( 1.0, indVarComp$corA_qw, + indVarComp$corA_qw, 1.0), nrow = 2, byrow = TRUE) + SP$addTraitA(nQtlPerChr = nQtlPerChr, mean = mean, var = varA, corA = corA, + name = c("queenTrait", "workersTrait")) + varE <- c(indVarComp$varE_q, indVarComp$varE_w) + corE <- matrix(data = c(1.0, indVarComp$corE_qw, + indVarComp$corE_qw, 1.0), nrow = 2, byrow = TRUE) + SP$setVarE(varE = varE, corE = corE) + basePop <- createVirginQueens(founderGenomes, n = 20) + + drones <- createDrones(x = basePop[1:nDPQ], nInd = 3) + colony <- createColony(x = basePop[nDPQ+1]) + colony <- cross(x = colony, drones = drones, checkCross = "warning") + colony <- addWorkers(x = colony, nInd = 50) + colony <- buildUp(colony) + apiary <- createMultiColony(basePop[7:20]) + drones <- createDrones(basePop[1:nDPQ], nInd = 100) + apiary <- cross(x = apiary, drones = drones, crossPlan = "create", checkCross = "warning") + apiary <- buildUp(apiary) + + if (fun == "sum") { + workersFUN <- colSums + } else if (fun == "mean") { + workersFUN <- colMeans + } + + # Get the real number of fathers and DPQs + real_A_wbar <- calcColonyGv(apiary, mapCasteToColonyGv, queenTrait = NULL, workersTrait = 2, workersFUN = workersFUN) + real_varA_wbar <- popVar(real_A_wbar) + real_A_c <- calcColonyGv(apiary, mapCasteToColonyGv, queenTrait = 1, workersTrait = 2, workersFUN = workersFUN) + real_varA_c <- popVar(real_A_c) + real_P_wbar <- calcColonyPheno(apiary, mapCasteToColonyPheno, queenTrait = NULL, workersTrait = 2, workersFUN = workersFUN) + real_E_wbar <- real_P_wbar - real_A_wbar + real_varE_wbar <- popVar(real_E_wbar) + real_P_c <- calcColonyPheno(apiary, mapCasteToColonyPheno, queenTrait = 1, workersTrait = 2, workersFUN = workersFUN) + real_E_c <- real_P_c - real_A_c + real_varE_c <- popVar(real_E_c) + + variances <- rbind(variances, data.frame(rep = rep, + set_var_wbar = varA_wbar, + + calc_var_wbar = calc_var_c$varA_wbar, calc_var_c = calc_var_c$varA_c, + real_var_wbar = real_varA_wbar[1,1], real_var_c = real_varA_c, + + component = "A", + + fun = fun)) + + variances <- rbind(variances, data.frame(rep = rep, + set_var_wbar = varE_wbar, + + calc_var_wbar = calc_var_c$varE_wbar, calc_var_c = calc_var_c$varE_c, + real_var_wbar = real_varE_wbar[1,1], real_var_c = real_varE_c, + + component = "E", + fun = fun)) + + + + } +} + + + +variancesLong <- variances |> + #select(rep, fun, real_varA_wbar, set_varA_wbar, real_varA_c, calc_varA_c, calc_varA_wbar) |> + pivot_longer(cols = c("set_var_wbar", + "calc_var_wbar", "calc_var_c", + "real_var_wbar", "real_var_c"), + names_to = "VarType", values_to = "Var") + +meanRealVar = variancesLong %>% group_by(fun, component, VarType) %>% summarise(meanVar = mean(Var)) + +library(viridis) +variancesLong %>% + mutate(rep = as.factor(rep)) %>% + mutate(VarType = factor(VarType, levels = c("set_var_wbar", "calc_var_wbar", "real_var_wbar", "calc_var_c", "real_var_c"))) %>% + ggplot(aes(x = rep, y = Var, color = VarType)) + + geom_point(size = 3, alpha = 0.7) + + geom_hline(data = meanRealVar, aes(yintercept = meanVar, colour = VarType), linewidth = 3) + + facet_wrap(. ~fun + component, scales = "free") + + theme_bw(base_size = 20) + + scale_colour_manual(values = c( + # Cool tones + "#1B4965", # deep blue + "#048BA8", # cyan-blue + "#16DB93", # green-teal + + # Warm tones + "#F4A261", # sand orange + "#D62828", # red + "#9D4EDD" # purple +)) + \ No newline at end of file diff --git a/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/inst/REFERENCES.bib b/inst/REFERENCES.bib new file mode 100644 index 00000000..2f5842e5 --- /dev/null +++ b/inst/REFERENCES.bib @@ -0,0 +1,285 @@ +% Shared bibliography for package help pages and vignettes. +% Keys use surnameYearFirst; sorted by key. + +@article{beye2006Exceptionally, + title = {Exceptionally high levels of recombination across the honey bee genome}, + author = {Beye, M. and Gattermeier, I. and Hasselmann, M. and Gempe, T. and Schioett, M. and Baines, J. F. and Schlipalius, D. and Mougel, F. and Emore, C. and Rueppell, O. and Sirviö, A. and Guzmán-Novoa, E. and Hunt, G. and Solignac, M. and Page, R. E.}, + year = {2006}, + journal = {Genome Research}, + volume = {16}, + number = {11}, + pages = {1339--1344}, + doi = {10.1101/gr.5680406}, + url = {https://doi.org/10.1101/gr.5680406} +} + +@article{bovo2021Application, + title = {Application of Next Generation Semiconductor-Based Sequencing for the Identification of {Apis} mellifera Complementary Sex Determiner ({csd}) Alleles from Honey {DNA}}, + author = {Bovo, S. and Ribani, A. and Utzeri, V. J. and Taurisano, V. and Schiavo, G. and Bolner, M. and Fontanesi, L.}, + year = {2021}, + journal = {Insects}, + volume = {12}, + number = {10}, + pages = {868}, + doi = {10.3390/insects12100868}, + url = {https://doi.org/10.3390/insects12100868} +} + +@article{brascamp2014Methods, + title = {Methods to estimate breeding values in honey bees}, + author = {Brascamp, E. W. and Bijma, P.}, + year = {2014}, + journal = {Genetics Selection Evolution}, + volume = {46}, + number = {1}, + pages = {53}, + doi = {10.1186/s12711-014-0053-9}, + url = {https://doi.org/10.1186/s12711-014-0053-9} +} + +@article{brascamp2019Note, + title = {A note on genetic parameters and accuracy of estimated breeding values in honey bees}, + author = {Brascamp, E. W. and Bijma, P.}, + year = {2019}, + journal = {Genetics Selection Evolution}, + volume = {51}, + number = {1}, + pages = {71}, + doi = {10.1186/s12711-019-0510-6}, + url = {https://doi.org/10.1186/s12711-019-0510-6} +} + +@article{chen2009Fast, + title = {Fast and flexible simulation of {DNA} sequence data}, + author = {Chen, G. K. and Marjoram, P. and Wall, J. D.}, + year = {2009}, + journal = {Genome Research}, + volume = {19}, + number = {1}, + pages = {136--142}, + doi = {10.1101/gr.083634.108}, + url = {https://doi.org/10.1101/gr.083634.108} +} + +@misc{clemson2020Frequently, + author = {Clemson Cooperative Extension}, + title = {Frequently asked questions about honey bee swarms}, + year = {2020}, + url = {https://hgic.clemson.edu/factsheet/frequently-asked-questions-about-honey-bee-swarms/}, + note = {Accessed 2022-11-11; publication year corrected from 2021 to 2020} +} + +@article{druet2020Theoretical, + title = {Theoretical and empirical comparisons of expected and realized relationships for the {X}-chromosome}, + author = {Druet, T. and Legarra, A.}, + year = {2020}, + journal = {Genetics Selection Evolution}, + volume = {52}, + number = {1}, + pages = {50}, + doi = {10.1186/s12711-020-00570-6}, + url = {https://doi.org/10.1186/s12711-020-00570-6} +} + +@article{du2021Short, + title = {Short-term effects of controlled mating and selection on the genetic variance of honeybee populations}, + author = {Du, M. and Bernstein, R. and Hoppe, A. and Bienefeld, K.}, + year = {2021}, + journal = {Heredity}, + volume = {126}, + number = {5}, + pages = {733--747}, + doi = {10.1038/s41437-021-00411-2}, + url = {https://doi.org/10.1038/s41437-021-00411-2} +} + +@article{fernando1989Covariance, + title = {Covariance between relatives for {X}-chromosomal loci in a population in disequilibrium}, + author = {Grossman, M. and Fernando, R. L.}, + year = {1989}, + journal = {Theoretical and Applied Genetics}, + volume = {77}, + number = {3}, + pages = {311--319}, + doi = {10.1007/bf00305821}, + url = {https://doi.org/10.1007/bf00305821} +} + +@article{fernando1990Genetic, + title = {Genetic evaluation with autosomal and {X}-chromosomal inheritance}, + author = {Fernando, R. L. and Grossman, M.}, + year = {1990}, + journal = {Theoretical and Applied Genetics}, + volume = {80}, + number = {1}, + pages = {75--80}, + doi = {10.1007/bf00224018}, + url = {https://doi.org/10.1007/bf00224018} +} + +@article{gaynor2021AlphaSimR, + title = {{AlphaSimR}: an {R} package for breeding program simulations}, + author = {Gaynor, R. C. and Gorjanc, G. and Hickey, J. M.}, + year = {2021}, + journal = {G3 Genes|Genomes|Genetics}, + volume = {11}, + number = {2}, + pages = {jkaa017}, + doi = {10.1093/g3journal/jkaa017}, + url = {https://doi.org/10.1093/g3journal/jkaa017} +} + +@article{grossman1989Inbreeding, + title = {Inbreeding, Coancestry, and Covariance between Relatives for {X}-Chromosomal Loci}, + author = {Grossman, M. and Eisen, E. J.}, + year = {1989}, + journal = {Journal of Heredity}, + volume = {80}, + number = {2}, + pages = {137--142}, + doi = {10.1093/oxfordjournals.jhered.a110812}, + url = {https://doi.org/10.1093/oxfordjournals.jhered.a110812} +} + +@article{hamdan2010Natural, + title = {Natural Supersedure of Queens in Honey Bee Colonies}, + author = {Hamdan, K.}, + year = {2010}, + journal = {Bee World}, + volume = {87}, + number = {3}, + pages = {52--54}, + doi = {10.1080/0005772X.2010.11417360}, + url = {https://doi.org/10.1080/0005772X.2010.11417360} +} + +@article{hill2011Variation, + title = {Variation in actual relationship as a consequence of {Mendelian} sampling and linkage}, + author = {HILL, W. G. and WEIR, B. S.}, + year = {2011}, + journal = {Genetics Research}, + volume = {93}, + number = {1}, + pages = {47--64}, + doi = {10.1017/s0016672310000480}, + url = {https://doi.org/10.1017/s0016672310000480} +} + +@article{lechner2014Nucleotide, + title = {Nucleotide Variability at Its Limit? {I}nsights into the Number and Evolutionary Dynamics of the Sex-Determining Specificities of the Honey Bee {Apis} mellifera}, + author = {Lechner, S. and Ferretti, L. and Schöning, C. and Kinuthia, W. and Willemsen, D. and Hasselmann, M.}, + year = {2014}, + journal = {Molecular Biology and Evolution}, + volume = {31}, + number = {2}, + pages = {272--287}, + doi = {10.1093/molbev/mst207}, + url = {https://doi.org/10.1093/molbev/mst207} +} + +@misc{nubdotdev2021Best, + author = {{nubDotDev}}, + title = {The BEST Way to Find a Random Point in a Circle}, + year = {2021}, + url = {https://youtu.be/4y_nmpv-9lI} +} + +@article{obsteter2023SIMplyBee, + title = {{SIMplyBee}: an {R} package to simulate honeybee populations and breeding programs}, + author = {Obšteter, J. and Strachan, L. K. and Bubnič, J. and Prešern, J. and Gorjanc, G.}, + year = {2023}, + journal = {Genetics Selection Evolution}, + volume = {55}, + number = {1}, + pages = {31}, + doi = {10.1186/s12711-023-00798-y}, + url = {https://doi.org/10.1186/s12711-023-00798-y} +} + +@article{rangel2012Colony, + title = {Colony fissioning in honey bees: size and significance of the swarm fraction}, + author = {Rangel, J. and Seeley, T. D.}, + year = {2012}, + journal = {Insectes Sociaux}, + volume = {59}, + number = {4}, + pages = {453--462}, + doi = {10.1007/s00040-012-0239-5}, + url = {https://doi.org/10.1007/s00040-012-0239-5} +} + +@book{seeley2019Lives, + title = {The Lives of Bees}, + author = {Seeley, T. D.}, + year = {2019}, + publisher = {Princeton University Press}, + doi = {10.1515/9780691189383}, + url = {https://doi.org/10.1515/9780691189383} +} + +@article{vanarendonk1994Use, + title = {Use of multiple genetic markers in prediction of breeding values}, + author = {Van Arendonk, J. A. and Tier, B. and Kinghorn, B. P.}, + year = {1994}, + journal = {Genetics}, + volume = {137}, + number = {1}, + pages = {319--329}, + doi = {10.1093/genetics/137.1.319}, + url = {https://doi.org/10.1093/genetics/137.1.319} +} + +@article{wallberg2014Worldwide, + title = {A worldwide survey of genome sequence variation provides insight into the evolutionary history of the honeybee {Apis} mellifera}, + author = {Wallberg, A. and Han, F. and Wellhagen, G. and Dahle, B. and Kawata, M. and Haddad, N. and Simões, Z. L. P. and Allsopp, M. H. and Kandemir, I. and De la Rúa, P. and Pirk, C. W. and Webster, M. T.}, + year = {2014}, + journal = {Nature Genetics}, + volume = {46}, + number = {10}, + pages = {1081--1088}, + doi = {10.1038/ng.3077}, + url = {https://doi.org/10.1038/ng.3077} +} + +@article{wallberg2019Hybrid, + title = {A hybrid de novo genome assembly of the honeybee, {Apis} mellifera, with chromosome-length scaffolds}, + author = {Wallberg, A. and Bunikis, I. and Pettersson, O. V. and Mosbech, M.-B. and Childers, A. K. and Evans, J. D. and Mikheyev, A. S. and Robertson, H. M. and Robinson, G. E. and Webster, M. T.}, + year = {2019}, + journal = {BMC Genomics}, + volume = {20}, + number = {1}, + pages = {275}, + doi = {10.1186/s12864-019-5642-0}, + url = {https://doi.org/10.1186/s12864-019-5642-0} +} + +@misc{wolfram2023Disk, + author = {{Wolfram MathWorld}}, + title = {Disk Point Picking}, + year = {2023}, + url = {https://mathworld.wolfram.com/DiskPointPicking.html} +} + +@article{yang2015Parent, + title = {Parent–progeny sequencing indicates higher mutation rates in heterozygotes}, + author = {Yang, S. and Wang, L. and Huang, J. and Zhang, X. and Yuan, Y. and Chen, J.-Q. and Hurst, L. D. and Tian, D.}, + year = {2015}, + journal = {Nature}, + volume = {523}, + number = {7561}, + pages = {463--467}, + doi = {10.1038/nature14649}, + url = {https://doi.org/10.1038/nature14649} +} + +@article{zareba2017Uneven, + title = {Uneven distribution of complementary sex determiner ({csd}) alleles in {Apis} mellifera population}, + author = {Zareba, J. and Blazej, P. and Laszkiewicz, A. and Sniezewski, L. and Majkowski, M. and Janik, S. and Cebrat, M.}, + year = {2017}, + journal = {Scientific Reports}, + volume = {7}, + number = {1}, + pages = {2317}, + doi = {10.1038/s41598-017-02629-9}, + url = {https://doi.org/10.1038/s41598-017-02629-9} +} diff --git a/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/literature/README.md b/literature/README.md new file mode 100644 index 00000000..d2cf74e0 --- /dev/null +++ b/literature/README.md @@ -0,0 +1,75 @@ +# SIMplyBee literature archive + +The citation inventory is [`inst/REFERENCES.bib`](../inst/REFERENCES.bib). +Checked on 2026-09-29: **21 of 22 scholarly references archived as PDFs**. +All 21 cited journal articles are available; +only Seeley's book remains missing. +Three additional citations are web/video resources. + +Open the local links below to read the papers. +All PDFs are named after their BibTeX keys. +PDF contents are unchanged. +Copyright and licences remain with the original rights holders. +The archive is excluded from package builds through `.Rbuildignore`. + +## Archived papers + +| BibTeX key | Local full text | Source / provenance | +| --- | --- | --- | +| `beye2006Exceptionally` | [Exceptionally high levels of recombination across the honey bee genome (PDF)](beye2006Exceptionally.pdf) | User supplied; [publication](https://doi.org/10.1101/gr.5680406) | +| `bovo2021Application` | [Application of Next Generation Semiconductor-Based Sequencing for the Identification of Apis mellifera Complementary Sex Determiner (csd) Alleles from Honey DNA (PDF)](bovo2021Application.pdf) | [Source](https://mdpi-res.com/d_attachment/insects/insects-12-00868/article_deploy/insects-12-00868.pdf) | +| `brascamp2014Methods` | [Methods to estimate breeding values in honey bees (PDF)](brascamp2014Methods.pdf) | [Source](https://doi.org/10.1186/s12711-014-0053-9) | +| `brascamp2019Note` | [A note on genetic parameters and accuracy of estimated breeding values in honey bees (PDF)](brascamp2019Note.pdf) | [Source](https://doi.org/10.1186/s12711-019-0510-6) | +| `chen2009Fast` | [Fast and flexible simulation of DNA sequence data (PDF)](chen2009Fast.pdf) | User supplied; [publication](https://doi.org/10.1101/gr.083634.108) | +| `druet2020Theoretical` | [Theoretical and empirical comparisons of expected and realized relationships for the X-chromosome (PDF)](druet2020Theoretical.pdf) | [Source](https://link.springer.com/content/pdf/10.1186/s12711-020-00570-6.pdf) | +| `du2021Short` | [Short-term effects of controlled mating and selection on the genetic variance of honeybee populations (PDF)](du2021Short.pdf) | [Source](https://www.nature.com/articles/s41437-021-00411-2.pdf) | +| `fernando1989Covariance` | [Covariance between relatives for X-chromosomal loci in a population in disequilibrium (PDF)](fernando1989Covariance.pdf) | [Source](https://link.springer.com/content/pdf/10.1007/bf00305821.pdf) | +| `fernando1990Genetic` | [Genetic evaluation with autosomal and X-chromosomal inheritance (PDF)](fernando1990Genetic.pdf) | [Source](https://link.springer.com/content/pdf/10.1007/bf00224018.pdf) | +| `gaynor2021AlphaSimR` | [AlphaSimR: an R package for breeding program simulations (PDF)](gaynor2021AlphaSimR.pdf) | [Source](https://pmc-oa-opendata.s3.amazonaws.com/PMC8022926.1/PMC8022926.1.pdf) | +| `grossman1989Inbreeding` | [Inbreeding, Coancestry, and Covariance between Relatives for X-Chromosomal Loci (PDF)](grossman1989Inbreeding.pdf) | User supplied; [publication](https://doi.org/10.1093/oxfordjournals.jhered.a110812) | +| `hamdan2010Natural` | [Natural Supersedure of Queens in Honey Bee Colonies (PDF)](hamdan2010Natural.pdf) | User supplied; [publication](https://doi.org/10.1080/0005772X.2010.11417360) | +| `hill2011Variation` | [Variation in actual relationship as a consequence of Mendelian sampling and linkage (PDF)](hill2011Variation.pdf) | [Source](https://www.cambridge.org/core/services/aop-cambridge-core/content/view/12D801902473A0F212EF49489DF0D687/S0016672310000480a.pdf/div-class-title-variation-in-actual-relationship-as-a-consequence-of-mendelian-sampling-and-linkage-div.pdf) | +| `lechner2014Nucleotide` | [Nucleotide Variability at Its Limit? Insights into the Number and Evolutionary Dynamics of the Sex-Determining Specificities of the Honey Bee Apis mellifera (PDF)](lechner2014Nucleotide.pdf) | [Source](https://pmc-oa-opendata.s3.amazonaws.com/PMC3907057.1/PMC3907057.1.pdf) | +| `obsteter2023SIMplyBee` | [SIMplyBee: an R package to simulate honeybee populations and breeding programs (PDF)](obsteter2023SIMplyBee.pdf) | [Source](https://link.springer.com/content/pdf/10.1186/s12711-023-00798-y.pdf) | +| `rangel2012Colony` | [Colony fissioning in honey bees: size and significance of the swarm fraction (PDF)](rangel2012Colony.pdf) | [Source](https://link.springer.com/content/pdf/10.1007/s00040-012-0239-5.pdf) | +| `vanarendonk1994Use` | [Use of multiple genetic markers in prediction of breeding values. (PDF)](vanarendonk1994Use.pdf) | User supplied; [publication](https://doi.org/10.1093/genetics/137.1.319) | +| `wallberg2014Worldwide` | [A worldwide survey of genome sequence variation provides insight into the evolutionary history of the honeybee Apis mellifera (PDF)](wallberg2014Worldwide.pdf) | [Source](https://repository.up.ac.za/bitstreams/6a6fbb44-8a17-45e7-adf9-cdefbbe313e5/download) | +| `wallberg2019Hybrid` | [A hybrid de novo genome assembly of the honeybee, Apis mellifera, with chromosome-length scaffolds (PDF)](wallberg2019Hybrid.pdf) | [Source](https://link.springer.com/content/pdf/10.1186/s12864-019-5642-0.pdf) | +| `yang2015Parent` | [Parent–progeny sequencing indicates higher mutation rates in heterozygotes (PDF)](yang2015Parent.pdf) | [Source](https://purehost.bath.ac.uk/ws/portalfiles/portal/136920961/Parent_progeny_sequencing_indicates_higher_mutation_rates_in_heterozygotes._.pdf) | +| `zareba2017Uneven` | [Uneven distribution of complementary sex determiner (csd) alleles in Apis mellifera population (PDF)](zareba2017Uneven.pdf) | [Source](https://www.nature.com/articles/s41598-017-02629-9.pdf) | + +## Full text still needed + +These references have no local full-text copy. + +| BibTeX key | Reference | Status | +| --- | --- | --- | +| `seeley2019Lives` | [The Lives of Bees](https://doi.org/10.1515/9780691189383) | Full text could not be downloaded from checked publisher/repository sources. | + +## Web and video references + +These are recorded as links, not counted as archived papers. + +- `clemson2020Frequently`: [Frequently asked questions about honey bee swarms](https://hgic.clemson.edu/factsheet/frequently-asked-questions-about-honey-bee-swarms/) +- `nubdotdev2021Best`: [The BEST Way to Find a Random Point in a Circle](https://youtu.be/4y_nmpv-9lI) +- `wolfram2023Disk`: [Disk Point Picking](https://mathworld.wolfram.com/DiskPointPicking.html) + +## Provenance and integrity + +[`manifest.json`](manifest.json) records each citation, local file, source, +retrieval date, format/version, validation, and download status. + +## Maintaining citations + +Use `surnameYearFirst` keys in `inst/REFERENCES.bib`. Vignettes use Pandoc +citations (`@key` or `[@key]`). +Roxygen help uses Rdpack references to the same file. Regenerate `man/` and +`NAMESPACE` through roxygen; do not edit generated help manually. + +The initial inventory includes all named scholarly references found in +`R/`, the vignettes, README, and `inst/CITATION`, +plus the three explicitly referenced web resources. +DOI metadata was resolved from Crossref/DOI records; +web-reference metadata was retained from existing docs. +`inst/CITATION` remains the package's conventional citation entry point. +General software links and incidental explanatory URLs are not treated as papers. diff --git a/man/Colony-class.Rd b/man/Colony-class.Rd index 8138470b..056d8832 100644 --- a/man/Colony-class.Rd +++ b/man/Colony-class.Rd @@ -40,7 +40,7 @@ An object holding honeybee colony \section{Slots}{ \describe{ -\item{\code{id}}{integer, unique ID of the colony} +\item{\code{id}}{character, unique ID of the colony, independent of its queen ID} \item{\code{location}}{numeric, location of the colony (x, y)} diff --git a/man/MultiColony-class.Rd b/man/MultiColony-class.Rd index d81e7d6f..62ec8e57 100644 --- a/man/MultiColony-class.Rd +++ b/man/MultiColony-class.Rd @@ -58,7 +58,9 @@ assign into \code{x} based on colony index or name \code{i}} } \description{ An object holding a collection of honeybee colonies. It behaves - like a list. + like a list. Numeric indices select positions; character indices select + colony by their IDs/names. Single bracket indexing returns a MultiColony, + while double brackets return one Colony (or NULL for an unpopulated entry). } \section{Functions}{ \itemize{ @@ -70,17 +72,17 @@ An object holding a collection of honeybee colonies. It behaves \item \code{c(MultiColonyOrNULL)}: Combine multiple Colony and MultiColony objects -\item \code{x[i}: Extract a colony (one or more!) with an integer/numeric/logical index (position) (return \code{\link[SIMplyBee]{MultiColony-class}}) +\item \code{x = MultiColony[i = integerOrNumericOrLogical]}: Extract a colony (one or more!) with an integer/numeric/logical index (position) (return \code{\link[SIMplyBee]{MultiColony-class}}) -\item \code{x[i}: Extract a colony (one or more!) with a character ID (name) (return \code{\link[SIMplyBee]{MultiColony-class}}) +\item \code{x = MultiColony[i = character]}: Extract a colony (one or more!) with a character ID (name) (return \code{\link[SIMplyBee]{MultiColony-class}}) -\item \code{x[[i}: Extract a colony (just one!) with an integer/numeric/logical index (position) (return \code{\link[SIMplyBee]{Colony-class}}) +\item \code{x = MultiColony[[i = integerOrNumericOrLogical]]}: Extract a colony (just one!) with an integer/numeric/logical index (position) (return \code{\link[SIMplyBee]{Colony-class}}) -\item \code{x[[i}: Extract a colony (just one!) with a character ID (name) (return \code{\link[SIMplyBee]{Colony-class}}) +\item \code{x = MultiColony[[i = character]]}: Extract a colony (just one!) with a character ID (name) (return \code{\link[SIMplyBee]{Colony-class}}) -\item \code{`[`(x = MultiColony, i = integerOrNumericOrLogicalOrCharacter, j = ANY) <- value}: Assign colonies into MultiColony +\item \code{x = MultiColony[i = integerOrNumericOrLogicalOrCharacter, j = ANY] <- value}: Assign colonies into MultiColony -\item \code{`[[`(x = MultiColony, i = integerOrNumericOrLogicalOrCharacter, j = ANY) <- value}: Assign Colony into MultiColony +\item \code{x = MultiColony[[i = integerOrNumericOrLogicalOrCharacter, j = ANY]] <- value}: Assign Colony into MultiColony }} \section{Slots}{ @@ -95,7 +97,7 @@ SP <- SimParamBee$new(founderGenomes) \dontshow{SP$nThreads = 1L} basePop <- createVirginQueens(founderGenomes) -drones <- createDrones(x = basePop[1], nInd = 1000) +drones <- createDrones(x = basePop[1], nInd = 200) droneGroups <- pullDroneGroupsFromDCA(drones, n = 10, nDrones = nFathersPoisson) apiary <- createMultiColony(basePop[1:6], n = 6) apiary <- cross(apiary, drones = droneGroups[1:6]) @@ -105,27 +107,23 @@ is(apiary) isMultiColony(apiary) getId(apiary) -apiary[1] getId(apiary[1]) getId(apiary["2"]) getId(apiary[2]) getId(apiary[-1]) getId(apiary[5]) -getId(apiary) getId(apiary[c(1, 3)]) getId(apiary[c("2", "4")]) getId(apiary[c(TRUE, FALSE, TRUE, FALSE)]) getId(apiary[c(TRUE, FALSE)]) # beware of recycling! -getId(apiary[c(5, 6)]) +getId(apiary[c(6, 7)]) getId(apiary[c("6", "7")]) +apiary[1] apiary[[1]] apiary[["2"]] -apiary[[3]] -apiary[["4"]] -try(apiary[[6]]) -apiary[["7"]] +try(apiary[[7]]) getId(c(apiary[c(1, 3)], apiary[2])) getId(c(apiary[2], apiary[c(1, 3)])) diff --git a/man/SIMplyBee-package.Rd b/man/SIMplyBee-package.Rd index 71d90a18..99748e94 100644 --- a/man/SIMplyBee-package.Rd +++ b/man/SIMplyBee-package.Rd @@ -21,6 +21,10 @@ extended for honeybees, including haplo-diploidy, csd locus, colony events See the introductory vignette on using this package by running: \code{vignette("Honeybee_biology", package="SIMplyBee")} } +\references{ +\insertRef{obsteter2023SIMplyBee}{SIMplyBee} +\insertRef{gaynor2021AlphaSimR}{SIMplyBee} +} \seealso{ Useful links: \itemize{ @@ -33,6 +37,7 @@ Useful links: Authors: \itemize{ + \item Jana Obšteter \email{obsteter.jana@gmail.com} (\href{https://orcid.org/0000-0003-1511-3916}{ORCID}) \item Laura Strachan (\href{https://orcid.org/0000-0002-2569-0250}{ORCID}) \item Jernej Bubnič (\href{https://orcid.org/0000-0003-1362-3736}{ORCID}) \item Gregor Gorjanc (\href{https://orcid.org/0000-0001-8008-2787}{ORCID}) diff --git a/man/SimParamBee.Rd b/man/SimParamBee.Rd index 664475f4..33c49abf 100644 --- a/man/SimParamBee.Rd +++ b/man/SimParamBee.Rd @@ -25,7 +25,7 @@ See also \code{vignette(package = "SIMplyBee")} for descriptions of how \examples{ ## ------------------------------------------------ -## Method `SimParamBee$new` +## Method `SimParamBee$new()` ## ------------------------------------------------ founderGenomes <- quickHaplo(nInd = 10, nChr = 3, segSites = 10) @@ -45,7 +45,7 @@ SP <- SimParamBee$new(founderGenomes, nCsdAlleles = 100) \dontshow{SP$nThreads = 1L} ## ------------------------------------------------ -## Method `SimParamBee$addToCaste` +## Method `SimParamBee$addToCaste()` ## ------------------------------------------------ founderGenomes <- quickHaplo(nInd = 2, nChr = 1, segSites = 100) @@ -65,7 +65,7 @@ SP$pedigree SP$caste ## ------------------------------------------------ -## Method `SimParamBee$changeCaste` +## Method `SimParamBee$changeCaste()` ## ------------------------------------------------ founderGenomes <- quickHaplo(nInd = 2, nChr = 1, segSites = 100) @@ -83,31 +83,18 @@ SP$pedigree SP$caste } \references{ -Bovo et al. (2021) Application of Next Generation Semiconductor-Based - Sequencing for the Identification of Apis mellifera Complementary Sex - Determiner (csd) Alleles from Honey DNA. Insects, 12(10), 868. - \doi{10.3390/insects12100868} - -Lechner et al. (2014) Nucleotide variability at its limit? Insights into - the number and evolutionary dynamics of the sex-determining specificities - of the honey bee Apis mellifera Molecular Biology and Evolution, 31, - 272-287. \doi{10.1093/molbev/mst207} - -Seeley (2019) The Lives of Bees: The Untold Story of the Honey - Bee in the Wild. Princeton: Princeton University Press. - \doi{10.1515/9780691189383} - -Zareba et al. (2017) Uneven distribution of complementary sex determiner - (csd) alleles in Apis mellifera population. Scientific Reports, 7, 2317. - \doi{10.1038/s41598-017-02629-9} +\insertRef{bovo2021Application}{SIMplyBee} +\insertRef{lechner2014Nucleotide}{SIMplyBee} +\insertRef{seeley2019Lives}{SIMplyBee} +\insertRef{zareba2017Uneven}{SIMplyBee} } \section{Super class}{ \code{\link[AlphaSimR:SimParam]{AlphaSimR::SimParam}} -> \code{SimParamBee} } \section{Public fields}{ -\if{html}{\out{
}} -\describe{ -\item{\code{nWorkers}}{numeric or function, a number of workers generated in a + \if{html}{\out{
}} + \describe{ + \item{\code{nWorkers}}{numeric or function, a number of workers generated in a colony - used in \code{\link[SIMplyBee]{createWorkers}}, \code{\link[SIMplyBee]{addWorkers}}, \code{\link[SIMplyBee]{buildUp}}. @@ -129,7 +116,7 @@ Zareba et al. (2017) Uneven distribution of complementary sex determiner You can provide your own functions that satisfy your needs!} -\item{\code{nDrones}}{numeric or function, a number of drones generated in a + \item{\code{nDrones}}{numeric or function, a number of drones generated in a colony - used in \code{\link[SIMplyBee]{createDrones}}, \code{\link[SIMplyBee]{addDrones}}, \code{\link[SIMplyBee]{buildUp}}. @@ -151,7 +138,7 @@ Zareba et al. (2017) Uneven distribution of complementary sex determiner You can provide your own functions that satisfy your needs!} -\item{\code{nVirginQueens}}{numeric or function, a number of virgin queens + \item{\code{nVirginQueens}}{numeric or function, a number of virgin queens generated when a queen dies or other situations - used in \code{\link[SIMplyBee]{createVirginQueens}} and \code{\link[SIMplyBee]{addVirginQueens}}. @@ -173,7 +160,7 @@ Zareba et al. (2017) Uneven distribution of complementary sex determiner You can provide your own functions that satisfy your needs!} -\item{\code{nFathers}}{numeric or function, a number of drones a queen mates + \item{\code{nFathers}}{numeric or function, a number of drones a queen mates with - used in \code{\link[SIMplyBee]{pullDroneGroupsFromDCA}}, \code{\link[SIMplyBee]{cross}}. @@ -195,7 +182,7 @@ Zareba et al. (2017) Uneven distribution of complementary sex determiner You can provide your own functions that satisfy your needs!} -\item{\code{swarmP}}{numeric or a function, the swarm proportion - the proportion + \item{\code{swarmP}}{numeric or a function, the swarm proportion - the proportion of workers that leave with the old queen when the colony swarms - used in \code{\link[SIMplyBee]{swarm}}. @@ -216,7 +203,7 @@ Zareba et al. (2017) Uneven distribution of complementary sex determiner You can provide your own functions that satisfy your needs!} -\item{\code{swarmRadius}}{numeric, radius within which to sample a location of + \item{\code{swarmRadius}}{numeric, radius within which to sample a location of of the swarm - used in \code{\link[SIMplyBee]{swarm}} - see its \code{radius} argument. @@ -225,7 +212,7 @@ Zareba et al. (2017) Uneven distribution of complementary sex determiner You can change this setting to your needs!} -\item{\code{splitP}}{numeric or a function, the split proportion - the + \item{\code{splitP}}{numeric or a function, the split proportion - the proportion of workers removed in a managed split - used in \code{\link[SIMplyBee]{split}}. @@ -246,7 +233,7 @@ Zareba et al. (2017) Uneven distribution of complementary sex determiner You can provide your own functions that satisfy your needs!} -\item{\code{downsizeP}}{numeric or a function, the downsize proportion - the + \item{\code{downsizeP}}{numeric or a function, the downsize proportion - the proportion of workers removed from the colony when downsizing, usually in autumn - used in \code{\link[SIMplyBee]{downsize}}. @@ -267,108 +254,113 @@ 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}}. - This function should work with internals of others functions - - therefore the function MUST be defined like \code{function(colony, arg - = default) someCode }, that is, the first argument MUST be - \code{colony} and any following arguments MUST have a default value. - For flexibility you can add ... argument to pass on any other argument. + The first argument receives a single \code{\link[SIMplyBee]{Colony-class}}, + passed by position; its name is unrestricted. + For example, use \code{function(colony, arg = default) someCode }. + For MultiColony input, \code{calcColonyValue} calls this function once + per colony and combines the results by row. + Additional arguments can have defaults or be supplied through + \code{...} in \code{calcColonyValue}. See \code{\link[SIMplyBee]{mapCasteToColonyValue}} for an example. You can provide your own functions that satisfy your needs!} -} -\if{html}{\out{
}} + } + \if{html}{\out{
}} } \section{Active bindings}{ -\if{html}{\out{
}} -\describe{ -\item{\code{caste}}{character, caste information for every individual ever + \if{html}{\out{
}} + \describe{ + \item{\code{caste}}{character, caste information for every individual ever created} -\item{\code{lastColonyId}}{integer, ID of the last Colony object + \item{\code{lastColonyId}}{integer, ID of the last Colony object created with \code{\link[SIMplyBee]{createColony}}} -\item{\code{csdChr}}{integer, chromosome of the csd locus} + \item{\code{csdChr}}{integer, chromosome of the csd locus} -\item{\code{csdPos}}{numeric, starting position of the csd locus on the + \item{\code{csdPos}}{numeric, starting position of the csd locus on the \code{csdChr} chromosome (relative at the moment, but could be in base pairs in the future)} -\item{\code{nCsdAlleles}}{integer, number of possible csd alleles} + \item{\code{nCsdAlleles}}{integer, number of possible csd alleles} -\item{\code{nCsdSites}}{integer, number of segregating sites representing the + \item{\code{nCsdSites}}{integer, number of segregating sites representing the csd locus} -\item{\code{csdPosStart}}{integer, starting position of the csd locus} + \item{\code{csdPosStart}}{integer, starting position of the csd locus} -\item{\code{csdPosStop}}{integer, ending position of the csd locus} + \item{\code{csdPosStop}}{integer, ending position of the csd locus} -\item{\code{version}}{list, versions of AlphaSimR and SIMplyBee packages used to + \item{\code{version}}{list, versions of AlphaSimR and SIMplyBee packages used to generate this object} -} -\if{html}{\out{
}} + } + \if{html}{\out{
}} } \section{Methods}{ \subsection{Public methods}{ -\itemize{ -\item \href{#method-SimParamBee-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 +374,81 @@ Starts the process of building a new simulation by creating csdPos = 0.865, nCsdAlleles = 128, colonyValueFUN = NULL -)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{founderPop}}{\code{\link[AlphaSimR]{MapPop-class}}, founder population of +)} + \if{html}{\out{
}} + } + \subsection{Arguments}{ + \if{html}{\out{
}} + \describe{ + \item{\code{founderPop}}{\code{\link[AlphaSimR]{MapPop-class}}, founder population of genomes} - -\item{\code{nWorkers}}{see \code{\link[SIMplyBee]{SimParamBee}} field \code{nWorkers}} - -\item{\code{nDrones}}{see \code{\link[SIMplyBee]{SimParamBee}} field \code{nDrones}} - -\item{\code{nVirginQueens}}{see \code{\link[SIMplyBee]{SimParamBee}} field \code{nVirginQueens}} - -\item{\code{nFathers}}{see \code{\link[SIMplyBee]{SimParamBee}} field \code{nFathers}} - -\item{\code{swarmP}}{see \code{\link[SIMplyBee]{SimParamBee}} field \code{swarmP}} - -\item{\code{swarmRadius}}{see \code{\link[SIMplyBee]{SimParamBee}} field \code{swarmRadius}} - -\item{\code{splitP}}{see \code{\link[SIMplyBee]{SimParamBee}} field \code{splitP}} - -\item{\code{downsizeP}}{see \code{\link[SIMplyBee]{SimParamBee}} field \code{downsizeP}} - -\item{\code{csdChr}}{integer, chromosome that will carry the csd locus, by + \item{\code{nWorkers}}{see \code{\link[SIMplyBee]{SimParamBee}} field \code{nWorkers}} + \item{\code{nDrones}}{see \code{\link[SIMplyBee]{SimParamBee}} field \code{nDrones}} + \item{\code{nVirginQueens}}{see \code{\link[SIMplyBee]{SimParamBee}} field \code{nVirginQueens}} + \item{\code{nFathers}}{see \code{\link[SIMplyBee]{SimParamBee}} field \code{nFathers}} + \item{\code{swarmP}}{see \code{\link[SIMplyBee]{SimParamBee}} field \code{swarmP}} + \item{\code{swarmRadius}}{see \code{\link[SIMplyBee]{SimParamBee}} field \code{swarmRadius}} + \item{\code{splitP}}{see \code{\link[SIMplyBee]{SimParamBee}} field \code{splitP}} + \item{\code{downsizeP}}{see \code{\link[SIMplyBee]{SimParamBee}} field \code{downsizeP}} + \item{\code{csdChr}}{integer, chromosome that will carry the csd locus, by default 3, but if there are less chromosomes (for a simplified simulation), the locus is put on the last available chromosome (1 or 2); if \code{NULL} then csd locus is ignored in the simulation} - -\item{\code{csdPos}}{numeric, starting position of the csd locus on the + \item{\code{csdPos}}{numeric, starting position of the csd locus on the \code{csdChr} chromosome (relative at the moment, but could be in base pairs in future)} - -\item{\code{nCsdAlleles}}{integer, number of possible csd alleles (this + \item{\code{nCsdAlleles}}{integer, number of possible csd alleles (this determines how many segregating sites will be needed to represent the csd locus from the underlying bi-allelic SNP; the minimum number of bi-allelic SNP needed is \code{log2(nCsdAlleles)}); if set to \code{0} then \code{csdChr=NULL} is triggered. By default we set \code{nCsdAlleles} to 128, which is at the upper end of the reported number of csd alleles (Lechner et al., 2014; Zareba et al., 2017; Bovo et al., 2021).} - -\item{\code{colonyValueFUN}}{see \code{\link[SIMplyBee]{SimParamBee}} field \code{colonyValueFUN}} -} -\if{html}{\out{
}} -} -\subsection{Examples}{ -\if{html}{\out{
}} -\preformatted{founderGenomes <- quickHaplo(nInd = 10, nChr = 3, segSites = 10) + \item{\code{colonyValueFUN}}{see \code{\link[SIMplyBee]{SimParamBee}} field \code{colonyValueFUN}} + } + \if{html}{\out{
}} + } + \subsection{Examples}{ + \if{html}{\out{
}} + \preformatted{founderGenomes <- quickHaplo(nInd = 10, nChr = 3, segSites = 10) SP <- SimParamBee$new(founderGenomes, nCsdAlleles = 2) -\dontshow{SP$nThreads = 1L} # We need enough segregating sites try(SP <- SimParamBee$new(founderGenomes, nCsdAlleles = 100)) -\dontshow{SP$nThreads = 1L} founderGenomes <- quickHaplo(nInd = 10, nChr = 3, segSites = 100) SP <- SimParamBee$new(founderGenomes, nCsdAlleles = 100) -\dontshow{SP$nThreads = 1L} # We can save the csd locus on chromosome 1 or 2, too, for quick simulations founderGenomes <- quickHaplo(nInd = 10, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, nCsdAlleles = 100) -\dontshow{SP$nThreads = 1L} } -\if{html}{\out{
}} - + \if{html}{\out{
}} + } } -} \if{html}{\out{
}} \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-SimParamBee-addToCaste}{}}} -\subsection{Method \code{addToCaste()}}{ -Store caste information (for internal use only!) -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{SimParamBee$addToCaste(id, caste)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{id}}{character, individuals whose caste will be stored} - -\item{\code{caste}}{character, single "Q" for queens, "W" for workers, "D" for +\subsection{\code{SimParamBee$addToCaste()}}{ + Store caste information (for internal use only!) + \subsection{Usage}{ + \if{html}{\out{
}} + \preformatted{SimParamBee$addToCaste(id, caste)} + \if{html}{\out{
}} + } + \subsection{Arguments}{ + \if{html}{\out{
}} + \describe{ + \item{\code{id}}{character, individuals whose caste will be stored} + \item{\code{caste}}{character, single "Q" for queens, "W" for workers, "D" for drones, "V" for virgin queens, and "F" for fathers} -} -\if{html}{\out{
}} -} -\subsection{Examples}{ -\if{html}{\out{
}} -\preformatted{founderGenomes <- quickHaplo(nInd = 2, nChr = 1, segSites = 100) + } + \if{html}{\out{
}} + } + \subsection{Examples}{ + \if{html}{\out{
}} + \preformatted{founderGenomes <- quickHaplo(nInd = 2, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes) -\dontshow{SP$nThreads = 1L} SP$setTrackPed(isTrackPed = TRUE) basePop <- createVirginQueens(founderGenomes) @@ -488,35 +462,33 @@ colony <- addVirginQueens(colony, nInd = 2) SP$pedigree SP$caste } -\if{html}{\out{
}} - + \if{html}{\out{
}} + } } -} \if{html}{\out{
}} \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-SimParamBee-changeCaste}{}}} -\subsection{Method \code{changeCaste()}}{ -Change caste information (for internal use only!) -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{SimParamBee$changeCaste(id, caste)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{id}}{character, individuals whose caste will be changed} - -\item{\code{caste}}{character, single "Q" for queens, "W" for workers, "D" for +\subsection{\code{SimParamBee$changeCaste()}}{ + Change caste information (for internal use only!) + \subsection{Usage}{ + \if{html}{\out{
}} + \preformatted{SimParamBee$changeCaste(id, caste)} + \if{html}{\out{
}} + } + \subsection{Arguments}{ + \if{html}{\out{
}} + \describe{ + \item{\code{id}}{character, individuals whose caste will be changed} + \item{\code{caste}}{character, single "Q" for queens, "W" for workers, "D" for drones, "V" for virgin queens, and "F" for fathers} -} -\if{html}{\out{
}} -} -\subsection{Examples}{ -\if{html}{\out{
}} -\preformatted{founderGenomes <- quickHaplo(nInd = 2, nChr = 1, segSites = 100) + } + \if{html}{\out{
}} + } + \subsection{Examples}{ + \if{html}{\out{
}} + \preformatted{founderGenomes <- quickHaplo(nInd = 2, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes) -\dontshow{SP$nThreads = 1L} SP$setTrackPed(isTrackPed = TRUE) basePop <- createVirginQueens(founderGenomes) SP$pedigree @@ -528,45 +500,139 @@ colony <- cross(colony, drones = drones) SP$pedigree SP$caste } -\if{html}{\out{
}} + \if{html}{\out{
}} + } +} + +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-SimParamBee-addToBeePed}{}}} +\subsection{\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 333abfc5..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! 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 4b6d03bc..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) @@ -119,4 +114,5 @@ nDrones(apiary) # Queen's counters getQueen(buildUp(colony))@misc + } diff --git a/man/calcBeeGRMIbd.Rd b/man/calcBeeGRMIbd.Rd index 0a9fe6af..106fbb98 100644 --- a/man/calcBeeGRMIbd.Rd +++ b/man/calcBeeGRMIbd.Rd @@ -83,23 +83,9 @@ GRMs$genome[dG, wG] GRMs$indiv[dI, wI] } \references{ -Grossman and Eisen (1989) Inbreeding, coancestry, and covariance between - relatives for X-chromosomal loci. The Journal of Heredity, - \doi{10.1093/oxfordjournals.jhered.a110812} - -Fernando and Grossman (1989) Covariance between relatives for X-chromosomal - loci in a population in disequilibrium. Theoretical and Applied Genetics, - \doi{10.1007/bf00305821} - -Fernando and Grossman (1990) Genetic evaluation with autosomal - and X-chromosomal inheritance. Theoretical and Applied Genetics, - \doi{10.1007/bf00224018} - -Van Arendonk, Tier, and Kinghorn (1994) Use of multiple genetic markers in - prediction of breeding values. Genetics, - \doi{10.1093/genetics/137.1.319} - -Hill and Weir (2011) Variation in actual relationship as a consequence of - Mendelian sampling and linkage. Genetics Research, - \doi{10.1017/s0016672310000480} +\insertRef{fernando1989Covariance}{SIMplyBee} +\insertRef{fernando1990Genetic}{SIMplyBee} +\insertRef{grossman1989Inbreeding}{SIMplyBee} +\insertRef{hill2011Variation}{SIMplyBee} +\insertRef{vanarendonk1994Use}{SIMplyBee} } diff --git a/man/calcBeeGRMIbs.Rd b/man/calcBeeGRMIbs.Rd index f0fe324d..bc619ff9 100644 --- a/man/calcBeeGRMIbs.Rd +++ b/man/calcBeeGRMIbs.Rd @@ -111,7 +111,5 @@ calcBeeGRMIbs(x = rbind(queenGeno, pooledGenoW), sex = c("F","F"), returnComponents = TRUE) } \references{ -Druet and Legarra (2020) Theoretical and empirical comparisons of - expected and realized relationships for the X-chromosome. Genetics - Selection Evolution, 52:50 \doi{10.1186/s12711-020-00570-6} +\insertRef{druet2020Theoretical}{SIMplyBee} } diff --git a/man/calcColonyAndIndCoefficients.Rd b/man/calcColonyAndIndCoefficients.Rd new file mode 100644 index 00000000..cbba8eae --- /dev/null +++ b/man/calcColonyAndIndCoefficients.Rd @@ -0,0 +1,72 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/Functions_L0_auxilary.R +\name{calcColonyAndIndCoefficients} +\alias{calcColonyAndIndCoefficients} +\title{Calculate coefficients to map across individual and colony variances} +\usage{ +calcColonyAndIndCoefficients(nW, nF, nDPQ, workersFUN, workerAllocation) +} +\arguments{ +\item{nW}{Positive integer scalar, number of workers in the colony.} + +\item{nF}{Positive integer scalar, number of distinct mating fathers available +to sire workers. With random allocation, some fathers may sire no workers.} + +\item{nDPQ}{Positive integer scalar, number of distinct drone-producing queens +(DPQs) represented among the mating fathers. Equal numbers of fathers per +DPQ are assumed; nF must be divisible by nDPQ.} + +\item{workersFUN}{Character scalar, "sum" or "mean", specifying aggregation +of the workers' worker-effect trait values.} + +\item{workerAllocation}{Character scalar, "random" for independent uniform +sampling of a father for each worker, or "balanced" for exactly nW/nF +workers per father. Balanced allocation requires nW divisible by nF.} +} +\value{ +A list of three coefficients: + \itemize{ + \item \code{worker}: multiplier converting individual worker-effect additive + genetic variance to variance of the worker-group sum or mean. + \item \code{queenWorker}: multiplier converting within-individual genetic + covariance between queen-effect and worker-effect traits to covariance + between the colony queen's queen-effect contribution and the worker-group + worker-effect contribution. This coefficient does not include the factor + of two used when calculating total colony variance. + \item \code{environment}: multiplier converting individual worker-effect + environmental variance to variance of the worker-group sum or mean, + assuming environmental deviations are independent between workers. + } +} +\description{ +Calculate the coefficients used to map variances in a fixed colony design. +Forward mappings in \code{mapIndToColonyVar} multiply individual components. +Inverse mappings in \code{mapColonyToIndVar} divide aggregate components. +} +\details{ +The model assumes non-inbred colony queens and DPQs, mutually + unrelated across those parents. Distinct fathers from the same DPQ may be + brothers. The queen-effect variance multiplier is one and is not returned. + + Let w be 1 for sums or 1/nW for means. + Ordered distinct-worker pairs are partitioned into + same father giving super-sisters with additive relationship of 3/4, + distinct fathers from the same DPQ giving full-sisters with additive relationship of 1/2, and + different DPQs giving half-sisters with additive relationship of 1/4. + The worker coefficient is w^2 * (nW + relationship-weighted pair counts). + Random allocation uses expected pair counts; + balanced allocation uses exact pair counts. + The queenWorker coefficient is nW*w/2, and + the environment coefficient is nW*w^2. + + Divisibility checks establish that the assumed equal allocation is possible; + totals alone cannot verify actual family composition. + These coefficients describe marginal colony components, + not sample variances across colonies sharing relatives. + Unequal contributions, general ancestry, and random colony sizes + require a more general model. +} +\seealso{ +\code{\link{mapIndToColonyVar}}, \code{\link{mapColonyToIndVar}} +} +\keyword{internal} diff --git a/man/calcColonyValue.Rd b/man/calcColonyValue.Rd index 09736f62..4253fe6e 100644 --- a/man/calcColonyValue.Rd +++ b/man/calcColonyValue.Rd @@ -25,7 +25,10 @@ calcColonyAa(x, FUN = mapCasteToColonyAa, simParamBee = NULL, ...) \item{x}{\code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}}} \item{FUN}{function, that calculates colony value from values of -colony members} +colony members. Its first argument receives a single \code{\link[SIMplyBee]{Colony-class}}, +passed by position, and can have any name (for example, \code{colony} or \code{x}). +For \code{\link[SIMplyBee]{MultiColony-class}} input, +the function is called separately for each colony and the results are combined by row.} \item{simParamBee}{\code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters} @@ -110,6 +113,13 @@ SP$colonyValueFUN <- mapCasteToColonyPheno calcColonyValue(colony) calcColonyValue(apiary) +# Colony value - using a simple custom function +countWorkers <- function(colony) { + matrix(nInd(colony@workers), nrow = 1, + dimnames = list(NULL, "nWorkers")) +} +calcColonyValue(colony, FUN = countWorkers) +calcColonyValue(apiary, FUN = countWorkers) } \seealso{ \code{\link[SIMplyBee]{mapCasteToColonyValue}} as an example of \code{FUN}, diff --git a/man/calcInheritanceCriterion.Rd b/man/calcInheritanceCriterion.Rd index 50a8580c..73a5154b 100644 --- a/man/calcInheritanceCriterion.Rd +++ b/man/calcInheritanceCriterion.Rd @@ -76,9 +76,7 @@ calcInheritanceCriterion(apiary, queenTrait = 1, workersTrait = 2) } \references{ -Du, M., et al. (2021) Short-term effects of controlled mating and selection - on the genetic variance of honeybee populations. Heredity 126, 733–747. - \doi{10.1038/s41437-021-00411-2} +\insertRef{du2021Short}{SIMplyBee} } \seealso{ \code{\link[SIMplyBee]{calcSelectionCriterion}} and diff --git a/man/calcPerformanceCriterion.Rd b/man/calcPerformanceCriterion.Rd index 62db9e8b..4cd6ad5d 100644 --- a/man/calcPerformanceCriterion.Rd +++ b/man/calcPerformanceCriterion.Rd @@ -82,9 +82,7 @@ calcPerformanceCriterion(apiary, queenTrait = 1, } \references{ -Du, M., et al. (2021) Short-term effects of controlled mating and selection - on the genetic variance of honeybee populations. Heredity 126, 733–747. - \doi{10.1038/s41437-021-00411-2} +\insertRef{du2021Short}{SIMplyBee} } \seealso{ \code{\link[SIMplyBee]{calcSelectionCriterion}} and diff --git a/man/calcQueensPHomBrood.Rd b/man/calcQueensPHomBrood.Rd index 76378eef..009157c0 100644 --- a/man/calcQueensPHomBrood.Rd +++ b/man/calcQueensPHomBrood.Rd @@ -19,8 +19,13 @@ nHomBrood(x, simParamBee = NULL) \item{simParamBee}{\code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters} } \value{ -numeric, expected csd homozygosity named by colony id when \code{x} - is \code{\link[SIMplyBee]{MultiColony-class}} +Numeric, proportion of homozygous brood for \code{calcQueensPHomBrood()} and + \code{pHomBrood()}, or counts for \code{nHomBrood()}, named by colony ID + when \code{x} is \code{\link[SIMplyBee]{MultiColony-class}}. An empty + \code{\link[AlphaSimR]{Pop-class}} returns \code{numeric(0)}. Missing + brood proportions and counts are represented by \code{NA_real_}. + All three functions warn and return \code{NA_real_} for a colony without + a queen. } \description{ Level 0 functions that calculate or report the proportion of csd @@ -34,7 +39,7 @@ Level 0 functions that calculate or report the proportion of csd } \section{Functions}{ \itemize{ -\item \code{pHomBrood()}: Expected percentage of csd homozygous brood +\item \code{pHomBrood()}: Expected proportion of csd homozygous brood of a queen / colony \item \code{nHomBrood()}: Realised number of csd homozygous brood diff --git a/man/calcSelectionCriterion.Rd b/man/calcSelectionCriterion.Rd index 1ed27420..906c29e4 100644 --- a/man/calcSelectionCriterion.Rd +++ b/man/calcSelectionCriterion.Rd @@ -90,9 +90,7 @@ calcSelectionCriterion(apiary, queenTrait = 1, } \references{ -Du, M., et al. (2021) Short-term effects of controlled mating and selection - on the genetic variance of honeybee populations. Heredity 126, 733–747. - \doi{10.1038/s41437-021-00411-2} +\insertRef{du2021Short}{SIMplyBee} } \seealso{ \code{\link[SIMplyBee]{calcInheritanceCriterion}} and diff --git a/man/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/cor2cov.Rd b/man/cor2cov.Rd new file mode 100644 index 00000000..6a863f68 --- /dev/null +++ b/man/cor2cov.Rd @@ -0,0 +1,23 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/Functions_L0_auxilary.R +\name{cor2cov} +\alias{cor2cov} +\title{Convert correlation matrix to covariance matrix} +\usage{ +cor2cov(corr, var) +} +\arguments{ +\item{corr}{correlation matrix} + +\item{var}{vector of variances} +} +\value{ +covariance matrix +} +\description{ +Convert correlation matrix to covariance matrix +This function is adopted from AlphaSimR (Gaynor et al., 2021). +} +\references{ +\insertRef{gaynor2021AlphaSimR}{SIMplyBee} +} diff --git a/man/covVar2Cor.Rd b/man/covVar2Cor.Rd new file mode 100644 index 00000000..06990edb --- /dev/null +++ b/man/covVar2Cor.Rd @@ -0,0 +1,24 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/Functions_L0_auxilary.R +\name{covVar2Cor} +\alias{covVar2Cor} +\title{Stable conversion of a covariance and two variances to a correlation} +\usage{ +covVar2Cor(covariance, variance1, variance2) +} +\arguments{ +\item{covariance}{Numeric scalar covariance between the two variables.} + +\item{variance1}{Numeric scalar variance of the first variable.} + +\item{variance2}{Numeric scalar variance of the second variable.} +} +\value{ +Numeric scalar correlation, or \code{NA_real_} + if either variance is zero and the correlation is therefore undefined. +} +\description{ +Divide a covariance by the product of the corresponding standard deviations, +but return \code{NA} when either variance (standard deviation) are zero. +} +\keyword{internal} diff --git a/man/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..13b5e707 100644 --- a/man/createColony.Rd +++ b/man/createColony.Rd @@ -4,12 +4,15 @@ \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). +Numeric IDs are converted to character.} } \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..7bd44f8c 100644 --- a/man/cross.Rd +++ b/man/cross.Rd @@ -54,17 +54,21 @@ to their distance from the virgin colony (that is, in a radius)} \item{radius}{numeric, the radius around the virgin colony in which to sample mating partners, only needed when \code{spatial = TRUE}} -\item{checkCross}{character, throw a warning (when \code{checkCross = "warning"}),} +\item{checkCross}{character, throw a warning (when \code{checkCross = "warning"}). +This will also remove the unmated queens and return only the mated ones.} \item{simParamBee}{\code{\link[SIMplyBee]{SimParamBee}}, global simulation parameters} \item{...}{other arguments for \code{nDrones}, when \code{nDrones} is a function} } \value{ -\code{\link[AlphaSimR]{Pop-class}} with mated queen(s). The misc slot of the - queens contains additional information about the number of workers, drones, - and homozygous brood produced, and the expected percentage of csd homozygous - brood. +A \code{\link[AlphaSimR]{Pop-class}}, + \code{\link[SIMplyBee]{Colony-class}}, or + \code{\link[SIMplyBee]{MultiColony-class}} with mated queen(s), matching + the input type. The queens' \code{misc} slots contain worker, drone, and + homozygous brood counts, initially zero, and the expected proportion of + csd homozygous brood (\code{pHomBrood}). When csd is inactive, + \code{pHomBrood} is \code{NA_real_}. } \description{ Level 1 function that crosses (mates) a virgin queen to a group @@ -95,7 +99,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..dcc178f9 --- /dev/null +++ b/man/crossVirginQueen.Rd @@ -0,0 +1,24 @@ +% 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} +} +\value{ +The supplied queen \code{\link[AlphaSimR]{Pop-class}} with fathers + stored in \code{misc}, worker, drone, and homozygous brood counts set to + zero, and \code{pHomBrood} set to the expected proportion of csd homozygous + brood, or \code{NA_real_} when csd is inactive. +} +\description{ +Internal function to cross a virgin queen +} diff --git a/man/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 3386a215..4e888692 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/getId.Rd b/man/getId.Rd index bdd5915e..73c8f301 100644 --- a/man/getId.Rd +++ b/man/getId.Rd @@ -2,19 +2,29 @@ % Please edit documentation in R/Functions_L0_auxilary.R \name{getId} \alias{getId} -\title{Get the colony ID} +\title{Get individual or colony IDs} \usage{ getId(x) } \arguments{ -\item{x}{\code{\link[AlphaSimR]{Pop-class}}, \code{\link[SIMplyBee]{Colony-class}}, or \code{\link[SIMplyBee]{MultiColony-class}}} +\item{x}{\code{NULL}, \code{\link[AlphaSimR]{Pop-class}}, +\code{\link[SIMplyBee]{Colony-class}}, or \code{\link[SIMplyBee]{MultiColony-class}}} } \value{ -character, \code{NA} when queen not present +character, \code{NA_character_} for NULL entries or a Colony without + an assigned ID, and \code{character(0)} for an empty Pop or MultiColony. } \description{ -Level 0 function that returns the colony ID. This is by - definition the ID of the queen. +Level 0 function that returns individual IDs for a Pop or + colony IDs for a Colony or MultiColony. Colony IDs are independent of + queen IDs and are retained when a queen is removed or replaced. +} +\details{ +A NULL entry represents a missing colony or individual, + so it contributes one missing ID and preserves alignment with the MultiColony's entries. + An empty Pop or MultiColony contains no individuals or entries to identify. + An empty colony created with \code{createColony()} still has an assigned ID; + an uninitialised \code{new("Colony")} has no assigned ID. } \examples{ founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) 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/mapIndToColonyVar.Rd b/man/mapIndToColonyVar.Rd new file mode 100644 index 00000000..fa7dedab --- /dev/null +++ b/man/mapIndToColonyVar.Rd @@ -0,0 +1,228 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/Functions_L0_auxilary.R +\name{mapIndToColonyVar} +\alias{mapIndToColonyVar} +\alias{mapColonyToIndVar} +\title{Map variance components between individuals and colonies} +\usage{ +mapIndToColonyVar( + varAQueen, + varAWorker, + corAQueenWorker, + varEQueen, + varEWorker, + corEQueenWorker, + nW, + nF, + nDPQ, + workersFUN = "sum", + workerAllocation = "random" +) + +mapColonyToIndVar( + varAQueen, + varAWorkerGroup, + corAQueenWorkerGroup, + varEQueen, + varEWorkerGroup, + corEQueenWorkerGroup, + nW, + nF, + nDPQ, + workersFUN = "sum", + workerAllocation = "random" +) +} +\arguments{ +\item{varAQueen}{Numeric scalar, additive genetic variance of +the queen-effect trait among individual diploid bees in a base population.} + +\item{varAWorker}{Numeric scalar, additive genetic variance of +the worker-effect trait among individual diploid bees in a base population.} + +\item{corAQueenWorker}{Numeric scalar, additive genetic correlation between +the queen-effect trait and the worker-effect trait +among individual diploid bees in a base population. +This is the within-individual cross-trait correlation among individuals.} + +\item{varEQueen}{Numeric scalar, environmental variance of +the queen-effect trait among individual bees in a base population.} + +\item{varEWorker}{Numeric scalar, environmental variance of +the worker-effect trait among individual bees in a base population.} + +\item{corEQueenWorker}{Numeric scalar, environmental correlation between +the queen-effect trait and the worker-effect trait +among individual diploid bees in a base population. +This is the within-individual cross-trait correlation among individuals.} + +\item{nW}{numeric, number of workers in the colony} + +\item{nF}{numeric, number of fathers of the workers} + +\item{nDPQ}{numeric, number of drone producing queens (DPQs) +represented among the mating fathers} + +\item{workersFUN}{character, either "sum" or "mean", +indicating whether the workers' contributions are summed or averaged +when forming the aggregated worker-effect contribution to colony value.} + +\item{workerAllocation}{character, either "random" (default) or "balanced".} + +\item{varAWorkerGroup}{Numeric scalar, additive genetic variance of +the aggregated worker-effect trait among colonies in a base population.} + +\item{corAQueenWorkerGroup}{Numeric scalar, additive genetic correlation between +the queen's queen-effect trait and +the aggregated workers' worker-effect trait +among colonies in a base population. +This is the cross-caste and cross-trait correlation among colonies.} + +\item{varEWorkerGroup}{Numeric scalar, environmental variance of +the aggregated worker-effect trait among colonies in a base population.} + +\item{corEQueenWorkerGroup}{Numeric scalar, environmental correlation between +the queen's queen-effect trait and +the aggregated workers' worker-effect trait +among colonies in a base population. +This is the cross-caste and cross-trait correlation among colonies.} +} +\value{ +Both functions return a flat list with the same named components. + + \strong{Components already described as inputs} + All components listed below are returned by both functions; the function + labels indicate which inputs they correspond to. + \itemize{ + \item Both functions: \code{varAQueen}, \code{varEQueen}, \code{nW}, + \code{nF}, \code{nDPQ}, \code{workersFUN}, and \code{workerAllocation}. + \item \code{mapIndToColonyVar}: \code{varAWorker}, \code{varEWorker}, + \code{corAQueenWorker}, and \code{corEQueenWorker}. + \item \code{mapColonyToIndVar}: \code{varAWorkerGroup}, + \code{varEWorkerGroup}, \code{corAQueenWorkerGroup}, and + \code{corEQueenWorkerGroup}. The returned group correlations are + \code{NA} if either corresponding variance is zero, even if zero + was supplied as the correlation. + } + + \strong{Additional components} + \itemize{ + \item \code{covAQueenWorker}: additive genetic covariance between + the queen-effect trait and the worker-effect trait + among individual diploid bees in a base population. + \item \code{covAQueenWorkerGroup}: additive genetic covariance between + the queen's queen-effect trait and + the aggregated workers' worker-effect trait + among colonies in a base population. + \item \code{covEQueenWorker}: environmental covariance between + the queen-effect trait and the worker-effect trait + among individual diploid bees in a base population. + \item \code{covEQueenWorkerGroup}: environmental covariance between + the queen's queen-effect trait and + the aggregated workers' worker-effect trait + among colonies in a base population. + Zero under the assumption of independent environmental deviations between bees. + \item \code{varAColony} and \code{varEColony}: additive genetic + and environmental variance of colony values. + Each is the sum of the queen and worker-group variances plus twice their covariance. + \item \code{h2Queen}: \code{varAQueen / (varAQueen + varEQueen)}, + heritability of the queen-effect trait among individual bees. + \item \code{h2Worker}: \code{varAWorker / (varAWorker + varEWorker)}, + heritability of the worker-effect trait among individual bees. + \item \code{h2WorkerGroup}: \code{varAWorkerGroup / (varAWorkerGroup + varEWorkerGroup)}, + heritability of the aggregated worker-effect trait among colonies. + \item \code{h2Colony}: \code{varAColony / (varAColony + varEColony)}, + heritability of colony values, including genetic covariance between + queen's queen trait and worker-group's worker trait in \code{varAColony}. + All four heritabilities are \code{NA} when their denominator is zero. + } + + Covariances are not multiplied by two. + Calculated correlations are \code{NA} if either corresponding variance is zero. + In \code{mapColonyToIndVar}, \code{covEQueenWorker} and \code{corEQueenWorker} + are both returned as \code{NA}, + because colony components do not identify + within-individual environmental covariance or correlation. +} +\description{ +Map individual queen-effect and worker-effect variance components + to colony variance components, or recover individual variance components from + separate queen and worker-group colony variance components. +} +\details{ +These mappings describe marginal variances under an additive model + with non-inbred, mutually unrelated colony queens and drone-producing + queens (DPQs), distinct fathers, and equal numbers of fathers per DPQ. + They do not predict sample variance across colonies sharing relatives. + Each diploid bee has genetic values for both the queen-effect and + worker-effect traits. A colony value combines the queen's value for the + queen-effect trait with the aggregated workers' values for the + worker-effect trait. Thus Queen and Worker identify trait roles as well as + their expressing castes; WorkerGroup always denotes an aggregate. + + With random worker allocation, + each worker independently samples a father uniformly. + With balanced allocation, + each father has exactly \code{nW/nF} workers, + which requires \code{nW} to be divisible by \code{nF}. + Both require \code{nF} divisible by \code{nDPQ}. + The distinct-worker relationship is 3/4 for a shared father, + 1/2 for distinct fathers from the same DPQ, and 1/4 otherwise. + Queen-offspring relationship is 1/2. + Environmental deviations are independent between bees. + Calculated correlations are \code{NA} when either variance is zero; + individual correlations supplied to the forward mapping are retained. + + The inverse divides worker-group variances and queen-worker-group + covariance by the corresponding design coefficients. + Both directions must use the same colony design and aggregation. + A nonzero \code{corEQueenWorkerGroup} raises an error, + as do colony components implying an individual genetic correlation outside [-1, 1]. + If either genetic component variance is zero, + the inverse accepts \code{NA} or zero for \code{corAQueenWorkerGroup}. + Similarly, \code{NA} or zero can be supplied for \code{corEQueenWorkerGroup} + when either environmental component variance is zero. + The zero-correlation restriction between bees does not apply to \code{corEQueenWorker}, + which describes environmental association between traits within the same bee. + + Both results are flat lists. To pass a result to either mapping function, + select the entries named in \code{names(formals(fun))} before using + \code{do.call(fun, ...)}; the full result contains extra components. + Before mapping an inverse result forward, supply an explicit + \code{corEQueenWorker}, which the inverse cannot identify. +} +\section{Functions}{ +\itemize{ +\item \code{mapColonyToIndVar()}: Recover individual variance components from +separate queen and worker-group colony components. + +}} +\examples{ +nW <- 100 +nF <- 15 +nDPQ <- 5 + +# Mapping individual vars to colony with worker group mean +(colonyVars <- mapIndToColonyVar( + varAQueen = 2, varAWorker = 0.01, corAQueenWorker = -0.5, + varEQueen = 3, varEWorker = 0.02, corEQueenWorker = 0.3, + nW = nW, nF = nF, nDPQ = nDPQ, workersFUN = "mean")) +# ... and inverse +(indVars <- do.call(mapColonyToIndVar, + colonyVars[names(formals(mapColonyToIndVar))])) + +# Mapping colony vars with worker group sum to individual vars +(indVars <- mapColonyToIndVar( + varAQueen = 2, varAWorkerGroup = 0.01, corAQueenWorkerGroup = -0.5, + varEQueen = 3, varEWorkerGroup = 0.02, corEQueenWorkerGroup = 0.0, + nW = nW, nF = nF, nDPQ = nDPQ, workersFUN = "sum")) +# ... and back to colony components, assuming zero within-bee +# environmental correlation (not identified by the inverse mapping). +indArgs <- indVars[names(formals(mapIndToColonyVar))] +indArgs$corEQueenWorker <- 0 +(colonyVars <- do.call(mapIndToColonyVar, indArgs)) +} +\references{ +\insertRef{brascamp2014Methods}{SIMplyBee} +\insertRef{brascamp2019Note}{SIMplyBee} +} diff --git a/man/mapLoci.Rd b/man/mapLoci.Rd index 5ccf535c..d08cb198 100644 --- a/man/mapLoci.Rd +++ b/man/mapLoci.Rd @@ -16,5 +16,8 @@ A list with number of loci per chromosome and genetic positions of the markers } \description{ Finds loci on a genetic map and return a list of positions. -This function is adopted from AlphaSimR (Gaynor et al., 2021) +This function is adopted from AlphaSimR (Gaynor et al., 2021). +} +\references{ +\insertRef{gaynor2021AlphaSimR}{SIMplyBee} } diff --git a/man/nCaste.Rd b/man/nCaste.Rd index 84c973ee..44141a63 100644 --- a/man/nCaste.Rd +++ b/man/nCaste.Rd @@ -23,7 +23,9 @@ nDrones(x, simParamBee = NULL) nVirginQueens(x, simParamBee = NULL) } \arguments{ -\item{x}{\code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}}} +\item{x}{\code{\link[SIMplyBee]{Colony-class}} or \code{\link[SIMplyBee]{MultiColony-class}}. +For \code{nFathers()}, also a \code{\link[AlphaSimR]{Pop-class}} +containing queens.} \item{caste}{character, "queen", "fathers", "workers", "drones", "virginQueens", or "all"} @@ -35,7 +37,8 @@ when \code{x} is \code{\link[SIMplyBee]{Colony-class}} return is integer for \code{caste != "all"} or list for \code{caste == "all"} with nodes named by caste; when \code{x} is \code{\link[SIMplyBee]{MultiColony-class}} return is named integer for \code{caste != "all"} or named list of lists for - \code{caste == "all"} + \code{caste == "all"}. For \code{nFathers()} with a queen population, + returns a numeric vector with one father count per queen. } \description{ Returns the number of individuals of a caste in a colony diff --git a/man/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/rcircle.Rd b/man/rcircle.Rd index 7aec0c6e..3c2885f5 100644 --- a/man/rcircle.Rd +++ b/man/rcircle.Rd @@ -34,9 +34,6 @@ lim <- range(x) plot(x, xlim = lim, ylim = lim, main = "Gaussian") } \references{ -nubDotDev (2021) The BEST Way to Find a Random Point in a Circle -https://youtu.be/4y_nmpv-9lI - -Wolfram MathWorld (2023) Disk Point Picking -https://mathworld.wolfram.com/DiskPointPicking.html +\insertRef{nubdotdev2021Best}{SIMplyBee} +\insertRef{wolfram2023Disk}{SIMplyBee} } diff --git a/man/reQueen.Rd b/man/reQueen.Rd index e90abb52..dab59c0a 100644 --- a/man/reQueen.Rd +++ b/man/reQueen.Rd @@ -26,7 +26,7 @@ to ensure the provided queen prevails (see details)} \description{ Level 2 function that re-queens a Colony or MultiColony object by adding a mated or a virgin queen, removing the - previous queen, and changing the colony id to the new mated queen. + previous queen, while preserving the colony ID. } \details{ If the provided queen is mated, then she is saved in the queen slot @@ -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/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/simulateHoneyBeeGenomes.Rd b/man/simulateHoneyBeeGenomes.Rd index 3e5c70d1..03017da2 100644 --- a/man/simulateHoneyBeeGenomes.Rd +++ b/man/simulateHoneyBeeGenomes.Rd @@ -60,23 +60,10 @@ automatically detected} Level 0 function that returns simulated honeybee genomes } \references{ -Wallberg, A., Bunikis, I., Pettersson, O.V. et al. - A hybrid de novo genome assembly of the honeybee, Apis mellifera, - with chromosome-length scaffolds. 2019, BMC Genomics 20:275. - \doi{10.1186/s12864-019-5642-0} - -Beye M, Gattermeier I, Hasselmann M, et al. Exceptionally high levels - of recombination across the honey bee genome. - 2006, Genome Res 16(11):1339-1344. \doi{10.1101/gr.5680406} - -Wallberg, A., Han, F., Wellhagen, G. et al. A worldwide survey of - genome sequence variation provides insight into the evolutionary - history of the honeybee Apis mellifera. - 2014, Nat Genet 46:1081–1088. \doi{10.1038/ng.3077} - -Yang S, Wang L, Huang J, Zhang X, Yuan Y, Chen JQ, Hurst LD, Tian D. - Parent-progeny sequencing indicates higher mutation rates in heterozygotes. - 2015, Nature 523(7561):463-7. \doi{10.1038/nature14649}. +\insertRef{beye2006Exceptionally}{SIMplyBee} +\insertRef{yang2015Parent}{SIMplyBee} +\insertRef{wallberg2014Worldwide}{SIMplyBee} +\insertRef{wallberg2019Hybrid}{SIMplyBee} } \seealso{ Due to the computational time and resources required to run this function, diff --git a/man/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..768312e9 100644 --- a/man/splitPFun.Rd +++ b/man/splitPFun.Rd @@ -6,12 +6,18 @@ \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, + simParamBee = NULL +) } \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} @@ -26,6 +32,9 @@ value)} \item{scale}{numeric, scaling of numbers in \code{splitPColonyStrength} to avoid to narrow range when colonies have a large number of bees (in that case change \code{nWorkersFull} too!)} + +\item{simParamBee}{\code{\link[SIMplyBee]{SimParamBee}}, simulation parameters +for \code{splitPColonyStrength}} } \value{ numeric, split proportion diff --git a/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/man/validateVarsAndCors.Rd b/man/validateVarsAndCors.Rd new file mode 100644 index 00000000..b12e84a9 --- /dev/null +++ b/man/validateVarsAndCors.Rd @@ -0,0 +1,23 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/Functions_L0_auxilary.R +\name{validateVarsAndCors} +\alias{validateVarsAndCors} +\title{Validate variance and correlation inputs} +\usage{ +validateVarsAndCors(variances, correlations) +} +\arguments{ +\item{variances}{Named list of numeric, finite, nonnegative variance scalars.} + +\item{correlations}{Named list of numeric, finite correlation scalars in +the interval [-1, 1].} +} +\value{ +Invisibly returns \code{NULL} when all checked inputs are valid; + otherwise stops with an error. +} +\description{ +Check named collections of scalar variance and correlation parameters used +by the individual/colony variance mappings. Invalid inputs raise an error. +} +\keyword{internal} diff --git a/tests/testthat/test-L0_auxiliary_functions.R b/tests/testthat/test-L0_auxiliary_functions.R index b9883b0a..79d738d4 100644 --- a/tests/testthat/test-L0_auxiliary_functions.R +++ b/tests/testthat/test-L0_auxiliary_functions.R @@ -1,23 +1,30 @@ # ---- 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) expect_equal(nColonies(createMultiColony(n = 10, simParamBee = SP)), 10) }) - # ---- nCaste ---- + test_that("nCaste", { founderGenomes <- quickHaplo(nInd = 5, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) + SP$nThreads <- 1L basePop <- createVirginQueens(founderGenomes, simParamBee = SP) drones <- createDrones(x = basePop[1], nInd = 45, simParamBee = SP) - droneGroups <- pullDroneGroupsFromDCA(drones, n = 3, nDrones = 10, simParamBee = SP) + droneGroups <- pullDroneGroupsFromDCA( + drones, + n = 3, + nDrones = 10, + simParamBee = SP + ) colony <- createColony(x = basePop[2], simParamBee = SP) colony <- cross(colony, drones = droneGroups[[1]], simParamBee = SP) colony <- buildUp(colony, nDrones = 10, nWorkers = 20, simParamBee = SP) @@ -26,12 +33,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 ---- @@ -39,10 +46,16 @@ test_that("nCaste", { test_that("nQueens", { founderGenomes <- quickHaplo(nInd = 10, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) - SP$nThreads = 1L + SP$nThreads <- 1L + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) drones <- createDrones(basePop[1], n = 1000, simParamBee = SP) - fatherGroups <- pullDroneGroupsFromDCA(drones, n = 10, nDrones = 10, simParamBee = SP) + fatherGroups <- pullDroneGroupsFromDCA( + drones, + n = 10, + nDrones = 10, + simParamBee = SP + ) colony1 <- createColony(x = basePop[1], simParamBee = SP) colony1 <- cross(colony1, drones = fatherGroups[[1]], simParamBee = SP) @@ -56,20 +69,26 @@ test_that("nQueens", { }) # ---- nDrones ---- + test_that("nDrones", { founderGenomes <- quickHaplo(nInd = 10, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) - SP$nThreads = 1L + SP$nThreads <- 1L + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) drones <- createDrones(basePop[1], n = 1000, simParamBee = SP) - fatherGroups <- pullDroneGroupsFromDCA(drones, n = 10, nDrones = 10, simParamBee = SP) + fatherGroups <- pullDroneGroupsFromDCA( + drones, + n = 10, + nDrones = 10, + simParamBee = SP + ) colony1 <- createColony(x = basePop[1], simParamBee = SP) colony1 <- cross(colony1, drones = fatherGroups[[1]], simParamBee = SP) colony2 <- createColony(x = basePop[2], simParamBee = SP) colony2 <- cross(colony2, drones = fatherGroups[[2]], simParamBee = SP) - expect_equal(nDrones(colony1, simParamBee = SP), 0) colony1 <- addDrones(colony1, nInd = 5, simParamBee = SP) colony2 <- addDrones(colony2, nInd = 10, simParamBee = SP) @@ -79,22 +98,116 @@ test_that("nDrones", { expect_error(nDrones(basePop, simParamBee = SP)) }) +# ---- nFathers ---- + +test_that("nFathers accepts queens and colonies and reports all supported classes", { + set.seed(123) + founderGenomes <- quickHaplo(nInd = 3, nChr = 1, segSites = 10) + SP <- SimParamBee$new(founderGenomes, csdChr = NULL) + SP$nThreads <- 1L + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) + drones <- createDrones(basePop[1], nInd = 4, simParamBee = SP) + colony <- createColony(basePop[2], simParamBee = SP) + colony <- cross(colony, drones = drones, simParamBee = SP) + + expect_equal(nFathers(colony@queen, simParamBee = SP), 4) + expect_equal(nFathers(colony, simParamBee = SP), 4) + expect_equal(unname(nFathers(c(colony), simParamBee = SP)), 4) + expect_error( + nFathers(basePop, simParamBee = SP), + "Individuals in x must be queens!", + fixed = TRUE + ) + for (invalid in list(NULL, 123, "queen", list())) { + expect_error( + nFathers(invalid, simParamBee = SP), + "Argument x must be a Pop, Colony, or MultiColony class object!", + fixed = TRUE + ) + } + expect_error( + nCaste(colony@queen, caste = "fathers", simParamBee = SP), + "Argument colony must be a Colony or MultiColony class object!", + fixed = TRUE + ) +}) + # ---- isGenoHeterozygous ---- -####----- isGenoHeterozygous ---- #### test_that("isGenoHeterozygous", { geno <- matrix( data = c( - 0, 1, 2, - 0, 0, 0, - 2, 2, 2 + 0, + 1, + 2, + 0, + 0, + 0, + 2, + 2, + 2 ), - nrow = 3, byrow = TRUE + nrow = 3, + byrow = TRUE ) - expect_true(SIMplyBee:::isGenoHeterozygous(geno[1, , drop = FALSE])) - expect_false(SIMplyBee:::isGenoHeterozygous(geno[2, , drop = FALSE])) - expect_false(SIMplyBee:::isGenoHeterozygous(geno[3, , drop = FALSE])) - expect_equal(SIMplyBee:::isGenoHeterozygous(geno), c(TRUE, FALSE, FALSE)) + expect_true(isGenoHeterozygous(geno[1, , drop = FALSE])) + expect_false(isGenoHeterozygous(geno[2, , drop = FALSE])) + expect_false(isGenoHeterozygous(geno[3, , drop = FALSE])) + expect_equal(isGenoHeterozygous(geno), c(TRUE, FALSE, FALSE)) +}) + +test_that("isHeterozygous detects differences between chromosome copies", { + # Two rows per bee, one column per locus; entries are ordinary 0/1 alleles + haplotypes <- matrix(0, nrow = 6, ncol = 16) + haplotypes[2, 9] <- 1 # Bee 1: its two copies differ at locus 9 + haplotypes[3:4, ] <- 1 # Bee 2: both copies are identical (all 1s) + haplotypes[6, 8] <- 1 # Bee 3: its two copies differ at locus 8 + founders <- newMapPop( + genMap = list(seq(0, 1, length.out = 16)), + haplotypes = list(haplotypes) + ) + + # Loci 8 and 9 straddle an internal storage boundary + # Four threads for three bees also tests the automatic thread limit + for (nThreads in c(1L, 4L)) { + observed <- isHeterozygous( + geno = founders@geno, + lociPerChr = 4L, + lociLoc = c(1L, 8L, 9L, 16L), + nThreads = nThreads + ) + expect_equal(as.vector(observed), c(1, 0, 1)) + } +}) + +test_that("isHeterozygous ignores chromosomes and loci that were not selected", { + # Two bees, each with two chromosome copies (rows 1:2 and 3:4) + chr1 <- chr2 <- chr3 <- matrix(0, nrow = 4, ncol = 16) + chr1[2, 1] <- 1 # Bee 1 differs at chromosome 1, locus 1 + chr2[c(2, 4), ] <- 1 # Both bees differ throughout chromosome 2 + chr3[4, 9] <- 1 # Bee 2 differs at chromosome 3, locus 9 + founders <- newMapPop( + genMap = rep(list(seq(0, 1, length.out = 16)), 3), + haplotypes = list(chr1, chr2, chr3) + ) + + # Select chromosome 1 locus 8 and chromosome 3 locus 9: only bee 2 differs + observed <- isHeterozygous( + geno = founders@geno, + lociPerChr = c(1L, 0L, 1L), + lociLoc = c(8L, 9L), + nThreads = 1L + ) + expect_equal(as.vector(observed), c(0, 1)) + + # Select only chromosome 1 locus 1: only bee 1 differs + observed <- isHeterozygous( + geno = founders@geno, + lociPerChr = c(1L, 0L, 0L), + lociLoc = 1L, + nThreads = 1L + ) + expect_equal(as.vector(observed), c(1, 0)) }) # ---- isCaste ---- @@ -102,11 +215,17 @@ test_that("isGenoHeterozygous", { test_that("isCaste", { founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) - SP$nThreads = 1L + SP$nThreads <- 1L + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) drones <- createDrones(x = basePop[1], nInd = 1000, simParamBee = SP) - fatherGroups <- pullDroneGroupsFromDCA(drones, n = 10, nDrones = 10, simParamBee = SP) + fatherGroups <- pullDroneGroupsFromDCA( + drones, + n = 10, + nDrones = 10, + simParamBee = SP + ) # Create a Colony class colony <- createColony(x = basePop[2], simParamBee = SP) @@ -115,15 +234,38 @@ test_that("isCaste", { # get the queen that is a caste "queen" and ask if it is a caste "queen" # and drones and drones - expect_true(isCaste(getQueen(colony, simParamBee = SP), caste = "queen", simParamBee = SP)) - expect_true(all(isCaste(getDrones(colony, simParamBee = SP), caste = "drones", simParamBee = SP))) - expect_true(all(isCaste(getDrones(colony, simParamBee = SP), caste = "drones", simParamBee = SP))) + expect_true(isCaste( + getQueen(colony, simParamBee = SP), + caste = "queen", + simParamBee = SP + )) + expect_true(all(isCaste( + getDrones(colony, simParamBee = SP), + caste = "drones", + simParamBee = SP + ))) + expect_true(all(isCaste( + getDrones(colony, simParamBee = SP), + caste = "drones", + simParamBee = SP + ))) # get the queen that is a caste "queen" and test if it is a caste "workers", #test on virgin queen that is not present in a colony - expect_false(isCaste(getQueen(colony, simParamBee = SP), caste = "workers", simParamBee = SP)) + expect_false(isCaste( + getQueen(colony, simParamBee = SP), + caste = "workers", + simParamBee = SP + )) #test on virgin queen that is not present in a colony - expect_null(isCaste(getVirginQueens(colony, simParamBee = SP), caste = "virginQueens", simParamBee = SP)) - malePop <- c(getDrones(colony, simParamBee = SP), getFathers(colony, simParamBee = SP)) + expect_null(isCaste( + getVirginQueens(colony, simParamBee = SP), + caste = "virginQueens", + simParamBee = SP + )) + malePop <- c( + getDrones(colony, simParamBee = SP), + getFathers(colony, simParamBee = SP) + ) expect_true(any(isCaste(malePop, caste = "drones", simParamBee = SP))) expect_true(any(isCaste(malePop, caste = "fathers", simParamBee = SP))) expect_false(all(isCaste(malePop, caste = "drones", simParamBee = SP))) @@ -133,96 +275,375 @@ test_that("isCaste", { # ---- calcQueensPHomBrood ---- test_that("calcQueensPHomBrood", { - founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) - SP <- SimParamBee$new(founderGenomes) - SP$nThreads = 1L - basePop <- createVirginQueens(founderGenomes, simParamBee = SP) + set.seed(1) + founderGenomes <- quickHaplo(nInd = 3, nChr = 1, segSites = 100) + SP <- SimParamBee$new(founderGenomes, csdChr = 1, nCsdAlleles = 4) + SP$nThreads <- 1L + + # Queen 1 is AB; queens 2 and 3 are CD, so their fathers cannot match. + AB <- rbind(c(0, 0), c(0, 1)) + CD <- rbind(c(1, 0), c(1, 1)) + basePop <- createVirginQueens( + founderGenomes, + csdAlleles = list(AB, CD, CD), + simParamBee = SP + ) + expect_error( + calcQueensPHomBrood(basePop, simParamBee = SP), + "calcQueensPHomBrood can only be used with queens!", + fixed = TRUE + ) + expect_error( + calcQueensPHomBrood(basePop[3], simParamBee = SP), + "calcQueensPHomBrood can only be used with queens!", + fixed = TRUE + ) + expect_length(calcQueensPHomBrood(basePop[integer(0)], simParamBee = SP), 0L) + expect_identical( + calcQueensPHomBrood(basePop[integer(0)], simParamBee = SP), + numeric(0) + ) - drones <- createDrones(x = basePop[1], nInd = 1000, simParamBee = SP) - fatherGroups <- pullDroneGroupsFromDCA(drones, n = 10, nDrones = 10, simParamBee = SP) + drones <- createDrones(x = basePop[1], nInd = 100, simParamBee = SP) + fatherGroups <- pullDroneGroupsFromDCA( + drones, + n = 3, + nDrones = 10, + simParamBee = SP + ) - # Create a Colony class object - colony <- createColony(x = basePop[2], simParamBee = SP) + colony <- createColony(x = basePop[1], simParamBee = SP) colony <- cross(colony, drones = fatherGroups[[1]], simParamBee = SP) colony <- buildUp(x = colony, nWorkers = 120, nDrones = 20, simParamBee = SP) colony <- addVirginQueens(x = colony, nInd = 1, simParamBee = SP) - expect_error(calcQueensPHomBrood(colony@drones, simParamBee = SP)) - expect_error(calcQueensPHomBrood(colony@workers, simParamBee = SP)) + expect_error( + calcQueensPHomBrood(colony@workers, simParamBee = SP), + "calcQueensPHomBrood can only be used with queens!" + ) + # Empty populations return an empty numeric vector, regardless of caste. + expect_identical( + calcQueensPHomBrood(colony@virginQueens[integer(0)], simParamBee = SP), + numeric(0) + ) + expect_error( + calcQueensPHomBrood(colony@drones, simParamBee = SP), + "calcQueensPHomBrood can only be used with queens!" + ) expect_true(is.numeric(calcQueensPHomBrood(colony@queen, simParamBee = SP))) + expect_true(calcQueensPHomBrood(colony@queen, simParamBee = SP) > 0) + expect_true(calcQueensPHomBrood(colony@queen, simParamBee = SP) == 0.5) colony@queen <- NULL - expect_error(calcQueensPHomBrood(colony@queen, simParamBee = SP)) + expect_error( + calcQueensPHomBrood(colony@queen, simParamBee = SP), + "Argument x must be a Pop, Colony, or MultiColony class object!" + ) + expect_warning( + missing <- calcQueensPHomBrood(colony, simParamBee = SP), + "Colony has no queen - returning NA!", + fixed = TRUE + ) + expect_identical(missing, NA_real_) + apiary <- createMultiColony(simParamBee = SP) - colony@workers <- NULL - colony@drones <- NULL - colony@virginQueens <- NULL - expect_error(calcQueensPHomBrood(colony, simParamBee = SP)) - expect_equal((length(calcQueensPHomBrood(apiary, simParamBee = SP))), 0) + expect_equal(length(calcQueensPHomBrood(apiary, simParamBee = SP)), 0) + + apiary <- createMultiColony(x = basePop[2:3], simParamBee = SP) + apiary <- cross(apiary, drones = fatherGroups[2:3], simParamBee = SP) + tmp <- calcQueensPHomBrood(apiary, simParamBee = SP) + expect_equal(length(tmp), 2) + expect_equal(tmp, c(`2` = 0, `3` = 0)) +}) + +test_that("calcQueensPHomBrood reflects controlled father proportions", { + set.seed(1) + founderGenomes <- quickHaplo(nInd = 4, nChr = 1, segSites = 100) + SP <- SimParamBee$new(founderGenomes, csdChr = 1, nCsdAlleles = 4) + SP$nThreads <- 1L + + # Four distinct csd alleles, each encoded by two SNPs. + AB <- rbind(c(0, 0), c(0, 1)) + CD <- rbind(c(1, 0), c(1, 1)) + queens <- createVirginQueens( + founderGenomes, + csdAlleles = list(AB, AB, AB, CD), + simParamBee = SP + ) + + # Both recipient queens are AB. Every drone from queen 3 matches; + # none from queen 4 matches, regardless of random segregation. + matching <- createDrones(queens[3], nInd = 9, simParamBee = SP) + nonmatching <- createDrones(queens[4], nInd = 11, simParamBee = SP) + fatherGroups <- list( + c(matching[1:7], nonmatching[1:3]), + c(matching[8:9], nonmatching[4:11]) + ) + apiary <- createMultiColony(queens[1:2], simParamBee = SP) + apiary <- cross(apiary, drones = fatherGroups, simParamBee = SP) + + # Matching fathers contribute homozygous brood with probability 1/2. + expected <- setNames(c(0.35, 0.10), getId(apiary)) + expect_equal(calcQueensPHomBrood(apiary, simParamBee = SP), expected) + for (i in seq_len(2)) { + expect_equal( + calcQueensPHomBrood(apiary[[i]], simParamBee = SP), + unname(expected[i]) + ) + expect_equal( + calcQueensPHomBrood(apiary[[i]]@queen, simParamBee = SP), + unname(expected[i]) + ) + } }) # ---- pHomBrood ---- test_that("pHomBrood", { - 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) + set.seed(1) + founderGenomes <- quickHaplo(nInd = 3, nChr = 1, segSites = 100) + SP <- SimParamBee$new(founderGenomes, csdChr = 1, nCsdAlleles = 4) + SP$nThreads <- 1L + + # Queen 1 is AB; queens 2 and 3 are CD, so their fathers cannot match. + AB <- rbind(c(0, 0), c(0, 1)) + CD <- rbind(c(1, 0), c(1, 1)) + basePop <- createVirginQueens( + founderGenomes, + csdAlleles = list(AB, CD, CD), + simParamBee = SP + ) + expect_error( + pHomBrood(basePop, simParamBee = SP), + "Individuals in x must be queens!", + fixed = TRUE + ) + expect_error( + pHomBrood(basePop[3], simParamBee = SP), + "Individuals in x must be queens!", + fixed = TRUE + ) + expect_length(pHomBrood(basePop[integer(0)], simParamBee = SP), 0L) + expect_identical(pHomBrood(basePop[integer(0)], simParamBee = SP), numeric(0)) + + drones <- createDrones(x = basePop[1], nInd = 100, simParamBee = SP) + fatherGroups <- pullDroneGroupsFromDCA( + drones, + n = 3, + nDrones = 10, + simParamBee = SP + ) - # Create a Colony class object - colony <- createColony(x = basePop[2], simParamBee = SP) + colony <- createColony(x = basePop[1], simParamBee = SP) colony <- cross(colony, drones = fatherGroups[[1]], simParamBee = SP) colony <- buildUp(x = colony, nWorkers = 120, nDrones = 20, simParamBee = SP) colony <- addVirginQueens(x = colony, nInd = 1, simParamBee = SP) - expect_error(pHomBrood(colony@workers, simParamBee = SP)) - expect_error(pHomBrood(colony@virginQueens, simParamBee = SP)) - expect_error(pHomBrood(colony@drones, simParamBee = SP)) + expect_error( + pHomBrood(colony@workers, simParamBee = SP), + "Individuals in x must be queens!" + ) + # Explicitly empty populations return numeric(0), regardless of caste. + expect_identical( + pHomBrood(colony@virginQueens[integer(0)], simParamBee = SP), + numeric(0) + ) + expect_error( + pHomBrood(colony@drones, simParamBee = SP), + "Individuals in x must be queens!" + ) expect_true(is.numeric(pHomBrood(colony@queen, simParamBee = SP))) + expect_true(pHomBrood(colony@queen, simParamBee = SP) > 0) + expect_true(pHomBrood(colony@queen, simParamBee = SP) == 0.5) colony@queen <- NULL - expect_error(pHomBrood(colony@queen, simParamBee = SP)) + expect_error( + pHomBrood(colony@queen, simParamBee = SP), + "Argument x must be a Pop, Colony, or MultiColony class object!" + ) + expect_warning( + missing <- pHomBrood(colony, simParamBee = SP), + "Colony has no queen - returning NA!", + fixed = TRUE + ) + expect_identical(missing, NA_real_) + apiary <- createMultiColony(simParamBee = SP) - colony@workers <- NULL - colony@drones <- NULL - colony@virginQueens <- NULL - expect_error(pHomBrood(colony, simParamBee = SP)) expect_equal(length(pHomBrood(apiary, simParamBee = SP)), 0) + + apiary <- createMultiColony(x = basePop[2:3], simParamBee = SP) + apiary <- cross(apiary, drones = fatherGroups[2:3], simParamBee = SP) + tmp <- pHomBrood(apiary, simParamBee = SP) + expect_equal(length(tmp), 2) + expect_equal(tmp, c(`2` = 0, `3` = 0)) }) -#---- nHomBrood ----- +test_that("pHomBrood reflects controlled father proportions", { + set.seed(1) + founderGenomes <- quickHaplo(nInd = 4, nChr = 1, segSites = 100) + SP <- SimParamBee$new(founderGenomes, csdChr = 1, nCsdAlleles = 4) + SP$nThreads <- 1L + + # Four distinct csd alleles, each encoded by two SNPs. + AB <- rbind(c(0, 0), c(0, 1)) + CD <- rbind(c(1, 0), c(1, 1)) + queens <- createVirginQueens( + founderGenomes, + csdAlleles = list(AB, AB, AB, CD), + simParamBee = SP + ) -test_that("nHomBrood", { - founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) - SP <- SimParamBee$new(founderGenomes) - SP$nThreads = 1L - basePop <- createVirginQueens(founderGenomes, simParamBee = SP) + # Both recipient queens are AB. Every drone from queen 3 matches; + # none from queen 4 matches, regardless of random segregation. + matching <- createDrones(queens[3], nInd = 9, simParamBee = SP) + nonmatching <- createDrones(queens[4], nInd = 11, simParamBee = SP) + fatherGroups <- list( + c(matching[1:7], nonmatching[1:3]), + c(matching[8:9], nonmatching[4:11]) + ) + apiary <- createMultiColony(queens[1:2], simParamBee = SP) + apiary <- cross(apiary, drones = fatherGroups, simParamBee = SP) + + # Matching fathers contribute homozygous brood with probability 1/2. + expected <- setNames(c(0.35, 0.10), getId(apiary)) + expect_equal(pHomBrood(apiary, simParamBee = SP), expected) + for (i in seq_len(2)) { + expect_equal(pHomBrood(apiary[[i]], simParamBee = SP), unname(expected[i])) + expect_equal( + pHomBrood(apiary[[i]]@queen, simParamBee = SP), + unname(expected[i]) + ) + } +}) - drones <- createDrones(x = basePop[1], nInd = 1000, simParamBee = SP) - fatherGroups <- pullDroneGroupsFromDCA(drones, n = 10, nDrones = 10, simParamBee = SP) +# ---- nHomBrood ---- - # Create a Colony class object - colony <- createColony(x = basePop[2], simParamBee = SP) +test_that("nHomBrood", { + set.seed(1) + founderGenomes <- quickHaplo(nInd = 3, nChr = 1, segSites = 100) + SP <- SimParamBee$new(founderGenomes, csdChr = 1, nCsdAlleles = 4) + SP$nThreads <- 1L + + # Queen 1 is AB; queens 2 and 3 are CD, so their fathers cannot match. + AB <- rbind(c(0, 0), c(0, 1)) + CD <- rbind(c(1, 0), c(1, 1)) + basePop <- createVirginQueens( + founderGenomes, + csdAlleles = list(AB, CD, CD), + simParamBee = SP + ) + expect_error( + nHomBrood(basePop, simParamBee = SP), + "Individuals in x must be queens!", + fixed = TRUE + ) + expect_error( + nHomBrood(basePop[3], simParamBee = SP), + "Individuals in x must be queens!", + fixed = TRUE + ) + expect_length(nHomBrood(basePop[integer(0)], simParamBee = SP), 0L) + expect_identical(nHomBrood(basePop[integer(0)], simParamBee = SP), numeric(0)) + + drones <- createDrones(x = basePop[1], nInd = 100, simParamBee = SP) + fatherGroups <- pullDroneGroupsFromDCA( + drones, + n = 3, + nDrones = 10, + simParamBee = SP + ) + + colony <- createColony(x = basePop[1], simParamBee = SP) colony <- cross(colony, drones = fatherGroups[[1]], simParamBee = SP) colony <- buildUp(x = colony, nWorkers = 120, nDrones = 20, simParamBee = SP) colony <- addVirginQueens(x = colony, nInd = 1, simParamBee = SP) - expect_error(nHomBrood(colony@workers, simParamBee = SP)) - expect_error(nHomBrood(colony@virginQueens, simParamBee = SP)) - expect_error(nHomBrood(colony@drones, simParamBee = SP)) + expect_error( + nHomBrood(colony@workers, simParamBee = SP), + "Individuals in x must be queens!" + ) + # Empty populations return an empty numeric vector, regardless of caste. + expect_identical( + nHomBrood(colony@virginQueens[integer(0)], simParamBee = SP), + numeric(0) + ) + expect_error( + nHomBrood(colony@drones, simParamBee = SP), + "Individuals in x must be queens!" + ) expect_true(is.numeric(nHomBrood(colony@queen, simParamBee = SP))) + # Of the 120 worker offspring requested, csd homozygotes did not survive. + expect_equal( + nHomBrood(colony@queen, simParamBee = SP), + 120 - nWorkers(colony, simParamBee = SP) + ) colony@queen <- NULL - expect_error(nHomBrood(colony@queen, simParamBee = SP)) + expect_error( + nHomBrood(colony@queen, simParamBee = SP), + "Argument x must be a Pop, Colony, or MultiColony class object!" + ) + expect_warning( + missing <- nHomBrood(colony, simParamBee = SP), + "Colony has no queen - returning NA!", + fixed = TRUE + ) + expect_identical(missing, NA_real_) + apiary <- createMultiColony(simParamBee = SP) - colony@workers <- NULL - colony@drones <- NULL - colony@virginQueens <- NULL - expect_error(nHomBrood(colony, simParamBee = SP)) expect_equal(length(nHomBrood(apiary, simParamBee = SP)), 0) + + apiary <- createMultiColony(x = basePop[2:3], simParamBee = SP) + apiary <- cross(apiary, drones = fatherGroups[2:3], simParamBee = SP) + tmp <- nHomBrood(apiary, simParamBee = SP) + expect_equal(length(tmp), 2) + expect_equal(tmp, c(`2` = 0, `3` = 0)) +}) + +test_that("nHomBrood tracks realised brood with controlled fathers", { + set.seed(1) + founderGenomes <- quickHaplo(nInd = 4, nChr = 1, segSites = 100) + SP <- SimParamBee$new(founderGenomes, csdChr = 1, nCsdAlleles = 4) + SP$nThreads <- 1L + + # Four distinct csd alleles, each encoded by two SNPs. + AB <- rbind(c(0, 0), c(0, 1)) + CD <- rbind(c(1, 0), c(1, 1)) + queens <- createVirginQueens( + founderGenomes, + csdAlleles = list(AB, AB, AB, CD), + simParamBee = SP + ) + + # Both recipient queens are AB. Every drone from queen 3 matches; + # none from queen 4 matches, regardless of random segregation. + matching <- createDrones(queens[3], nInd = 9, simParamBee = SP) + nonmatching <- createDrones(queens[4], nInd = 11, simParamBee = SP) + fatherGroups <- list( + c(matching[1:7], nonmatching[1:3]), + c(matching[8:9], nonmatching[4:11]) + ) + apiary <- createMultiColony(queens[1:2], simParamBee = SP) + apiary <- cross(apiary, drones = fatherGroups, simParamBee = SP) + + expected <- setNames(c(0, 0), getId(apiary)) + expect_equal(nHomBrood(apiary, simParamBee = SP), expected) + for (i in seq_len(2)) { + expect_equal(nHomBrood(apiary[[i]], simParamBee = SP), 0) + expect_equal(nHomBrood(apiary[[i]]@queen, simParamBee = SP), 0) + } + + apiary <- buildUp(apiary, nWorkers = 40, nDrones = 0, simParamBee = SP) + # Realised counts vary, but every missing worker is csd homozygous. + expected <- 40 - nWorkers(apiary, simParamBee = SP) + expect_equal(nHomBrood(apiary, simParamBee = SP), expected) + for (i in seq_len(2)) { + expect_equal(nHomBrood(apiary[[i]], simParamBee = SP), unname(expected[i])) + expect_equal( + nHomBrood(apiary[[i]]@queen, simParamBee = SP), + unname(expected[i]) + ) + } }) # ---- isQueenPresent ---- @@ -230,18 +651,24 @@ test_that("nHomBrood", { test_that("isQueenPresent", { founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) - SP$nThreads = 1L + SP$nThreads <- 1L + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) drones <- createDrones(x = basePop[1], nInd = 1000, simParamBee = SP) - fatherGroups <- pullDroneGroupsFromDCA(drones, n = 10, nDrones = 10, simParamBee = SP) + fatherGroups <- pullDroneGroupsFromDCA( + drones, + n = 10, + nDrones = 10, + simParamBee = SP + ) # Create a Colony class object colony <- createColony(x = basePop[2], simParamBee = SP) colony <- cross(colony, drones = fatherGroups[[1]], simParamBee = SP) colony <- addVirginQueens(x = colony, nInd = 1, simParamBee = SP) apiary <- createMultiColony(n = 1, simParamBee = SP) - vec <- c(1,2,3,4) + vec <- c(1, 2, 3, 4) apiary2 <- createMultiColony(simParamBee = SP) colony2 <- createColony(simParamBee = SP) @@ -258,11 +685,17 @@ test_that("isQueenPresent", { test_that("isVirginQueensPresent", { founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) - SP$nThreads = 1L + SP$nThreads <- 1L + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) drones <- createDrones(x = basePop[1], nInd = 1000, simParamBee = SP) - fatherGroups <- pullDroneGroupsFromDCA(drones, n = 10, nDrones = 10, simParamBee = SP) + fatherGroups <- pullDroneGroupsFromDCA( + drones, + n = 10, + nDrones = 10, + simParamBee = SP + ) # Create a Colony class object colony <- createColony(x = basePop[2], simParamBee = SP) @@ -270,11 +703,10 @@ test_that("isVirginQueensPresent", { colony <- buildUp(x = colony, nWorkers = 120, nDrones = 20, simParamBee = SP) colony <- addVirginQueens(x = colony, nInd = 1, simParamBee = SP) apiary <- createMultiColony(n = 1, simParamBee = SP) - vec <- c(1,2,3,4) + vec <- c(1, 2, 3, 4) apiary2 <- createMultiColony(simParamBee = SP) colony2 <- createColony(simParamBee = SP) - expect_true(isVirginQueensPresent(colony, simParamBee = SP)) expect_false(isVirginQueensPresent(apiary2, simParamBee = SP)) expect_error(isVirginQueenPresent(vec, simParamBee = SP)) @@ -288,11 +720,17 @@ test_that("isVirginQueensPresent", { test_that("isProductive", { founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) - SP$nThreads = 1L + SP$nThreads <- 1L + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) drones <- createDrones(x = basePop[1], nInd = 1000, simParamBee = SP) - fatherGroups <- pullDroneGroupsFromDCA(drones, n = 10, nDrones = 10, simParamBee = SP) + fatherGroups <- pullDroneGroupsFromDCA( + drones, + n = 10, + nDrones = 10, + simParamBee = SP + ) # Create a Colony and a MultiColony class colony <- createColony(x = basePop[2], simParamBee = SP) @@ -317,22 +755,27 @@ test_that("isProductive", { apiary <- createMultiColony(simParamBee = SP) expect_true(is.list(isProductive(apiary))) }) + # ---- reduceDroneHaplo ---- test_that("reduceDroneHaplo", { founderGenomes <- quickHaplo(nInd = 3, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) - SP$nThreads = 1L + SP$nThreads <- 1L + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) drones <- createDrones(x = basePop[1], nInd = 2, simParamBee = SP) virginQueens <- c(basePop[2:3]) - vec <- c(1,2,"a") + vec <- c(1, 2, "a") tmp <- getSegSiteHaplo(virginQueens, simParamBee = SP) df <- as.data.frame(tmp) tmpD <- getSegSiteHaplo(drones, simParamBee = SP) mix <- rbind(tmp, tmpD) - expect_equal(nrow(reduceDroneHaplo(haplo = mix, pop = c(drones, virginQueens))), 6) + expect_equal( + nrow(reduceDroneHaplo(haplo = mix, pop = c(drones, virginQueens))), + 6 + ) expect_equal(nrow(reduceDroneHaplo(haplo = tmpD, pop = drones)), 2) expect_error(reduceDroneHaplo(haplo = vec, pop = drones)) expect_error(reduceDroneHaplo(haplo = df, pop = drones)) @@ -346,19 +789,19 @@ test_that("reduceDroneHaplo", { test_that("reduceDroneGeno", { founderGenomes <- quickHaplo(nInd = 10, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) - SP$nThreads = 1L + SP$nThreads <- 1L + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) drones <- createDrones(x = basePop[1], nInd = 2, simParamBee = SP) virginQueens <- c(basePop[2:3]) - vec <- c(1,2,"a") + vec <- c(1, 2, "a") tmp <- getSegSiteGeno(virginQueens, simParamBee = SP) df <- as.data.frame(tmp) tmpD <- getSegSiteGeno(drones, simParamBee = SP) - expect_equal(nrow(reduceDroneGeno(geno = tmpD, pop = drones)), 2) expect_error(reduceDroneGeno(geno = vec, pop = drones)) - expect_error(reduceDroneGeno(geno = df, pop = drones)) + expect_error(reduceDroneGeno(geno = df, pop = drones)) expect_true(is.matrix(reduceDroneGeno(geno = tmpD, pop = drones))) tmp <- reduceDroneGeno(geno = tmpD, pop = drones) expect_true(all(rle(as.vector(tmp))$values %in% 0:1)) @@ -369,28 +812,47 @@ test_that("reduceDroneGeno", { test_that("getCsdAlleles", { founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes) - SP$nThreads = 1L + SP$nThreads <- 1L + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) + baseAlleles <- getCsdAlleles(basePop, simParamBee = SP) + expect_equal(nrow(baseAlleles), 8 * 2) drones <- createDrones(x = basePop[1], nInd = 1000, simParamBee = SP) - fatherGroups <- pullDroneGroupsFromDCA(drones, n = 10, nDrones = 10, 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 - colony <- createColony(x = basePop[2],simParamBee = SP) + colony <- createColony(x = basePop[2], simParamBee = SP) colony <- cross(colony, drones = fatherGroups[[1]], simParamBee = SP) colony <- buildUp(x = colony, simParamBee = SP) expect_true(is.list(getCsdAlleles(colony, simParamBee = SP))) - expect_true(is.matrix(getCsdAlleles(getQueen(colony, simParamBee = SP), simParamBee = SP))) + expect_true(is.matrix(getCsdAlleles( + getQueen(colony, simParamBee = SP), + simParamBee = SP + ))) # set CSD to NULL rm(SP) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) - SP$nThreads = 1L + SP$nThreads <- 1L + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) drones <- createDrones(x = basePop[1], nInd = 1000, simParamBee = SP) - fatherGroups <- pullDroneGroupsFromDCA(drones, n = 10, nDrones = 10, simParamBee = SP) + fatherGroups <- pullDroneGroupsFromDCA( + drones, + n = 10, + nDrones = 10, + simParamBee = SP + ) # Create a Colony class colony <- createColony(x = basePop[2], simParamBee = SP) @@ -402,24 +864,55 @@ 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) - fatherGroups <- pullDroneGroupsFromDCA(drones, n = 10, nDrones = 10, simParamBee = SP) + fatherGroups <- pullDroneGroupsFromDCA( + drones, + n = 10, + nDrones = 10, + simParamBee = SP + ) # Create a Colony class colony <- createColony(x = basePop[2], simParamBee = SP) colony <- cross(colony, drones = fatherGroups[[1]], simParamBee = SP) colony <- buildUp(x = colony, simParamBee = SP) - expect_true(is.matrix(getCsdAlleles(colony, collapse = TRUE, simParamBee = SP))) - expect_equal(nrow(getCsdAlleles(colony, collapse = TRUE, simParamBee = SP)), - sum(nQueens(colony, simParamBee = SP)*2, nDrones(colony, simParamBee = SP), - nWorkers(colony, simParamBee = SP)*2, nFathers(colony, simParamBee = SP), - nVirginQueens(colony, simParamBee = SP)*2)) - expect_equal(nrow(getCsdAlleles(colony, collapse = TRUE, unique = TRUE, simParamBee = SP)), - nrow(unique(getCsdAlleles(colony, collapse = TRUE, simParamBee = SP)))) - expect_true(nrow(getCsdAlleles(colony, collapse = TRUE, unique = TRUE, simParamBee = SP)) <= SP$nCsdAlleles) - + expect_true(is.matrix(getCsdAlleles( + colony, + collapse = TRUE, + simParamBee = SP + ))) + expect_equal( + nrow(getCsdAlleles(colony, collapse = TRUE, simParamBee = SP)), + sum( + nQueens(colony, simParamBee = SP) * 2, + nDrones(colony, simParamBee = SP), + nWorkers(colony, simParamBee = SP) * 2, + nFathers(colony, simParamBee = SP), + nVirginQueens(colony, simParamBee = SP) * 2 + ) + ) + expect_equal( + nrow(getCsdAlleles( + colony, + collapse = TRUE, + unique = TRUE, + simParamBee = SP + )), + nrow(unique(getCsdAlleles(colony, collapse = TRUE, simParamBee = SP))) + ) + expect_true( + nrow(getCsdAlleles( + colony, + collapse = TRUE, + unique = TRUE, + simParamBee = SP + )) <= + SP$nCsdAlleles + ) }) # ---- getCsdGeno ---- @@ -427,11 +920,17 @@ test_that("getCsdAlleles", { test_that("getCsdGeno", { founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, nCsdAlleles = 5) - SP$nThreads = 1L + SP$nThreads <- 1L + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) drones <- createDrones(x = basePop[1], nInd = 1000, simParamBee = SP) - fatherGroups <- pullDroneGroupsFromDCA(drones, n = 10, nDrones = 10, simParamBee = SP) + fatherGroups <- pullDroneGroupsFromDCA( + drones, + n = 10, + nDrones = 10, + simParamBee = SP + ) # Create a Colony class colony <- createColony(x = basePop[2], simParamBee = SP) @@ -439,18 +938,29 @@ test_that("getCsdGeno", { colony <- buildUp(x = colony, simParamBee = SP) expect_true(is.list(getCsdGeno(colony, simParamBee = SP))) - expect_true(is.matrix(getCsdGeno(getQueen(colony, simParamBee = SP), simParamBee = SP))) - expect_true(nCsdAlleles(colony, collapse = TRUE, simParamBee = SP) <= SP$nCsdAlleles) + expect_true(is.matrix(getCsdGeno( + getQueen(colony, simParamBee = SP), + simParamBee = SP + ))) + expect_true( + nCsdAlleles(colony, collapse = TRUE, simParamBee = SP) <= SP$nCsdAlleles + ) geno <- getCsdGeno(colony, simParamBee = SP) expect_equal(nrow(geno$fathers), 10) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) - SP$nThreads = 1L + SP$nThreads <- 1L + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) drones <- createDrones(x = basePop[1], nInd = 1000, simParamBee = SP) - fatherGroups <- pullDroneGroupsFromDCA(drones, n = 10, nDrones = 10, simParamBee = SP) + fatherGroups <- pullDroneGroupsFromDCA( + drones, + n = 10, + nDrones = 10, + simParamBee = SP + ) # Create a Colony class colony <- createColony(x = basePop[2], simParamBee = SP) @@ -458,45 +968,44 @@ test_that("getCsdGeno", { colony <- buildUp(x = colony, simParamBee = SP) expect_error(getCsdGeno(colony, simParamBee = SP)) - }) # ---- 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 + SP$nThreads <- 1L + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) + expect_true(all(isCsdHeterozygous(basePop, simParamBee = SP))) drones <- createDrones(x = basePop[1], nInd = 1000, simParamBee = SP) - fatherGroups <- pullDroneGroupsFromDCA(drones, n = 10, nDrones = 10, 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) + SP$nThreads <- 1L - expect_error(isCsdHeterozygous(colony@queen, simParamBee = SP)) + basePop <- createVirginQueens(founderGenomes[10:15], simParamBee = SP) + expect_error(isCsdHeterozygous(basePop, simParamBee = SP)) }) # ---- nCsdAlleles ---- @@ -504,11 +1013,17 @@ test_that("isCsdHeterozygous", { test_that("nCsdAlleles", { founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes) - SP$nThreads = 1L + SP$nThreads <- 1L + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) drones <- createDrones(x = basePop[1], nInd = 1000, simParamBee = SP) - fatherGroups <- pullDroneGroupsFromDCA(drones, n = 10, nDrones = 10, simParamBee = SP) + fatherGroups <- pullDroneGroupsFromDCA( + drones, + n = 10, + nDrones = 10, + simParamBee = SP + ) # Create a Colony class colony <- createColony(x = basePop[2], simParamBee = SP) @@ -522,11 +1037,17 @@ test_that("nCsdAlleles", { # set CSD to NULL SP <- SimParamBee$new(founderGenomes, csdChr = NULL) - SP$nThreads = 1L + SP$nThreads <- 1L + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) drones <- createDrones(x = basePop[1], nInd = 1000, simParamBee = SP) - fatherGroups <- pullDroneGroupsFromDCA(drones, n = 10, nDrones = 10, simParamBee = SP) + fatherGroups <- pullDroneGroupsFromDCA( + drones, + n = 10, + nDrones = 10, + simParamBee = SP + ) # Create a Colony class colony <- createColony(x = basePop[2], simParamBee = SP) @@ -538,17 +1059,30 @@ 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) - fatherGroups <- pullDroneGroupsFromDCA(drones, n = 10, nDrones = 10, simParamBee = SP) + fatherGroups <- pullDroneGroupsFromDCA( + drones, + n = 10, + nDrones = 10, + simParamBee = SP + ) # Create a Colony class colony <- createColony(x = basePop[2], simParamBee = SP) colony <- cross(colony, drones = fatherGroups[[1]], simParamBee = SP) colony <- buildUp(x = colony, simParamBee = SP) - expect_true(is.numeric(nCsdAlleles(colony, collapse = TRUE, simParamBee = SP))) - expect_true(nCsdAlleles(colony, collapse = TRUE, simParamBee = SP) <= nCsdAlleles) + expect_true(is.numeric(nCsdAlleles( + colony, + collapse = TRUE, + simParamBee = SP + ))) + expect_true( + nCsdAlleles(colony, collapse = TRUE, simParamBee = SP) <= nCsdAlleles + ) }) # ---- calcBeeGRMIbs ---- @@ -556,7 +1090,7 @@ test_that("nCsdAlleles", { test_that("calcBeeGRMIbs", { founderGenomes <- quickHaplo(nInd = 3, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) - SP$nThreads = 1L + SP$nThreads <- 1L SP$setTrackRec(TRUE) SP$setTrackPed(isTrackPed = TRUE) SP$addTraitA(10) @@ -564,7 +1098,12 @@ test_that("calcBeeGRMIbs", { basePop <- createVirginQueens(founderGenomes, simParamBee = SP) drones <- createDrones(x = basePop[1], nInd = 1000, simParamBee = SP) - fatherGroups <- pullDroneGroupsFromDCA(drones, n = 10, nDrones = 10, simParamBee = SP) + fatherGroups <- pullDroneGroupsFromDCA( + drones, + n = 10, + nDrones = 10, + simParamBee = SP + ) apiary <- createMultiColony(basePop[2:3], n = 2, simParamBee = SP) apiary <- cross(x = apiary, drones = fatherGroups[c(2, 3)], simParamBee = SP) apiary <- buildUp(x = apiary, simParamBee = SP) @@ -584,8 +1123,13 @@ test_that("calcBeeGRMIbs", { sex <- getCasteSex(x = apiary[[1]], simParamBee = SP) sex <- c( - sex$queen, sex$fathers, sex$workers, sex$drones, sex$virginQueens, - "F", "M" + sex$queen, + sex$fathers, + sex$workers, + sex$drones, + sex$virginQueens, + "F", + "M" ) GRM <- calcBeeGRMIbs(x = geno, sex = sex) @@ -593,7 +1137,7 @@ test_that("calcBeeGRMIbs", { # added a vector since x must be a matrix - vec <- c(1,2,"a") + vec <- c(1, 2, "a") expect_error(calcBeeGRMIbs(x = vec, sex = sex)) @@ -601,8 +1145,13 @@ test_that("calcBeeGRMIbs", { sex <- getCasteSex(x = apiary[[1]], simParamBee = SP) sex <- c( - sex$queen, sex$drones, sex$workers, sex$drones, sex$virginQueens, - "A", "B" + sex$queen, + sex$drones, + sex$workers, + sex$drones, + sex$virginQueens, + "A", + "B" ) expect_error(calcBeeGRMIbs(x = GRM, sex = sex)) @@ -610,26 +1159,37 @@ test_that("calcBeeGRMIbs", { # ---- editCsdLocus ---- - test_that("editCsdLocus", { founderGenomes <- quickHaplo(nInd = 100, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = 1, nCsdAlleles = 8) - SP$nThreads = 1L - basePop <- createVirginQueens(founderGenomes, editCsd = FALSE, simParamBee = SP) + SP$nThreads <- 1L + + basePop <- createVirginQueens( + founderGenomes, + editCsd = FALSE, + simParamBee = SP + ) nrow(getCsdAlleles(basePop, unique = TRUE, simParamBee = SP)) expect_false(all(isCsdHeterozygous(basePop, simParamBee = SP))) - basePopEdited <- SIMplyBee:::editCsdLocus(basePop, simParamBee = SP) + basePopEdited <- editCsdLocus(basePop, simParamBee = SP) expect_true(isPop(basePopEdited)) expect_true(all(isCsdHeterozygous(basePopEdited, simParamBee = SP))) }) # ---- emptyNULL ---- + test_that("emptyNULL", { founderGenomes <- quickHaplo(nInd = 5, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = 1, nCsdAlleles = 8) - basePop <- createVirginQueens(founderGenomes, editCsd = FALSE, simParamBee = SP) + SP$nThreads <- 1L + + basePop <- createVirginQueens( + founderGenomes, + editCsd = FALSE, + simParamBee = SP + ) expect_true(isEmpty(new(Class = "Pop"))) expect_true(isEmpty(basePop[0])) @@ -641,7 +1201,10 @@ test_that("emptyNULL", { expect_false(isEmpty(nonEmptyColony)) emptyApiary <- createMultiColony(n = 3, simParamBee = SP) - emptyApiary1 <- c(createColony(simParamBee = SP), createColony(simParamBee = SP)) + emptyApiary1 <- c( + createColony(simParamBee = SP), + createColony(simParamBee = SP) + ) nonEmptyApiary <- createMultiColony(basePop[2:5], n = 4, simParamBee = SP) expect_true(all(isEmpty(emptyApiary))) @@ -664,11 +1227,17 @@ test_that("emptyNULL", { test_that("isDronesPresent", { founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) - SP$nThreads = 1L + SP$nThreads <- 1L + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) drones <- createDrones(x = basePop[1], nInd = 1000, simParamBee = SP) - fatherGroups <- pullDroneGroupsFromDCA(drones, n = 10, nDrones = nFathersPoisson, simParamBee = SP) + fatherGroups <- pullDroneGroupsFromDCA( + drones, + n = 10, + nDrones = nFathersPoisson, + simParamBee = SP + ) # Create a Colony class object colony <- createColony(x = basePop[2], simParamBee = SP) @@ -676,7 +1245,7 @@ test_that("isDronesPresent", { colony <- buildUp(x = colony, nWorkers = 120, nDrones = 20, simParamBee = SP) colony <- addVirginQueens(x = colony, nInd = 1, simParamBee = SP) apiary <- createMultiColony(n = 1, simParamBee = SP) - vec <- c(1,2,3,4) + vec <- c(1, 2, 3, 4) apiary2 <- createMultiColony(simParamBee = SP) expect_true(isDronesPresent(colony, simParamBee = SP)) @@ -689,11 +1258,17 @@ test_that("isDronesPresent", { test_that("isFathersPresent", { founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) - SP$nThreads = 1L + SP$nThreads <- 1L + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) drones <- createDrones(x = basePop[1], nInd = 1000, simParamBee = SP) - fatherGroups <- pullDroneGroupsFromDCA(drones, n = 10, nDrones = 10, simParamBee = SP) + fatherGroups <- pullDroneGroupsFromDCA( + drones, + n = 10, + nDrones = 10, + simParamBee = SP + ) # Create a Colony class object colony <- createColony(x = basePop[2], simParamBee = SP) @@ -701,7 +1276,7 @@ test_that("isFathersPresent", { colony <- buildUp(x = colony, nWorkers = 120, nDrones = 20, simParamBee = SP) colony <- addVirginQueens(x = colony, nInd = 1, simParamBee = SP) apiary <- createMultiColony(n = 1, simParamBee = SP) - vec <- c(1,2,3,4) + vec <- c(1, 2, 3, 4) apiary2 <- createMultiColony(simParamBee = SP) expect_true(isFathersPresent(colony, simParamBee = SP)) @@ -717,11 +1292,17 @@ test_that("isFathersPresent", { test_that("isWorkersPresent", { founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) - SP$nThreads = 1L + SP$nThreads <- 1L + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) drones <- createDrones(x = basePop[1], nInd = 1000, simParamBee = SP) - fatherGroups <- pullDroneGroupsFromDCA(drones, n = 10, nDrones = 10, simParamBee = SP) + fatherGroups <- pullDroneGroupsFromDCA( + drones, + n = 10, + nDrones = 10, + simParamBee = SP + ) # Create a Colony class object colony <- createColony(x = basePop[2], simParamBee = SP) @@ -729,7 +1310,7 @@ test_that("isWorkersPresent", { colony <- buildUp(x = colony, nWorkers = 120, nDrones = 20, simParamBee = SP) colony <- addVirginQueens(x = colony, nInd = 1, simParamBee = SP) apiary <- createMultiColony(n = 1, simParamBee = SP) - vec <- c(1,2,3,4) + vec <- c(1, 2, 3, 4) apiary2 <- createMultiColony(simParamBee = SP) expect_true(isWorkersPresent(colony, simParamBee = SP)) @@ -739,232 +1320,373 @@ test_that("isWorkersPresent", { }) # ---- isGenoHeterozygous ---- + test_that("isGenoHeterozygous", { - founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) - SP <- SimParamBee$new(founderGenomes) - SP$nThreads = 1L - basePop <- createVirginQueens(founderGenomes, simParamBee = SP) + set.seed(123) + founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) + SP <- SimParamBee$new(founderGenomes) + SP$nThreads <- 1L - drones <- createDrones(x = basePop[1], nInd = 1000, simParamBee = SP) - droneGroups <- pullDroneGroupsFromDCA(drones, n = 10, nDrones = nFathersPoisson, simParamBee = SP) + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) - # Create a Colony and a MultiColony class - colony <- createColony(x = basePop[2], simParamBee = SP) - colony <- cross(colony, drones = droneGroups[[1]], simParamBee = SP) - colony <- buildUp(x = colony, nWorkers = 6, nDrones = 3, simParamBee = SP) - colony <- addVirginQueens(x = colony, nInd = 4, simParamBee = SP) + # Test on a Pop + tmp <- getCsdGeno(basePop, simParamBee = SP) + expect_true(all(isGenoHeterozygous(tmp))) - apiary <- createMultiColony(basePop[3:4], n = 2, simParamBee = SP) - apiary <- cross(apiary, drones = droneGroups[c(2, 3)], simParamBee = SP) - apiary <- buildUp(x = apiary, nWorkers = 6, nDrones = 3, simParamBee = SP) - apiary <- addVirginQueens(x = apiary, nInd = 5, simParamBee = SP) + drones <- createDrones(x = basePop[1], nInd = 1000, simParamBee = SP) + tmp <- getCsdGeno(drones, dronesHaploid = FALSE, simParamBee = SP) + expect_false(any(isGenoHeterozygous(tmp))) + expect_true(all(isCsdHeterozygous(drones, simParamBee = SP))) + + droneGroups <- pullDroneGroupsFromDCA( + drones, + n = 10, + nDrones = nFathersPoisson, + simParamBee = SP + ) - # Caste members taken from Colony class - (tmp <- getCsdGeno(getQueen(colony, simParamBee = SP), simParamBee = SP)) - expect_true(SIMplyBee:::isGenoHeterozygous(tmp)) + # Create a Colony and a MultiColony class + colony <- createColony(x = basePop[2], simParamBee = SP) + colony <- cross(colony, drones = droneGroups[[1]], simParamBee = SP) + colony <- buildUp(x = colony, nWorkers = 6, nDrones = 3, simParamBee = SP) + colony <- addVirginQueens(x = colony, nInd = 4, simParamBee = SP) - # Caste members taken from MultiColony class - (tmp <- getCsdGeno(getQueen(apiary[[1]], simParamBee = SP), simParamBee = SP)) - expect_true(SIMplyBee:::isGenoHeterozygous(tmp)) + apiary <- createMultiColony(basePop[3:4], n = 2, simParamBee = SP) + apiary <- cross(apiary, drones = droneGroups[c(2, 3)], simParamBee = SP) + apiary <- buildUp(x = apiary, nWorkers = 6, nDrones = 3, simParamBee = SP) + apiary <- addVirginQueens(x = apiary, nInd = 5, simParamBee = SP) + # Caste members taken from Colony class + (tmp <- getCsdGeno(getQueen(colony, simParamBee = SP), simParamBee = SP)) + expect_true(isGenoHeterozygous(tmp)) + + # Caste members taken from MultiColony class + (tmp <- getCsdGeno(getQueen(apiary[[1]], simParamBee = SP), simParamBee = SP)) + expect_true(isGenoHeterozygous(tmp)) }) # ---- getBV ---- + test_that("getBV", { - founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) - SP <- SimParamBee$new(founderGenomes, csdChr = NULL) - SP$nThreads = 1L - SP$addTraitA(nQtlPerChr = 10, var = 1) - SP$addSnpChip(5) - basePop <- createVirginQueens(founderGenomes, simParamBee = SP) - - drones <- createDrones(x = basePop[1], nInd = 1000, simParamBee = SP) - 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 = 6, nDrones = 3, simParamBee = SP) - - apiary <- createMultiColony(basePop[3:4], n = 2, simParamBee = SP) - apiary <- cross(apiary, drones = droneGroups[c(2, 3)], simParamBee = SP) - apiary <- buildUp(x = apiary, nWorkers = 6, nDrones = 3, simParamBee = SP) - - expect_equal(nrow(SIMplyBee:::getBv(x = getQueen(colony, simParamBee = SP), simParamBee = SP)), 1) - expect_equal(nrow(SIMplyBee:::getQueenBv(x = colony, simParamBee = SP)), 1) - expect_equal(nrow(SIMplyBee:::getBv(x = getWorkers(colony, simParamBee = SP), simParamBee = SP)), 6) - expect_equal(nrow(SIMplyBee:::getWorkersBv(x = colony, simParamBee = SP)), 6) - - expect_length(SIMplyBee:::getBv(apiary, caste = "workers", simParamBee = SP), 2) - expect_equal(nrow(SIMplyBee:::getBv(apiary, caste = "workers", simParamBee = SP)[[1]]), 6) + founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) + SP <- SimParamBee$new(founderGenomes, csdChr = NULL) + SP$nThreads <- 1L + SP$addTraitA(nQtlPerChr = 10, var = 1) + SP$addSnpChip(5) + + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) + + drones <- createDrones(x = basePop[1], nInd = 1000, simParamBee = SP) + 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 = 6, nDrones = 3, simParamBee = SP) + + apiary <- createMultiColony(basePop[3:4], n = 2, simParamBee = SP) + apiary <- cross(apiary, drones = droneGroups[c(2, 3)], simParamBee = SP) + apiary <- buildUp(x = apiary, nWorkers = 6, nDrones = 3, simParamBee = SP) + + expect_equal( + nrow(getBv( + x = getQueen(colony, simParamBee = SP), + simParamBee = SP + )), + 1 + ) + expect_equal(nrow(getQueenBv(x = colony, simParamBee = SP)), 1) + expect_equal( + nrow(getBv( + x = getWorkers(colony, simParamBee = SP), + simParamBee = SP + )), + 6 + ) + expect_equal(nrow(getWorkersBv(x = colony, simParamBee = SP)), 6) + + expect_length( + getBv(apiary, caste = "workers", simParamBee = SP), + 2 + ) + expect_equal( + nrow(getBv(apiary, caste = "workers", simParamBee = SP)[[1]]), + 6 + ) }) # ---- getDd ---- + test_that("getDd", { - founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) - SP <- SimParamBee$new(founderGenomes, csdChr = NULL) - SP$nThreads = 1L - SP$addTraitAD(nQtlPerChr = 10, meanDD = 0.2, varDD = 0.1) - basePop <- createVirginQueens(founderGenomes, simParamBee = SP) - - drones <- createDrones(x = basePop[1], nInd = 1000, simParamBee = SP) - 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 = 6, nDrones = 3, simParamBee = SP) - - apiary <- createMultiColony(basePop[3:4], n = 2, simParamBee = SP) - apiary <- cross(apiary, drones = droneGroups[c(2, 3)], simParamBee = SP) - apiary <- buildUp(x = apiary, nWorkers = 6, nDrones = 3, simParamBee = SP) - - expect_equal(nrow(SIMplyBee:::getDd(x = getQueen(colony, simParamBee = SP), simParamBee = SP)), 1) - expect_equal(nrow(SIMplyBee:::getQueenDd(x = colony, simParamBee = SP)), 1) - expect_equal(nrow(SIMplyBee:::getDd(x = getWorkers(colony, simParamBee = SP), simParamBee = SP)), 6) - expect_equal(nrow(SIMplyBee:::getWorkersDd(x = colony, simParamBee = SP)), 6) - - expect_length(SIMplyBee:::getDd(apiary, caste = "workers", simParamBee = SP), 2) - expect_equal(nrow(SIMplyBee:::getDd(apiary, caste = "workers", simParamBee = SP)[[1]]), 6) + 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) + + drones <- createDrones(x = basePop[1], nInd = 1000, simParamBee = SP) + 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 = 6, nDrones = 3, simParamBee = SP) + + apiary <- createMultiColony(basePop[3:4], n = 2, simParamBee = SP) + apiary <- cross(apiary, drones = droneGroups[c(2, 3)], simParamBee = SP) + apiary <- buildUp(x = apiary, nWorkers = 6, nDrones = 3, simParamBee = SP) + + expect_equal( + nrow(getDd( + x = getQueen(colony, simParamBee = SP), + simParamBee = SP + )), + 1 + ) + expect_equal(nrow(getQueenDd(x = colony, simParamBee = SP)), 1) + expect_equal( + nrow(getDd( + x = getWorkers(colony, simParamBee = SP), + simParamBee = SP + )), + 6 + ) + expect_equal(nrow(getWorkersDd(x = colony, simParamBee = SP)), 6) + + expect_length( + getDd(apiary, caste = "workers", simParamBee = SP), + 2 + ) + expect_equal( + nrow(getDd(apiary, caste = "workers", simParamBee = SP)[[1]]), + 6 + ) }) # ---- getAa ---- + test_that("getAa", { - founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) - SP <- SimParamBee$new(founderGenomes, csdChr = NULL) - SP$nThreads = 1L - SP$addTraitADE(nQtlPerChr = 10, meanDD = 0.2, varDD = 0.1, relAA = 0.5) - basePop <- createVirginQueens(founderGenomes, simParamBee = SP) - - drones <- createDrones(x = basePop[1], nInd = 1000, simParamBee = SP) - 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 = 6, nDrones = 3, simParamBee = SP) - - apiary <- createMultiColony(basePop[3:4], n = 2, simParamBee = SP) - apiary <- cross(apiary, drones = droneGroups[c(2, 3)], simParamBee = SP) - apiary <- buildUp(x = apiary, nWorkers = 6, nDrones = 3, simParamBee = SP) - - expect_equal(nrow(SIMplyBee:::getAa(x = getQueen(colony, simParamBee = SP), simParamBee = SP)), 1) - expect_equal(nrow(SIMplyBee:::getQueenAa(x = colony, simParamBee = SP)), 1) - expect_equal(nrow(SIMplyBee:::getAa(x = getWorkers(colony, simParamBee = SP), simParamBee = SP)), 6) - expect_equal(nrow(SIMplyBee:::getWorkersAa(x = colony, simParamBee = SP)), 6) - - expect_length(SIMplyBee:::getAa(apiary, caste = "workers", simParamBee = SP), 2) - expect_equal(nrow(SIMplyBee:::getAa(apiary, caste = "workers", simParamBee = SP)[[1]]), 6) + 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) + + drones <- createDrones(x = basePop[1], nInd = 1000, simParamBee = SP) + 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 = 6, nDrones = 3, simParamBee = SP) + + apiary <- createMultiColony(basePop[3:4], n = 2, simParamBee = SP) + apiary <- cross(apiary, drones = droneGroups[c(2, 3)], simParamBee = SP) + apiary <- buildUp(x = apiary, nWorkers = 6, nDrones = 3, simParamBee = SP) + + expect_equal( + nrow(getAa( + x = getQueen(colony, simParamBee = SP), + simParamBee = SP + )), + 1 + ) + expect_equal(nrow(getQueenAa(x = colony, simParamBee = SP)), 1) + expect_equal( + nrow(getAa( + x = getWorkers(colony, simParamBee = SP), + simParamBee = SP + )), + 6 + ) + expect_equal(nrow(getWorkersAa(x = colony, simParamBee = SP)), 6) + + expect_length( + getAa(apiary, caste = "workers", simParamBee = SP), + 2 + ) + expect_equal( + nrow(getAa(apiary, caste = "workers", simParamBee = SP)[[1]]), + 6 + ) }) # ---- editCsdLocus ---- + test_that("editCsdLocus", { - founderGenomes <- quickHaplo(nInd = 100, nChr = 1, segSites = 100) - SP <- SimParamBee$new(founderGenomes, csdChr = 1, nCsdAlleles = 8) - SP$nThreads = 1L - basePop <- createVirginQueens(founderGenomes, editCsd = FALSE, simParamBee = SP) - nrow(getCsdAlleles(basePop, unique = TRUE, simParamBee = SP)) - all(isCsdHeterozygous(basePop, simParamBee = SP)) - - basePopEdited <- SIMplyBee:::editCsdLocus(basePop, simParamBee = SP) - nrow(getCsdAlleles(basePopEdited, unique = TRUE, simParamBee = SP)) - expect_true(all(isCsdHeterozygous(basePopEdited, simParamBee = SP))) + 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)) + + basePopEdited <- editCsdLocus(basePop, simParamBee = SP) + nrow(getCsdAlleles(basePopEdited, unique = TRUE, simParamBee = SP)) + expect_true(all(isCsdHeterozygous(basePopEdited, simParamBee = SP))) }) # ---- getLocation ---- + test_that("getLocation", { - founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) - SP <- SimParamBee$new(founderGenomes) - SP$nThreads = 1L - basePop <- createVirginQueens(founderGenomes, simParamBee = SP) - drones <- createDrones(x = basePop[1], nInd = 1000, simParamBee = SP) - droneGroups <- pullDroneGroupsFromDCA(drones, n = 10, nDrones = nFathersPoisson, simParamBee = SP) - colony <- createColony(x = basePop[2], simParamBee = SP) - colony <- cross(colony, drones = droneGroups[[1]], simParamBee = SP) - apiary <- createMultiColony(basePop[3:4], simParamBee = SP) - apiary <- cross(apiary, drones = droneGroups[c(2, 3)], simParamBee = SP) - - expect_equal(getLocation(colony), c(0, 0)) - expect_equal(getLocation(apiary[[1]]), c(0, 0)) - expect_equal(getLocation(apiary), list("2" = c(0, 0), "3" = c(0, 0))) - tmp <- matrix(data = 0, nrow = 2, ncol = 2, dimnames = list(c("2", "3"), NULL)) - expect_equal(getLocation(apiary, collapse = TRUE), tmp) - - loc <- c(123, 456) - expect_equal(getLocation(setLocation(colony, location = loc)), loc) - - expect_equal(getLocation(setLocation(apiary, location = loc)), - list("2" = loc, "3" = loc)) + founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) + SP <- SimParamBee$new(founderGenomes) + SP$nThreads <- 1L + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) + drones <- createDrones(x = basePop[1], nInd = 1000, simParamBee = SP) + droneGroups <- pullDroneGroupsFromDCA( + drones, + n = 10, + nDrones = nFathersPoisson, + simParamBee = SP + ) + colony <- createColony(x = basePop[2], simParamBee = SP) + colony <- cross(colony, drones = droneGroups[[1]], simParamBee = SP) + apiary <- createMultiColony(basePop[3:4], simParamBee = SP) + apiary <- cross(apiary, drones = droneGroups[c(2, 3)], simParamBee = SP) + + expect_equal(getLocation(colony), c(0, 0)) + expect_equal(getLocation(apiary[[1]]), c(0, 0)) + expect_equal(getLocation(apiary), list("2" = c(0, 0), "3" = c(0, 0))) + tmp <- matrix( + data = 0, + nrow = 2, + ncol = 2, + dimnames = list(c("2", "3"), NULL) + ) + expect_equal(getLocation(apiary, collapse = TRUE), tmp) + + loc <- c(123, 456) + expect_equal( + getLocation(setLocation(colony, location = loc, simParamBee = SP)), + loc + ) + + expect_equal( + getLocation(setLocation(apiary, location = loc, simParamBee = SP)), + list("2" = loc, "3" = loc) + ) }) # ---- createCrossPlan ---- + test_that("createCrossPlan", { founderGenomes <- quickHaplo(nInd = 1000, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes) - SP$nThreads = 1L + SP$nThreads <- 1L + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) # Create three virgin MultiColony objects with locations virginColonies1 <- createMultiColony(basePop[1:2], simParamBee = SP) - virginColonies1 <- setLocation(virginColonies1, - location = Map(c, runif(2, 0, 2*pi), - runif(2, 0, 2*pi))) + virginColonies1 <- setLocation( + virginColonies1, + location = Map(c, runif(2, 0, 2 * pi), runif(2, 0, 2 * pi)), + simParamBee = SP + ) virginColonies2 <- createMultiColony(basePop[3:4], simParamBee = SP) - virginColonies2 <- setLocation(virginColonies2, - location = Map(c, runif(2, 0, 2*pi), - runif(2, 0, 2*pi))) + virginColonies2 <- setLocation( + virginColonies2, + location = Map(c, runif(2, 0, 2 * pi), runif(2, 0, 2 * pi)), + simParamBee = SP + ) virginColonies3 <- createMultiColony(basePop[5:6], simParamBee = SP) - virginColonies3 <- setLocation(virginColonies3, - location = Map(c, runif(2, 0, 2*pi), - runif(2, 0, 2*pi))) + virginColonies3 <- setLocation( + virginColonies3, + location = Map(c, runif(2, 0, 2 * pi), runif(2, 0, 2 * pi)), + simParamBee = SP + ) # Create drone colonies droneColonies <- createMultiColony(basePop[7:9], simParamBee = SP) - droneColonies <- setLocation(droneColonies, - location = Map(c, runif(3, 0, 2*pi), - runif(3, 0, 2*pi))) + droneColonies <- setLocation( + droneColonies, + location = Map(c, runif(3, 0, 2 * pi), runif(3, 0, 2 * pi)), + simParamBee = SP + ) # Create some drones to mate initial drone colonies with DCA <- createDrones(basePop[10:12], nInd = 20, simParamBee = SP) # Cross initial virgin drone colonies to the DCA with a random cross plan - randomCrossPlan <- createCrossPlan(x = droneColonies, - drones = DCA, - nDrones = 15, - spatial = FALSE, - simParamBee = SP) + randomCrossPlan <- createCrossPlan( + x = droneColonies, + drones = DCA, + nDrones = 15, + spatial = FALSE, + simParamBee = SP + ) expect_length(randomCrossPlan, 3) - droneColonies <- cross(droneColonies, - drones = DCA, - nDrones = nFathersPoisson, - crossPlan = randomCrossPlan, - simParamBee = SP) + droneColonies <- cross( + droneColonies, + drones = DCA, + nDrones = nFathersPoisson, + crossPlan = randomCrossPlan, + simParamBee = SP + ) - expect_equal(as.vector(nFathers(droneColonies, simParamBee = SP)), c(15, 15, 15)) + expect_equal( + as.vector(nFathers(droneColonies, simParamBee = SP)), + c(15, 15, 15) + ) # Cross according to a spatial cross plan according to the colonies' locations - crossPlanSpatial <- createCrossPlan(x = virginColonies1, - droneColonies = droneColonies, - nDrones = nFathersPoisson, - spatial = TRUE, - radius = 1.5, - simParamBee = SP) + crossPlanSpatial <- createCrossPlan( + x = virginColonies1, + droneColonies = droneColonies, + nDrones = nFathersPoisson, + spatial = TRUE, + radius = 1.5, + simParamBee = SP + ) expect_length(crossPlanSpatial, 2) - expect_error(createCrossPlan(x = droneColonies, droneColonies = virginColonies1, simParamBee = SP)) + expect_error(createCrossPlan( + x = droneColonies, + droneColonies = virginColonies1, + simParamBee = SP + )) }) +# ---- getCaste ---- -# ---- Get Caste ---- test_that("getCaste", { founderGenomes <- quickHaplo(nInd = 1000, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes) - SP$nThreads = 1L + SP$nThreads <- 1L + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) expect_vector(getCaste(basePop, simParamBee = SP), "virginQueens") #Create drones drones <- createDrones(x = basePop[1], nInd = 1000, simParamBee = SP) - droneGroups <- pullDroneGroupsFromDCA(drones, n = 10, nDrones = nFathersPoisson, simParamBee = SP) + droneGroups <- pullDroneGroupsFromDCA( + drones, + n = 10, + nDrones = nFathersPoisson, + simParamBee = SP + ) expect_vector(getCaste(drones, simParamBee = SP), "drones") # Create a Colony and a MultiColony class @@ -972,42 +1694,86 @@ test_that("getCaste", { colony <- cross(colony, drones = droneGroups[[1]], simParamBee = SP) # test that all drones in colony are now fathers. Colony should only contain queen and fathers - expect_vector(getCaste(getQueen(colony, simParamBee = SP), simParamBee = SP), "queen") - expect_vector(getCaste(getFathers(colony, simParamBee = SP), simParamBee = SP), "fathers") + expect_vector( + getCaste(getQueen(colony, simParamBee = SP), simParamBee = SP), + "queen" + ) + expect_vector( + getCaste(getFathers(colony, simParamBee = SP), simParamBee = SP), + "fathers" + ) expect_error(getCaste(getWorkers(colony, simParamBee = SP), simParamBee = SP)) expect_error(getCaste(getDrones(colony, simParamBee = SP), simParamBee = SP)) - expect_error(getCaste(getVirginQueens(colony, simParamBee = SP), simParamBee = SP)) + expect_error(getCaste( + getVirginQueens(colony, simParamBee = SP), + simParamBee = SP + )) # all caste members are now present colony <- buildUp(x = colony, nWorkers = 20, nDrones = 5, simParamBee = SP) colony <- addVirginQueens(colony, nInd = 5, simParamBee = SP) - expect_vector(getCaste(getQueen(colony, simParamBee = SP), simParamBee = SP), "queen") - expect_vector(getCaste(getFathers(colony, simParamBee = SP), simParamBee = SP), "fathers") - expect_vector(getCaste(getWorkers(colony, simParamBee = SP), simParamBee = SP), "workers") - expect_vector(getCaste(getDrones(colony, simParamBee = SP), simParamBee = SP), "drones") - expect_vector(getCaste(getVirginQueens(colony, simParamBee = SP), simParamBee = SP), "virginQueen") + expect_vector( + getCaste(getQueen(colony, simParamBee = SP), simParamBee = SP), + "queen" + ) + expect_vector( + getCaste(getFathers(colony, simParamBee = SP), simParamBee = SP), + "fathers" + ) + expect_vector( + getCaste(getWorkers(colony, simParamBee = SP), simParamBee = SP), + "workers" + ) + expect_vector( + getCaste(getDrones(colony, simParamBee = SP), simParamBee = SP), + "drones" + ) + expect_vector( + getCaste(getVirginQueens(colony, simParamBee = SP), simParamBee = SP), + "virginQueen" + ) # Check colony collapses expect_length(getCaste(colony, collapse = FALSE, simParamBee = SP), 5) - expect_vector(getCaste(colony, collapse = TRUE, simParamBee = SP), c("queen", "fathers", "workers", "drones", "virginQueens")) + expect_vector( + getCaste(colony, collapse = TRUE, simParamBee = SP), + c("queen", "fathers", "workers", "drones", "virginQueens") + ) # Create virgin apiary containing 2 colonies apiary <- createMultiColony(basePop[3:4], n = 2, simParamBee = SP) expect_length(getCaste(apiary, simParamBee = SP), 2) - expect_vector(getCaste(getVirginQueens(apiary[[1]], simParamBee = SP), simParamBee = SP), "virginQueen") + expect_vector( + getCaste(getVirginQueens(apiary[[1]], simParamBee = SP), simParamBee = SP), + "virginQueen" + ) # Mate apiaries, now only contains queens and fathers apiary <- cross(apiary, drones = droneGroups[c(2, 3)], simParamBee = SP) - expect_vector(getCaste(getQueen(apiary[[1]], simParamBee = SP), simParamBee = SP), "queen") - expect_vector(getCaste(getFathers(apiary[[1]], simParamBee = SP), simParamBee = SP), "fathers") + expect_vector( + getCaste(getQueen(apiary[[1]], simParamBee = SP), simParamBee = SP), + "queen" + ) + expect_vector( + getCaste(getFathers(apiary[[1]], simParamBee = SP), simParamBee = SP), + "fathers" + ) # all caste members are now present in apiary apiary <- buildUp(x = apiary, nWorkers = 10, nDrones = 2, simParamBee = SP) apiary <- addVirginQueens(apiary, nInd = 4, simParamBee = SP) - expect_vector(getCaste(getWorkers(apiary[[1]], simParamBee = SP), simParamBee = SP), "workers") - expect_vector(getCaste(getDrones(apiary[[1]], simParamBee = SP), simParamBee = SP), "drones") - expect_vector(getCaste(getVirginQueens(apiary[[1]], simParamBee = SP), simParamBee = SP), "virginQueen") - + expect_vector( + getCaste(getWorkers(apiary[[1]], simParamBee = SP), simParamBee = SP), + "workers" + ) + expect_vector( + getCaste(getDrones(apiary[[1]], simParamBee = SP), simParamBee = SP), + "drones" + ) + expect_vector( + getCaste(getVirginQueens(apiary[[1]], simParamBee = SP), simParamBee = SP), + "virginQueen" + ) bees <- c( getQueen(colony, simParamBee = SP), @@ -1016,12 +1782,154 @@ test_that("getCaste", { getDrones(colony, nInd = 2, simParamBee = SP), getVirginQueens(colony, nInd = 2, simParamBee = SP) ) - expect_vector(getCaste(bees, simParamBee = SP), c("queen", "fathers", "workers", "drones", "virginQueens")) + expect_vector( + getCaste(bees, simParamBee = SP), + c("queen", "fathers", "workers", "drones", "virginQueens") + ) +}) + +# ---- getIbdHaplo ---- +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) }) +# ---- trackingHomozygotes ---- + +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)) +}) +# ---- getId ---- +test_that("getId returns character IDs independently of queen IDs", { + set.seed(123) + founderGenomes <- quickHaplo(nInd = 4, nChr = 1, segSites = 100) + SP <- SimParamBee$new(founderGenomes, csdChr = NULL) + SP$nThreads = 1L + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) + colony <- createColony(basePop[2], simParamBee = SP) + expect_identical(colony@id, "1") + expect_identical(getId(basePop), c("1", "2", "3", "4")) + expect_identical(getId(colony), "1") + expect_identical(getId(NULL), NA_character_) + expect_identical(getId(new("Colony")), NA_character_) + expect_identical(getId(basePop[0]), character(0)) + expect_identical(getId(createMultiColony(simParamBee = SP)), character(0)) + expect_identical(getId(createMultiColony(n = 2, simParamBee = SP)), rep(NA_character_, 2)) + populated <- createMultiColony(n = 2, populateColonies = TRUE, simParamBee = SP) + expect_type(getId(populated), "character") + expect_false(anyNA(getId(populated))) + emptyColony <- createColony(simParamBee = SP) + expect_identical(getId(emptyColony), as.character(SP$lastColonyId)) + mixed <- new("MultiColony", colonies = list(colony, NULL, emptyColony)) + expect_identical(getId(mixed), c("1", NA_character_, getId(emptyColony))) + expect_identical(getId(createColony(id = 20L, simParamBee = SP)), "20") + expect_identical(getId(createColony(id = "hive-A", simParamBee = SP)), "hive-A") + drones <- createDrones(basePop[1], nInd = 10, simParamBee = SP) + colony <- cross(colony, drones = drones, simParamBee = SP) + expect_identical(getId(colony), "1") + expect_identical(getId(getQueen(colony, simParamBee = SP)), "2") + expect_identical(getId(removeQueen(colony, simParamBee = SP)), "1") + colony <- reQueen(colony, queen = basePop[3], simParamBee = SP) + expect_identical(getId(colony), "1") + expect_identical(getId(getVirginQueens(colony, simParamBee = SP)), "3") +}) +# ---- calcColonyValue ---- +test_that("colony value callbacks receive individual colonies positionally", { + set.seed(47) + SP <- SimParamBee$new( + quickHaplo(nInd = 2, nChr = 1, segSites = 10), + csdChr = NULL + ) + SP$nThreads <- 1L + apiary <- createMultiColony(n = 2, simParamBee = SP) + apiary[[1]] <- createColony(simParamBee = SP) + apiary[[2]] <- createColony(simParamBee = SP) + apiary[[1]]@location <- c(2, 0) + apiary[[2]]@location <- c(5, 0) + + colony_callback <- function(colony, scale) { + expect_s4_class(colony, "Colony") + matrix(scale * colony@location[1], nrow = 1, dimnames = list(NULL, "value")) + } + x_callback <- function(x, scale) { + expect_s4_class(x, "Colony") + matrix(scale * x@location[1], nrow = 1, dimnames = list(NULL, "value")) + } + + for (callback in list(colony_callback, x_callback)) { + SP$colonyValueFUN <- callback + for (explicit in c(TRUE, FALSE)) { + fun <- if (explicit) callback else NULL + expect_equal( + calcColonyValue(apiary[[1]], FUN = fun, scale = 3, simParamBee = SP), + matrix(6, dimnames = list(NULL, "value")) + ) + expect_equal( + calcColonyValue(apiary, FUN = fun, scale = 3, simParamBee = SP), + matrix(c(6, 15), ncol = 1, dimnames = list(getId(apiary), "value")) + ) + } + } +}) diff --git a/tests/testthat/test-L1_pop_functions.R b/tests/testthat/test-L1_pop_functions.R index 7cabd2b8..d6915565 100644 --- a/tests/testthat/test-L1_pop_functions.R +++ b/tests/testthat/test-L1_pop_functions.R @@ -1,9 +1,11 @@ + # ---- getCastePop ---- 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 +41,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 +68,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 +93,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 +144,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 +176,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 +196,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")) @@ -223,10 +229,12 @@ test_that("pullCastePop", { }) # ---- cross ---- + 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 +290,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) @@ -354,10 +332,12 @@ test_that("createDCA", { }) # ---- pullDroneGroupsFromDCA ---- + 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) @@ -384,15 +364,18 @@ test_that("pullDroneGroupsFromDCA", { expect_error(pullDroneGroupsFromDCA(DCA2, n =10, nDrones = 20, simParamBee = SP)) }) +# ---- combineBeeGametes ---- + test_that("combineBeeGametes", { founderGenomes <- quickHaplo(nInd = 3, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) SP$nThreads = 1L + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) queen <- basePop[1] drones <- createDrones(x = basePop[2], nInd = 5, simParamBee = SP) - workers <- SIMplyBee:::combineBeeGametes(queen, drones, nProgeny = 4, simParamBee = SP) + workers <- combineBeeGametes(queen, drones, nProgeny = 4, simParamBee = SP) expect_equal(drones@ploidy, 2) expect_equal(nInd(drones), 5) @@ -400,10 +383,13 @@ test_that("combineBeeGametes", { }) +# ---- combineBeeGametesHaploidDiploid ---- + 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 +400,28 @@ test_that("combineBeeGametesHaploidDiploid", { expect_equal(nInd(drones), 5) expect_equal(drones@ploidy, 1) }) + +# ---- cross plans with character IDs ---- + +test_that("cross plans match character colony IDs independently of queen IDs", { + set.seed(123) + founderGenomes <- quickHaplo(nInd = 7, nChr = 1, segSites = 100) + SP <- SimParamBee$new(founderGenomes, csdChr = NULL) + SP$nThreads = 1L + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) + donors <- c(createColony(basePop[1], id = "donor-B", simParamBee = SP), + createColony(basePop[2], id = "donor-A", simParamBee = SP)) + drones <- createDrones(basePop[7], nInd = 4, simParamBee = SP) + donors <- cross(donors, drones = list(drones[1:2], drones[3:4]), simParamBee = SP) + apiary <- c(createColony(basePop[3], id = "hive-C", simParamBee = SP), + createColony(basePop[4], id = "hive-A", simParamBee = SP), + createColony(basePop[5], id = "hive-B", simParamBee = SP)) + plan <- list("hive-B" = "donor-B", "hive-C" = "donor-A", "hive-A" = "donor-B") + mated <- expect_no_warning(cross(apiary, droneColonies = donors, + crossPlan = plan, nDrones = 2, simParamBee = SP)) + expect_identical(getId(mated), c("hive-C", "hive-A", "hive-B")) + expect_identical(unname(getId(getQueen(mated, collapse = TRUE, simParamBee = SP))), c("3", "4", "5")) + expect_equal(unname(getFathers(mated[[1]], simParamBee = SP)@mother), rep("2", 2)) + expect_equal(unname(getFathers(mated[[2]], simParamBee = SP)@mother), rep("1", 2)) + expect_equal(unname(getFathers(mated[[3]], simParamBee = SP)@mother), rep("1", 2)) +}) diff --git a/tests/testthat/test-L2_colony_functions.R b/tests/testthat/test-L2_colony_functions.R index bb1a729e..3b46b0c8 100644 --- a/tests/testthat/test-L2_colony_functions.R +++ b/tests/testthat/test-L2_colony_functions.R @@ -1,9 +1,10 @@ -# ---- Create Colony ---- +# ---- createColony ---- 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) @@ -18,12 +19,13 @@ test_that("createColony", { expect_error(createColony(x = drones[1], simParamBee = SP)) }) -# ---- ReQueen ---- +# ---- reQueen ---- 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] @@ -61,12 +63,13 @@ test_that("reQueen", { expect_true(isQueenPresent(reQueen(matedColony, queen = matedQueen1, simParamBee = SP), simParamBee = SP)) }) -# ---- Add Functions ---- +# ---- add functions ---- test_that("Add functions", { founderGenomes <- quickHaplo(nInd = 5, nChr = 1, segSites = 100) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) SP$nThreads = 1L + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) drones <- createDrones(x = basePop[1], nInd = 100, simParamBee = SP) @@ -109,21 +112,20 @@ 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") expect_s4_class(addDrones(apiary, nInd = 5, simParamBee = SP), "MultiColony") }) -# ---- BuildUp downSize ---- +# ---- buildUp and downsize ---- test_that("BuildUpDownsize", { founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) 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,17 +171,18 @@ 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) }) -# ---- Replace Functions ---- +# ---- replace functions ---- 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,22 +222,23 @@ 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 ---- +# ---- remove functions ---- 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") @@ -276,11 +280,13 @@ test_that("removeFunctions", { expect_equal(nColonies(removeDrones(apiary, p = 0, simParamBee = SP)), nColonies(apiary)) }) -# ---- SetLocation ---- +# ---- setLocation ---- + test_that("setLocation", { founderGenomes <- quickHaplo(nInd = 5, nChr = 1, segSites = 50) SP <- SimParamBee$new(founderGenomes, csdChr = NULL) 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,37 +296,37 @@ 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 ---- +# ---- supersede ---- 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) @@ -351,12 +357,13 @@ test_that("supersede", { expect_error(supersede(colony, simParamBee = SP)) }) -# ---- Split ---- +# ---- split ---- 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) @@ -392,12 +399,13 @@ test_that("split", { }) -# ---- ResetEvents ---- +# ---- resetEvents ---- 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 +429,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))) @@ -430,12 +438,13 @@ test_that("resetEvents", { expect_false(all(hasSuperseded(apiary))) }) -# ---- Combine ---- +# ---- combine colonies ---- 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,22 +465,23 @@ 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 ---- +# ---- swarm ---- 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) @@ -507,13 +517,13 @@ test_that("swarm", { expect_true(areVirginQueensPresent(tmp$remnant[[4]], simParamBee = SP)) }) - -# ---- Collapse ----- +# ---- collapse ---- 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..f1f8c2cd 100644 --- a/tests/testthat/test-L3_Colonies_functions.R +++ b/tests/testthat/test-L3_Colonies_functions.R @@ -6,6 +6,7 @@ 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 +38,80 @@ test_that("createMultiColony", { expect_s4_class(createMultiColony(x = basePop[4:5], n = 2, simParamBee = SP), "MultiColony") }) +# ---- MultiColony indexing ---- + +test_that("MultiColony indexing", { + set.seed(123) + founderGenomes <- quickHaplo(nInd = 4, nChr = 1, segSites = 100) + SP <- SimParamBee$new(founderGenomes, csdChr = NULL) + SP$nThreads = 1L + basePop <- createVirginQueens(founderGenomes, simParamBee = SP) + apiary <- createMultiColony(basePop, n = 4, simParamBee = SP) + # IDs deliberately differ from positions and include a nonnumeric name + apiary@colonies[[1]]@id <- "20" + apiary@colonies[[2]]@id <- "10" + apiary@colonies[[3]]@id <- "hive-A" + apiary@colonies[[4]]@id <- "30" + ids <- getId(apiary) + expect_identical(ids, c("20", "10", "hive-A", "30")) + expect_identical(apiary[getId(apiary)], apiary) + expect_identical(apiary[["10"]], apiary[[2]]) + expect_identical(getId(selectColonies(apiary, ID = 10, simParamBee = SP)), "10") + expect_identical(getId(removeColonies(apiary, ID = 10, simParamBee = SP)), ids[-2]) + pulled <- pullColonies(apiary, ID = 10, simParamBee = SP) + expect_identical(getId(pulled$pulled), "10") + expect_identical(getId(pulled$remnant), ids[-2]) + replacement <- createColony(simParamBee = SP, id = "replacement") + replaced <- apiary + replaced[["10"]] <- replacement + expect_identical(replaced[[2]], replacement) + replaced <- apiary + replaced["10"] <- c(replacement) + expect_identical(replaced[[2]], replacement) + + # Single brackets preserve MultiColony, including single and empty subsets + expect_s4_class(apiary[1], "MultiColony") + expect_equal(nColonies(apiary[1]), 1) + expect_identical(getId(apiary[c(3L, 1L)]), ids[c(3L, 1L)]) + expect_identical(getId(apiary[c(3, 1)]), ids[c(3, 1)]) + expect_identical(getId(apiary[-2]), ids[-2]) + expect_identical(getId(apiary[c(TRUE, FALSE)]), ids[c(1, 3)]) + expect_identical(getId(apiary[as.character(ids[c(3, 1)])]), ids[c(3, 1)]) + expect_s4_class(apiary[0], "MultiColony") + expect_equal(nColonies(apiary[0]), 0) + expect_equal(nColonies(apiary[integer(0)]), 0) + expect_equal(nColonies(apiary[FALSE]), 0) + + # Double brackets return the selected Colony, by position or character ID + expect_s4_class(apiary[[2]], "Colony") + expect_identical(apiary[[2]], apiary@colonies[[2]]) + expect_identical(apiary[[2L]], apiary@colonies[[2]]) + expect_identical(apiary[[as.character(ids[2])]], apiary@colonies[[2]]) + expect_identical(apiary[2][[1]], apiary[[2]]) + expect_identical(apiary[[TRUE]], apiary[[1]]) + expect_warning(selected <- apiary[[c(2, 3)]], "Selecting only the first colony") + expect_identical(selected, apiary[[2]]) + expect_warning(selected <- apiary[[as.character(ids[c(2, 3)])]], "Selecting only the first colony") + expect_identical(selected, apiary[[2]]) + expect_error(apiary[[5]], "subscript out of bounds") + expect_error(apiary[c(1, 1)], "Some colonies are duplicated") + + # Unmatched IDs and unpopulated slots retain the existing NULL behavior + expect_null(apiary[["missing"]]) + expect_null(apiary[5][[1]]) + emptyApiary <- createMultiColony(n = 2, simParamBee = SP) + expect_s4_class(emptyApiary[1], "MultiColony") + expect_null(emptyApiary[[1]]) + expect_identical(getId(apiary), ids) +}) + # ---- selectColonies ---- test_that("selectColonies", { founderGenomes <- quickHaplo(nInd = 8, nChr = 1, segSites = 100) 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 +156,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 +198,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/tests/testthat/test-variance-mapping.R b/tests/testthat/test-variance-mapping.R new file mode 100644 index 00000000..31eff40c --- /dev/null +++ b/tests/testthat/test-variance-mapping.R @@ -0,0 +1,167 @@ +test_that("individual-to-colony round trip recovers the identifiable individual components", { + for (workersFUN in c("sum", "mean")) { + for (workerAllocation in c("random", "balanced")) { + referenceColony <- NULL + for (corE in c(0, 0.7)) { + # Start with individual inputs, independently of the inverse mapping + indArgs <- list( + varAQueen = 1, + varAWorker = 1, + corAQueenWorker = -0.5, + varEQueen = 1, + varEWorker = 1, + corEQueenWorker = corE, + nW = if (workerAllocation == "balanced") 120 else 100, + nF = 15, + nDPQ = 5, + workersFUN = workersFUN, + workerAllocation = workerAllocation + ) + colonyVars <- do.call(mapIndToColonyVar, indArgs) + indVars <- do.call( + mapColonyToIndVar, + colonyVars[names(formals(mapColonyToIndVar))] + ) + + expect_equal(colonyVars[names(indArgs)], indArgs) + identifiableInputs <- setdiff(names(indArgs), "corEQueenWorker") + expect_equal(indVars[identifiableInputs], indArgs[identifiableInputs]) + expect_equal(indVars$covAQueenWorker, -0.5) + expect_equal(colonyVars$covEQueenWorker, corE) + expect_equal(colonyVars$corEQueenWorker, corE) + expect_equal(colonyVars$covEQueenWorkerGroup, 0) + expect_equal(colonyVars$corEQueenWorkerGroup, 0) + + # An unknown within-bee association must not become an assumed zero + expect_identical(indVars$covEQueenWorker, NA_real_) + expect_identical(indVars$corEQueenWorker, NA_real_) + expect_false(identical(indVars, colonyVars)) + expect_identical(names(indVars), names(colonyVars)) + recoverable <- setdiff( + names(colonyVars), + c("covEQueenWorker", "corEQueenWorker") + ) + # Numerical equality allows floating-point rounding in the inverse + expect_equal(indVars[recoverable], colonyVars[recoverable]) + + # Changing within-bee corE must leave colony components unchanged + if (is.null(referenceColony)) { + referenceColony <- colonyVars[recoverable] + } else { + expect_equal(colonyVars[recoverable], referenceColony) + } + } + } + } +}) + +test_that("colony-to-individual round trip recovers the supplied colony components", { + for (workersFUN in c("sum", "mean")) { + for (workerAllocation in c("random", "balanced")) { + # Start with colony inputs, independently of the forward mapping + colonyArgs <- list( + varAQueen = 1, + varAWorkerGroup = 1, + corAQueenWorkerGroup = -0.5, + varEQueen = 1, + varEWorkerGroup = 1, + corEQueenWorkerGroup = 0, + nW = if (workerAllocation == "balanced") 120 else 100, + nF = 15, + nDPQ = 5, + workersFUN = workersFUN, + workerAllocation = workerAllocation + ) + indVars <- do.call(mapColonyToIndVar, colonyArgs) + expect_identical(indVars$covEQueenWorker, NA_real_) + expect_identical(indVars$corEQueenWorker, NA_real_) + + # The within-bee environmental assumption does not affect colony values + for (corE in c(0, 0.7)) { + indArgs <- indVars[names(formals(mapIndToColonyVar))] + indArgs$corEQueenWorker <- corE + colonyVars <- do.call(mapIndToColonyVar, indArgs) + + expect_equal(colonyVars[names(colonyArgs)], colonyArgs) + expect_equal(colonyVars$covAQueenWorkerGroup, -0.5) + expect_equal(colonyVars$varAColony, 1) + expect_equal(colonyVars$covEQueenWorkerGroup, 0) + expect_equal(colonyVars$varEColony, 2) + expect_equal(colonyVars$corEQueenWorker, corE) + expect_equal( + colonyVars$covEQueenWorker, + corE * sqrt(indVars$varEQueen * indVars$varEWorker) + ) + recoverable <- setdiff( + names(indVars), + c("covEQueenWorker", "corEQueenWorker") + ) + expect_identical(names(colonyVars), names(indVars)) + expect_equal(colonyVars[recoverable], indVars[recoverable]) + } + } + } +}) + + +test_that("mapping heritabilities distinguish worker groups and include colony covariance", { + colonyVars <- mapIndToColonyVar( + varAQueen = 1, + varAWorker = 1, + corAQueenWorker = -0.5, + varEQueen = 1, + varEWorker = 1, + corEQueenWorker = 0, + nW = 100, + nF = 15, + nDPQ = 5, + workersFUN = "mean" + ) + indVars <- do.call( + mapColonyToIndVar, + colonyVars[names(formals(mapColonyToIndVar))] + ) + for (result in list(colonyVars, indVars)) { + expect_equal(result$h2Queen, 0.5) + expect_equal(result$h2Worker, 0.5) + # Worker-group VarA = 0.3235 and VarE = 0.01; individual heritability is 0.5. + expect_equal(result$h2WorkerGroup, 0.3235 / (0.3235 + 0.01)) + # Colony VarA = 1 + 0.3235 - 0.5 = 0.8235 and VarE = 1.01. + expect_equal(result$h2Colony, 0.8235 / (0.8235 + 1.01)) + } +}) + +test_that("mapping heritabilities handle zero genetic and environmental variances", { + for (varA in c(0, 1)) { + for (varE in c(0, 1)) { + colonyVars <- mapIndToColonyVar( + varAQueen = varA, + varAWorker = varA, + corAQueenWorker = 0, + varEQueen = varE, + varEWorker = varE, + corEQueenWorker = 0, + nW = 1, + nF = 1, + nDPQ = 1 + ) + indVars <- do.call( + mapColonyToIndVar, + colonyVars[names(formals(mapColonyToIndVar))] + ) + expected <- if (varA == 0 && varE == 0) { + NA_real_ + } else if (varA == varE) { + 0.5 + } else { + varA + } + for (result in list(colonyVars, indVars)) { + expect_identical(result$h2Queen, expected) + expect_identical(result$h2Worker, expected) + expect_identical(result$h2WorkerGroup, expected) + expect_identical(result$h2Colony, expected) + } + } + } +}) 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/A_Honeybee_biology.Rmd b/vignettes/A_Honeybee_biology.Rmd index 85cc1c3f..b76beb6e 100644 --- a/vignettes/A_Honeybee_biology.Rmd +++ b/vignettes/A_Honeybee_biology.Rmd @@ -2,6 +2,7 @@ title: "Honeybee biology" date: "`r Sys.Date()`" output: rmarkdown::html_vignette +bibliography: '`r normalizePath(if (file.exists("../inst/REFERENCES.bib")) "../inst/REFERENCES.bib" else system.file("REFERENCES.bib", package = "SIMplyBee", mustWork = TRUE), winslash = "/", mustWork = TRUE)`' vignette: > %\VignetteIndexEntry{Honeybee biology} %\VignetteEngine{knitr::rmarkdown} @@ -57,10 +58,8 @@ approach only for demonstrations and testing. Alternatively, you can more accurately simulate honeybee genomes with SIMplyBee's `simulateHoneyBeeGenomes()`. This function simulates the honeybee -genome using coalescent simulation of whole chromosomes using MaCS (Chen et al., -2009) for three subspecies: *A. m. ligustica*, *A. m. carnica*, and *A. m. -mellifera* according to the demographic model described by Wallberg et al. -(2014). +genome using coalescent simulation of whole chromosomes using MaCS [@chen2009Fast] for three subspecies: *A. m. ligustica*, *A. m. carnica*, and *A. m. +mellifera* according to the demographic model described by @wallberg2014Worldwide. As a demonstration, we will use `quickHaplo()` and simulate genomes of two founding individuals. In this example, the genomes will be represented by only @@ -416,12 +415,3 @@ getQueen(inbredColony)@misc ``` # References - -Chen G.K., Marjoram P., Wall J.D. (2009) Fast and flexible simulation of DNA -sequence data. Genome Research, 19(1):136--142. - - -Wallberg, A., Han, F., Wellhagen, G. et al. (2014) A worldwide survey of genome -sequence variation provides insight into the evolutionary history of the -honeybee Apis mellifera. Nature Genetics, 46:1081--1088. - diff --git a/vignettes/C_Colony_events.Rmd b/vignettes/C_Colony_events.Rmd index 39374f33..809bdc41 100644 --- a/vignettes/C_Colony_events.Rmd +++ b/vignettes/C_Colony_events.Rmd @@ -2,6 +2,7 @@ title: "Colony events" date: "`r Sys.Date()`" output: rmarkdown::html_vignette +bibliography: '`r normalizePath(if (file.exists("../inst/REFERENCES.bib")) "../inst/REFERENCES.bib" else system.file("REFERENCES.bib", package = "SIMplyBee", mustWork = TRUE), winslash = "/", mustWork = TRUE)`' vignette: > %\VignetteIndexEntry{Colony events} %\VignetteEngine{knitr::rmarkdown} @@ -59,7 +60,7 @@ When a honeybee colony outgrows its hive, becomes too congested, or too populated for the queen's pheromones to spread among workers, then the swarming begins. The workers start building swarm cells for new virgin queens. When the queen is ready, she leaves the hive and is followed by about 70% of the workers -in a massive cloud of flying bees, the swarm (Rangel and Seeley, 2012). The +in a massive cloud of flying bees, the swarm [@rangel2012Colony]. The swarm will cluster on a nearby tree or bush and remain there until they find a suitable new home. @@ -69,7 +70,7 @@ swarm. After few days, the new virgin queens begin to emerge. Typically, the first queen to emerge will kill the rest of virgin queens to assume the role as the new queen for the colony. She will then go on a mating flight to find drones to mate with to begin laying eggs and rebuilding the workforce in the colony -(Clemson Cooperative Extension, 2021; Rangel and Seeley, 2012). +[@clemson2020Frequently; @rangel2012Colony]. In SIMplyBee, function `swarm()` simulates swarming (Figure 1). The function takes a `Colony` class object and a percentage `p` of workers that leave with @@ -287,7 +288,7 @@ Supersedure is a replacement of the queen by one of her daughters without interference of the beekeeper. Supersedure is a natural way of re-queening a colony without swarming. There are many reasons for supersedure: poor physical condition of a queen, old age, diseases, depleted spermatheca, poorly bread -queen, reduced pheromone output and many others (Hamdan, 2010). +queen, reduced pheromone output and many others [@hamdan2010Natural]. Function `supersede()` removes the old queen and triggers the creation of new virgin queens from the brood (Figure 3). The function returns a single `Colony` @@ -362,15 +363,3 @@ apiary ``` # References - -Clemson Cooperative Extension (2021) Frequently asked questions about honey bee -swarms. - -(accessed on 2022-11-11) - -Hamdan K. (2010) Natural Supersedure of Queens in Honey Bee Colonies. Bee World, -87(3):52-54. - -Rangel J., Seeley T. D. (2012) Colony fissioning in honey bees: size and -significance of the swarm fraction. Insectes sociaux, 59(4):453-462. - diff --git a/vignettes/Colony_locations.csv b/vignettes/Colony_locations.csv deleted file mode 100644 index 0ac2a90d..00000000 --- a/vignettes/Colony_locations.csv +++ /dev/null @@ -1,36 +0,0 @@ -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 diff --git a/vignettes/D_Crossing.Rmd b/vignettes/D_Crossing.Rmd index 7c25f075..70418894 100644 --- a/vignettes/D_Crossing.Rmd +++ b/vignettes/D_Crossing.Rmd @@ -63,7 +63,7 @@ following the questions: queen/colony. - cross **according to a cross plan**. This option is the recommended option when mating a larger number of virgin queens/colonies. Continue to question - 3. + 3. 3. When mating **according to a cross plan**, you can either: @@ -131,8 +131,8 @@ beekeeper2 <- createMultiColony(basePop[12:16]) beekeeper3 <- createMultiColony(basePop[17:21]) beekeeper4 <- createMultiColony(basePop[22:31]) beekeeper5 <- createMultiColony(basePop[32:40]) -beekeeper6 <- createMultiColony(basePop[41:50]) -beekeeper7 <- createMultiColony(basePop[51:60]) +beekeeper6 <- createMultiColony(basePop[41:50]) +beekeeper7 <- createMultiColony(basePop[51:60]) ``` We will now create a groups of drones from the remaining queens with 1,000 @@ -294,18 +294,18 @@ pairs (with the `Map` function). We could also set locations randomly. ```{r} # Read locations from a file -locations = read.csv("Colony_locations.csv") +locations = read.csv("colony_locations.csv") # Set location to apiaries beekeeper1_locations <- locations[locations$ColonyID %in% getId(beekeeper1),] -beekeeper1 <- setLocation(beekeeper1, +beekeeper1 <- setLocation(beekeeper1, location = Map(c, beekeeper1_locations$X, beekeeper1_locations$Y)) beekeeper2_locations <- locations[locations$ColonyID %in% getId(beekeeper2),] -beekeeper2 <- setLocation(beekeeper2, +beekeeper2 <- setLocation(beekeeper2, location = Map(c, beekeeper2_locations$X, beekeeper2_locations$Y)) beekeeper3_locations <- locations[locations$ColonyID %in% getId(beekeeper3),] -beekeeper3 <- setLocation(beekeeper3, +beekeeper3 <- setLocation(beekeeper3, location = Map(c, beekeeper3_locations$X, beekeeper3_locations$Y)) ``` @@ -320,7 +320,7 @@ locationsDF <- data.frame(Location = getLocation(c(beekeeper1, beekeeper2, beeke rep("Beekeeper2", nColonies(beekeeper2)), rep("Beekeeper3", nColonies(beekeeper3)))) -ggplot(data = locationsDF, aes(x = Location.1, y = Location.2, colour = Beekeeper)) + +ggplot(data = locationsDF, aes(x = Location.1, y = Location.2, colour = Beekeeper)) + geom_point() ``` @@ -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 @@ -347,7 +347,7 @@ radius, if you think that is sensible, or some virgin queens will remain unmated. Once we have the spatial cross plan, we can mate our colonies. ```{r} -beekeeper3 <- cross(x = beekeeper3, +beekeeper3 <- cross(x = beekeeper3, crossPlan = crossPlan2, droneColonies = c(beekeeper1, beekeeper2), nDrones = 13, @@ -380,11 +380,11 @@ the beekeepers 4 and 5 colonies. ```{r} beekeeper4_locations <- locations[locations$ColonyID %in% getId(beekeeper4),] -beekeeper4 <- setLocation(beekeeper4, +beekeeper4 <- setLocation(beekeeper4, location = Map(c, beekeeper4_locations$X, beekeeper4_locations$Y)) beekeeper5_locations <- locations[locations$ColonyID %in% getId(beekeeper5),] -beekeeper5 <- setLocation(beekeeper5, +beekeeper5 <- setLocation(beekeeper5, location = Map(c, beekeeper5_locations$X, beekeeper5_locations$Y)) ``` @@ -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) @@ -469,22 +469,22 @@ into one. Let's mate the multicolony of beekeeper 4 in such a manner. ```{r} # Create a single drone for single drone insemination singleDrone = createDrones(beekeeper1[[1]], nInd = 1) -# Create a cross plan for crossing some of the colonies in an open DCA, +# Create a cross plan for crossing some of the colonies in an open DCA, # some with single drone, and some on a mating station crossPlanBeekeeper7 <- c( - createCrossPlan(x = beekeeper7[1], - drones = singleDrone, + createCrossPlan(x = beekeeper7[1], + drones = singleDrone, nDrones = 1), - createCrossPlan(x = beekeeper7[2:6], - drones = DCA, + createCrossPlan(x = beekeeper7[2:6], + drones = DCA, nDrones = nFathersTruncPoisson), - createCrossPlan(x = beekeeper7[7:10], - drones = matingStationDCA, + createCrossPlan(x = beekeeper7[7:10], + drones = matingStationDCA, nDrones = nFathersTruncPoisson) ) -beekeeper7 <- cross(x = beekeeper7, - crossPlan = crossPlanBeekeeper7, +beekeeper7 <- cross(x = beekeeper7, + crossPlan = crossPlanBeekeeper7, drones = c(singleDrone, DCA, matingStationDCA), checkCross = "warning") nFathers(beekeeper7) diff --git a/vignettes/E_Genomics.Rmd b/vignettes/E_Genomics.Rmd index e138cd4a..17cb63fc 100644 --- a/vignettes/E_Genomics.Rmd +++ b/vignettes/E_Genomics.Rmd @@ -2,6 +2,7 @@ title: "Genomics" date: "`r Sys.Date()`" output: rmarkdown::html_vignette +bibliography: '`r normalizePath(if (file.exists("../inst/REFERENCES.bib")) "../inst/REFERENCES.bib" else system.file("REFERENCES.bib", package = "SIMplyBee", mustWork = TRUE), winslash = "/", mustWork = TRUE)`' vignette: > %\VignetteIndexEntry{Genomics} %\VignetteEngine{knitr::rmarkdown} @@ -243,7 +244,7 @@ Matrices (GRM) using SIMplyBee's `calcBeeGRMIbs()` and `calcBeeGRMIbd()`. Let's look at the `calcBeeGRMIbs()` first. This function returns a Genomic Relatedness Matrix (GRM) for honeybees from IBS genomic data (bi-allelic SNP represented as allele dosages) following the method for the sex X chromosome -(Druet and Legarra, 2020). +[@druet2020Theoretical]. To see this, let's obtain the genotypes and sex information of all individuals in the colony. @@ -315,9 +316,8 @@ Now lets look at `calcBeeGRMIbd()`. This function creates Genomic Relatedness Matrix (GRM) for honeybees based on Identical-By-Descent (IBD) information. It returns a list with a matrix of gametic relatedness coefficients (between genomes) and a matrix of individual relatedness coefficients (between -individuals). Please refer to Grossman and Eisen (1989), Fernando and Grossman -(1989), Fernando and Grossman (1990), Van Arendonk, Tier, and Kinghorn (1994), -and Hill and Weir (2011) for the background on this function. +individuals). Please refer to @grossman1989Inbreeding, @fernando1989Covariance, +@fernando1990Genetic, @vanarendonk1994Use, and @hill2011Variation for the background on this function. Now obtain the IBD haplotypes and compute IBD GRM. @@ -396,27 +396,3 @@ hist(GRMs$indiv[dI, qI], xlim = r) ``` # References - -Druet and Legarra (2020) Theoretical and empirical comparisons of expected and -realized relationships for the X-chromosome. Genetics Selection Evolution, -52:50. - -Grossman and Eisen (1989) Inbreeding, coancestry, and covariance between -relatives for X-chromosomal loci. The Journal of Heredity, 80(2):137--142. - - -Fernando and Grossman (1989) Covariance between relatives for X-chromosomal loci -in a population in disequilibrium. Theoretical and Applied Genetics, -77:311--319. - -Fernando and Grossman (1990) Genetic evaluation with autosomal and X-chromosomal -inheritance. Theoretical and Applied Genetics, 80:75--80. - - -Van Arendonk, Tier, and Kinghorn (1994) Use of multiple genetic markers in -prediction of breeding values. Genetics, 137(1):319--329. - - -Hill and Weir (2011) Variation in actual relationship as a consequence of -Mendelian sampling and linkage. Genetics Research, 93(1):47--64. - diff --git a/vignettes/F2_Variance_calculations.Rmd b/vignettes/F2_Variance_calculations.Rmd index 5daf390e..547ad6bf 100644 --- a/vignettes/F2_Variance_calculations.Rmd +++ b/vignettes/F2_Variance_calculations.Rmd @@ -2,6 +2,7 @@ title: "Variance calculations between individual and colony level values" date: "`r Sys.Date()`" output: rmarkdown::html_vignette +bibliography: '`r normalizePath(if (file.exists("../inst/REFERENCES.bib")) "../inst/REFERENCES.bib" else system.file("REFERENCES.bib", package = "SIMplyBee", mustWork = TRUE), winslash = "/", mustWork = TRUE)`' vignette: > %\VignetteIndexEntry{VarianceCalculations} %\VignetteEngine{knitr::rmarkdown} @@ -20,176 +21,175 @@ knitr::opts_chunk$set( ) ``` -```{r FirstExampleFromQuanGenVignette} -library(package = "SIMplyBee") -founderGenomes <- quickHaplo(nInd = 20, nChr = 16, segSites = 1000) -SP <- SimParamBee$new(founderGenomes) -nQtlPerChr <- 100 -mean <- c(10, 10 / SP$nWorkers) -varA <- c(1, 1 / SP$nWorkers) -corA <- matrix(data = c( 1.0, -0.5, - -0.5, 1.0), nrow = 2, byrow = TRUE) -SP$addTraitA(nQtlPerChr = nQtlPerChr, mean = mean, var = varA, corA = corA, - name = c("queenTrait", "workersTrait")) -varE <- c(3, 3 / SP$nWorkers) -corE <- matrix(data = c(1.0, 0.3, - 0.3, 1.0), nrow = 2, byrow = TRUE) -SP$setVarE(varE = varE, corE = corE) -basePop <- createVirginQueens(founderGenomes, n = 20) -head(basePop@gv) -head(basePop@pheno) -drones <- createDrones(x = basePop[1:5], nInd = 3) -colony <- createColony(x = basePop[6]) -colony <- cross(x = colony, drones = drones, checkCross = "warning") -colony <- addWorkers(x = colony, nInd = 50) -colony <- buildUp(colony) -apiary <- createMultiColony(basePop[7:20]) -drones <- createDrones(basePop[1:5], nInd = 100) -droneGroups <- pullDroneGroupsFromDCA(drones, n = nColonies(apiary), nDrones = 15) -apiary <- cross(x = apiary, drones = droneGroups, checkCross = "warning") -apiary <- buildUp(apiary) -colonyGv <- calcColonyGv(apiary) -colonyPheno <- calcColonyPheno(apiary) -``` - -The idea of this work is: - -1) We want to do honey bee simulations with individual queens, drones, and - workers - -2) To do the above, we require individual variances and covariances - -3) Literature reports only variances and covariances at the colony level +# Introduction of the problem -4) The aim of this paper is to show how to use variances and covariances at the - colony level to do simulations at the individual level. +As seen in the quantitative genetics vignette, in SIMplyBee, +traits are defined and simulated at the individual (queen, worker, drone) level and +mapped to colony-level values. +This requires specification of individual-level variances and covariances +for the queen and workers effects. +However, in practice and literature, we can obtain only colony-level values, and +we would like to be able to use these to inform the individual-level trait definitions. +This requires understanding how colony-level variances and covariances translate to +individual-level variances and covariances, as well as vice-versa. -# Introduction WORK IN PROGRESS +This vignettes presents: +- the theory behind the relationship between individual-level and colony-level (co)variances, +- the implementation of this theory in SIMplyBee, and +- examples of implementation for when the workers's values are combined as a mean or a sum. -This document develops theory for the variance of genetic and phenotypic values -between colonies with the aim to understand how to fine tune a SIMplyBee -simulation where we need variance components for queen and workers effects at an -individual honeybee level. The challenge here is that in reality we do not -observe such variances, but only on a colony level. +# Theory: colony-level variance components -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 theory builds on prior work of @brascamp2014Methods and @brascamp2019Note. +Their worker-group mean and colony residual must be distinguished from +SIMplyBee's configurable worker aggregation and individual environmental deviations. -TODO: What do we do about this? It feels like we need a full paper on all of -this;) :( +Both papers use the individual variance parameters below; +the worker-group variance of 0.32 and its comparison with 0.40 +under equilibrium relatedness come from the 2019 study. -INTRODUCTION - -TODO: Topic 1 - -TODO: cite this paper that does honeybee simulations, but without actually doing -honeybee colony stuff etc. Heritability in honeybees paper: - - -TOOD: cite some classic papers on variances in honeybees - -TODO: cite recent papers from German and Dutch colleagues on variances in -honeybees - -Brascamp and Bijma (2014): Methods to estimate breeding values in honey bees - - -Brascamp and Bijma (2019): A note on genetic parameters and accuracy of -estimated breeding values in honey bees - +$\sigma_{g_q}^2=0.5$ - this is their $\sigma_{A_q}^2=0.5$ -Andonov et al.: Modeling honey yield, defensive and swarming behaviors of -Italian honey bees (Apis mellifera ligustica) using linear-threshold approaches - +$\sigma_{g_w}^2=1.0$ - this is their $\sigma_{A_w}^2=1.0$ on the individual worker-trait scale -To make use of the material in this document you should run the quantitative -genetics vignette - the first example. Then you can continue here! +$\sigma_{\bar{g}_w}^2=0.32$ - this is their $\sigma_{\bar{A}_w}^2=0.32$ among +base related groups of workers -Having multiple colonies and their values, we can now return to the "about" -point mentioned at the start of this section, when we defined quantitative -genetic parameters. Recall that our starting quantitative genetic parameters for -the queen and workers effects were: +Equation (3) of @brascamp2019Note gives the relationship between +individual worker variance and worker-group mean variance. +In our notation, its finite-worker form and an equivalent rearrangement are: -We will follow the example from Brascamp and Bijma (2019) they have: +$$ +\sigma_{\bar{g}_w}^2 += \frac{1+(n_w-1)a_{ii}}{n_w}\sigma_{g_w}^2 += \left[a_{ii}+\frac{1-a_{ii}}{n_w}\right]\sigma_{g_w}^2 +\approx a_{ii}\sigma_{g_w}^2, +$$ -$\sigma_{g_q}^2=0.5$ - this is their $\sigma_{A_q}^2=0.5$ +where $n_w$ is the number of workers. +The paper writes the final approximation as an equality and +explains that it holds because the worker group is very large. +We retain the finite-worker term when simulating smaller groups. -$\sigma_{g_w}^2=1.0$ - this is their $\sigma_{A_w}^2=1.0$ among unrelated -honeybees +The coefficient $a_{ii}$ is the average additive genetic relationship between +two distinct workers in a colony and can be defined (in a non-inbred population) as +$a_{ii} = 1/4 + 1/2p_1 + 1/4(p_2 - p_1) + 1/4(1 - p_2)a_{ss}$; +where +$p_1$ is the probability that two workers descend from the same drone, +$p_2$ is the probability that they descend from the same DPQ, and +$a_{ss}$ is the relatedness between two distinct DPQs. +This relationship is given in Equation 4 of @brascamp2019Note, +derived from Equation 24 of @brascamp2014Methods +for a non-related and non-inbred population. -$\sigma_{g_w}^2=0.32$ - this is their $\sigma_{\bar{A}_w}^2=0.32$ among averages -of groups of honeybees? +TODO: At the moment we ignore the $a_{ss}$ part in this example by assuming unrelated DPQs. $\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\approx0.19$ -$h_w^2=a_base\sigma_{g,w}^2/\sigma_{p,c}^2=0.13$ +Here $a_{base}=0.32$, +so the large-worker-group genetic variance is $0.5+0.32-0.35=0.47$ and +phenotypic variance is $2.47$. +This variance ratio is distinct from $T^2$, the heritable-variation ratio below. + +$h_w^2=a_{base}\sigma_{g,w}^2/\sigma_{p,c}^2=0.13$ $h_q^2=\sigma_{g,q}^2/\sigma_{p,c}^2=0.20$ -$T^2=(sigma_{g,w}^2 + 2\sigma_{{g,w},{g,q}} \sigma_{g,q}^2)/\sigma_{p,c}^2=0.32$ +$T^2=(\sigma_{g,w}^2 + 2\sigma_{{g,w},{g,q}} + \sigma_{g,q}^2)/\sigma_{p,c}^2=0.32$ $T_w^2=\sigma_{g,w}^2/\sigma_{p,c}^2=0.41$ $T_q^2=\sigma_{g,q}^2/\sigma_{p,c}^2=0.20$ -$r_g = cor(g_w, g_q) = -0.50$ - -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? +$r_g = cor(g_w, g_q) \approx -0.50$ (the covariance above is rounded). TODO: show sensitivity to the number of workers - the larger the number of -workers, the smaller the variance between workers +workers, the smaller the variance of the worker mean (towards a nonzero relatedness limit) + +$covA[1, 1] + nW * covA[2, 2] + 2 * k * covA[1, 2]$ + +Let's run again the example from the quantitative genetics vignette +to have some data to work with. +In this example, +we assumed that the contribution of workers was summed up +to obtain the combined colony-level worker contribution. +Accordingly, +the variance for the worker trait was naively scaled by $1/nWorkers$, +which assumed that workers' contributions were independent. +What does this give us? + +```{r load_variance_scripts, include = FALSE} +# load shared variance helper functions for this vignette +library("SIMplyBee") +library("dplyr") +library("ggplot2") +``` -```{r quan_gen_param_revision} -# Trait means -mean +```{r FirstExampleFromQuanGenVignette} +library(package = "SIMplyBee") +founderGenomes <- quickHaplo(nInd = 20, nChr = 16, segSites = 1000) +SP <- SimParamBee$new(founderGenomes) +nQtlPerChr <- 100 +mean <- c(10, 10 / SP$nWorkers) +varA <- c(1, 1 / SP$nWorkers) +corA <- matrix(data = c( 1.0, -0.5, + -0.5, 1.0), nrow = 2, byrow = TRUE) +SP$addTraitA(nQtlPerChr = nQtlPerChr, mean = mean, var = varA, corA = corA, + name = c("queenTrait", "workersTrait")) +varE <- c(3, 3 / SP$nWorkers) +corE <- matrix(data = c(1.0, 0.3, + 0.3, 1.0), nrow = 2, byrow = TRUE) +SP$setVarE(varE = varE, corE = corE) +basePop <- createVirginQueens(founderGenomes, n = 20) +drones <- createDrones(x = basePop[1:5], nInd = 3) +colony <- createColony(x = basePop[6]) +colony <- cross(x = colony, drones = drones, checkCross = "warning") +colony <- addWorkers(x = colony, nInd = 50) +colony <- buildUp(colony) +apiary <- createMultiColony(basePop[7:20]) +drones <- createDrones(basePop[1:5], nInd = 100) +apiary <- cross(x = apiary, drones = drones, crossPlan = "create", checkCross = "warning") +apiary <- buildUp(apiary) +colonyGv <- calcColonyGv(apiary) +colonyPheno <- calcColonyPheno(apiary) + +(popVar(colonyGv)) +(popVar(colonyPheno)) +``` + +In this example, we assumed that phenotypic variance on the individual level is +about 1/4 due to genetic variation and about 3/4 due to environmental variation, +but looking at colony genetic and phenotypic variances the ratio was about 1/2! -# Trait genetic variation - on a per honeybee level -varA -corA +Also, if we naively compute the expected colony-level variances based on our assumptions of worker-independence when +setting individual-level variances, we get: +```{r variance_expectation} (covA <- corA * outer(X = sqrt(varA), Y = sqrt(varA), FUN = "*")) # Trait environmental variation - on a per honeybee level -varE -corE (covE <- corE * outer(X = sqrt(varE), Y = sqrt(varE), FUN = "*")) # Trait phenotypic variation - on a per honeybee level (covP <- covA + covE) -(corP <- cov2cor(covP)) -(varP <- diag(covP)) -# Expected phenotypic variation - on a per colony level -# TODO: there is in fact more stuff happening here - see below! -nW <- SP$nWorkers # TODO: this is not correct - we have queen-workers pairs and workers-workers (see below!) -# Var(z)=Var(x+y)=Var(x)+Var(sum(y))=Var(x)+Var(y_1)+Var(y_2)+... -# this is all wrong likely ... +(covA[1, 1] + SP$nWorkers * covA[2, 2] + 2 * covA[1, 2]) +(covP[1, 1] + SP$nWorkers * covP[2, 2] + 2 * covP[1, 2]) +``` +Here, we see an even larger discrepancy between the assumed and realised colony-level genetic variance, +where the realised values greatly exceed the assumed values. -k <- 1 # just adding this so vignette can run, but I don't know what this k should be +So, let's have a look at how we can improve the simulation to get the desired +colony-level variances and covariances. -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] +# Theory: Breaking down colony-level variance components -# Observed variation - on a per colony level -var(colonyGv) -var(colonyPheno) -var(colonyGv) / var(colonyPheno) -``` - -Hmm, we have much higher genetic and phenotypic variances in simulation than -based simply looking at queen and n\*workers variances, as well as much higher -ratio between the two than the initial value of \~1/4! Why? Let's see. For -genetic value of a colony $g_c$ we add up the queen's genetic value for the +For genetic value of a colony $g_c$ we add up the queen's genetic value for the queen effect $g_{q,q}$ and workers' genetic values for the workers effect $\Sigma_{i=1}^{n_w}(g_{i,w})$: @@ -244,9 +244,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 +285,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 +327,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 @@ -370,7 +375,8 @@ Is this correct? nW * nW (a <- nW * nW / nF) (b <- (nF - 1) * nW * nW / nF) -a+b +a+b +#TODO define nDPQ ``` Looks like! @@ -381,7 +387,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,113 +445,354 @@ $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? +# SIMplyBee implementation -Alright, what can we now do with this? We now have a system of expected genetic -and phenotypic variances for colony values as a function of number of workers, -fathers, and genetic and phenotypic covariances between the queen and worker -effects. So, it should be possible, in principle, to solve for what kind of -covariance values for the queen and workers effects should we use, to get the -desired colony genetic and phenotypic variances! +We have developed a set of functions that use the theory explained above to: +(i) calculate expected colony-level variances +and covariances based on the provided individual-level variances and covariances: `mapIndToColonyVar()` +(ii) calculate the required individual-level variances and covariances to achieve the desired +colony-level variances and covariances: `mapColonyToIndVar()` -TODO: develop such estimating equations! +# Example: summarising worker effects as a sum -So, we have genetic part: +Let's see how these work in practice. We will use the same example as above, so let's just recall what values we've set. +Note again, that we are summarising the workers' effects as a sum, so we naively set the individual-level variance for the worker effect +to be $1/nWorkers$ of the desired colony-level variance for the worker effect. -$A_g = \sigma^2_{g_q}$ +Let's start off with a fresh simulation. -$B1_g = n_w \sigma^2_{g_w}$ +```{r} +founderGenomes <- quickHaplo(nInd = 20, nChr = 16, segSites = 1000) +SP <- SimParamBee$new(founderGenomes) +nQtlPerChr <- 100 +mean <- c(10, 10 / SP$nWorkers) +varA <- c(1, 1 / SP$nWorkers) +corA <- matrix(data = c( 1.0, -0.5, + -0.5, 1.0), nrow = 2, byrow = TRUE) +SP$addTraitA(nQtlPerChr = nQtlPerChr, mean = mean, var = varA, corA = corA, + name = c("queenTrait", "workersTrait")) +varE <- c(3, 3 / SP$nWorkers) +corE <- matrix(data = c(3.0, 0.3, + 0.3, 3.0), nrow = 2, byrow = TRUE) +SP$setVarE(varE = varE, corE = corE) +basePop <- createVirginQueens(founderGenomes, n = 20) +drones <- createDrones(x = basePop[1:5], nInd = 3) +colony <- createColony(x = basePop[6]) +colony <- cross(x = colony, drones = drones, checkCross = "warning") +colony <- addWorkers(x = colony, nInd = 50) +colony <- buildUp(colony) +apiary <- createMultiColony(basePop[7:20]) +drones <- createDrones(basePop[1:5], nInd = 100) +apiary <- cross(x = apiary, drones = drones, crossPlan = "create", checkCross = "warning") +apiary <- buildUp(apiary) +``` -$B2_g = \frac{n^2_w}{n_f} \frac{1}{2} \sigma^2_{g_w}$ +Now, let's compute the corresponding colony-level variances and covariances using the `mapIndToColonyVar()` function. +```{r mapIndToColonyVar_sum} +# When the function to summarise worker effects is SUM +calcColonyValues <- mapIndToColonyVar(varA_q = varA[1], + varA_w= varA[2], + corA_qw = corA[1, 2], + varE_q = varE[1], + varE_w = varE[2], + corE_qw = corE[1, 2], + nW = nW, nF = nF, + nDPQ = nDPQ, + workersFUN = "sum") + +calcColonyValues$varA_c +colonyGv <- calcColonyGv(apiary, FUN = mapCasteToColonyGv, workersFUN = colSums) +var(colonyGv) +``` +We see that the realised and calculated colony-level variances match quite closely. + +Now, let's do it the other way around. This is a more realistic scenario since you would normally obtain +the colony-level variances and covariances from the literature and would want to recreate them using simulation. +Here, we assume, you obtain a separate estimate for the queen and for the worker trait. +Let's say we want to achieve the following colony-level variances and covariances: +```{r mapColonyToIndVar_sum} +varA_q <- 1 +varA_wbar <- 1 +corA_qwbar <- -0.5 + +varE_q <- 3 +varE_wbar <- 3 +corE_qwbar <- 0.3 + +nW <- 100 +nF <- 15 +nDPQ <- 5 + +calcIndValues <- mapColonyToIndVar(varA_q = varA_q, varA_wbar = varA_wbar, corA_qwbar = corA_qwbar, + varE_q = varE_q, varE_wbar = varE_wbar, corE_qwbar = corE_qwbar, + nW = nW, nF = nF, nDPQ = nDPQ, workersFUN = "sum") +``` +Now, let's use these calculated individual-level variances and covariances to simulate a new population and check if we achieve the desired colony-level variances and covariances. -$B3_g = \frac{(n_f - 1) n^2_w}{n_f} \frac{1}{4} \sigma^2_{g_w}$ -$C_g = n_w \sigma^2_{{g_q},{g_w}}$ +```{r example_sum} +founderGenomes <- quickHaplo(nInd = 20, nChr = 16, segSites = 1000) +SP <- SimParamBee$new(founderGenomes) +SP$nWorkers = nW +SP$nFathers = nF +nQtlPerChr <- 100 +mean <- c(0, 0) +varA <- c(calcIndValues$varA_q, calcIndValues$varA_w) +corA <- matrix(data = c( 1.0, calcIndValues$corA_qw, + calcIndValues$corA_qw, 1.0), nrow = 2, byrow = TRUE) +SP$addTraitA(nQtlPerChr = nQtlPerChr, mean = mean, var = varA, corA = corA, + name = c("queenTrait", "workersTrait")) +varE <- c(calcIndValues$varE_q, calcIndValues$varE_w) +corE <- matrix(data = c(1.0, calcIndValues$corE_qw, + calcIndValues$corE_qw, 1.0), nrow = 2, byrow = TRUE) +SP$setVarE(varE = varE, corE = corE) +basePop <- createVirginQueens(founderGenomes, n = 20) -here are 3 unknowns: $\sigma^2_{g_q}$, $\sigma^2_{g_w}$, and -$\sigma^2_{{g_q},{g_w}}$ +drones <- createDrones(x = basePop[1:nDPQ], nInd = 3) +colony <- createColony(x = basePop[nDPQ+1]) +colony <- cross(x = colony, drones = drones, checkCross = "warning") +colony <- addWorkers(x = colony, nInd = 50) +colony <- buildUp(colony) +apiary <- createMultiColony(basePop[7:20]) +drones <- createDrones(basePop[1:nDPQ], nInd = 100) +apiary <- cross(x = apiary, drones = drones, crossPlan = "create", checkCross = "warning") +apiary <- buildUp(apiary) -we can add phenotypic part: +# Get the realised numbers +real_A_q <- calcColonyGv(apiary, mapCasteToColonyGv, queenTrait = 1, workersTrait = NULL) +real_varA_q <- popVar(real_A_q) +real_A_wbar <- calcColonyGv(apiary, mapCasteToColonyGv, queenTrait = NULL, workersTrait = 2, workersFUN = colSums) +real_varA_wbar <- popVar(real_A_wbar) +real_A_c <- calcColonyGv(apiary, mapCasteToColonyGv, queenTrait = 1, workersTrait = 2, workersFUN = colSums) +real_varA_c <- popVar(real_A_c) + +real_P_q <- calcColonyPheno(apiary, mapCasteToColonyPheno, queenTrait = 1, workersTrait = NULL) +real_E_q <- real_P_q - real_A_q +real_varE_q <- popVar(real_E_q) +real_P_wbar <- calcColonyPheno(apiary, mapCasteToColonyPheno, queenTrait = NULL, workersTrait = 2, workersFUN = colSums) +real_E_wbar <- real_P_wbar - real_A_wbar +real_varE_wbar <- popVar(real_E_wbar) +real_P_c <- calcColonyPheno(apiary, mapCasteToColonyPheno, queenTrait = 1, workersTrait = 2, workersFUN = colSums) +real_E_c <- real_P_c - real_A_c +real_varE_c <- popVar(real_E_c) + +variances <- data.frame(set_varA_q = varA_q, real_varA_q = real_varA_q[1,1], + set_varA_wbar = varA_wbar, real_varA_wbar = real_varA_wbar[1,1], + real_varA_c = real_varA_c[1,1], + set_varE_q = varE_q, real_varE_q = real_varE_q[1,1], + set_varE_wbar = varE_wbar, real_varE_wbar = real_varE_wbar[1,1], + real_varE_c = real_varE_c[1,1], + fun = "sum") + +# Plot the results +variancesLong <- variances %>% + tidyr::pivot_longer(cols = -c(fun), names_to = "VarType", values_to = "Var") +variancesLong$RealCalc <- sapply(strsplit(as.character(variancesLong$VarType), "_"), "[", 1) +# Extract the second and third elements and paste them together to get the variance type for plotting +variancesLong$VarTypePlot <- paste0(sapply(strsplit(as.character(variancesLong$VarType), "_"), "[", 2), "_", sapply(strsplit(as.character(variancesLong$VarType), "_"), "[", 3)) + +variancesLong$VarTypePlot <- factor(variancesLong$VarTypePlot, levels = c("varA_q", "varA_wbar", "varA_c", + "varE_q", "varE_wbar", "varE_c")) + +variancesLong |> filter(VarTypePlot %in% c("varA_q", "varA_wbar", "varE_q", "varE_wbar")) |> + ggplot(aes(x = VarTypePlot, y = Var, fill = RealCalc)) + + geom_col(position = "dodge") + + facet_wrap(. ~fun, scales = "free") + + theme_bw(base_size = 20) + + scale_fill_manual(values = c("#D55E00", "#084159")) # one color per RealCalc level (set/real) +``` -$A_p = \sigma^2_{p_q}$ +As we see, we are pretty much on point with matching the desired values! There is of course the element of stochasticity and +the limited samples size. -$B1_p = n_w \sigma^2_{p_w}$ -$B2_p = \frac{n^2_w}{n_f} \frac{1}{2} \sigma^2_{g_w}$ TODO: check if its only -genetic +# Example: summarising worker effects as a mean +Let's repeat all of the above using a mean to summarise workers' values. +For this, we set the individual-level variance for the worker effect the same as the desired colony-level variance. +For this, we need to resimulate our apiary. -$B3_p = \frac{(n_f - 1) n^2_w}{n_f} \frac{1}{4} \sigma^2_{g_w}$ TODO: check if -its only genetic +```{r simulation_mean} +founderGenomes <- quickHaplo(nInd = 20, nChr = 16, segSites = 1000) +SP <- SimParamBee$new(founderGenomes) +nQtlPerChr <- 100 +mean <- c(10, 10) +varA <- c(1, 1) +corA <- matrix(data = c( 1.0, -0.5, + -0.5, 1.0), nrow = 2, byrow = TRUE) +SP$addTraitA(nQtlPerChr = nQtlPerChr, mean = mean, var = varA, corA = corA, + name = c("queenTrait", "workersTrait")) +varE <- c(3, 3 / SP$nWorkers) +corE <- matrix(data = c(3.0, 0.3, + 0.3, 3.0), nrow = 2, byrow = TRUE) +SP$setVarE(varE = varE, corE = corE) +basePop <- createVirginQueens(founderGenomes, n = 20) +drones <- createDrones(x = basePop[1:5], nInd = 3) +colony <- createColony(x = basePop[6]) +colony <- cross(x = colony, drones = drones, checkCross = "warning") +colony <- addWorkers(x = colony, nInd = 50) +colony <- buildUp(colony) +apiary <- createMultiColony(basePop[7:20]) +drones <- createDrones(basePop[1:5], nInd = 100) +apiary <- cross(x = apiary, drones = drones, crossPlan = "create", checkCross = "warning") +apiary <- buildUp(apiary) +``` -$C_p = n_w \sigma^2_{{p_q},{p_w}}$ +Let's again compute the corresponding colony-level variances and covariances using the `mapIndToColonyVar()` function. +```{r mapIndToColonyVar_mean} +# When the function to summarise worker effects is MEAN +calcColonyValues <- mapIndToColonyVar(varA_q = varA[1], + varA_w= varA[2], + corA_qw = corA[1, 2], + varE_q = varE[1], + varE_w = varE[2], + corE_qw = corE[1, 2], + nW = nW, nF = nF, + nDPQ = nDPQ, + workersFUN = "mean") + +calcColonyValues$varA_c +colonyGv <- calcColonyGv(apiary, FUN = mapCasteToColonyGv, workersFUN = colMeans) +var(colonyGv) +``` +We again see that the realised and calculated colony-level variances match very closely. -here are additional 3 unknowns: $\sigma^2_{p_q}$, $\sigma^2_{p_w}$, and -$\sigma^2_{{p_q},{p_w}}$ +And for the other way around: +```{r mapColonyToIndVar_mean} +calcIndValues <- mapColonyToIndVar(varA_q = varA_q, varA_wbar = varA_wbar, corA_qwbar = corA_qwbar, + varE_q = varE_q, varE_wbar = varE_wbar, corE_qwbar = corE_qwbar, + nW = nW, nF = nF, nDPQ = nDPQ, workersFUN = "sum") +``` +Now, let's use these calculated individual-level variances and covariances to simulate a new population and check if we achieve the desired colony-level variances and covariances. -while we could provide as guidance 2, maybe 3, inputs: $\sigma^2_{g_c}$, -$\sigma^2_{p_c}$, and $\frac{\sigma^2_{g_c}}{\sigma^2_{p_c}}$. -TODO: are there any additional inputs that we could get from literature? How do -we connect all this with variance estimates for the queen and the workers effect -in the honeybee genetics and breeding literature? I think that those estimates -are essentially this: -$\sigma^2_{g_c} = \sigma^2_{g_{c,q}} + \sigma^2_{g_{c,w}} + 2\sigma_{g_{c,q},g_{c,w}}$ -where $\sigma^2_{g_{c,q}}$ is the queen part of $\sigma^2_{g_c}$, but not -necessarily the same as $\sigma^2_{g_w}$, or is it? Maybe that is the same, and -$\sigma^2_{g_{c,w}}$ is a counterpart to -$n_w \sigma^2_{g_w} + \frac{n^2_w}{n_f} \frac{1}{2} \sigma^2_{g_w}, \frac{(n_f - 1) n^2_w}{n_f} \frac{1}{4} \sigma^2_{g_w}$ -(TODO: should we add full-sisters?), while $\sigma_{g_{c,q},g_{c,w}}$ is a -counterpart to $n_w \sigma_{{g_q},{g_w}}$. If this is so, then it fells that we -should have 3 more inputs for genetic part, so 4 inputs to estimate 3 unknowns -of which some are very simple transformations!!! +```{r example_mean} +founderGenomes <- quickHaplo(nInd = 20, nChr = 16, segSites = 1000) +SP <- SimParamBee$new(founderGenomes) +SP$nWorkers = nW +SP$nFathers = nF +nQtlPerChr <- 100 +mean <- c(0, 0) +varA <- c(calcIndValues$varA_q, calcIndValues$varA_w) +corA <- matrix(data = c( 1.0, calcIndValues$corA_qw, + calcIndValues$corA_qw, 1.0), nrow = 2, byrow = TRUE) +SP$addTraitA(nQtlPerChr = nQtlPerChr, mean = mean, var = varA, corA = corA, + name = c("queenTrait", "workersTrait")) +varE <- c(calcIndValues$varE_q, calcIndValues$varE_w) +corE <- matrix(data = c(1.0, calcIndValues$corE_qw, + calcIndValues$corE_qw, 1.0), nrow = 2, byrow = TRUE) +SP$setVarE(varE = varE, corE = corE) +basePop <- createVirginQueens(founderGenomes, n = 20) -Additional input could be $\sigma^2_{p_c}$. For sure we don't get estimates of -$\sigma^2_{p_c} = \sigma^2_{p_{c,q}} + \sigma^2_{p_{c,w}} + 2\sigma_{p_{c,q},p_{c,w}}$, -but, having sorted the genetic part and if $B2_p$ and $B3_p$ depend only on -genetic covariance, then maybe, we have some maneuvering space to estimate also -$\sigma^2_{p_q}$, $\sigma^2_{p_w}$, and $\sigma^2_{{p_q},{p_w}}$?! +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) -Furthermore, we have some constraints, so this is not just any system of -equations. For example, we know that variances must be positive. Futhermore, we -might know that come covariances are either positive or negative. +# Get the realised numbers +real_A_q <- calcColonyGv(apiary, mapCasteToColonyGv, queenTrait = 1, workersTrait = NULL) +real_varA_q <- popVar(real_A_q) +real_A_wbar <- calcColonyGv(apiary, mapCasteToColonyGv, queenTrait = NULL, workersTrait = 2, workersFUN = colSums) +real_varA_wbar <- popVar(real_A_wbar) +real_A_c <- calcColonyGv(apiary, mapCasteToColonyGv, queenTrait = 1, workersTrait = 2, workersFUN = colSums) +real_varA_c <- popVar(real_A_c) + +real_P_q <- calcColonyPheno(apiary, mapCasteToColonyPheno, queenTrait = 1, workersTrait = NULL) +real_E_q <- real_P_q - real_A_q +real_varE_q <- popVar(real_E_q) +real_P_wbar <- calcColonyPheno(apiary, mapCasteToColonyPheno, queenTrait = NULL, workersTrait = 2, workersFUN = colSums) +real_E_wbar <- real_P_wbar - real_A_wbar +real_varE_wbar <- popVar(real_E_wbar) +real_P_c <- calcColonyPheno(apiary, mapCasteToColonyPheno, queenTrait = 1, workersTrait = 2, workersFUN = colSums) +real_E_c <- real_P_c - real_A_c +real_varE_c <- popVar(real_E_c) + +variances <- data.frame(set_varA_q = varA_q, real_varA_q = real_A_q[1,1], + set_varA_wbar = varA_wbar, real_varA_wbar = real_varA_wbar[1,1], + real_varA_c = real_varA_c[1,1], + set_varE_q = varE_q, real_varE_q = real_varE_q[1,1], + set_varE_wbar = varE_wbar, real_varE_wbar = real_varE_wbar[1,1], + real_varE_c = real_varE_c[1,1], + fun = "sum") + +# Plot the results +variancesLong <- variances %>% + tidyr::pivot_longer(cols = -c(fun), names_to = "VarType", values_to = "Var") +variancesLong$RealCalc <- sapply(strsplit(as.character(variancesLong$VarType), "_"), "[", 1) +# Extract the second and third elements and paste them together to get the variance type for plotting +variancesLong$VarTypePlot <- paste0(sapply(strsplit(as.character(variancesLong$VarType), "_"), "[", 2), "_", sapply(strsplit(as.character(variancesLong$VarType), "_"), "[", 3)) + +variancesLong$VarTypePlot <- factor(variancesLong$VarTypePlot, levels = c("varA_q", "varA_wbar", "varA_c", + "varE_q", "varE_wbar", "varE_c")) + +variancesLong |> filter(VarTypePlot %in% c("varA_q", "varA_wbar", "varE_q", "varE_wbar")) |> + ggplot(aes(x = VarTypePlot, y = Var, fill = RealCalc)) + + geom_col(position = "dodge") + + facet_wrap(. ~fun, scales = "free") + + theme_bw(base_size = 20) + + scale_fill_manual(values = c("#D55E00", "#084159")) # one color per RealCalc level (set/real) +``` -TODO: Develop and polish all this further and create a Shiny application where -we can change these individual-level parameters and study how that will change -colony-level parameters and then how we could go the other way around based on -literature and solving the above systems of equations. We could host such a -Shiny app on SIMplyBee.info!? Can we? +# References diff --git a/vignettes/F2_Variance_calculations_functions.Rmd b/vignettes/F2_Variance_calculations_functions.Rmd new file mode 100644 index 00000000..e41b391f --- /dev/null +++ b/vignettes/F2_Variance_calculations_functions.Rmd @@ -0,0 +1,605 @@ +--- +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 load_variance_scripts, include = FALSE} +# load shared variance helper functions +source("vignettes/scripts/variance_functions.R") +library("SIMplyBee") +library("dplyr") +library("ggplot2") +``` + +Let's again run the example from the quantitative genetic vignette. + +```{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 a MEAN +# When the function to summarise worker effects is SUM +calcVar <- mapIndToColonyVar(varA_q = varA[1], + varA_w= varA[2], + corA_qw = corA[1,2], + varE_q = varE[1], + varE_w = varE[2], + corE_qw = corE[1,2], + nW = nW, nF = nF, + nDPQ = nDPQ, + workersFUN = "mean") + +# Let's obtain realised values +real_gv_q <- calcColonyGv(apiary, FUN = mapCasteToColonyGv, queenTrait = 1, workersTrait = NULL) +real_pheno_q <- calcColonyPheno(apiary, FUN = mapCasteToColonyPheno, queenTrait = 1, workersTrait = NULL) +real_e_q <- real_pheno_q - real_gv_q +real_gv_wbar <- calcColonyGv(apiary, FUN = mapCasteToColonyGv, queenTrait = NULL, workersTrait = 2, workersFUN = colMeans) +real_pheno_wbar <- calcColonyPheno(apiary, FUN = mapCasteToColonyPheno, queenTrait = NULL, workersTrait = 2, workersFUN = colMeans) +real_e_wbar <- real_pheno_wbar - real_gv_wbar +real_gv_c <- calcColonyGv(apiary, FUN = mapCasteToColonyGv, queenTrait = 1, workersTrait = 2, workersFUN = colMeans) +real_pheno_c <- calcColonyPheno(apiary, FUN = mapCasteToColonyPheno, queenTrait = 1, workersTrait = 2, workersFUN = colMeans) +real_e_c <- real_pheno_c - real_gv_c + + +# Now let's compute the realised variances and covariances +real_varA_q <- var(real_gv_q) +real_varA_wbar <- var(real_gv_wbar) +real_varA_c <- var(real_gv_c) + +real_varE_q <- var(real_e_q) +real_varE_wbar <- var(real_e_wbar) +real_varE_c <- var(real_e_c) + +real_varP_q <- var(real_pheno_q) +real_varP_wbar <- var(real_pheno_wbar) +real_varP_c <- var(real_pheno_c) + +real_covA_qwbar <- cov(real_gv_q, real_gv_wbar) +real_corA_qwbar <- cor(real_gv_q, real_gv_wbar) + +variances0 <- data.frame(calc_varA_q = calcVar$varA_q, real_varA_q = real_varA_q[1,1], + calc_varA_wbar = calcVar$varA_wbar, real_varA_wbar = real_varA_wbar[1,1], + calc_varA_c = calcVar$varA_c, real_varA_c = real_varA_c[1,1], + calc_varE_c = calcVar$varE_c, real_varE_c = real_varE_c[1,1], + fun = "mean") + + + + +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) + + +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") + +# Let's obtain realised values +real_gv_q <- calcColonyGv(apiary, FUN = mapCasteToColonyGv, queenTrait = 1, workersTrait = NULL) +real_pheno_q <- calcColonyPheno(apiary, FUN = mapCasteToColonyPheno, queenTrait = 1, workersTrait = NULL) +real_e_q <- real_pheno_q - real_gv_q +real_gv_wbar <- calcColonyGv(apiary, FUN = mapCasteToColonyGv, queenTrait = NULL, workersTrait = 2, workersFUN = colSums) +real_pheno_wbar <- calcColonyPheno(apiary, FUN = mapCasteToColonyPheno, queenTrait = NULL, workersTrait = 2, workersFUN = colSums) +real_e_wbar <- real_pheno_wbar - real_gv_wbar +real_gv_c <- calcColonyGv(apiary, FUN = mapCasteToColonyGv, queenTrait = 1, workersTrait = 2, workersFUN = colSums) +real_pheno_c <- calcColonyPheno(apiary, FUN = mapCasteToColonyPheno, queenTrait = 1, workersTrait = 2, workersFUN = colSums) +real_e_c <- real_pheno_c - real_gv_c + + +# Now let's compute the realised variances and covariances +real_varA_q <- var(real_gv_q) +real_varA_wbar <- var(real_gv_wbar) +real_varA_c <- var(real_gv_c) + +real_varE_q <- var(real_e_q) +real_varE_wbar <- var(real_e_wbar) +real_varE_c <- var(real_e_c) + +real_varP_q <- var(real_pheno_q) +real_varP_wbar <- var(real_pheno_wbar) +real_varP_c <- var(real_pheno_c) + +real_covA_qwbar <- cov(real_gv_q, real_gv_wbar) +real_corA_qwbar <- cor(real_gv_q, real_gv_wbar) + +variances0 <- rbind(variances0, data.frame(calc_varA_q = calcVar$varA_q, real_varA_q = real_varA_q[1,1], + calc_varA_wbar = calcVar$varA_wbar, real_varA_wbar = real_varA_wbar[1,1], + calc_varA_c = calcVar$varA_c, real_varA_c = real_varA_c[1,1], + calc_varE_c = calcVar$varE_c, real_varE_c = real_varE_c[1,1], + fun = "sum")) + +# Plot the variances0 from the two different ways of aggregating worker effects +variances0Long <- variances0 %>% + tidyr::pivot_longer(cols = -c(fun), names_to = "VarType", values_to = "Var") +variances0Long$Component <- sapply(strsplit(as.character(variances0Long$VarType), "_"), "[", 2) +variances0Long$RealCalc <- sapply(strsplit(as.character(variances0Long$VarType), "_"), "[", 1) +# Now extract the second and the third element and paste them together to get the type of variance for plotting +variances0Long$VarTypePlot <- paste0(sapply(strsplit(as.character(variances0Long$VarType), "_"), "[", 2), "_", sapply(strsplit(as.character(variances0Long$VarType), "_"), "[", 3)) +variances0Long$Measure <- sapply(strsplit(as.character(variances0Long$VarTypePlot), "_"), "[", 1) + +variances0Long$VarTypePlot <- factor(variances0Long$VarTypePlot, levels = c("varA_q", "varA_wbar", "varA_c", + "varE_c", "varP_c")) + + +variances0Long |> + ggplot(aes(x = VarTypePlot, y = Var, fill = VarTypePlot, alpha = RealCalc)) + + geom_col(position = "dodge") + + facet_wrap(. ~fun, scales = "free") + + theme_bw(base_size = 20) + + scale_fill_manual(values = c( + "#D55E00", # vermillion + "#084159", # blue + "#32c237", + "#b560b4", + "#a80805", # reddish purple + "grey", # bluish green + "black", "black", "black" + ), guide = "none") + + scale_alpha_manual(values = c(0.5, 1), labels = c("Calculated", "Realised")) +``` + +Now the other way around. Let's say you have a colony-level estimate of variance components - this is what you would get out of a paper. + +```{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 = "mean") +calc_var_c <- mapIndToColonyVar(varA_q = indVarComp$varA_q, varA_w = indVarComp$varA_w, corA_qw = indVarComp$corA_qw, + varE_q = indVarComp$varE_q, varE_w = indVarComp$varE_w, corE_qw = indVarComp$corE_qw, + nW = nW, nF = nF, nDPQ = nDPQ, workersFUN = "mean") + +founderGenomes <- quickHaplo(nInd = 20, nChr = 16, segSites = 1000) +SP <- SimParamBee$new(founderGenomes) +SP$nWorkers = nW +SP$nFathers = nF +nQtlPerChr <- 100 +mean <- c(0, 0) +varA <- c(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) + + +# Get the real number of fathers and DPQs +real_A_q <- calcColonyGv(apiary, mapCasteToColonyGv, queenTrait = 1, workersTrait = NULL) +real_varA_q <- popVar(real_A_q) +real_A_wbar <- calcColonyGv(apiary, mapCasteToColonyGv, queenTrait = NULL, workersTrait = 2, workersFUN = colMeans) +real_varA_wbar <- popVar(real_A_wbar) +real_A_c <- calcColonyGv(apiary, mapCasteToColonyGv, queenTrait = 1, workersTrait = 2, workersFUN = colMeans) +real_varA_c <- popVar(real_A_c) + +real_P_q <- calcColonyPheno(apiary, mapCasteToColonyPheno, queenTrait = 1, workersTrait = NULL) +real_E_q <- real_P_q - real_A_q +real_varE_q <- popVar(real_E_q) +real_P_wbar <- calcColonyPheno(apiary, mapCasteToColonyPheno, queenTrait = NULL, workersTrait = 2, workersFUN = colMeans) +real_E_wbar <- real_P_wbar - real_A_wbar +real_varE_wbar <- popVar(real_E_wbar) +real_P_c <- calcColonyPheno(apiary, mapCasteToColonyPheno, queenTrait = 1, workersTrait = 2, workersFUN = colMeans) +real_E_c <- real_P_c - real_A_c +real_varE_c <- popVar(real_E_c) + +variances <- data.frame(set_varA_q = varA_q, calc_varA_q = calc_var_c$varA_q, real_varA_q = varA_q, + set_varA_wbar = varA_wbar, calc_varA_wbar = calc_var_c$varA_wbar, real_varA_wbar = real_varA_wbar[1,1], + calc_varA_c = calc_var_c$varA_c, real_varA_c = real_varA_c, + set_varE_q = varE_q, calc_varE_q = calc_var_c$varE_q, real_varE_q = real_varE_q[1,1], + set_varE_wbar = varE_wbar, calc_varE_wbar = calc_var_c$varE_wbar, real_varE_wbar = real_varE_wbar[1,1], + calc_varE_c = calc_var_c$varE_c, real_varE_c = real_varE_c, + fun = "mean") + + +print("Workers aggregate is a sum") +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 = "sum") +calc_var_c <- mapIndToColonyVar(varA_q = indVarComp$varA_q, varA_w = indVarComp$varA_w, corA_qw = indVarComp$corA_qw, + varE_q = indVarComp$varE_q, varE_w = indVarComp$varE_w, corE_qw = indVarComp$corE_qw, + nW = nW, nF = nF, nDPQ = nDPQ, workersFUN = "sum") + +founderGenomes <- quickHaplo(nInd = 20, nChr = 16, segSites = 1000) +SP <- SimParamBee$new(founderGenomes) +SP$nWorkers = nW +SP$nFathers = nF +nQtlPerChr <- 100 +mean <- c(0, 0) +varA <- c(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) + +# Get the real number of fathers and DPQs +real_A_q <- calcColonyGv(apiary, mapCasteToColonyGv, queenTrait = 1, workersTrait = NULL) +real_varA_q <- popVar(real_A_q) +real_A_wbar <- calcColonyGv(apiary, mapCasteToColonyGv, queenTrait = NULL, workersTrait = 2, workersFUN = colSums) +real_varA_wbar <- popVar(real_A_wbar) +real_A_c <- calcColonyGv(apiary, mapCasteToColonyGv, queenTrait = 1, workersTrait = 2, workersFUN = colSums) +real_varA_c <- popVar(real_A_c) + +real_P_q <- calcColonyPheno(apiary, mapCasteToColonyPheno, queenTrait = 1, workersTrait = NULL) +real_E_q <- real_P_q - real_A_q +real_varE_q <- popVar(real_E_q) +real_P_wbar <- calcColonyPheno(apiary, mapCasteToColonyPheno, queenTrait = NULL, workersTrait = 2, workersFUN = colSums) +real_E_wbar <- real_P_wbar - real_A_wbar +real_varE_wbar <- popVar(real_E_wbar) +real_P_c <- calcColonyPheno(apiary, mapCasteToColonyPheno, queenTrait = 1, workersTrait = 2, workersFUN = colSums) +real_E_c <- real_P_c - real_A_c +real_varE_c <- popVar(real_E_c) + +variances <- rbind(variances, data.frame(set_varA_q = varA_q, calc_varA_q = calc_var_c$varA_q, real_varA_q = varA_q, + set_varA_wbar = varA_wbar, calc_varA_wbar = calc_var_c$varA_wbar, real_varA_wbar = real_varA_wbar[1,1], + calc_varA_c = calc_var_c$varA_c, real_varA_c = real_varA_c, + set_varE_q = varE_q, calc_varE_q = calc_var_c$varE_q, real_varE_q = real_varE_q[1,1], + set_varE_wbar = varE_wbar, calc_varE_wbar = calc_var_c$varE_wbar, real_varE_wbar = real_varE_wbar[1,1], + calc_varE_c = calc_var_c$varE_c, real_varE_c = real_varE_c, + fun = "sum")) +``` + +Now plot. + +```{r plotMapColonyToIndFunction} +# Plot the variances from the two different ways of aggregating worker effects +variancesLong <- variances %>% + tidyr::pivot_longer(cols = -c(fun), names_to = "VarType", values_to = "Var") +variancesLong$Component <- sapply(strsplit(as.character(variancesLong$VarType), "_"), "[", 2) +variancesLong$RealCalc <- sapply(strsplit(as.character(variancesLong$VarType), "_"), "[", 1) +# Now extract the second and the third element and paste them together to get the type of variance for plotting +variancesLong$VarTypePlot <- paste0(sapply(strsplit(as.character(variancesLong$VarType), "_"), "[", 2), "_", sapply(strsplit(as.character(variancesLong$VarType), "_"), "[", 3)) +variancesLong$Measure <- sapply(strsplit(as.character(variancesLong$VarTypePlot), "_"), "[", 1) + +variancesLong$VarTypePlot <- factor(variancesLong$VarTypePlot, levels = c("varA_q", "varA_wbar", "varA_c", + "varE_q", "varE_wbar", "varE_c")) + + +variancesLong |> + ggplot(aes(x = VarTypePlot, y = Var, fill = RealCalc)) + + geom_col(position = "dodge") + + facet_wrap(. ~fun, scales = "free") + + theme_bw(base_size = 20) + + scale_fill_manual(values = c( + "#D55E00", # vermillion + "#084159", # blue + "#32c237", + "#b560b4", + "#a80805", # reddish purple + "grey", # bluish green + "black", "black", "black" + )) + + scale_alpha_manual(values = c(0.5, 1, 0.75), labels = c("Calculated", "Realised", "Set")) +``` \ No newline at end of file diff --git a/vignettes/F_Quantitative_Genetics.Rmd b/vignettes/F_Quantitative_Genetics.Rmd index 6d6d2755..e24e0ae1 100644 --- a/vignettes/F_Quantitative_Genetics.Rmd +++ b/vignettes/F_Quantitative_Genetics.Rmd @@ -2,6 +2,7 @@ title: "Quantitative genetics" date: "`r Sys.Date()`" output: rmarkdown::html_vignette +bibliography: '`r normalizePath(if (file.exists("../inst/REFERENCES.bib")) "../inst/REFERENCES.bib" else system.file("REFERENCES.bib", package = "SIMplyBee", mustWork = TRUE), winslash = "/", mustWork = TRUE)`' vignette: > %\VignetteIndexEntry{Quantitative genetics} %\VignetteEngine{knitr::rmarkdown} @@ -124,7 +125,7 @@ all the other trait simulation options in AlphaSimR via: `vignette(topic = "traits", package="AlphaSimR")`. ```{r SimParamBee_corA_and_addTrait} -corA <- matrix(data = c( 1.0, -0.5, +corA <- matrix(data = c( 1.0, -0.5, -0.5, 1.0), nrow = 2, byrow = TRUE) SP$addTraitA(nQtlPerChr = nQtlPerChr, mean = mean, var = varA, corA = corA, name = c("queenTrait", "workersTrait")) @@ -139,7 +140,7 @@ simulation scenarios of interest. ```{r SimParamBee_varE_and_corR} varE <- c(3, 3 / SP$nWorkers) -corE <- matrix(data = c(1.0, 0.3, +corE <- matrix(data = c(1.0, 0.3, 0.3, 1.0), nrow = 2, byrow = TRUE) SP$setVarE(varE = varE, corE = corE) ``` @@ -173,7 +174,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 +279,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 @@ -436,9 +437,9 @@ nQtlPerChr <- 100 # Quantitative genetic parameters - for two traits, each with the queen and workers effects meanP <- c(10, 10 / SP$nWorkers, 0, 0) varA <- c(1, 1 / SP$nWorkers, 1, 1 / SP$nWorkers) -corA <- matrix(data = c( 1.0, -0.5, 0.0, 0.0, +corA <- matrix(data = c( 1.0, -0.5, 0.0, 0.0, -0.5, 1.0, 0.0, 0.0, - 0.0, 0.0, 1.0, -0.4, + 0.0, 0.0, 1.0, -0.4, 0.0, 0.0, -0.4, 1.0), nrow = 4, byrow = TRUE) SP$addTraitA(nQtlPerChr = 100, mean = meanP, var = varA, corA = corA, name = c("yieldQueenTrait", "yieldWorkersTrait", @@ -459,8 +460,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 +496,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", @@ -569,7 +569,7 @@ nWorkers <- 100 mean <- c(nWorkers, 10, 10 / nWorkers) varA <- c(25, 1, 1 / nWorkers) corA <- matrix(data = c(1.0, 0.0, 0.0, - 0.0, 1.0, -0.5, + 0.0, 1.0, -0.5, 0.0, -0.5, 1.0), nrow = 3, byrow = TRUE) SP$addTraitA(nQtlPerChr = 100, mean = mean, var = varA, corA = corA, name = c("fecundityQueenTrait", "yieldQueenTrait", "yieldWorkersTrait")) @@ -587,8 +587,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 +614,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 +630,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..103ab02d --- /dev/null +++ b/vignettes/H_Parallelisation.Rmd @@ -0,0 +1,172 @@ +--- +title: "Parallelisation and high-performing cluster setup" +date: "`r Sys.Date()`" +output: rmarkdown::html_vignette +vignette: > + %\VignetteIndexEntry{Parallelisation and high-performing cluster setup} + %\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) + +NWORKERS <- 8 # Choose a worker count within your allocated resources + +# Choose ONE backend (each plan() call replaces the previous plan) +plan(sequential) # Default: no parallel workers +# plan(multicore, workers = NWORKERS) # Forking, where supported +# plan(multisession, workers = NWORKERS) # Separate local R processes (PSOCK) +# plan(cluster, workers = c("machine1", "machine2")) # Remote R processes + +# Run your simulation here, then stop the parallel backend +plan(sequential) +``` + +# 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 mentioned in the quick set-up, there are four different +options to the `plan` function: no parallelisation (`sequential`), forking +(`multicore`), PSOCK (`multisession`), and running R processes on multiple +machines (`cluster`). You can read more about these options in the `future` +documentation (). + +The two parallelisation controls have different roles: + +- `future::plan()` selects the backend and worker count for colony operations + implemented with `future_lapply()`. +- `SP$nThreads` controls native threads in supported SIMplyBee and AlphaSimR + routines. Setting it does not create or configure future workers. + +When using multiple workers, `SP$nThreads <- 1L` is a useful starting point to +avoid requesting multiple native threads inside each worker. Choose worker and +thread counts together to fit the resources allocated to your simulation. +The following setup is shown without execution during vignette rendering. + +```{r nThread_setup, eval=FALSE} +library(package = "SIMplyBee") +library(package = "future") + +# Set the desired number of workers within your allocated resources +plan(multisession, workers = 8) +# Alternatively, replace the preceding line with: +# plan(multisession, workers = availableCores()) + +founderGenomes <- quickHaplo(nInd = 30, nChr = 1, segSites = 100) +SP <- SimParamBee$new(founderGenomes) +SP$nThreads <- 1L # Native threads, independently of the future worker count + +# Run your simulation here, then release the workers +plan(sequential) +``` + +Two mechanisms used by these backends are `FORK` and `PSOCK`. +The forking (`FORK`) creates subprocesses that share memory and objects with the +parent process, which means it's very efficient! However, such parallelisation +is not supported on Windows. On an HPC cluster, follow the site's policy and +scheduler allocation when choosing a backend and worker count. + +The alternative, PSOCK, can be used on all system, but it works by creating a +separate R process for each subprocess (that communicate through sockets), +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 = 20, nChr = 1, segSites = 50) + SP <- SimParamBee$new(founderGenomes) + + basePop <- createVirginQueens(founderGenomes) + drones = createDrones(basePop, nInd = 100) + baseColonies <- createMultiColony(cross(basePop, drones = drones, crossPlan = "create")) + baseColonies <- buildUp(baseColonies, nWorkers = 10, nDrones = 10) + 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 +nCores = 1 +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("parallelisation_time_mean.png") +``` + +```{r meanPCPU_figure, echo=FALSE, out.width='100%'} +knitr::include_graphics("parallelisation_cpu_mean.png") +``` + +```{r meanRSS_figure, echo=FALSE, out.width='100%'} +knitr::include_graphics("parallelisation_memory_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("parallelisation_function_timings_unix.png") +``` diff --git a/vignettes/colony_locations.csv b/vignettes/colony_locations.csv new file mode 100644 index 00000000..443bd664 --- /dev/null +++ b/vignettes/colony_locations.csv @@ -0,0 +1,101 @@ +ColonyID,X,Y +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/parallelisation_cpu_mean.png b/vignettes/parallelisation_cpu_mean.png new file mode 100644 index 00000000..5b3949aa Binary files /dev/null and b/vignettes/parallelisation_cpu_mean.png differ diff --git a/vignettes/parallelisation_function_timings_unix.png b/vignettes/parallelisation_function_timings_unix.png new file mode 100644 index 00000000..b3111150 Binary files /dev/null and b/vignettes/parallelisation_function_timings_unix.png differ diff --git a/vignettes/parallelisation_memory_mean.png b/vignettes/parallelisation_memory_mean.png new file mode 100644 index 00000000..2d2f5975 Binary files /dev/null and b/vignettes/parallelisation_memory_mean.png differ diff --git a/vignettes/parallelisation_time_mean.png b/vignettes/parallelisation_time_mean.png new file mode 100644 index 00000000..7bad43bc Binary files /dev/null and b/vignettes/parallelisation_time_mean.png differ diff --git a/vignettes/scripts/variance_functions.R b/vignettes/scripts/variance_functions.R new file mode 100644 index 00000000..ea99f1d8 --- /dev/null +++ b/vignettes/scripts/variance_functions.R @@ -0,0 +1,135 @@ +# Shared helper functions for variance calculations vignette + +# cor2cov: convert correlation matrix (or vector) and variances to covariance matrix +cor2cov <- function(corr, var) { + corr <- as.matrix(corr) + var <- as.numeric(var) + sd <- sqrt(var) + cov <- corr * (sd %o% sd) + return(cov) +} + +# mapIndToColonyVar: map individual-level variances/covariances to colony-level +mapIndToColonyVar <- function(varA_q, varA_w, corA_qw, + varE_q, varE_w, corE_qw, + nW, nF, nDPQ, workersFUN = "sum") { + + if (!workersFUN %in% c("sum", "mean")) { + stop("Invalid value for workersFUN. We currently only support either 'sum' or 'mean'.") + } + + # Pair counts + n_SS <- (nW * nW / nF) - nW + n_FS <- (nW * nW / nDPQ) - (nW * nW / nF) + n_HS <- (nW * nW / nDPQ) * (nDPQ - 1) + + if (workersFUN == "mean") { + B1 = 1 / nW * varA_w + } else if (workersFUN == "sum") { + B1 = nW * varA_w + } + + B2_ss <- n_SS * 0.75 * varA_w + B2_fs <- n_FS * 0.50 * varA_w + B2_hs <- n_HS * 0.25 * varA_w + + if (workersFUN == "mean") { + varA_wbar = B1 + 1/nW^2 * (B2_ss + B2_fs + B2_hs) + } else if (workersFUN == "sum") { + varA_wbar = B1 + B2_ss + B2_fs + B2_hs + } + + covA_qw = corA_qw * sqrt(varA_q) * sqrt(varA_w) + + if (workersFUN == "mean") { + covA_qwbar <- covA_qw + } else if (workersFUN == "sum") { + covA_qwbar <- nW * covA_qw + } + corA_qwbar <- covA_qwbar / (sqrt(varA_q) * sqrt(varA_wbar)) + + varA_c <- varA_q + varA_wbar + 2*covA_qwbar + + # Environmental part + if (workersFUN == "mean") { + varE_wbar = 1 / nW * varE_w + } else if (workersFUN == "sum") { + varE_wbar = nW * varE_w + } + + covE_qw = corE_qw * sqrt(varE_q) * sqrt(varE_w) + + if (workersFUN == "mean") { + covE_qwbar <- covE_qw + } else if (workersFUN == "sum") { + covE_qwbar <- nW * covE_qw + } + corE_qwbar <- covE_qwbar / (sqrt(varE_q) * sqrt(varE_wbar)) + + varE_c <- varE_q + varE_wbar + 2*covE_qwbar + + return(list(varA_q = varA_q, varA_wbar = varA_wbar, covA_qwbar = covA_qwbar, corA_qwbar = corA_qwbar, varA_c = varA_c, + varE_q = varE_q, varE_wbar = varE_wbar, covE_qwbar = covE_qwbar, corE_qwbar = corE_qwbar, varE_c = varE_c)) +} + +# mapColonyToIndVar: map colony-level variance components back to individual-level +mapColonyToIndVar <- function(varA_q, + varA_wbar, + corA_qwbar, + varE_q, + varE_wbar, + corE_qwbar, + nW, + nF, + nDPQ, + workersFUN = "sum") { + + if (!workersFUN %in% c("sum", "mean")) { + stop("Invalid value for workersFUN. We currently only support either 'sum' or 'mean'.") + } + + covA_qwbar <- corA_qwbar * sqrt(varA_q) * sqrt(varA_wbar) + + if (workersFUN == "sum") { + covA_qw <- covA_qwbar / nW + } else if (workersFUN == "mean") { + covA_qw <- covA_qwbar + } + + n_SS <- (nW * nW / nF) - nW + n_FS <- (nW * nW / nDPQ) - (nW * nW / nF) + n_HS <- (nW * nW / nDPQ) * (nDPQ - 1) + + if (workersFUN == "sum") { + K <- nW + + n_SS * 0.75 + + n_FS * 0.50 + + n_HS * 0.25 + } else if (workersFUN == "mean") { + K <- 1 / nW + ((n_SS * 0.75 + + n_FS * 0.50 + + n_HS * 0.25) / nW^2) + } + + varA_w <- varA_wbar / K + + corA_qw <- covA_qw / (sqrt(varA_q) * sqrt(varA_w)) + + # Environmental part + covE_qwbar <- corE_qwbar * sqrt(varE_q) * sqrt(varE_wbar) + + if (workersFUN == "sum") { + varE_w <- varE_wbar / nW + covE_qw <- covE_qwbar / nW + } else if (workersFUN == "mean") { + varE_w <- varE_wbar * nW + covE_qw <- covE_qwbar + } + + corE_qw <- covE_qw / (sqrt(varE_q) * sqrt(varE_w)) + + return(list(varA_q = varA_q, varA_wbar = varA_wbar, varA_w = varA_w, + covA_qwbar = covA_qwbar, covA_qw = covA_qw, corA_qw = corA_qw, + varE_q = varE_q, varE_wbar = varE_wbar, varE_w = varE_w, + covE_qwbar = covE_qwbar, covE_qw = covE_qw, corE_qw = corE_qw)) +}