diff --git a/PR132_REVIEW_PLAN.md b/PR132_REVIEW_PLAN.md new file mode 100644 index 0000000..0c6c3aa --- /dev/null +++ b/PR132_REVIEW_PLAN.md @@ -0,0 +1,261 @@ +# PR #132 API Review Plan + +## Pause handoff (2026-08-21) + +The review is deliberately paused at the start of variant iteration while +Gregor is away and until the intended user-facing design has been discussed +with Jinyang. This is a clean review boundary, not an indication that the +variant implementation has been approved. + +Completed review slices are node and remaining table-row access, table-row +appenders, tree-sequence sample access, table-collection sorting, and table- +collection/tree-sequence simplification. Their detailed notes are retained in +the companion review-plan files. + +The next work is **section 7, low-level variant iteration**. Resume with +iterator state, initialization, ownership, and cleanup in +`PR132_REVIEW_PLAN_variants.md`; then review decoding and exhaustion; only then +review the user-facing `TreeSequence$variants()` API. Do not restart the review +from the beginning of the PR. + +Before continuing, ask Jinyang for: + +- concise user-facing documentation for the intended variants workflow; +- one or two executable examples, including expected returned content and the + AlphaSimR use case; +- the intended public API and compatibility requirements, particularly which + iterator methods and arguments downstream code needs. + +The local review branch was clean at commit `ac89284` before this handoff note +was added. At that point it contained ten review commits beyond PR #132's head +commit `24509d1`, and the latest commit had not yet been pushed to Gregor's +`origin/lynx-clean-work`. PR #132 is open from +`LynxJinyangii:add-multiple-functions-on-pr-131` into +`HighlanderLab:main`; pushing this review branch to Gregor's fork does not by +itself update the PR. + +After variants are agreed and reviewed, complete section 9 cross-cutting +cleanup and all final quality gates. No final full-package quality-gate result +is claimed by this pause handoff. + +## Goal + +Review and polish PR #132 function by function before it is merged into +`HighlanderLab/RcppTskit`. + +For every API slice: + +- align the RcppTskit R API with the upstream tskit Python API; +- align the RcppTskit C++ API with the upstream tskit C API; +- document any intentional deviation; +- add or update examples and focused regression tests; +- update `RcppTskit/NEWS.md` for user-visible changes; +- regenerate exports and documentation rather than editing generated files; +- keep focused and full quality gates green. + +## Review method for each function + +### 1. Review the low-level C++ wrapper + +- Compare its name, arguments, defaults, return value, ownership rules, and + error handling with the corresponding tskit C function. +- Check conversions between `tsk_id_t`, `tsk_size_t`, flags, pointers, strings, + raw metadata, and R values. +- Check special values such as `TSK_NULL`, empty arrays, missing values, and + invalid indices. +- Use `const` for local values that are not modified, including converted row + indices and tskit return codes. +- Where the upstream row struct exposes an `id` field, return `row.id` rather + than reconstructing the ID from the input index. +- Confirm that the wrapper does not add unsupported semantics silently. + +### 2. Review the user-facing R method + +- Compare its name, arguments, defaults, return value, and error behaviour with + the corresponding tskit Python method. +- Prefer Python naming and semantics unless an R-specific deviation is clearly + justified. +- Document and test every intentional deviation. +- Check input validation and conversions before calling the C++ wrapper. + +### 3. Review tests and documentation + +- Test normal results and content, not only object types or lengths. +- Test boundary cases, empty inputs, special values, and invalid inputs. +- Add a concise user-facing example. +- Verify roxygen documentation and `NEWS.md` wording. + +## Function-by-function order + +### 1. Node table row access + +- [x] `rtsk_node_table_get_row()` against `tsk_node_table_get_row()` +- [x] `TableCollection$node_table_get_row()` against Python node-table row + access +- [x] Focused tests and documentation + +This is the first review target. It is small, establishes the table-row return +conventions used throughout the PR, and is used by `TreeSequence$samples()`. + +Review specifically: + +- all node fields and their R types; +- 0-based row IDs; +- `TSK_NULL` population and individual values; +- empty and nonempty metadata; +- first, last, negative, out-of-range, missing, and invalid indices; +- C error propagation; +- parity of the returned R object with the Python row object. + +### 2. Tree-sequence sample access + +- [x] `rtsk_treeseq_get_samples()` against `tsk_treeseq_get_samples()` +- [x] `TreeSequence$samples()` against `TreeSequence.samples()` +- [x] Omit Python's already-deprecated `population_id` alias from the new R API +- [x] Focused tests and documentation + +The completed review is recorded in `PR132_REVIEW_PLAN_samples.md`. + +### 3. Remaining table row accessors + +- [x] `individual_table_get_row()` +- [x] `edge_table_get_row()` +- [x] `site_table_get_row()` +- [x] `mutation_table_get_row()` +- [x] `population_table_get_row()` +- [x] `migration_table_get_row()` +- [x] `provenance_table_get_row()` + +For each entry, review the low-level `rtsk_*` wrapper first and then the +corresponding `TableCollection$*` method. As part of each C++ review, make +unmodified index and return-code locals `const`, and return the upstream row +struct's `id` field where that struct provides one. + +### 4. Table row appenders + +- [x] `individual_table_add_row()` +- [x] `node_table_add_row()` +- [x] `edge_table_add_row()` +- [x] `site_table_add_row()` +- [x] `mutation_table_add_row()` +- [x] `population_table_add_row()` +- [x] `migration_table_add_row()` +- [x] `provenance_table_add_row()` + +For each entry, review the low-level `rtsk_*` wrapper against the C API and the +corresponding `TableCollection$*` method against Python `add_row()`. + +### 5. Table collection sorting + +- [x] `rtsk_table_collection_sort()` against `tsk_table_collection_sort()` +- [x] `TableCollection$sort()` against `TableCollection.sort()` +- [x] Focused tests and documentation + +The completed review is recorded in `PR132_REVIEW_PLAN_sort.md`. It confirms +the intended C++/C and R/Python API parity, documents partial-sort constraints +and index invalidation, and adds focused safety and semantic tests. + +### 6. Table collection simplification + +- [x] `rtsk_table_collection_simplify()` against + `tsk_table_collection_simplify()` +- [x] `TableCollection$simplify()` against `TableCollection.simplify()` +- [x] Review every option bit and default +- [x] Replace or resolve the placeholder provenance record +- [x] Add focused tests for the currently uncovered option-building branches: + `reduce_to_site_topology = TRUE`, `keep_unary = TRUE`, + `keep_input_roots = TRUE`, `keep_unary_in_individuals = TRUE`, + `filter_nodes = FALSE`, and `update_sample_flags = FALSE`. Use a fresh + table collection for each case because `simplify()` mutates it, and test + the resulting semantics rather than only executing each branch. +- [x] Focused tests and documentation + +The completed review is recorded in `PR132_REVIEW_PLAN_simplify.md`. It +confirms all C option mappings and Python defaults, replaces the bare +placeholder provenance with a valid provenance-schema document, and tests the +semantic effect of every public option. + +### 6a. Tree-sequence simplification + +- [x] `TreeSequence$simplify()` against Python `TreeSequence.simplify()` +- [x] Preserve the input tree sequence and support `map_nodes` +- [x] Reuse the reviewed table-collection implementation rather than + duplicating option construction or adding an unnecessary C++ wrapper +- [x] Focused tests and documentation + +The completed review of both table-collection and tree-sequence simplification +is recorded in `PR132_REVIEW_PLAN_simplify.md`. + +### 7. Low-level variant iteration + +The detailed review and workstation handoff plan is recorded in +`PR132_REVIEW_PLAN_variants.md`. Start with iterator state, initialization, +ownership, and cleanup before reviewing decoding. + +- [ ] `rtsk_treeseq_init_variants_iterator()` against `tsk_variant_init()` +- [ ] `rtsk_treeseq_next_variant()` against `tsk_variant_decode()` and + `tsk_variant_t` +- [ ] Review memory ownership, preservation, cleanup, and iterator exhaustion +- [ ] Review samples, alleles, missing-data semantics, and genomic bounds +- [ ] Focused tests and documentation + +### 8. User-facing variant iteration + +- [ ] `TreeSequence$variants()` against `TreeSequence.variants()` +- [ ] Review arguments, defaults, return shape, copying, and iteration protocol +- [ ] Decide how closely the R iterator should mirror Python iteration +- [ ] Focused tests and documentation + +### 9. Cross-cutting cleanup + +- [ ] Review shared validators introduced or changed by the PR +- [ ] Confirm all reviewed C++ row getters consistently use `const` locals and + return `row.id` where the upstream row struct provides it +- [ ] Add a shared binary-metadata round-trip test using bytes such as + `as.raw(c(0x00, 0x7f, 0x80, 0xff))` for metadata-bearing row appenders + and getters +- [ ] Confirm consistent terminology, argument names, and error messages +- [ ] We have some C functions names rtsk_x while for some we have just x, + particulalry the internal functions - I guess internals are fine, but are there any non-internal functions that don't start as rtsk_x? +- [ ] Confirm examples are concise and executable +- [ ] Investigate and resolve the existing + `vignette 'RcppTskit_intro' not found` warning emitted by + `devtools::run_examples()`. +- [ ] Update `RcppTskit/NEWS.md` +- [ ] Regenerate Rcpp exports and roxygen documentation +- [ ] Review generated diffs for consistency only + +## Final quality gates + +- [ ] Run focused tests after each API slice +- [ ] Run `pre-commit run --all-files` +- [ ] Run `Rscript -e "setwd('RcppTskit'); devtools::test()"` +- [ ] Run `Rscript -e "setwd('RcppTskit'); devtools::check()"` +- [ ] Review the complete PR diff against `upstream/main` + +## Useful diff commands + +Review the PR without the additional local integration commit: + +```sh +git diff upstream/main...LynxJinyangii/add-multiple-functions-on-pr-131 +``` + +Review the combined local branch: + +```sh +git diff upstream/main...HEAD +``` + +Review the hand-written implementation and tests while initially excluding +generated exports and manuals: + +```sh +git diff upstream/main...HEAD -- \ + RcppTskit/R/Class-TableCollection.R \ + RcppTskit/R/Class-TreeSequence.R \ + RcppTskit/R/RcppTskit.R \ + RcppTskit/src/RcppTskit.cpp \ + RcppTskit/inst/include/RcppTskit_public.hpp \ + RcppTskit/tests/testthat/ +``` diff --git a/PR132_REVIEW_PLAN_samples.md b/PR132_REVIEW_PLAN_samples.md new file mode 100644 index 0000000..7a79ead --- /dev/null +++ b/PR132_REVIEW_PLAN_samples.md @@ -0,0 +1,234 @@ +# PR #132 Review: Tree-Sequence Sample Access + +## Status + +Review complete for the agreed scope. The low-level wrapper, single-call helper, +and user-facing filtering method have been reviewed and tested. + +This file records the review of: + +- `rtsk_treeseq_get_samples()` against `tsk_treeseq_get_samples()`; +- `TreeSequence$samples()` against Python `TreeSequence.samples()`. + +The direct low-level wrapper now guards the copy for a zero-sample tree +sequence. Focused tests cover empty and nonconsecutive sample sets and confirm +that the returned R vector is an independent copy. + +The review distinguishes correctness and API-parity fixes from optional +optimisation. The current per-sample filtering path is sufficiently expensive +to treat its replacement as part of this review rather than as a later +optimisation. + +## Low-level C++ wrapper + +Current implementation: + +```cpp +Rcpp::IntegerVector rtsk_treeseq_get_samples(SEXP ts) { + rtsk_treeseq_t ts_xptr(ts); + const tsk_id_t *samples = tsk_treeseq_get_samples(ts_xptr); + const tsk_size_t num_samples = tsk_treeseq_get_num_samples(ts_xptr); + Rcpp::IntegerVector out(num_samples); + if (num_samples > 0) { + std::copy_n(samples, num_samples, out.begin()); + } + return out; +} +``` + +The upstream C function returns a borrowed pointer owned by the tree sequence. +The wrapper correctly copies those IDs into R-owned memory. + +### Suggested changes + +- [x] Explicitly guard the copy when there are no samples: + + ```cpp + Rcpp::IntegerVector out(num_samples); + if (num_samples > 0) { + std::copy_n(samples, num_samples, out.begin()); + } + ``` + +- [x] Change the C API documentation link from `latest` to `stable`. +- [x] State that the returned vector is an R-owned copy of the borrowed C + array, and that IDs are returned in numerical order. + +### Suggested low-level tests + +- [x] A tree sequence with no samples returns `integer()`. +- [x] Nonconsecutive sample IDs are returned exactly and in order. +- [x] The returned R vector is an independent copy of tskit-owned memory. + +For copy independence: + +```r +samples1 <- rtsk_treeseq_get_samples(ts$xptr) +samples1[1] <- 999L +samples2 <- rtsk_treeseq_get_samples(ts$xptr) +expect_false(samples2[1] == 999L) +``` + +## User-facing R method + +Current signature: + +```r +samples = function(population = NULL, time = NULL) +``` + +Upstream Python signature: + +```python +samples(population=None, *, population_id=None, time=None) +``` + +## Finding 1: population validation + +The R method calls: + +```r +validate_row_index(population, "population", allow_null = TRUE) +``` + +This intentionally rejects `-1L`. Although Python filters by direct equality +and therefore permits `population=-1`, RcppTskit consistently treats public R +population IDs as non-negative, 0-based IDs. The value `-1`/`TSK_NULL` is +accepted only by methods that store an unknown population reference, not by a +method requesting an actual population ID. `NULL` means that no population +filter is applied. + +### Decision + +- [x] Retain non-negative row-index validation for `population`. +- [x] Document the intentional RcppTskit convention that negative population + IDs are unsupported. + +## Finding 2: infinite scalar time + +The former comparison was: + +```r +tol <- 1e-08 + 1e-05 * abs(time_num) +keep <- keep & (abs(sample_time - time_num) <= tol) +``` + +For `time = Inf`, both sides can become `Inf`, incorrectly selecting finite +sample times. Python `numpy.isclose(finite_value, Inf)` returns `FALSE`. + +### Implemented change + +- [x] Implement an internal vectorised comparison using NumPy's default + `isclose()` tolerances and explicit infinity handling. + + The method now calls + `numeric_values_are_close(sample_time, time)`, which implements the default + NumPy tolerances and handles equal infinities without matching finite values. + +- [x] Reject R `NA` and `NaN` through the shared argument validator so missing + values cannot produce missing IDs in the result. This is an intentional R + safety convention; Python accepts `NaN` and returns no matches. +- [x] Test scalar `Inf` and `-Inf` matching, and rejection of `NA_real_` and + `NaN`. + +The former `is.numeric()` check also accepted complex values and numeric arrays +or matrices. `TreeSequence$samples()` now uses the shared optional +numeric-vector validator with permitted lengths one and two. The validator +accepts ordinary integer or double vectors and rejects missing values and +shaped objects before the C++ helper is called. + +## Finding 3: filtering performance + +For either filter, the current implementation: + +1. copies the entire table collection using `dump_tables()`; +2. crosses the R/C++ boundary once for every sample; +3. allocates one row list for every sample; +4. retrieves metadata and node fields that filtering does not use. + +This is likely to scale poorly for large tree sequences. + +Python instead indexes directly into the node population and time columns. + +### Implemented design + +- [x] Add a separate internal C++ helper that retrieves sample node IDs, + populations, and times in a single call. +- [x] Keep `rtsk_treeseq_get_samples()` as a faithful wrapper of the C API; + do not overload it with Python-level filtering semantics. +- [x] Use the helper in `TreeSequence$samples()` to filter vectors without + copying all tables or constructing row lists. + +The internal interface is: + +```cpp +Rcpp::List rtsk_treeseq_get_sample_node_data(SEXP ts); +``` + +returning: + +```r +list( + samples = integer_vector, + population = integer_vector, + time = numeric_vector +) +``` + +The helper reads directly from the tree sequence's read-only node table in one +C++ call. It does not copy the full table collection or construct per-node row +lists. The public `rtsk_treeseq_get_samples()` remains the direct C API wrapper +and has not acquired filtering arguments. The helper is Rcpp-exported for +internal package use but intentionally omitted from `RcppTskit_public.hpp` +because it has no direct tskit C API counterpart. + +## Finding 4: deprecated `population_id` alias + +Python retains `population_id` as a deprecated alias for `population`. + +Because `TreeSequence$samples()` is new in RcppTskit, the current +recommendation is not to introduce an already-deprecated argument. This should +be recorded as an intentional omission. Deprecated aliases copied elsewhere in +PR #132 should be reconsidered during their respective reviews. + +- [x] Omit `population_id` because this is a new R API and the Python alias is + already deprecated. +- [x] Record this intentional omission in the main review plan. + +## Suggested R-method tests + +- [ ] Combined `population` and `time` filters. +- [ ] A population with no matching samples. +- [x] A negative population ID is rejected. +- [x] Scalar-time matching and tolerance behavior. +- [x] `Inf`, `-Inf`, `NA`, and `NaN` time inputs. +- [x] Time-interval filtering with an included lower bound. +- [ ] Time-interval upper bound is excluded. +- [ ] Empty filtered results remain `integer()`. +- [x] Filtered IDs remain in numerical order. +- [x] Complex, matrix, and array `time` inputs are rejected rather than + flattened or coerced with loss. +- [ ] A tree sequence containing no samples. +- [ ] On a tree sequence containing no samples, exercise population filtering + and confirm that the internal empty population vector branch returns + `integer(0)` and the public result remains `integer(0)`. +- [ ] On a tree sequence containing no samples, exercise time filtering and + confirm that the internal empty time vector branch returns `numeric(0)` + and the public result remains `integer(0)`. + +## Recommended implementation order + +1. [x] Harden and test the direct low-level `rtsk_treeseq_get_samples()` wrapper. +2. [x] Implement the single-call internal C++ sample-node-data helper. +3. [x] Switch `TreeSequence$samples()` to that helper for filtered calls. +4. [x] Correct population and time validation and filtering semantics. +5. [x] Complete the agreed content tests and concise documentation. Additional + boundary combinations are intentionally deferred because the current test + fixture does not expose them clearly. + +## Upstream references + +- C API: +- Python API: +- Python implementation: + diff --git a/PR132_REVIEW_PLAN_simplify.md b/PR132_REVIEW_PLAN_simplify.md new file mode 100644 index 0000000..9c2de70 --- /dev/null +++ b/PR132_REVIEW_PLAN_simplify.md @@ -0,0 +1,116 @@ +# PR #132 Review: c + +## Status + +Reviewed and implemented for both: + +- `rtsk_table_collection_simplify()` and `TableCollection$simplify()`; +- `TreeSequence$simplify()`. + +The review checks the C++ wrapper against the tskit C API and the two R methods +against their tskit Python counterparts. The implementation follows upstream +names, defaults, and semantics where practical, with R-specific return values +documented below. + +## Low-level C++ wrapper + +`rtsk_table_collection_simplify()` is the only new C++ simplify wrapper needed. +It calls `tsk_table_collection_simplify()` directly and: + +- distinguishes `samples = NULL` from an explicit `integer()`; `NULL` uses the + nodes currently marked as samples, whereas `integer()` requests no samples; +- converts R integer sample IDs to `tsk_id_t` values; +- allocates the node map to the node-table length before simplification; +- accepts only the nine supported table-simplify option flags; +- propagates tskit errors, including invalid and duplicate sample IDs; +- returns an R integer node map, using `-1` (`TSK_NULL`) for removed nodes. + +Tests cover option validation, invalid and duplicate samples, explicit empty +samples, equivalence of `NULL` to the currently flagged samples, node-map +contents, and index invalidation. + +## `TableCollection$simplify()` + +The method mutates its table collection in place and returns the node map. Its +public argument names and defaults follow Python +`TableCollection.simplify()`. Integer-valued numeric sample IDs are also +accepted as an intentional R convenience and safely converted to R integers. + +Python's `None` defaults are represented by `NULL`. They resolve as follows: + +- `filter_populations`, `filter_individuals`, `filter_sites`, `filter_nodes`, + and `update_sample_flags` resolve to `TRUE`; +- `keep_unary_in_individuals` resolves to `FALSE`. + +The R arguments map to C flags as follows: + +| R argument | C option when active | +| --- | --- | +| `filter_sites = TRUE` | `TSK_SIMPLIFY_FILTER_SITES` | +| `filter_populations = TRUE` | `TSK_SIMPLIFY_FILTER_POPULATIONS` | +| `filter_individuals = TRUE` | `TSK_SIMPLIFY_FILTER_INDIVIDUALS` | +| `reduce_to_site_topology = TRUE` | `TSK_SIMPLIFY_REDUCE_TO_SITE_TOPOLOGY` | +| `keep_unary = TRUE` | `TSK_SIMPLIFY_KEEP_UNARY` | +| `keep_input_roots = TRUE` | `TSK_SIMPLIFY_KEEP_INPUT_ROOTS` | +| `keep_unary_in_individuals = TRUE` | `TSK_SIMPLIFY_KEEP_UNARY_IN_INDIVIDUALS` | +| `filter_nodes = FALSE` | `TSK_SIMPLIFY_NO_FILTER_NODES` | +| `update_sample_flags = FALSE` | `TSK_SIMPLIFY_NO_UPDATE_SAMPLE_FLAGS` | + +`keep_unary` and `keep_unary_in_individuals` are rejected when both are true, +matching their incompatible upstream semantics. The obsolete +`filter_zero_mutation_sites` compatibility argument is intentionally absent. + +When requested, the method appends a provenance-schema 1.0.0 record containing +the RcppTskit version and normalised simplify arguments. No row is appended +when `record_provenance = FALSE`. + +Content tests use a fresh table collection for every mutating case and verify: + +- node-map contents and a smaller simplified topology; +- site-topology reduction; +- `keep_unary`, `keep_input_roots`, and `keep_unary_in_individuals`; +- population, individual, site, and node filtering; +- identity mapping when node filtering is disabled; +- unchanged flags when sample-flag updates are disabled; +- provenance enabled and disabled behavior. + +## `TreeSequence$simplify()` + +No separate `tsk_treeseq_simplify()` wrapper is required. Following the Python +method's high-level behavior, the R method copies the input tables, delegates +to the reviewed `TableCollection$simplify()`, and constructs a new tree +sequence. The input tree sequence is therefore unchanged, and option mapping +and provenance behavior remain centralised in one implementation. + +The arguments and defaults match the table-collection method, with the +addition of `map_nodes`. With `map_nodes = FALSE`, the method returns the new +`TreeSequence`. With `map_nodes = TRUE`, it returns a named list containing +`tree_sequence` and `node_map`, the natural R equivalent of Python's tuple. +Deprecated compatibility arguments never supported by RcppTskit are omitted. + +Tree-sequence tests verify: + +- the result is a new, smaller tree sequence and the input is unchanged; +- sample IDs and provenance behavior in the result; +- the conditional node-map return and map contents; +- invalid `map_nodes`, duplicate samples, and incompatible unary options; +- representative forwarding for `keep_unary` and `filter_nodes`. + +The detailed option semantics are tested once at table-collection level; the +tree-sequence tests intentionally focus on delegation and return behavior. + +## Audit conclusion + +The implementation, documentation, examples, NEWS entry, and tests agree on +the public contract. No simplify code changes are outstanding from this +review. + +## Upstream references + +- C API: +- Python `TableCollection.simplify()`: + +- Python `TreeSequence.simplify()`: + +- Provenance schema: + diff --git a/PR132_REVIEW_PLAN_sort.md b/PR132_REVIEW_PLAN_sort.md new file mode 100644 index 0000000..559d4a9 --- /dev/null +++ b/PR132_REVIEW_PLAN_sort.md @@ -0,0 +1,68 @@ +# PR #132 Review: Table-Collection Sorting + +## Status + +Reviewed and implemented. + +This file records the review of: + +- `rtsk_table_collection_sort()` against `tsk_table_collection_sort()`; +- `TableCollection$sort()` against Python `TableCollection.sort()`. + +The project-wide parity goal is to align the RcppTskit C++ API with the tskit +C API and the R API with the tskit Python API. Intentional R-specific +conveniences or deviations must be documented and tested. + +## Low-level C++ wrapper + +The wrapper constructs a `tsk_bookmark_t`, forwards its edge, site, and +mutation offsets and the supported `TSK_NO_CHECK_INTEGRITY` flag, mutates the +table collection in place, and translates tskit error codes to R errors. + +Changes made during review: + +- reject negative signed offsets before converting them to unsigned + `tsk_size_t` values; +- retain strict option validation so only `TSK_NO_CHECK_INTEGRITY` is accepted; +- make the unmodified tskit return code `const`; +- retain the explanatory error for unsupported site/mutation offset pairs; +- use stable upstream documentation links. + +Focused tests cover negative offsets, negative and unsupported options, the +edge upper-bound error, and supported boundary offsets. + +## User-facing R method + +The R signature mirrors Python's argument names and defaults: + +```r +sort = function(edge_start = 0L, site_start = 0L, mutation_start = 0L) +``` + +R cannot enforce Python's keyword-only marker for `site_start` and +`mutation_start`. As an intentional R convenience consistent with the rest of +RcppTskit, integer-valued numeric scalars are accepted and safely converted to +32-bit integers after validation. + +The documentation now states that: + +- `edge_start` may range from zero through the edge-table length; +- site and mutation sorting can only be skipped together, by setting both + offsets to their respective table lengths; +- rows before `edge_start` must already be sorted; +- sorting is in place and invalidates existing indexes; +- node, individual, population, and provenance tables are unaffected. + +The example demonstrates converting an unsorted table collection into a valid +tree sequence. Focused tests check the invisible return value, integer-valued +numeric inputs, successful full sorting, site ordering, creation of a valid +tree sequence, boundary offsets, and index invalidation. Binding-specific +tests also verify that `edge_start` preserves the prefix and sorts actual rows +in the suffix, and that passing both site and mutation table lengths leaves +those tables unchanged. + +## Upstream references + +- C API: +- Python API: +- Python implementation: diff --git a/PR132_REVIEW_PLAN_variants.md b/PR132_REVIEW_PLAN_variants.md new file mode 100644 index 0000000..3c1256a --- /dev/null +++ b/PR132_REVIEW_PLAN_variants.md @@ -0,0 +1,369 @@ +# PR #132 Review: Variant Iteration + +## Status + +Paused on 2026-08-21 pending discussion with Jinyang. The low-level iterator- +state documentation and ownership model have been mapped, but the variant +implementation and user-facing API have not been approved. There are not yet +sufficient user-facing docs or examples to resolve the API by review alone. + +When work resumes, continue with the finalizer and initializer, then review +decoding and exhaustion, and only then review `TreeSequence$variants()`. Do not +restart from earlier PR slices, which are recorded as complete in +`PR132_REVIEW_PLAN.md`. + +### Questions for Jinyang before resuming + +- What concrete workflow should `TreeSequence$variants()` support, especially + in AlphaSimR? +- Can he provide one or two small executable examples with expected site, + allele, genotype, sample-order, and missing-data results? +- What returned R object and iteration protocol does he intend? Are both + `next()` and `next_variant()` required? +- Are the `copy` and deprecated `impute_missing_data` compatibility arguments + required by downstream code, or should this new R API omit unsupported or + deprecated compatibility surface? +- Are the low-level iterator functions intended to be public installed C++ API + or internal implementation details? +- What behavior is intended for `NULL` versus empty `samples` and `alleles`, + interval bounds, fixed allele mappings, and isolated/missing samples? + +### Exact restart point + +1. Resolve the questions above and record intentional deviations from Python. +2. Resume at **C++ iterator state and initialization** below. +3. Confirm finalizer and partial-initialization cleanup semantics from the + upstream C API before changing ownership code. +4. Remove the redundant `ts_sexp` preservation only together with regression + tests covering garbage collection, iterator lifetime, early abandonment, + and absence of double-free behavior. +5. Complete decoding/exhaustion and exact-content tests before reviewing the R + iterator API, documentation, and examples. +6. Run the focused and full completion gates in section 5. + +This review covers: + +- `rtsk_treeseq_init_variants_iterator()` against `tsk_variant_init()`; +- `rtsk_treeseq_next_variant()` against `tsk_variant_decode()` and + `tsk_variant_t`; +- `TreeSequence$variants()` against Python `TreeSequence.variants()`. + +The goal is C++/C and R/Python parity where practical, safe ownership across +the R/C++ boundary, clear documentation and examples, and focused tests of +returned variant content rather than only iterator shape. + +## Review order + +1. Low-level C++ iterator state and initialization. +2. Low-level decoding, result conversion, and exhaustion. +3. User-facing R iterator and Python parity. +4. Documentation, examples, NEWS, and quality gates. + +## Architecture and usage map + +These components are used inside RcppTskit. The user-facing +`TreeSequence$variants()` method calls the low-level initializer and its +returned closures call the low-level next function: + +```text +TreeSequence$variants() + | + v +rtsk_treeseq_init_variants_iterator() + | + |-- creates rtsk_variant_iterator_state_t + |-- compute_variant_iteration_bounds() + | `-- validate_variant_site_index_range() + |-- calls tsk_variant_init() + `-- wraps the state in rtsk_variant_iterator_t + | + v + R iterator object + | + next_variant()/next() + | + v + rtsk_treeseq_next_variant() + | + |-- checks next_site_id against stop_site_id + |-- calls tsk_variant_decode() + |-- converts the result to an R-owned list + `-- advances next_site_id + +When the iterator is garbage-collected: + +rtsk_variant_iterator_free() + |-- calls tsk_variant_free() + |-- releases tree-sequence lifetime protection + `-- deletes the iterator state +``` + +The central connector, omitted easily when reading individual functions, is: + +```cpp +using rtsk_variant_iterator_t = + Rcpp::XPtr; +``` + +Component roles: + +| Component | Role | +| --- | --- | +| `rtsk_variant_iterator_state_t` | Persistent tree-sequence reference, reusable `tsk_variant_t`, and remaining site-ID interval. | +| `rtsk_variant_iterator_free()` | Finalizer called when the iterator external pointer is garbage-collected. | +| `rtsk_variant_iterator_t` | External-pointer type connecting the state to its finalizer. | +| `compute_variant_iteration_bounds()` | Converts genomic coordinates `[left, right)` to site-ID bounds `[start, stop)`. | +| `validate_variant_site_index_range()` | Checks that `tsk_size_t` site offsets can be represented as `tsk_id_t`. | +| `rtsk_treeseq_init_variants_iterator()` | Creates and initializes persistent state and transfers its ownership to an R external pointer. | +| `rtsk_treeseq_next_variant()` | Decodes one site into an R-owned list, or returns `NULL` at exhaustion. | + +### AlphaSimR downstream usage + +Jinyang's AlphaSimR `ts` branch uses the R API: + +```r +it <- ts$variants() +v <- it$next_variant() +``` + +See +[`R/makeFoundersFromTs.R`](https://github.com/LynxJinyangii/AlphaSimR/blob/ts/R/makeFoundersFromTs.R#L37). +A search of the branch found no direct calls to +`rtsk_treeseq_init_variants_iterator()`, +`rtsk_treeseq_next_variant()`, the state/bounds helpers, or the test helpers. +AlphaSimR is therefore a downstream consumer of the RcppTskit R API, rather +than the only location where the implementation is used. + +This evidence does not establish a downstream need to expose the two +low-level iterator functions in the installed public C++ header. Revisit +whether they should be PUBLIC RcppTskit extensions or INTERNAL implementation +functions before finalising the PR. + +### Test-only scaffolding to challenge + +The following functions do not participate in normal iteration: + +- `test_rtsk_variant_iterator_force_null_first_allele()` uses global mutable + state and mutates a live tskit variant. Prefer a naturally occurring missing + allele test if practical. +- `test_rtsk_variant_iterator_set_site_bounds()` deliberately creates invalid + iterator state to force a decode error that valid public inputs cannot + normally reach. Decide whether this coverage is valuable enough to retain. +- `test_variant_site_index_range()` exposes an otherwise impractical range + branch for testing. It is more defensible, but still adds production + test-only surface solely for coverage. + +Review the essential iterator implementation separately from these coverage +devices. If retained, test-only helpers should not be mistaken for part of the +public RcppTskit API. + +## 1. C++ iterator state and initialization + +### Iterator lifetime and ownership + +- [ ] Document `rtsk_variant_iterator_state_t`, its fields, and the invariant + represented by `variant_initialized`. +- [ ] Confirm the external-pointer finalizer calls `tsk_variant_free()` exactly + once for every successfully initialized variant. +- [ ] Confirm partial `tsk_variant_init()` failure is cleaned up according to + the C API contract; do not assume that a failed initialization allocated + nothing. +- [ ] Confirm `std::unique_ptr` protects every pre-external-pointer error path. +- [x] Determine whether the separate `ts_sexp` preservation is necessary. + It is redundant: `rtsk_treeseq_t` is an `Rcpp::XPtr` using + `Rcpp::PreserveStorage`, so the `ts_xptr` member already preserves the + originating R external pointer and releases it when the state is + destroyed. `ts_sexp` is otherwise only assigned, manually preserved, + checked, and manually released; it is never used to access the tree + sequence or passed to tskit. +- [ ] Remove `ts_sexp`, `R_PreserveObject(ts)`, and the matching + `R_ReleaseObject()` together. Retain the cleanup order in which + `tsk_variant_free()` runs before deleting the state and thereby + destroying `ts_xptr`. +- [ ] Test that iteration remains valid after the original R `TreeSequence` + reference is removed and garbage collection runs. Add this regression + test with the `ts_sexp` removal to verify that `ts_xptr` alone provides + the required lifetime protection. +- [ ] Test abandoning an iterator before exhaustion and exercising garbage + collection without a crash or double free. + +### Samples + +- [ ] Verify the distinction between `samples = NULL` and explicit + `integer()`: `NULL` requests all tree-sequence samples, while + `integer()` requests zero decoded nodes. +- [ ] Verify sample IDs are copied into tskit-owned iterator storage and do not + depend on the temporary C++ vector after initialization. +- [ ] Validate R sample input before C++ conversion: ordinary integer IDs, + missing values, negative IDs, out-of-range IDs, duplicates, ordering, + non-sample nodes, and empty input. +- [ ] Confirm genotype order follows the requested sample order, including a + deliberately non-numerical order. +- [ ] Confirm non-sample nodes are accepted, matching Python. + +### Alleles + +- [ ] Verify whether `tsk_variant_init()` copies fixed allele strings and its + pointer array; confirm temporary `std::string` storage is safe. +- [ ] Review `NULL` versus `character()` semantics. Python requires at least one + allele when a fixed mapping is supplied; decide whether empty character + input should error rather than behave like `NULL`. +- [ ] Validate type, `NA`, duplicate alleles, empty strings, embedded NUL bytes, + and allele-count limits. +- [ ] Test fixed allele ordering and genotype indices against known content. + +### Options and genomic bounds + +- [ ] Confirm `isolated_as_missing = TRUE` maps to options `0`, while `FALSE` + maps to `TSK_ISOLATED_NOT_MISSING`. +- [ ] Validate `isolated_as_missing` as a non-missing logical scalar at the R + boundary. +- [ ] Compare R defaults with Python's effective defaults, including Python's + `None` compatibility behavior. +- [ ] Review `left` and `right` validation for type, scalar length, `NA`, `NaN`, + infinities, negatives, reversed bounds, and values beyond sequence + length. +- [ ] Confirm half-open interval semantics: first site at or after `left`, last + site strictly before `right`. +- [ ] Test `left == right`, boundaries with no sites, exact site positions, + sequence endpoints, and a tree sequence with zero sites. +- [ ] Confirm `lower_bound()` is valid because site positions are sorted, or + ensure an appropriate error is propagated for invalid input tables. +- [ ] Review the `tsk_size_t` to `tsk_id_t` range check and retain only test + helpers that exercise otherwise unreachable safety branches. + +## 2. C++ decoding and iterator exhaustion + +### Decode progression + +- [ ] Confirm each site ID is decoded once and in increasing site-table order. +- [ ] Decide whether `next_site_id` should advance before or only after a + successful `tsk_variant_decode()` call. +- [ ] Confirm exhaustion returns `NULL` repeatedly without decoding or mutating + state. +- [ ] Test an empty interval, zero-site tree sequence, normal exhaustion, and + repeated calls after exhaustion. +- [ ] Verify C errors are propagated with useful messages and leave the + iterator in a documented state. + +### Returned variant content + +- [ ] Compare the returned R representation with Python `Variant`: site ID, + position, alleles, genotypes, and missing-data status. +- [ ] Test exact site IDs and positions against site-table rows. +- [ ] Test exact genotype content and confirm genotype values index the returned + allele vector. +- [ ] Confirm genotype `-1` represents missing data. +- [ ] Confirm `has_missing_data` is exposed as an R logical scalar rather than + an accidental integer. +- [ ] Confirm allele strings use `allele_lengths`, preserving valid binary-safe + lengths where R character semantics permit them. +- [ ] Confirm a null C allele pointer is represented as `NA_character_` and is + covered without relying unnecessarily on global mutable test state. +- [ ] Confirm every returned vector/list owns its R memory and remains unchanged + after subsequent iterator calls. + +## 3. `TreeSequence$variants()` + +Current R signature: + +```r +variants = function( + samples = NULL, + isolated_as_missing = TRUE, + alleles = NULL, + impute_missing_data = NULL, + copy = TRUE, + left = 0, + right = NULL +) +``` + +Upstream Python signature: + +```python +variants( + *, samples=None, isolated_as_missing=None, alleles=None, + impute_missing_data=None, copy=None, left=None, right=None +) +``` + +### API and validation + +- [ ] Compare argument names, keyword-only behavior, defaults, accepted types, + and error behavior with Python. +- [ ] Decide whether to retain the already-deprecated + `impute_missing_data` compatibility argument in this new R API. If + retained, document and test precedence and warnings precisely. +- [ ] Review `copy`: the R implementation always returns fresh R objects and + currently rejects `FALSE`; document this intentional deviation or remove + the unsupported argument before release. +- [ ] Reuse shared validators where appropriate instead of maintaining inline + validation. +- [ ] Confirm `right = NULL` maps to the sequence length and document `left = 0` + as the R equivalent of Python's `left = None` default. + +### Iterator protocol + +- [ ] Decide whether both `next()` and `next_variant()` are useful, and document + the chosen R iteration convention. +- [ ] Confirm both methods share exactly one iterator state. +- [ ] Confirm retaining either closure keeps the external pointer alive. +- [ ] Consider whether the iterator needs a print method or standard R iterator + integration; avoid expanding scope unless it materially helps users. +- [ ] Test interleaved calls to `next()` and `next_variant()` and repeated calls + after exhaustion. + +### Documentation and examples + +- [ ] Expand the return documentation to describe every variant-list field and + the genotype-to-allele relationship. +- [ ] Add a concise content example that decodes one variant and uses + `variant$alleles[variant$genotypes + 1L]`, handling genotype `-1` safely. +- [ ] Document sample order, interval bounds, missing genotypes, fixed alleles, + and all intentional Python deviations without reproducing the full Python + manual. +- [ ] Ensure low-level C++ functions have stable C API links, ownership notes, + executable examples, and documented exhaustion behavior. +- [ ] Update `RcppTskit/NEWS.md` for any user-visible changes. + +## 4. Focused test matrix + +- [ ] Default iteration returns all sites in order with exact content checks on + at least one or two known sites. +- [ ] Custom samples preserve requested genotype order, accept a non-sample + node, and distinguish `NULL` from `integer()`. +- [ ] Fixed alleles produce the expected allele vector and genotype encoding. +- [ ] Missing-data behavior differs correctly between + `isolated_as_missing = TRUE` and `FALSE`. +- [ ] Intervals are half-open and cover empty and endpoint cases. +- [ ] Returned variants are independent R copies across iterator advancement. +- [ ] Iterator lifetime is safe across garbage collection and early disposal. +- [ ] Exhaustion is stable and repeatedly returns `NULL`. +- [ ] Invalid samples, alleles, logicals, bounds, and compatibility-argument + combinations produce focused errors. +- [ ] Low-level error and range-check branches are covered where practical. + +## 5. Completion gates + +- [ ] Regenerate Rcpp exports and roxygen documentation. +- [ ] Review generated diffs rather than editing generated files manually. +- [ ] Run focused variant tests. +- [ ] Run `pre-commit run --all-files`. +- [ ] Run `Rscript -e "setwd('RcppTskit'); devtools::test()"`. +- [ ] Run `Rscript -e "setwd('RcppTskit'); devtools::check()"`. +- [ ] Review the complete variant diff against upstream C and Python APIs. + +## Upstream references + +- C variant API: + +- `tsk_variant_init()`: + +- `tsk_variant_decode()`: + +- Python `TreeSequence.variants()`: + +- Python `Variant`: + diff --git a/README.md b/README.md index 664da63..c6f311b 100644 --- a/README.md +++ b/README.md @@ -21,8 +21,9 @@ seamlessly load and analyse a tree sequence, as described at For example, for high-performance and low-level work with tree sequences. Currently, `RcppTskit` provides a limited number of functions due to the availability of extensive `Python` API and the `reticulate` option. -The provided `RcppTskit R` API mirrors the `tskit Python` API, -while the `RcppTskit C++` API mirrors the `tskit C` API. +The `RcppTskit R` API combines an `R6` object model inspired by the +`tskit Python` API with operations that map directly to the `tskit C` API. +The `RcppTskit C++` API closely mirrors the `tskit C` API. See more details on the state of the tree sequence ecosystem and aims of `RcppTskit` in [the introduction vignette](https://highlanderlab.r-universe.dev/articles/RcppTskit/RcppTskit_intro.html) ([source](RcppTskit/vignettes/RcppTskit_intro.qmd)). diff --git a/RcppTskit/.Rbuildignore b/RcppTskit/.Rbuildignore index c6c54c7..bcf17f1 100644 --- a/RcppTskit/.Rbuildignore +++ b/RcppTskit/.Rbuildignore @@ -5,6 +5,9 @@ ^[.]?air[.]toml$ ^[.]?jarl[.]toml$ ^\.Rproj\.user$ +^\.idea$ +^src/\.idea$ +^src/tskit/\.idea$ ^\.\.$ ^\.clang-format$ ^\.covrignore$ @@ -19,7 +22,6 @@ ^inst/examples/explore_reticulate\.R$ ^inst/examples/explore_slendr\.R$ ^notes_pkg_dev\.Rmd$ -^pkg_dev_notes\.md$ ^src/.*\.gcda$ ^src/.*\.gcno$ ^test\.trees$ diff --git a/RcppTskit/DESCRIPTION b/RcppTskit/DESCRIPTION index 539dd26..c6941db 100644 --- a/RcppTskit/DESCRIPTION +++ b/RcppTskit/DESCRIPTION @@ -2,10 +2,14 @@ Type: Package Package: RcppTskit Title: 'R' Access to the 'tskit C' API Version: 0.3.0 -Date: 2026-03-01 +Date: 2026-08-21 Authors@R: c( person("Gregor", "Gorjanc", , "gregor.gorjanc@gmail.com", role = c("aut", "cre", "cph"), comment = c(ORCID = "0000-0001-8008-2787")), + person("Jinyang", "Liang", role = "ctb", + comment = c(ORCID = "0009-0007-4015-6228")), + person("Hannes", "Becher", role = "ctb", + comment = c(ORCID = "0000-0003-3700-2942")), person("Tskit Developers", role = "cph", comment = "Authors of included tskit C library") ) @@ -23,11 +27,12 @@ Description: 'Tskit' enables efficient storage, manipulation, and analysis 'reticulate' option is not optimal; for example, high-performance or low-level work with tree sequences. Currently, 'RcppTskit' provides a limited set of functions because the 'Python' API and 'reticulate' - already cover most needs. The provided 'RcppTskit R' API mirrors the - 'tskit Python' API, while the 'RcppTskit C++' API mirrors the 'tskit - C' API. Users should explore the 'RcppTskit' help pages of 'R' - functions, while developers should explore the 'RcppTskit:::rtsk_*' - low-level 'R' and 'C++'' functions. + already cover most needs. The 'RcppTskit R' API combines an 'R6' + object model inspired by the 'tskit Python' API with operations that + map directly to the 'tskit C' API. The 'RcppTskit C++' API closely + mirrors the 'tskit C' API. Users should explore the 'RcppTskit' help + pages of 'R' functions, while developers should explore the + 'RcppTskit:::rtsk_*' low-level 'R' and 'C++'' functions. License: MIT + file LICENSE URL: https://github.com/HighlanderLab/RcppTskit BugReports: https://github.com/HighlanderLab/RcppTskit/issues diff --git a/RcppTskit/NEWS.md b/RcppTskit/NEWS.md index aa05e4f..9f2535b 100644 --- a/RcppTskit/NEWS.md +++ b/RcppTskit/NEWS.md @@ -4,7 +4,10 @@ All notable changes to `RcppTskit` are documented in this file. The file format is based on [Keep a Changelog](https://keepachangelog.com), and releases adhere to [Semantic Versioning](https://semver.org/spec/v2.0.0.html). -## [0.3.0] 2026-04-07 (not yet released) +## [0.3.0] 2026-08-21 (not yet released) + +A lot of work has gone into this release with help from +Jinyang Liang and Hannes Becher. ### Added (new features) @@ -39,8 +42,32 @@ and releases adhere to [Semantic Versioning](https://semver.org/spec/v2.0.0.html to append site rows from \code{R}, mirroring `tsk_site_table_add_row()`. - Added `rtsk_mutation_table_add_row()` and `TableCollection$mutation_table_add_row()` to append mutation rows from - \code{R}, mirroring `tsk_mutation_table_add_row()`. -- TODO + `R`, mirroring `tsk_mutation_table_add_row()`. +- Added `rtsk_population_table_add_row()` and + `TableCollection$population_table_add_row()` to append population rows from + `R`, mirroring `tsk_population_table_add_row()`. +- Added `rtsk_migration_table_add_row()` and + `TableCollection$migration_table_add_row()` to append migration rows from + `R`, mirroring `tsk_migration_table_add_row()`. +- Added `rtsk_provenance_table_add_row()` and + `TableCollection$provenance_table_add_row()` to append provenance rows from + `R`, mirroring `tsk_provenance_table_add_row()`. +- Added `rtsk_node_table_get_row()` and `TableCollection$node_table_get_row()` + to retrieve node-table rows by 0-based row index. +- Added `rtsk_table_collection_sort()` and `TableCollection$sort()` to sort a + table collection in place. +- Added `rtsk_table_collection_simplify()` and + `TableCollection$simplify()` to simplify table collection in place, and + `TreeSequence$simplify()` to return a simplified tree sequence. +- Added low-level variant iterators + (`rtsk_treeseq_init_variants_iterator()`/`rtsk_treeseq_next_variant()`) and a + user-facing `TreeSequence$variants()` method to iterate over decoded + site-by-site variants from `R`, aligned with `Python` API + semantics for `samples`, `isolated_as_missing`, `alleles`, and + `left`/`right` intervals. +- Added `rtsk_treeseq_get_samples()` and `TreeSequence$samples()` to retrieve + sample node IDs from a tree sequence, with `TreeSequence$samples()` now + supporting `population` and `time` filters. ### Changed @@ -53,17 +80,17 @@ and releases adhere to [Semantic Versioning](https://semver.org/spec/v2.0.0.html `pointer` to `xptr`. - Ensured `TableCollection$tree_sequence()` matches `tskit Python` API: it now builds indexes on the `TableCollection`, if indexes are not present. +- Refined integer validation behaviour across scalar and optional vector inputs. - We now use `bit64::integer64` (signed 64 bit integer) instead of `int` aiming to approach `tsk_size_t` in `tskit C` (unsigned 64 bit integer); in low-level `rtsk_treeseq_get_num_*()` wrappers and count/metadata-length fields. -- TODO ### Maintenance - Turn vignette URL as hyperlinks and similar cosmetics. -- State that we mirror the `R/Python` APIs and `C++/C` APIs across the package. -- Update `tskit C` to 1.3.1 -- TODO +- Clarify that the `R` API combines a Python-inspired `R6` object model with + operations that map directly to the `tskit C` API. +- Update `tskit C` to 1.3.1 and `kastore` to `2.1.3` (security update). ## [0.2.0] - 2026-02-22 diff --git a/RcppTskit/R/Class-TableCollection.R b/RcppTskit/R/Class-TableCollection.R index c3ce608..79483f2 100644 --- a/RcppTskit/R/Class-TableCollection.R +++ b/RcppTskit/R/Class-TableCollection.R @@ -18,9 +18,7 @@ TableCollection <- R6Class( #' reference genome sequence information. #' @param xptr an external pointer (\code{externalptr}) to a table collection. #' @details See the \code{tskit Python} equivalent at - #' \url{https://github.com/tskit-dev/tskit/blob/dc394d72d121c99c6dcad88f7a4873880924dd72/python/tskit/tables.py#L3463}. - #' TODO: Update URL to TableCollection.load() method #104 - #' https://github.com/HighlanderLab/RcppTskit/issues/104 + #' \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.TableCollection.load}. #' @return A \code{\link{TableCollection}} object. #' @examples #' ts_file <- system.file("examples/test.trees", package = "RcppTskit") @@ -67,7 +65,7 @@ TableCollection <- R6Class( #' @description Write a table collection to a file. #' @param file a string specifying the full path of the tree sequence file. #' @details See the \code{tskit Python} equivalent at - #' \url{https://tskit.dev/tskit/docs/latest/python-api.html#tskit.TableCollection.dump}. + #' \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.TableCollection.dump}. #' @return No return value; called for side effects. #' @examples #' ts_file <- system.file("examples/test.trees", package = "RcppTskit") @@ -88,7 +86,7 @@ TableCollection <- R6Class( #' @description Create a \code{\link{TreeSequence}} from this table collection. #' @details See the \code{tskit Python} equivalent at - #' \url{https://tskit.dev/tskit/docs/latest/python-api.html#tskit.TableCollection.tree_sequence}. + #' \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.TableCollection.tree_sequence}. #' @return A \code{\link{TreeSequence}} object. #' @examples #' ts_file <- system.file("examples/test.trees", package = "RcppTskit") @@ -103,6 +101,220 @@ TableCollection <- R6Class( TreeSequence$new(xptr = ts_xptr) }, + #' @description Sort this table collection in place. + #' @param edge_start integer or integer-valued numeric scalar edge-table + #' start row index (0-based). + #' @param site_start integer or integer-valued numeric scalar site-table + #' start row index (0-based). + #' @param mutation_start integer or integer-valued numeric scalar + #' mutation-table start row index (0-based). + #' @details See the \code{tskit Python} equivalent at + #' \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.TableCollection.sort}. + #' @return No return value; called for side effects. + #' @examples + #' unsorted_file <- system.file("examples/test_unsorted.trees", package = "RcppTskit") + #' tc <- tc_load(unsorted_file) + #' inherits(try(tc$tree_sequence(), silent = TRUE), "try-error") + #' tc$sort() + #' ts <- tc$tree_sequence() + #' is(ts) + sort = function(edge_start = 0L, site_start = 0L, mutation_start = 0L) { + validate_row_index(edge_start, "edge_start") + validate_row_index(site_start, "site_start") + validate_row_index(mutation_start, "mutation_start") + rtsk_table_collection_sort( + tc = self$xptr, + start_edges = as.integer(edge_start), + start_sites = as.integer(site_start), + start_mutations = as.integer(mutation_start), + options = 0L + ) + }, + + #' @description Simplify this table collection in place. + #' @param samples optional integer vector of distinct node IDs to retain as + #' samples. If \code{NULL}, use the nodes currently marked as samples. + #' @param reduce_to_site_topology logical; if \code{TRUE}, retain only + #' topology needed to represent trees containing sites. + #' @param filter_populations optional logical; if \code{TRUE}, remove + #' populations no longer referenced by nodes. If \code{NULL}, treated as + #' \code{TRUE}. + #' @param filter_individuals optional logical; if \code{TRUE}, remove + #' individuals no longer referenced by nodes. If \code{NULL}, treated as + #' \code{TRUE}. + #' @param filter_sites optional logical; if \code{TRUE}, remove sites no + #' longer referenced by mutations. If \code{NULL}, treated as + #' \code{TRUE}. + #' @param filter_nodes optional logical; if \code{TRUE}, remove nodes no + #' longer referenced by edges. If \code{NULL}, treated as + #' \code{TRUE}. + #' @param update_sample_flags optional logical; if \code{TRUE}, update node + #' flags so exactly the requested samples carry the sample flag. If + #' \code{NULL}, treated as \code{TRUE}. + #' @param keep_unary logical; if \code{TRUE}, retain unary nodes on paths + #' from samples to roots. + #' @param keep_unary_in_individuals optional logical; if \code{TRUE}, retain + #' unary nodes that are associated with an individual, while other unary + #' nodes may still be removed. Cannot be used with + #' \code{keep_unary = TRUE}. If \code{NULL}, treated as \code{FALSE}. + #' @param keep_input_roots logical; if \code{TRUE}, retain topology back to + #' the roots in the input tables rather than stopping at samples' MRCAs. + #' @param record_provenance logical; if \code{TRUE}, append a + #' provenance row describing this simplify call. + #' @details See the \code{tskit Python} equivalent at + #' \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.TableCollection.simplify}. + #' @return Integer vector mapping input node IDs to simplified node IDs. + #' Removed nodes map to \code{-1}. + #' @examples + #' ts_file <- system.file("examples/test.trees", package = "RcppTskit") + #' tc <- tc_load(ts_file) + #' nodes_before <- as.integer(tc$num_nodes()) + #' node_map <- tc$simplify(samples = c(0L, 1L, 2L, 3L)) + #' c(before = nodes_before, after = as.integer(tc$num_nodes())) + simplify = function( + samples = NULL, + reduce_to_site_topology = FALSE, + filter_populations = NULL, + filter_individuals = NULL, + filter_sites = NULL, + filter_nodes = NULL, + update_sample_flags = NULL, + keep_unary = FALSE, + keep_unary_in_individuals = NULL, + keep_input_roots = FALSE, + record_provenance = TRUE + ) { + if (!is.null(samples)) { + validate_optional_integer_vector_arg(samples, "samples") + samples <- as.integer(samples) + } + validate_logical_arg(reduce_to_site_topology, "reduce_to_site_topology") + validate_logical_arg(keep_unary, "keep_unary") + validate_logical_arg(keep_input_roots, "keep_input_roots") + validate_logical_arg(record_provenance, "record_provenance") + + resolve_optional_logical <- function(value, name, default) { + if (is.null(value)) { + return(default) + } + validate_logical_arg(value, name) + return(value) + } + + filter_populations <- resolve_optional_logical( + filter_populations, + "filter_populations", + TRUE + ) + filter_individuals <- resolve_optional_logical( + filter_individuals, + "filter_individuals", + TRUE + ) + filter_sites <- resolve_optional_logical( + filter_sites, + "filter_sites", + TRUE + ) + filter_nodes <- resolve_optional_logical( + filter_nodes, + "filter_nodes", + TRUE + ) + update_sample_flags <- resolve_optional_logical( + update_sample_flags, + "update_sample_flags", + TRUE + ) + keep_unary_in_individuals <- resolve_optional_logical( + keep_unary_in_individuals, + "keep_unary_in_individuals", + FALSE + ) + + if (keep_unary && keep_unary_in_individuals) { + stop("keep_unary and keep_unary_in_individuals cannot both be TRUE!") + } + + # See https://tskit.dev/tskit/docs/stable/c-api.html#tsk-treeseq-simplify-tsk-table-collection-simplify + options <- 0L + if (filter_sites) { + options <- bitwOr(options, bitwShiftL(1L, 0)) + } + if (filter_populations) { + options <- bitwOr(options, bitwShiftL(1L, 1)) + } + if (filter_individuals) { + options <- bitwOr(options, bitwShiftL(1L, 2)) + } + if (reduce_to_site_topology) { + options <- bitwOr(options, bitwShiftL(1L, 3)) + } + if (keep_unary) { + options <- bitwOr(options, bitwShiftL(1L, 4)) + } + if (keep_input_roots) { + options <- bitwOr(options, bitwShiftL(1L, 5)) + } + if (keep_unary_in_individuals) { + options <- bitwOr(options, bitwShiftL(1L, 6)) + } + if (!filter_nodes) { + options <- bitwOr(options, bitwShiftL(1L, 7)) + } + if (!update_sample_flags) { + options <- bitwOr(options, bitwShiftL(1L, 8)) + } + + node_map <- rtsk_table_collection_simplify( + tc = self$xptr, + samples = samples, + options = options + ) + + if (record_provenance) { + json_bool <- function(value) { + if (value) "true" else "false" + } + samples_json <- if (is.null(samples)) { + "null" + } else { + paste0("[", paste(samples, collapse = ","), "]") + } + package_version <- as.character(utils::packageVersion("RcppTskit")) + provenance_record <- paste0( + '{"schema_version":"1.0.0",', + '"software":{"name":"RcppTskit","version":"', + package_version, + '"},"parameters":{"command":"simplify","samples":', + samples_json, + ',"reduce_to_site_topology":', + json_bool(reduce_to_site_topology), + ',"filter_populations":', + json_bool(filter_populations), + ',"filter_individuals":', + json_bool(filter_individuals), + ',"filter_sites":', + json_bool(filter_sites), + ',"filter_nodes":', + json_bool(filter_nodes), + ',"update_sample_flags":', + json_bool(update_sample_flags), + ',"keep_unary":', + json_bool(keep_unary), + ',"keep_unary_in_individuals":', + json_bool(keep_unary_in_individuals), + ',"keep_input_roots":', + json_bool(keep_input_roots), + '},"environment":{}}' + ) + self$provenance_table_add_row( + record = provenance_record + ) + } + return(node_map) + }, + #' @description Get the number of provenances in a table collection. #' @return A signed 64 bit integer \code{bit64::integer64}. #' @examples @@ -113,6 +325,58 @@ TableCollection <- R6Class( rtsk_table_collection_get_num_provenances(self$xptr) }, + #' @description Add a row to the provenance table. + #' @param record character string record for the new provenance. + #' @param timestamp optional character string timestamp for the new + #' provenance. If provided, it should be in ISO8601 form. If + #' \code{NULL}, a current UTC timestamp in ISO8601 form is generated. + #' @details See the \code{tskit Python} equivalent at + #' \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.ProvenanceTable.add_row}. + #' @return An integer row index and hence ID (0-based) of the newly added provenance. + #' @examples + #' ts_file <- system.file("examples/test.trees", package = "RcppTskit") + #' tc <- tc_load(ts_file) + #' new_id <- tc$provenance_table_add_row( + #' record = "{\"software\":\"RcppTskit\"}", + #' timestamp = "2025-01-01T00:00:00Z" + #' ) + #' tc$provenance_table_get_row(new_id) + provenance_table_add_row = function(record, timestamp = NULL) { + validate_character_scalar_arg(record, "record") + timestamp_value <- if (is.null(timestamp)) { + strftime(Sys.time(), "%Y-%m-%dT%H:%M:%OS6Z", tz = "UTC") + } else { + validate_character_scalar_arg(timestamp, "timestamp") + as.character(timestamp) + } + rtsk_provenance_table_add_row( + tc = self$xptr, + timestamp = timestamp_value, + record = as.character(record) + ) + }, + + #' @description Get one row from the provenance table. + #' @param index integer or numeric scalar row index (0-based). + #' @details See the \code{tskit Python} equivalent at + #' \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.ProvenanceTable.__getitem__}. + #' The function accepts numeric \code{index} for ease of use, but converts + #' it to integer after checking that conversion to 32-bit integer succeeds. + #' Unlike Python table indexing, negative indices are not supported. + #' @return A named list with fields \code{id}, \code{timestamp}, + #' and \code{record}. + #' @examples + #' ts_file <- system.file("examples/test.trees", package = "RcppTskit") + #' tc <- tc_load(ts_file) + #' id <- tc$provenance_table_add_row( + #' record = "{}", timestamp = "2025-01-01T00:00:00Z" + #' ) + #' tc$provenance_table_get_row(id) + provenance_table_get_row = function(index) { + validate_row_index(index) + rtsk_provenance_table_get_row(self$xptr, index = as.integer(index)) + }, + #' @description Get the number of populations in a table collection. #' @return A signed 64 bit integer \code{bit64::integer64}. #' @examples @@ -123,6 +387,45 @@ TableCollection <- R6Class( rtsk_table_collection_get_num_populations(self$xptr) }, + #' @description Add a row to the population table. + #' @param metadata for the new population; accepts \code{NULL}, + #' a raw vector, or a character vector of length 1. Values are stored as + #' raw bytes without metadata-schema validation or encoding. + #' @details See the \code{tskit Python} equivalent at + #' \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.PopulationTable.add_row}. + #' Metadata schemas are not currently applied. + #' @return An integer row index and hence ID (0-based) of the newly added population. + #' @examples + #' ts_file <- system.file("examples/test.trees", package = "RcppTskit") + #' tc <- tc_load(ts_file) + #' new_id <- tc$population_table_add_row(metadata = "abc") + #' tc$population_table_get_row(new_id) + population_table_add_row = function(metadata = NULL) { + metadata_raw <- validate_metadata_arg(metadata) + rtsk_population_table_add_row( + tc = self$xptr, + metadata = metadata_raw + ) + }, + + #' @description Get one row from the population table. + #' @param index integer or numeric scalar row index (0-based). + #' @details See the \code{tskit Python} equivalent at + #' \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.PopulationTable.__getitem__}. + #' The function accepts numeric \code{index} for ease of use, but converts + #' it to integer after checking that conversion to 32-bit integer succeeds. + #' Unlike Python table indexing, negative indices are not supported. + #' @return A named list with fields \code{id} and \code{metadata} + #' (as raw bytes without metadata-schema decoding). + #' @examples + #' ts_file <- system.file("examples/test.trees", package = "RcppTskit") + #' tc <- tc_load(ts_file) + #' tc$population_table_get_row(0) + population_table_get_row = function(index) { + validate_row_index(index) + rtsk_population_table_get_row(self$xptr, index = as.integer(index)) + }, + #' @description Get the number of migrations in a table collection. #' @return A signed 64 bit integer \code{bit64::integer64}. #' @examples @@ -133,6 +436,94 @@ TableCollection <- R6Class( rtsk_table_collection_get_num_migrations(self$xptr) }, + #' @description Add a row to the migration table. + #' @param left numeric scalar left coordinate (inclusive) for the new + #' migration. + #' @param right numeric scalar right coordinate (exclusive) for the new + #' migration. + #' @param node integer or integer-valued numeric scalar node ID (0-based). + #' @param source integer or integer-valued numeric scalar source population + #' ID (0-based). + #' @param dest integer or integer-valued numeric scalar destination + #' population ID (0-based). + #' @param time numeric scalar time of the migration event. + #' @param metadata for the new migration; accepts \code{NULL}, + #' a raw vector, or a character vector of length 1. Values are stored as + #' raw bytes without metadata-schema validation or encoding. + #' @details See the \code{tskit Python} equivalent at + #' \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.MigrationTable.add_row}. + #' Metadata schemas are not currently applied. + #' @return An integer row index and hence ID (0-based) of the newly added migration. + #' @examples + #' ts_file <- system.file("examples/test.trees", package = "RcppTskit") + #' tc <- tc_load(ts_file) + #' new_population <- tc$population_table_add_row(metadata = "new-population") + #' migrating_node <- tc$node_table_add_row(time = 0.5, population = new_population) + #' new_id <- tc$migration_table_add_row( + #' left = 0, + #' right = 1, + #' node = migrating_node, + #' source = 0L, + #' dest = new_population, + #' time = 1.0, + #' metadata = "abc" + #' ) + #' tc$migration_table_get_row(new_id) + migration_table_add_row = function( + left, + right, + node, + source, + dest, + time, + metadata = NULL + ) { + validate_numeric_scalar_arg(left, "left") + validate_numeric_scalar_arg(right, "right") + if (as.numeric(left) >= as.numeric(right)) { + stop("left must be strictly less than right!") + } + validate_row_index(node, "node") + validate_row_index(source, "source") + validate_row_index(dest, "dest") + validate_numeric_scalar_arg(time, "time") + metadata_raw <- validate_metadata_arg(metadata) + rtsk_migration_table_add_row( + tc = self$xptr, + left = as.numeric(left), + right = as.numeric(right), + node = as.integer(node), + source = as.integer(source), + dest = as.integer(dest), + time = as.numeric(time), + metadata = metadata_raw + ) + }, + + #' @description Get one row from the migration table. + #' @param index integer or numeric scalar row index (0-based). + #' @details See the \code{tskit Python} equivalent at + #' \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.MigrationTable.__getitem__}. + #' The function accepts numeric \code{index} for ease of use, but converts + #' it to integer after checking that conversion to 32-bit integer succeeds. + #' Unlike Python table indexing, negative indices are not supported. + #' @return A named list with fields \code{id}, \code{left}, \code{right}, + #' \code{node}, \code{source}, \code{dest}, \code{time}, and + #' \code{metadata} (as raw bytes without metadata-schema decoding). + #' @examples + #' ts_file <- system.file("examples/test.trees", package = "RcppTskit") + #' tc <- tc_load(ts_file) + #' if (tc$num_migrations() == 0L) { + #' tc$migration_table_add_row( + #' left = 0, right = 1, node = 0L, source = 0L, dest = 0L, time = 1 + #' ) + #' } + #' tc$migration_table_get_row(0) + migration_table_get_row = function(index) { + validate_row_index(index) + rtsk_migration_table_get_row(self$xptr, index = as.integer(index)) + }, + #' @description Get the number of individuals in a table collection. #' @return A signed 64 bit integer \code{bit64::integer64}. #' @examples @@ -143,62 +534,40 @@ TableCollection <- R6Class( rtsk_table_collection_get_num_individuals(self$xptr) }, - #' @description Add a row to the individuals table. - #' @param flags integer scalar flags for the new individual. + #' @description Add a row to the individual table. + #' @param flags integer or integer-valued numeric scalar bitwise flags for + #' the new individual. Values from 0 through 2^31 - 1 are supported. #' @param location numeric vector with the location of the new individual; - #' can be \code{NULL} if unknown. - #' @param parents integer vector with parent individual IDs (0-based); - #' can be \code{NULL} if unknown + #' \code{NULL} stores an empty location. + #' @param parents integer or integer-valued numeric vector with parent + #' individual IDs (0-based); \code{NULL} stores no parents. #' @param metadata for the new individual; accepts \code{NULL}, - #' a raw vector, or a character of length 1. + #' a raw vector, or a character vector of length 1. Values are stored as + #' raw bytes without metadata-schema validation or encoding. #' @details See the \code{tskit Python} equivalent at #' \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.IndividualTable.add_row}. - #' @return Integer row ID (0-based) of the newly added individual. + #' Metadata schemas are not currently applied. + #' @return An integer row index and hence ID (0-based) of the newly added individual. #' @examples #' ts_file <- system.file("examples/test.trees", package = "RcppTskit") #' tc <- tc_load(ts_file) - #' (n_before <- tc$num_individuals()) - #' new_id <- tc$individual_table_add_row() - #' new_id <- tc$individual_table_add_row(location = c(5, 8)) - #' new_id <- tc$individual_table_add_row(flags = 0L) - #' new_id <- tc$individual_table_add_row(parents = c(0L, 2L)) - #' new_id <- tc$individual_table_add_row(metadata = "abc") - #' new_id <- tc$individual_table_add_row(metadata = charToRaw("cba")) - #' (n_after <- tc$num_individuals()) + #' new_id <- tc$individual_table_add_row( + #' flags = 3L, + #' location = c(2, 11), + #' parents = c(1L, 3L), + #' metadata = "abc" + #' ) + #' tc$individual_table_get_row(new_id) individual_table_add_row = function( flags = 0L, location = NULL, parents = NULL, metadata = NULL ) { - if ( - is.null(flags) || - !is.integer(flags) || - length(flags) != 1L || - is.na(flags) || - flags < 0L - ) { - stop("flags must be a non-NA zero or positive integer scalar!") - } - if (!is.null(location) && (!is.numeric(location) || anyNA(location))) { - stop("location must be NULL or a numeric vector with no NA values!") - } - if (!is.null(parents) && (!is.integer(parents) || anyNA(parents))) { - stop("parents must be NULL or an integer vector with no NA values!") - } - if (is.null(metadata)) { - metadata_raw <- NULL - } else if (is.raw(metadata)) { - metadata_raw <- metadata - } else if ( - is.character(metadata) && length(metadata) == 1L && !is.na(metadata) - ) { - metadata_raw <- charToRaw(metadata) - } else { - stop( - "metadata must be NULL, a raw vector, or a length-1 non-NA character string!" - ) - } + validate_integer_scalar_arg(flags, "flags", minimum = 0L) + validate_optional_numeric_vector_arg(location, "location") + validate_optional_integer_vector_arg(parents, "parents") + metadata_raw <- validate_metadata_arg(metadata) rtsk_individual_table_add_row( tc = self$xptr, flags = as.integer(flags), @@ -208,6 +577,26 @@ TableCollection <- R6Class( ) }, + #' @description Get one row from the individual table. + #' @param index integer or numeric scalar row index (0-based). + #' @details See the \code{tskit Python} equivalent at + #' \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.IndividualTable.__getitem__}. + #' The function accepts numeric \code{index} for ease of use, but converts + #' it to integer after checking that conversion to 32-bit integer succeeds. + #' Unlike Python table indexing, negative indices are not supported. + #' @return A named list with fields \code{id}, \code{flags}, + #' \code{location}, \code{parents}, and \code{metadata} + #' (as raw bytes without metadata-schema decoding). + #' @examples + #' ts_file <- system.file("examples/test.trees", package = "RcppTskit") + #' tc <- tc_load(ts_file) + #' tc$individual_table_get_row(0) + individual_table_get_row = function(index) { + validate_row_index(index) + row <- rtsk_individual_table_get_row(self$xptr, index = as.integer(index)) + row[c("id", "flags", "location", "parents", "metadata")] + }, + #' @description Get the number of nodes in a table collection. #' @return A signed 64 bit integer \code{bit64::integer64}. #' @examples @@ -218,29 +607,30 @@ TableCollection <- R6Class( rtsk_table_collection_get_num_nodes(self$xptr) }, - #' @description Add a row to the nodes table. - #' @param flags integer scalar flags for the new node. - #' @param time numeric scalar time value for the new node. - #' @param population integer scalar population row ID (0-based); - #' use \code{-1} if not known - \code{NULL} maps to \code{-1} (\code{TSK_NULL}). - #' @param individual integer scalar individual row ID (0-based); - #' use \code{-1} if not known - \code{NULL} maps to \code{-1} (\code{TSK_NULL}). + #' @description Add a row to the node table. + #' @param flags integer or integer-valued numeric scalar bitwise flags for + #' the new node. Values from 0 through 2^31 - 1 are supported. + #' @param time numeric scalar birth time for the new node. + #' @param population integer or integer-valued numeric scalar population ID + #' (0-based); use \code{-1} or \code{NULL} if unknown. Both store + #' \code{TSK_NULL}. + #' @param individual integer or integer-valued numeric scalar individual ID + #' (0-based); use \code{-1} or \code{NULL} if unknown. Both store + #' \code{TSK_NULL}. #' @param metadata for the new node; accepts \code{NULL}, - #' a raw vector, or a character of length 1. + #' a raw vector, or a character vector of length 1. Values are stored as + #' raw bytes without metadata-schema validation or encoding. #' @details See the \code{tskit Python} equivalent at #' \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.NodeTable.add_row}. - #' @return Integer row ID (0-based) of the newly added node. + #' Metadata schemas are not currently applied. + #' @return An integer row index and hence ID (0-based) of the newly added node. #' @examples #' ts_file <- system.file("examples/test.trees", package = "RcppTskit") #' tc <- tc_load(ts_file) - #' (n_before <- tc$num_nodes()) - #' new_id <- tc$node_table_add_row() - #' new_id <- tc$node_table_add_row(time = 2.5) - #' new_id <- tc$node_table_add_row(flags = 1L, time = 3.5, population = 0L) - #' new_id <- tc$node_table_add_row(flags = 1L, time = 4.5, individual = 0L) - #' new_id <- tc$node_table_add_row(metadata = "abc") - #' new_id <- tc$node_table_add_row(metadata = charToRaw("cba")) - #' (n_after <- tc$num_nodes()) + #' new_id <- tc$node_table_add_row( + #' flags = 1L, time = 3.5, individual = 0L, metadata = "abc" + #' ) + #' tc$node_table_get_row(new_id) node_table_add_row = function( flags = 0L, time = 0, @@ -248,51 +638,21 @@ TableCollection <- R6Class( individual = -1L, metadata = NULL ) { - if ( - is.null(flags) || - !is.integer(flags) || - length(flags) != 1L || - is.na(flags) || - flags < 0L - ) { - stop("flags must be a non-NA zero or positive integer scalar!") - } - if ( - is.null(time) || !is.numeric(time) || length(time) != 1L || is.na(time) - ) { - stop("time must be a non-NA numeric scalar!") - } - if ( - !is.null(population) && - (!is.integer(population) || - length(population) != 1L || - is.na(population) || - population < -1L) - ) { - stop("population must be -1L, NULL, or a non-NA integer scalar!") - } - if ( - !is.null(individual) && - (!is.integer(individual) || - length(individual) != 1L || - is.na(individual) || - individual < -1L) - ) { - stop("individual must be -1L, NULL, or a non-NA integer scalar!") - } - if (is.null(metadata)) { - metadata_raw <- NULL - } else if (is.raw(metadata)) { - metadata_raw <- metadata - } else if ( - is.character(metadata) && length(metadata) == 1L && !is.na(metadata) - ) { - metadata_raw <- charToRaw(metadata) - } else { - stop( - "metadata must be NULL, a raw vector, or a length-1 non-NA character string!" - ) - } + validate_integer_scalar_arg(flags, "flags", minimum = 0L) + validate_numeric_scalar_arg(time, "time") + validate_integer_scalar_arg( + population, + "population", + minimum = -1L, + allow_null = TRUE + ) + validate_integer_scalar_arg( + individual, + "individual", + minimum = -1L, + allow_null = TRUE + ) + metadata_raw <- validate_metadata_arg(metadata) rtsk_node_table_add_row( tc = self$xptr, flags = as.integer(flags), @@ -303,6 +663,28 @@ TableCollection <- R6Class( ) }, + #' @description Get one row from the node table. + #' @param index integer or numeric scalar row index (0-based). + #' @details In \code{tskit Python}, rows are accessed by indexing a + #' \code{NodeTable}, for example \code{tables.nodes[index]}; see + #' \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.NodeTable}. + #' The function accepts numeric \code{index} for ease of use, but converts + #' it to integer after checking that conversion to 32-bit integer succeeds. + #' Unlike Python table indexing, negative indices are not supported. + #' @return A named list with fields \code{id}, \code{flags}, \code{time}, + #' \code{population}, \code{individual}, and \code{metadata} + #' (as raw bytes without metadata-schema decoding). + #' @examples + #' ts_file <- system.file("examples/test.trees", package = "RcppTskit") + #' tc <- tc_load(ts_file) + #' tc$node_table_get_row(0L) + #' (last_node <- as.integer(tc$num_nodes()) - 1L) + #' tc$node_table_get_row(last_node) + node_table_get_row = function(index) { + validate_row_index(index) + rtsk_node_table_get_row(self$xptr, index = as.integer(index)) + }, + #' @description Get the number of edges in a table collection. #' @return A signed 64 bit integer \code{bit64::integer64}. #' @examples @@ -313,31 +695,29 @@ TableCollection <- R6Class( rtsk_table_collection_get_num_edges(self$xptr) }, - #' @description Add a row to the edges table. - #' @param left numeric scalar left coordinate for the new edge. - #' @param right numeric scalar right coordinate for the new edge. - #' @param parent integer scalar parent node row ID (0-based). - #' @param child integer scalar child node row ID (0-based). + #' @description Add a row to the edge table. + #' @param left numeric scalar left coordinate (inclusive) for the new edge. + #' @param right numeric scalar right coordinate (exclusive) for the new + #' edge. + #' @param parent integer or integer-valued numeric scalar parent node ID + #' (0-based). + #' @param child integer or integer-valued numeric scalar child node ID + #' (0-based). #' @param metadata for the new edge; accepts \code{NULL}, - #' a raw vector, or a character of length 1. + #' a raw vector, or a character vector of length 1. Values are stored as + #' raw bytes without metadata-schema validation or encoding. #' @details See the \code{tskit Python} equivalent at #' \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.EdgeTable.add_row}. - #' @return Integer row ID (0-based) of the newly added edge. + #' Metadata schemas are not currently applied. + #' @return An integer row index and hence ID (0-based) of the newly added edge. #' @examples #' ts_file <- system.file("examples/test.trees", package = "RcppTskit") #' tc <- tc_load(ts_file) #' child <- tc$node_table_add_row(time = 0.0) - #' (n_before <- tc$num_edges()) - #' new_id <- tc$edge_table_add_row( - #' left = 0, right = 50, parent = 16L, child = child - #' ) #' new_id <- tc$edge_table_add_row( - #' left = 50, right = 75, parent = 17L, child = child, metadata = "abc" + #' left = 0, right = 50, parent = 16L, child = child, metadata = "abc" #' ) - #' new_id <- tc$edge_table_add_row( - #' left = 75, right = 100, parent = 18L, child = child, metadata = charToRaw("cba") - #' ) - #' (n_after <- tc$num_edges()) + #' tc$edge_table_get_row(new_id) edge_table_add_row = function( left, right, @@ -345,54 +725,14 @@ TableCollection <- R6Class( child, metadata = NULL ) { - if ( - is.null(left) || - !is.numeric(left) || - length(left) != 1L || - is.na(left) - ) { - stop("left must be a non-NA numeric scalar!") - } - if ( - is.null(right) || - !is.numeric(right) || - length(right) != 1L || - is.na(right) - ) { - stop("right must be a non-NA numeric scalar!") - } + validate_numeric_scalar_arg(left, "left") + validate_numeric_scalar_arg(right, "right") if (as.numeric(left) >= as.numeric(right)) { stop("left must be strictly less than right!") } - if ( - is.null(parent) || - !is.integer(parent) || - length(parent) != 1L || - is.na(parent) - ) { - stop("parent must be a non-NA integer scalar!") - } - if ( - is.null(child) || - !is.integer(child) || - length(child) != 1L || - is.na(child) - ) { - stop("child must be a non-NA integer scalar!") - } - if (is.null(metadata)) { - metadata_raw <- NULL - } else if (is.raw(metadata)) { - metadata_raw <- metadata - } else if ( - is.character(metadata) && length(metadata) == 1L && !is.na(metadata) - ) { - metadata_raw <- charToRaw(metadata) - } else { - stop( - "metadata must be NULL, a raw vector, or a length-1 non-NA character string!" - ) - } + validate_row_index(parent, "parent") + validate_row_index(child, "child") + metadata_raw <- validate_metadata_arg(metadata) rtsk_edge_table_add_row( tc = self$xptr, left = as.numeric(left), @@ -403,6 +743,25 @@ TableCollection <- R6Class( ) }, + #' @description Get one row from the edge table. + #' @param index integer or numeric scalar row index (0-based). + #' @details See the \code{tskit Python} equivalent at + #' \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.EdgeTable.__getitem__}. + #' The function accepts numeric \code{index} for ease of use, but converts + #' it to integer after checking that conversion to 32-bit integer succeeds. + #' Unlike Python table indexing, negative indices are not supported. + #' @return A named list with fields \code{id}, \code{left}, \code{right}, + #' \code{parent}, \code{child}, and \code{metadata} + #' (as raw bytes without metadata-schema decoding). + #' @examples + #' ts_file <- system.file("examples/test.trees", package = "RcppTskit") + #' tc <- tc_load(ts_file) + #' tc$edge_table_get_row(0) + edge_table_get_row = function(index) { + validate_row_index(index) + rtsk_edge_table_get_row(self$xptr, index = as.integer(index)) + }, + #' @description Get the number of sites in a table collection. #' @return A signed 64 bit integer \code{bit64::integer64}. #' @examples @@ -413,57 +772,31 @@ TableCollection <- R6Class( rtsk_table_collection_get_num_sites(self$xptr) }, - #' @description Add a row to the sites table. - #' @param position numeric scalar site position. - #' @param ancestral_state character string for the new site. + #' @description Add a row to the site table. + #' @param position numeric scalar position for the new site. + #' @param ancestral_state character string with the ancestral state. #' @param metadata for the new site; accepts \code{NULL}, - #' a raw vector, or a character of length 1. + #' a raw vector, or a character vector of length 1. Values are stored as + #' raw bytes without metadata-schema validation or encoding. #' @details See the \code{tskit Python} equivalent at #' \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.SiteTable.add_row}. - #' @return Integer row ID (0-based) of the newly added site. + #' Metadata schemas are not currently applied. + #' @return An integer row index and hence ID (0-based) of the newly added site. #' @examples #' ts_file <- system.file("examples/test.trees", package = "RcppTskit") #' tc <- tc_load(ts_file) - #' (n_before <- tc$num_sites()) - #' new_id <- tc$site_table_add_row(position = 0.5, ancestral_state = "A") - #' new_id <- tc$site_table_add_row(position = 2.5, ancestral_state = "T", metadata = "abc") - #' (n_after <- tc$num_sites()) + #' new_id <- tc$site_table_add_row( + #' position = 2.5, ancestral_state = "T", metadata = "abc" + #' ) + #' tc$site_table_get_row(new_id) site_table_add_row = function( position, ancestral_state, metadata = NULL ) { - if ( - is.null(position) || - !is.numeric(position) || - length(position) != 1L || - is.na(position) - ) { - stop("position must be a non-NA numeric scalar!") - } - if ( - is.null(ancestral_state) || - !is.character(ancestral_state) || - length(ancestral_state) != 1L || - is.na(ancestral_state) - ) { - stop( - "ancestral_state must be a length-1 non-NA character string!" - ) - } - if (is.null(metadata)) { - metadata_raw <- NULL - } else if (is.raw(metadata)) { - metadata_raw <- metadata - } else if ( - is.character(metadata) && length(metadata) == 1L && !is.na(metadata) - ) { - metadata_raw <- charToRaw(metadata) - } else { - stop( - "metadata must be NULL, a raw vector, or a length-1 non-NA character string!" - ) - } + validate_numeric_scalar_arg(position, "position") + validate_character_scalar_arg(ancestral_state, "ancestral_state") + metadata_raw <- validate_metadata_arg(metadata) rtsk_site_table_add_row( tc = self$xptr, position = as.numeric(position), @@ -472,6 +805,26 @@ TableCollection <- R6Class( ) }, + #' @description Get one row from the site table. + #' @param index integer or numeric scalar row index (0-based). + #' @details See the \code{tskit Python} equivalent at + #' \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.SiteTable.__getitem__}. + #' The function accepts numeric \code{index} for ease of use, but converts + #' it to integer after checking that conversion to 32-bit integer succeeds. + #' Unlike Python table indexing, negative indices are not supported. + #' @return A named list with fields \code{id}, \code{position}, + #' \code{ancestral_state}, and \code{metadata} + #' (as raw bytes without metadata-schema decoding). + #' @examples + #' ts_file <- system.file("examples/test.trees", package = "RcppTskit") + #' tc <- tc_load(ts_file) + #' tc$site_table_get_row(0) + site_table_get_row = function(index) { + validate_row_index(index) + row <- rtsk_site_table_get_row(self$xptr, index = as.integer(index)) + row[c("id", "position", "ancestral_state", "metadata")] + }, + #' @description Get the number of mutations in a table collection. #' @return A signed 64 bit integer \code{bit64::integer64}. #' @examples @@ -482,96 +835,53 @@ TableCollection <- R6Class( rtsk_table_collection_get_num_mutations(self$xptr) }, - #' @description Add a row to the mutations table. - #' @param site integer scalar site row ID (0-based). - #' @param node integer scalar node row ID (0-based). - #' @param derived_state character string for the new mutation. - #' @param parent integer scalar parent mutation row ID (0-based); - #' use \code{-1} if not known - \code{NULL} maps to \code{-1} (\code{TSK_NULL}). + #' @description Add a row to the mutation table. + #' @param site integer or integer-valued numeric scalar site ID (0-based). + #' @param node integer or integer-valued numeric scalar node ID (0-based). + #' @param derived_state character string with the derived state. + #' @param parent integer or integer-valued numeric scalar parent mutation ID + #' (0-based); use \code{-1} or \code{NULL} if unknown. Both store + #' \code{TSK_NULL}. #' @param metadata for the new mutation; accepts \code{NULL}, - #' a raw vector, or a character of length 1. - #' @param time numeric scalar mutation time; - #' use \code{NaN} if not known - \code{NULL} maps to \code{NaN} (\code{TSK_UNKNOWN_TIME}). + #' a raw vector, or a character vector of length 1. Values are stored as + #' raw bytes without metadata-schema validation or encoding. + #' @param time numeric scalar mutation time. Use \code{NULL} (the default) + #' or \code{NaN} if unknown; both store \code{TSK_UNKNOWN_TIME}. #' @details See the \code{tskit Python} equivalent at #' \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.MutationTable.add_row}. - #' @return Integer row ID (0-based) of the newly added mutation. + #' Metadata schemas are not currently applied. + #' @return An integer row index and hence ID (0-based) of the newly added mutation. #' @examples #' ts_file <- system.file("examples/test.trees", package = "RcppTskit") #' tc <- tc_load(ts_file) - #' (n_before <- tc$num_mutations()) - #' # From inspection of tc we have: - #' # node13(time=0) <- node16(time=0.02...) <- node20(time=0.08...) - #' # Add mutation above 16L - #' m0 <- tc$mutation_table_add_row(site = 0L, node = 16L, derived_state = "T", time = 0.03) - #' # Add mutation above 13L - #' m1 <- tc$mutation_table_add_row( - #' site = 0L, - #' node = 13L, - #' parent = m0, - #' time = 0.01, - #' derived_state = "C", - #' metadata = "abc" + #' new_id <- tc$mutation_table_add_row( + #' site = 0L, node = 16L, derived_state = "T", metadata = "abc" #' ) - #' (n_after <- tc$num_mutations()) + #' tc$mutation_table_get_row(new_id) mutation_table_add_row = function( site, node, derived_state, parent = -1L, metadata = NULL, - time = NaN + time = NULL ) { - if ( - is.null(site) || !is.integer(site) || length(site) != 1L || is.na(site) - ) { - stop("site must be a non-NA integer scalar!") - } - if ( - is.null(node) || !is.integer(node) || length(node) != 1L || is.na(node) - ) { - stop("node must be a non-NA integer scalar!") - } - if ( - is.null(derived_state) || - !is.character(derived_state) || - length(derived_state) != 1L || - is.na(derived_state) - ) { - stop( - "derived_state must be a length-1 non-NA character string!" - ) - } - if ( - !is.null(parent) && - (!is.integer(parent) || - length(parent) != 1L || - is.na(parent) || - parent < -1L) - ) { - stop("parent must be -1L, NULL, or a non-NA integer scalar!") - } - if (is.null(metadata)) { - metadata_raw <- NULL - } else if (is.raw(metadata)) { - metadata_raw <- metadata - } else if ( - is.character(metadata) && length(metadata) == 1L && !is.na(metadata) - ) { - metadata_raw <- charToRaw(metadata) - } else { - stop( - "metadata must be NULL, a raw vector, or a length-1 non-NA character string!" - ) - } - if (!is.null(time)) { - if ( - !(is.numeric(time) && - length(time) == 1L && - (!is.na(time) || is.nan(time))) - ) { - stop("time must be NaN, NULL, or a non-NA numeric scalar!") - } - } + validate_row_index(site, "site") + validate_row_index(node, "node") + validate_character_scalar_arg(derived_state, "derived_state") + validate_integer_scalar_arg( + parent, + "parent", + minimum = -1L, + allow_null = TRUE + ) + metadata_raw <- validate_metadata_arg(metadata) + validate_numeric_scalar_arg( + time, + "time", + allow_null = TRUE, + allow_nan = TRUE + ) rtsk_mutation_table_add_row( tc = self$xptr, site = as.integer(site), @@ -583,6 +893,34 @@ TableCollection <- R6Class( ) }, + #' @description Get one row from the mutation table. + #' @param index integer or numeric scalar row index (0-based). + #' @details See the \code{tskit Python} equivalent at + #' \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.MutationTable.__getitem__}. + #' The function accepts numeric \code{index} for ease of use, but converts + #' it to integer after checking that conversion to 32-bit integer succeeds. + #' Unlike Python table indexing, negative indices are not supported. + #' @return A named list with fields \code{id}, \code{site}, \code{node}, + #' \code{derived_state}, \code{parent}, \code{metadata} + #' (as raw bytes without metadata-schema decoding), and \code{time}. + #' @examples + #' ts_file <- system.file("examples/test.trees", package = "RcppTskit") + #' tc <- tc_load(ts_file) + #' tc$mutation_table_get_row(0) + mutation_table_get_row = function(index) { + validate_row_index(index) + row <- rtsk_mutation_table_get_row(self$xptr, index = as.integer(index)) + row[c( + "id", + "site", + "node", + "derived_state", + "parent", + "metadata", + "time" + )] + }, + #' @description Get the sequence length. #' @return A numeric. #' @examples @@ -615,7 +953,7 @@ TableCollection <- R6Class( #' @description Build edge indexes for this table collection. #' @details See the \code{tskit Python} equivalent at - #' \url{https://tskit.dev/tskit/docs/latest/python-api.html#tskit.TableCollection.build_index}. + #' \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.TableCollection.build_index}. #' @return No return value; called for side effects. #' @examples #' tc_file <- system.file("examples/test.trees", package = "RcppTskit") @@ -631,7 +969,7 @@ TableCollection <- R6Class( #' @description Drop edge indexes for this table collection. #' @details See the \code{tskit Python} equivalent at - #' \url{https://tskit.dev/tskit/docs/latest/python-api.html#tskit.TableCollection.drop_index}. + #' \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.TableCollection.drop_index}. #' @return No return value; called for side effects. #' @examples #' tc_file <- system.file("examples/test.trees", package = "RcppTskit") diff --git a/RcppTskit/R/Class-TreeSequence.R b/RcppTskit/R/Class-TreeSequence.R index 957619d..5bf5248 100644 --- a/RcppTskit/R/Class-TreeSequence.R +++ b/RcppTskit/R/Class-TreeSequence.R @@ -19,7 +19,7 @@ TreeSequence <- R6Class( #' reference genome sequence information. #' @param xptr an external pointer (\code{externalptr}) to a tree sequence. #' @details See the \code{tskit Python} equivalent at - #' \url{https://tskit.dev/tskit/docs/latest/python-api.html#tskit.load}. + #' \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.load}. #' @return A \code{\link{TreeSequence}} object. #' @seealso \code{\link{ts_load}} #' @examples @@ -68,7 +68,7 @@ TreeSequence <- R6Class( #' @description Write a tree sequence to a file. #' @param file a string specifying the full path of the tree sequence file. #' @details See the \code{tskit Python} equivalent at - #' \url{https://tskit.dev/tskit/docs/latest/python-api.html#tskit.TreeSequence.dump}. + #' \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.TreeSequence.dump}. #' @return No return value; called for side effects. #' @examples #' ts_file <- system.file("examples/test.trees", package = "RcppTskit") @@ -89,7 +89,7 @@ TreeSequence <- R6Class( #' @description Copy the tables into a \code{\link{TableCollection}}. #' @details See the \code{tskit Python} equivalent at - #' \url{https://tskit.dev/tskit/docs/latest/python-api.html#tskit.TreeSequence.dump_tables}. + #' \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.TreeSequence.dump_tables}. #' @return A \code{\link{TableCollection}} object. #' @examples #' ts_file <- system.file("examples/test.trees", package = "RcppTskit") @@ -101,6 +101,87 @@ TreeSequence <- R6Class( TableCollection$new(xptr = tc_xptr) }, + #' @description Return a simplified copy of this tree sequence. + #' @param samples optional integer vector of distinct node IDs to retain as + #' samples. If \code{NULL}, use the nodes currently marked as samples. + #' @param map_nodes logical; if \code{TRUE}, also return the mapping from + #' input node IDs to output node IDs (see also return section). + #' @param reduce_to_site_topology logical; if \code{TRUE}, retain only + #' topology needed to represent trees containing sites. + #' @param filter_populations optional logical; if \code{TRUE}, remove + #' populations no longer referenced by nodes. If \code{NULL}, treated as + #' \code{TRUE}. + #' @param filter_individuals optional logical; if \code{TRUE}, remove + #' individuals no longer referenced by nodes. If \code{NULL}, treated as + #' \code{TRUE}. + #' @param filter_sites optional logical; if \code{TRUE}, remove sites no + #' longer referenced by mutations. If \code{NULL}, treated as + #' \code{TRUE}. + #' @param filter_nodes optional logical; if \code{TRUE}, remove nodes no + #' longer referenced by edges. If \code{NULL}, treated as + #' \code{TRUE}. + #' @param update_sample_flags optional logical; if \code{TRUE}, update node + #' flags so exactly the requested samples carry the sample flag. If + #' \code{NULL}, treated as \code{TRUE}. + #' @param keep_unary logical; if \code{TRUE}, retain unary nodes on paths + #' from samples to roots. + #' @param keep_unary_in_individuals optional logical; if \code{TRUE}, retain + #' unary nodes that are associated with an individual, while other unary + #' nodes may still be removed. Cannot be used with + #' \code{keep_unary = TRUE}. If \code{NULL}, treated as \code{FALSE}. + #' @param keep_input_roots logical; retain topology back to the roots in the + #' input tree sequence rather than stopping at samples' MRCAs. + #' @param record_provenance logical; record this simplify call in the + #' returned tree sequence. + #' @details See the \code{tskit Python} equivalent at + #' \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.TreeSequence.simplify}. + #' The input tree sequence is unchanged. + #' @return A simplified \code{\link{TreeSequence}}. If + #' \code{map_nodes = TRUE}, return a named list containing + #' \code{tree_sequence} and the integer \code{node_map}; + #' removed nodes map to \code{-1}. + #' @examples + #' ts_file <- system.file("examples/test.trees", package = "RcppTskit") + #' ts <- ts_load(ts_file) + #' ts_simplified <- ts$simplify(samples = c(0L, 1L, 2L, 3L)) + #' c(before = ts$num_nodes(), + #' after = ts_simplified$num_nodes()) + simplify = function( + samples = NULL, + map_nodes = FALSE, + reduce_to_site_topology = FALSE, + filter_populations = NULL, + filter_individuals = NULL, + filter_sites = NULL, + filter_nodes = NULL, + update_sample_flags = NULL, + keep_unary = FALSE, + keep_unary_in_individuals = NULL, + keep_input_roots = FALSE, + record_provenance = TRUE + ) { + validate_logical_arg(map_nodes, "map_nodes") + tables <- self$dump_tables() + node_map <- tables$simplify( + samples = samples, + reduce_to_site_topology = reduce_to_site_topology, + filter_populations = filter_populations, + filter_individuals = filter_individuals, + filter_sites = filter_sites, + filter_nodes = filter_nodes, + update_sample_flags = update_sample_flags, + keep_unary = keep_unary, + keep_unary_in_individuals = keep_unary_in_individuals, + keep_input_roots = keep_input_roots, + record_provenance = record_provenance + ) + new_ts <- tables$tree_sequence() + if (map_nodes) { + return(list(tree_sequence = new_ts, node_map = node_map)) + } + return(new_ts) + }, + #' @description Print a summary of a tree sequence and its contents. #' @return A list with two data.frames; the first contains tree sequence #' properties and their values; the second contains the number of rows in @@ -161,10 +242,94 @@ TreeSequence <- R6Class( ) }, + #' @description Iterate over sites as decoded variants. + #' @param samples Optional integer vector of sample node IDs to decode. + #' @param isolated_as_missing Logical; decode isolated samples as missing + #' data (\code{TRUE}, default) or as ancestral state (\code{FALSE}). + #' @param alleles Optional character vector of allele states; when set, + #' genotypes are indexed to this allele order. + #' @param impute_missing_data Deprecated alias for + #' \code{!isolated_as_missing}. + #' @param copy Logical; currently only \code{TRUE} is supported. + #' @param left Left genomic coordinate (inclusive). + #' @param right Right genomic coordinate (exclusive). \code{NULL} means + #' sequence length. + #' @details See the \code{tskit Python} equivalent at + #' \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.TreeSequence.variants}. + #' @return A simple iterator object with methods \code{next()} and + #' \code{next_variant()} that each return either a variant list or + #' \code{NULL} at end. + #' @examples + #' ts_file <- system.file("examples/test.trees", package = "RcppTskit") + #' ts <- ts_load(ts_file) + #' it <- ts$variants() + #' v1 <- it$next_variant() + #' v2 <- it$next_variant() + #' is.list(v1) + #' is.list(v2) + variants = function( + samples = NULL, + isolated_as_missing = TRUE, + alleles = NULL, + impute_missing_data = NULL, + copy = TRUE, + left = 0, + right = NULL + ) { + if (!is.logical(copy) || length(copy) != 1 || is.na(copy)) { + stop("copy must be TRUE/FALSE!") + } + if (!copy) { + stop("copy = FALSE is not supported yet!") + } + if (!is.null(impute_missing_data)) { + if ( + !is.logical(impute_missing_data) || + length(impute_missing_data) != 1 || + is.na(impute_missing_data) + ) { + stop("impute_missing_data must be TRUE/FALSE or NULL!") + } + mapped <- !impute_missing_data + if ( + !missing(isolated_as_missing) && + !identical(isolated_as_missing, mapped) + ) { + stop( + "isolated_as_missing and impute_missing_data are inconsistent!" + ) + } + warning( + "impute_missing_data is deprecated; use isolated_as_missing", + call. = FALSE + ) + isolated_as_missing <- mapped + } + + iter_xptr <- rtsk_treeseq_init_variants_iterator( + ts = self$xptr, + samples = samples, + isolated_as_missing = isolated_as_missing, + alleles = alleles, + left = left, + right = if (is.null(right)) NA_real_ else right + ) + + env <- new.env(parent = emptyenv()) + env$iter_xptr <- iter_xptr + next_fun <- function() { + rtsk_treeseq_next_variant(env$iter_xptr) + } + structure( + list(`next` = next_fun, next_variant = next_fun), + class = "rtsk_variant_iterator" + ) + }, + #' @description Get the number of provenances in a tree sequence. #' @return A signed 64 bit integer \code{bit64::integer64}. #' @details See the \code{tskit Python} equivalent at - #' \url{https://tskit.dev/tskit/docs/latest/python-api.html#tskit.TreeSequence.num_provenances}. + #' \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.TreeSequence.num_provenances}. #' @examples #' ts_file <- system.file("examples/test.trees", package = "RcppTskit") #' ts <- ts_load(ts_file) @@ -176,7 +341,7 @@ TreeSequence <- R6Class( #' @description Get the number of populations in a tree sequence. #' @return A signed 64 bit integer \code{bit64::integer64}. #' @details See the \code{tskit Python} equivalent at - #' \url{https://tskit.dev/tskit/docs/latest/python-api.html#tskit.TreeSequence.num_populations}. + #' \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.TreeSequence.num_populations}. #' @examples #' ts_file <- system.file("examples/test.trees", package = "RcppTskit") #' ts <- ts_load(ts_file) @@ -188,7 +353,7 @@ TreeSequence <- R6Class( #' @description Get the number of migrations in a tree sequence. #' @return A signed 64 bit integer \code{bit64::integer64}. #' @details See the \code{tskit Python} equivalent at - #' \url{https://tskit.dev/tskit/docs/latest/python-api.html#tskit.TreeSequence.num_migrations}. + #' \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.TreeSequence.num_migrations}. #' @examples #' ts_file <- system.file("examples/test.trees", package = "RcppTskit") #' ts <- ts_load(ts_file) @@ -200,7 +365,7 @@ TreeSequence <- R6Class( #' @description Get the number of individuals in a tree sequence. #' @return A signed 64 bit integer \code{bit64::integer64}. #' @details See the \code{tskit Python} equivalent at - #' \url{https://tskit.dev/tskit/docs/latest/python-api.html#tskit.TreeSequence.num_individuals}. + #' \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.TreeSequence.num_individuals}. #' @examples #' ts_file <- system.file("examples/test.trees", package = "RcppTskit") #' ts <- ts_load(ts_file) @@ -212,7 +377,7 @@ TreeSequence <- R6Class( #' @description Get the number of samples (of nodes) in a tree sequence. #' @return A signed 64 bit integer \code{bit64::integer64}. #' @details See the \code{tskit Python} equivalent at - #' \url{https://tskit.dev/tskit/docs/latest/python-api.html#tskit.TreeSequence.num_samples}. + #' \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.TreeSequence.num_samples}. #' @examples #' ts_file <- system.file("examples/test.trees", package = "RcppTskit") #' ts <- ts_load(ts_file) @@ -221,10 +386,73 @@ TreeSequence <- R6Class( rtsk_treeseq_get_num_samples(self$xptr) }, + #' @description Get sample node IDs in this tree sequence. + #' @param population integer or integer-valued numeric scalar population ID + #' (0-based) used to filter samples. If \code{NULL}, do not filter by + #' population. + #' @param time numeric scalar or numeric vector of length 2 used to filter + #' samples by node time. A scalar selects samples with approximately equal + #' node time. A pair \code{c(min_time, max_time)} selects samples in the + #' half-open interval \code{min_time <= time < max_time}. If \code{NULL}, + #' do not filter by time. + #' @return An integer vector containing the sample node IDs (0-based) in + #' numerical order. + #' @details See the \code{tskit Python} equivalent at + #' \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.TreeSequence.samples}. + #' @examples + #' ts_file <- system.file("examples/test.trees", package = "RcppTskit") + #' ts <- ts_load(ts_file) + #' ts$samples() + samples = function(population = NULL, time = NULL) { + validate_row_index(population, "population", allow_null = TRUE) + validate_optional_numeric_vector_arg( + time, + "time", + lengths = c(1L, 2L), + error_message = paste0( + "time must be either a single value or a pair of values ", + "(min_time, max_time)." + ) + ) + needs_node_data <- !is.null(population) || !is.null(time) + sample_data <- if (needs_node_data) { + rtsk_treeseq_get_sample_node_data(self$xptr) + } else { + NULL + } + samples <- if (needs_node_data) { + sample_data$samples + } else { + rtsk_treeseq_get_samples(self$xptr) + } + keep <- rep(TRUE, length(samples)) + + if (!is.null(population)) { + sample_population <- sample_data$population + keep <- keep & (sample_population == as.integer(population)) + } + + if (!is.null(time)) { + sample_time <- sample_data$time + if (length(time) == 1L) { + keep <- keep & numeric_values_are_close(sample_time, time) + } else { + if (time[2] <= time[1]) { + stop("time_interval max is less than or equal to min.") + } + keep <- keep & + (sample_time >= time[1]) & + (sample_time < time[2]) + } + } + + samples[keep] + }, + #' @description Get the number of nodes in a tree sequence. #' @return A signed 64 bit integer \code{bit64::integer64}. #' @details See the \code{tskit Python} equivalent at - #' \url{https://tskit.dev/tskit/docs/latest/python-api.html#tskit.TreeSequence.num_nodes}. + #' \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.TreeSequence.num_nodes}. #' @examples #' ts_file <- system.file("examples/test.trees", package = "RcppTskit") #' ts <- ts_load(ts_file) @@ -236,7 +464,7 @@ TreeSequence <- R6Class( #' @description Get the number of edges in a tree sequence. #' @return A signed 64 bit integer \code{bit64::integer64}. #' @details See the \code{tskit Python} equivalent at - #' \url{https://tskit.dev/tskit/docs/latest/python-api.html#tskit.TreeSequence.num_nodes}. + #' \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.TreeSequence.num_nodes}. #' @examples #' ts_file <- system.file("examples/test.trees", package = "RcppTskit") #' ts <- ts_load(ts_file) @@ -248,7 +476,7 @@ TreeSequence <- R6Class( #' @description Get the number of trees in a tree sequence. #' @return A signed 64 bit integer \code{bit64::integer64}. #' @details See the \code{tskit Python} equivalent at - #' \url{https://tskit.dev/tskit/docs/latest/python-api.html#tskit.TreeSequence.num_trees}. + #' \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.TreeSequence.num_trees}. #' @examples #' ts_file <- system.file("examples/test.trees", package = "RcppTskit") #' ts <- ts_load(ts_file) @@ -260,7 +488,7 @@ TreeSequence <- R6Class( #' @description Get the number of sites in a tree sequence. #' @return A signed 64 bit integer \code{bit64::integer64}. #' @details See the \code{tskit Python} equivalent at - #' \url{https://tskit.dev/tskit/docs/latest/python-api.html#tskit.TreeSequence.num_sites}. + #' \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.TreeSequence.num_sites}. #' @examples #' ts_file <- system.file("examples/test.trees", package = "RcppTskit") #' ts <- ts_load(ts_file) @@ -272,7 +500,7 @@ TreeSequence <- R6Class( #' @description Get the number of mutations in a tree sequence. #' @return A signed 64 bit integer \code{bit64::integer64}. #' @details See the \code{tskit Python} equivalent at - #' \url{https://tskit.dev/tskit/docs/latest/python-api.html#tskit.TreeSequence.num_mutations}. + #' \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.TreeSequence.num_mutations}. #' @examples #' ts_file <- system.file("examples/test.trees", package = "RcppTskit") #' ts <- ts_load(ts_file) @@ -284,7 +512,7 @@ TreeSequence <- R6Class( #' @description Get the sequence length. #' @return A numeric. #' @details See the \code{tskit Python} equivalent at - #' \url{https://tskit.dev/tskit/docs/latest/python-api.html#tskit.TreeSequence.sequence_length}. + #' \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.TreeSequence.sequence_length}. #' @examples #' ts_file <- system.file("examples/test.trees", package = "RcppTskit") #' ts <- ts_load(ts_file) @@ -297,7 +525,7 @@ TreeSequence <- R6Class( #' @details Returns \code{TRUE} if all genomic coordinates in the tree #' sequence are discrete integer values. #' @details See the \code{tskit Python} equivalent at - #' \url{https://tskit.dev/tskit/docs/latest/python-api.html#tskit.TreeSequence.discrete_genome}. + #' \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.TreeSequence.discrete_genome}. #' @return A logical. #' @examples #' ts_file1 <- system.file("examples/test.trees", package = "RcppTskit") @@ -313,7 +541,7 @@ TreeSequence <- R6Class( #' @description Get whether the tree sequence has a reference genome sequence. #' @return A logical. #' @details See the \code{tskit Python} equivalent at - #' \url{https://tskit.dev/tskit/docs/latest/python-api.html#tskit.TreeSequence.has_reference_sequence}. + #' \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.TreeSequence.has_reference_sequence}. #' @examples #' ts_file1 <- system.file("examples/test.trees", package = "RcppTskit") #' ts_file2 <- system.file("examples/test_with_ref_seq.trees", package = "RcppTskit") @@ -328,7 +556,7 @@ TreeSequence <- R6Class( #' @description Get the time units string. #' @return A character. #' @details See the \code{tskit Python} equivalent at - #' \url{https://tskit.dev/tskit/docs/latest/python-api.html#tskit.TreeSequence.time_units}. + #' \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.TreeSequence.time_units}. #' @examples #' ts_file <- system.file("examples/test.trees", package = "RcppTskit") #' ts <- ts_load(ts_file) @@ -341,7 +569,7 @@ TreeSequence <- R6Class( #' @details Returns \code{TRUE} if all time values in the tree sequence are #' discrete integer values. #' @details See the \code{tskit Python} equivalent at - #' \url{https://tskit.dev/tskit/docs/latest/python-api.html#tskit.TreeSequence.discrete_time}. + #' \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.TreeSequence.discrete_time}. #' @return A logical. #' @examples #' ts_file1 <- system.file("examples/test.trees", package = "RcppTskit") @@ -356,7 +584,7 @@ TreeSequence <- R6Class( #' @description Get the min time in node table and mutation table. #' @details See the \code{tskit Python} equivalent at - #' \url{https://tskit.dev/tskit/docs/latest/python-api.html#tskit.TreeSequence.min_time}. + #' \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.TreeSequence.min_time}. #' @return A numeric. #' @examples #' ts_file <- system.file("examples/test.trees", package = "RcppTskit") @@ -368,7 +596,7 @@ TreeSequence <- R6Class( #' @description Get the max time in node table and mutation table. #' @details See the \code{tskit Python} equivalent at - #' \url{https://tskit.dev/tskit/docs/latest/python-api.html#tskit.TreeSequence.max_time}. + #' \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.TreeSequence.max_time}. #' @return A numeric. #' @examples #' ts_file <- system.file("examples/test.trees", package = "RcppTskit") diff --git a/RcppTskit/R/RcppExports.R b/RcppTskit/R/RcppExports.R index 2179a8b..570af2b 100644 --- a/RcppTskit/R/RcppExports.R +++ b/RcppTskit/R/RcppExports.R @@ -1,10 +1,34 @@ # Generated by using Rcpp::compileAttributes() -> do not edit by hand # Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393 +rtsk_treeseq_init_variants_iterator <- function(ts, samples = NULL, isolated_as_missing = TRUE, alleles = NULL, left = 0.0, right = NA_real_) { + .Call(`_RcppTskit_rtsk_treeseq_init_variants_iterator`, ts, samples, isolated_as_missing, alleles, left, right) +} + +rtsk_treeseq_next_variant <- function(iterator) { + .Call(`_RcppTskit_rtsk_treeseq_next_variant`, iterator) +} + +test_rtsk_variant_iterator_force_null_first_allele <- function(enabled) { + invisible(.Call(`_RcppTskit_test_rtsk_variant_iterator_force_null_first_allele`, enabled)) +} + +test_rtsk_variant_iterator_set_site_bounds <- function(iterator, next_site_id, stop_site_id) { + invisible(.Call(`_RcppTskit_test_rtsk_variant_iterator_set_site_bounds`, iterator, next_site_id, stop_site_id)) +} + +test_variant_site_index_range <- function(start, stop) { + invisible(.Call(`_RcppTskit_test_variant_site_index_range`, start, stop)) +} + test_validate_options <- function(options, supported) { .Call(`_RcppTskit_test_validate_options`, options, supported) } +test_rtsk_wrap_tsk_flags_as_int <- function(value) { + .Call(`_RcppTskit_test_rtsk_wrap_tsk_flags_as_int`, value) +} + test_rtsk_wrap_tsk_size_t_as_integer64 <- function(value, force_range_error = FALSE) { .Call(`_RcppTskit_test_rtsk_wrap_tsk_size_t_as_integer64`, value, force_range_error) } @@ -75,6 +99,14 @@ rtsk_treeseq_get_num_samples <- function(ts) { .Call(`_RcppTskit_rtsk_treeseq_get_num_samples`, ts) } +rtsk_treeseq_get_samples <- function(ts) { + .Call(`_RcppTskit_rtsk_treeseq_get_samples`, ts) +} + +rtsk_treeseq_get_sample_node_data <- function(ts) { + .Call(`_RcppTskit_rtsk_treeseq_get_sample_node_data`, ts) +} + rtsk_treeseq_get_num_nodes <- function(ts) { .Call(`_RcppTskit_rtsk_treeseq_get_num_nodes`, ts) } @@ -195,6 +227,14 @@ rtsk_table_collection_drop_index <- function(tc, options = 0L) { invisible(.Call(`_RcppTskit_rtsk_table_collection_drop_index`, tc, options)) } +rtsk_table_collection_sort <- function(tc, start_edges = 0L, start_sites = 0L, start_mutations = 0L, options = 0L) { + invisible(.Call(`_RcppTskit_rtsk_table_collection_sort`, tc, start_edges, start_sites, start_mutations, options)) +} + +rtsk_table_collection_simplify <- function(tc, samples = NULL, options = 0L) { + .Call(`_RcppTskit_rtsk_table_collection_simplify`, tc, samples, options) +} + rtsk_table_collection_summary <- function(tc) { .Call(`_RcppTskit_rtsk_table_collection_summary`, tc) } @@ -207,22 +247,66 @@ rtsk_individual_table_add_row <- function(tc, flags = 0L, location = NULL, paren .Call(`_RcppTskit_rtsk_individual_table_add_row`, tc, flags, location, parents, metadata) } +rtsk_individual_table_get_row <- function(tc, index) { + .Call(`_RcppTskit_rtsk_individual_table_get_row`, tc, index) +} + rtsk_node_table_add_row <- function(tc, flags = 0L, time = 0, population = -1L, individual = -1L, metadata = NULL) { .Call(`_RcppTskit_rtsk_node_table_add_row`, tc, flags, time, population, individual, metadata) } +rtsk_node_table_get_row <- function(tc, index) { + .Call(`_RcppTskit_rtsk_node_table_get_row`, tc, index) +} + rtsk_edge_table_add_row <- function(tc, left, right, parent, child, metadata = NULL) { .Call(`_RcppTskit_rtsk_edge_table_add_row`, tc, left, right, parent, child, metadata) } +rtsk_edge_table_get_row <- function(tc, index) { + .Call(`_RcppTskit_rtsk_edge_table_get_row`, tc, index) +} + rtsk_site_table_add_row <- function(tc, position, ancestral_state, metadata = NULL) { .Call(`_RcppTskit_rtsk_site_table_add_row`, tc, position, ancestral_state, metadata) } +rtsk_site_table_get_row <- function(tc, index) { + .Call(`_RcppTskit_rtsk_site_table_get_row`, tc, index) +} + rtsk_mutation_table_add_row <- function(tc, site, node, parent, time, derived_state, metadata = NULL) { .Call(`_RcppTskit_rtsk_mutation_table_add_row`, tc, site, node, parent, time, derived_state, metadata) } +rtsk_mutation_table_get_row <- function(tc, index) { + .Call(`_RcppTskit_rtsk_mutation_table_get_row`, tc, index) +} + +rtsk_population_table_add_row <- function(tc, metadata = NULL) { + .Call(`_RcppTskit_rtsk_population_table_add_row`, tc, metadata) +} + +rtsk_population_table_get_row <- function(tc, index) { + .Call(`_RcppTskit_rtsk_population_table_get_row`, tc, index) +} + +rtsk_migration_table_add_row <- function(tc, left, right, node, source, dest, time, metadata = NULL) { + .Call(`_RcppTskit_rtsk_migration_table_add_row`, tc, left, right, node, source, dest, time, metadata) +} + +rtsk_migration_table_get_row <- function(tc, index) { + .Call(`_RcppTskit_rtsk_migration_table_get_row`, tc, index) +} + +rtsk_provenance_table_add_row <- function(tc, timestamp, record) { + .Call(`_RcppTskit_rtsk_provenance_table_add_row`, tc, timestamp, record) +} + +rtsk_provenance_table_get_row <- function(tc, index) { + .Call(`_RcppTskit_rtsk_provenance_table_get_row`, tc, index) +} + test_tsk_bug_assert_c <- function() { invisible(.Call(`_RcppTskit_test_tsk_bug_assert_c`)) } @@ -275,3 +359,15 @@ test_rtsk_mutation_table_add_row_forced_error <- function(tc) { invisible(.Call(`_RcppTskit_test_rtsk_mutation_table_add_row_forced_error`, tc)) } +test_rtsk_population_table_add_row_forced_error <- function(tc) { + invisible(.Call(`_RcppTskit_test_rtsk_population_table_add_row_forced_error`, tc)) +} + +test_rtsk_migration_table_add_row_forced_error <- function(tc) { + invisible(.Call(`_RcppTskit_test_rtsk_migration_table_add_row_forced_error`, tc)) +} + +test_rtsk_provenance_table_add_row_forced_error <- function(tc) { + invisible(.Call(`_RcppTskit_test_rtsk_provenance_table_add_row_forced_error`, tc)) +} + diff --git a/RcppTskit/R/RcppTskit-package.R b/RcppTskit/R/RcppTskit-package.R index 60736bc..6c35c1b 100644 --- a/RcppTskit/R/RcppTskit-package.R +++ b/RcppTskit/R/RcppTskit-package.R @@ -15,11 +15,13 @@ #' where the \code{reticulate} option is not optimal; for example; high-performance #' or low-level work with tree sequences. Currently, \code{RcppTskit} provides a #' limited set of \code{R} functions because the \code{Python} API and -#' \code{reticulate} already covers most needs. The provided \code{RcppTskit R} -#' API mirrors the \code{tskit Python} API, while the \code{RcppTskit C++} API -#' mirrors the \code{tskit C} API. Users should explore the \code{RcppTskit} -#' help pages of \code{R} functions, while developers should explore the provided -#' \code{RcppTskit:::rtsk_*} low-level \code{R} and \code{C++} functions. +#' \code{reticulate} already covers most needs. The \code{RcppTskit R} API +#' combines an \code{R6} object model inspired by the \code{tskit Python} API +#' with operations that map directly to the \code{tskit C} API. The +#' \code{RcppTskit C++} API closely mirrors the \code{tskit C} API. Users should +#' explore the \code{RcppTskit} help pages of \code{R} functions, while +#' developers should explore the provided \code{RcppTskit:::rtsk_*} low-level +#' \code{R} and \code{C++} functions. #' @keywords internal #' #' @useDynLib RcppTskit, .registration = TRUE diff --git a/RcppTskit/R/RcppTskit.R b/RcppTskit/R/RcppTskit.R index d99a468..ed76da7 100644 --- a/RcppTskit/R/RcppTskit.R +++ b/RcppTskit/R/RcppTskit.R @@ -99,6 +99,7 @@ check_tskit_py <- function(object, stop = FALSE) { } } +# INTERNAL # @title Validating logical args # @param value logical from the argument # @param name character of the argument @@ -109,6 +110,262 @@ validate_logical_arg <- function(value, name) { } } +# INTERNAL +# @title Validating integer scalar args +# @param value integer scalar from the argument +# @param name character of the argument +# @param minimum lower bound +# @param allow_null logical +# @param strict logical throw an error when value is numeric +# @details To make it flexible for R users, we also accept numeric input, +# unless \code{strict = TRUE} (in that case this function throws an error). +# @return Integer scalar (or NULL if allowed). +validate_integer_scalar_arg <- function( + value, + name, + minimum = NULL, + allow_null = FALSE, + strict = FALSE +) { + if (is.null(value)) { + if (allow_null) { + return(NULL) + } + stop(name, " cannot be NULL.", call. = FALSE) + } + + abort <- function() { + msg <- "a non-NA integer scalar within 32-bit range" + if (identical(minimum, 0L)) { + msg <- paste0( + "a non-NA, non-negative integer scalar no greater than ", + ".Machine$integer.max" + ) + } else if (!is.null(minimum)) { + msg <- paste0(msg, " (>= ", minimum, ")") + } + if (allow_null) { + stop(name, " must be NULL or ", msg, "!", call. = FALSE) + } + stop(name, " must be ", msg, "!", call. = FALSE) + } + + is_valid_type <- if (strict) { + is.integer(value) + } else { + is.numeric(value) + } + if (!is_valid_type || length(value) != 1L || is.na(value)) { + abort() + } + + if (is.integer(value)) { + if (!is.null(minimum) && value < minimum) { + abort() + } + return(value) + } + + value_num <- as.numeric(value) + int_min <- -as.numeric(.Machine$integer.max) - 1 + int_max <- as.numeric(.Machine$integer.max) + is_whole <- value_num %% 1 == 0 + is_within_bounds <- value_num >= int_min && value_num <= int_max + is_above_min <- is.null(minimum) || value_num >= minimum + + if ( + !is.finite(value_num) || !is_whole || !is_within_bounds || !is_above_min + ) { + abort() + } + + return(as.integer(value_num)) +} + +# INTERNAL +# @title Validating row indexes +# @param index integer row index (0-based) +# @param name character of the argument +# @param allow_null logical +# @return No return value; called for side effects. +validate_row_index <- function( + index, + name = "index", + allow_null = FALSE +) { + validate_integer_scalar_arg( + index, + name, + minimum = 0L, + allow_null = allow_null + ) +} + +# INTERNAL +# @title Validating optional numeric vectors with no missing values +# @param value numeric vector or \code{NULL} +# @param name character of the argument +# @param lengths optional integer vector of permitted lengths +# @param error_message optional caller-specific error message +# @return No return value; called for side effects. +validate_optional_numeric_vector_arg <- function( + value, + name, + lengths = NULL, + error_message = NULL +) { + if (is.null(value)) { + return(invisible(NULL)) + } + + valid_type <- is.integer(value) || is.double(value) + valid_length <- is.null(lengths) || length(value) %in% lengths + if (!valid_type || !is.null(dim(value)) || anyNA(value) || !valid_length) { + if (!is.null(error_message)) { + stop(error_message, call. = FALSE) + } + stop( + name, + " must be NULL or a numeric vector with no NA values!", + call. = FALSE + ) + } + + invisible(NULL) +} + +# INTERNAL +# @title Compare numeric values using NumPy's default isclose tolerances +# @param value numeric vector +# @param target numeric scalar +# @return Logical vector indicating which values are close to \code{target}. +numeric_values_are_close <- function(value, target) { + close <- value == target + finite <- is.finite(value) & is.finite(target) + close[finite] <- + abs(value[finite] - target) <= 1e-08 + 1e-05 * abs(target) + close[is.na(close)] <- FALSE + close +} + +# INTERNAL +# @title Validating optional integer vectors with no missing values +# @param value integer vector or \code{NULL} +# @param name character of the argument +# @param strict logical throw an error when value is numeric +# @details To make it flexible for R users, we also accept numeric input, +# unless \code{strict = TRUE} (in that case this function throws an error). +# @return No return value; called for side effects. +validate_optional_integer_vector_arg <- function(value, name, strict = FALSE) { + int_min <- -as.numeric(.Machine$integer.max) - 1 + int_max <- as.numeric(.Machine$integer.max) + + if (is.null(value)) { + return(invisible(NULL)) + } + + if (strict && !is.integer(value)) { + stop( + name, + " must be NULL or an integer vector with no NA values within 32-bit range!" + ) + } + + value_num <- suppressWarnings(as.numeric(value)) + + if ( + !is.numeric(value) || + anyNA(value_num) || + !all(is.finite(value_num)) || + any(value_num != trunc(value_num)) || + any(value_num < int_min) || + any(value_num > int_max) + ) { + stop( + name, + " must be NULL or an integer vector with no NA values within 32-bit range!" + ) + } + + invisible(as.integer(value_num)) +} + +# INTERNAL +# @title Validating numeric scalar args +# @param value numeric scalar +# @param name character of the argument +# @param allow_null logical +# @param allow_nan logical +# @return No return value; called for side effects. +validate_numeric_scalar_arg <- function( + value, + name, + allow_null = FALSE, + allow_nan = FALSE +) { + if (is.null(value)) { + if (allow_null) { + return(invisible(NULL)) + } + stop(name, " must be a non-NA numeric scalar!") + } + if (!is.numeric(value) || length(value) != 1L) { + if (allow_null && allow_nan) { + stop(name, " must be NaN, NULL, or a non-NA numeric scalar!") + } + stop(name, " must be a non-NA numeric scalar!") + } + if (allow_nan) { + if (!is.na(value) || is.nan(value)) { + return(invisible(NULL)) + } + stop(name, " must be NaN, NULL, or a non-NA numeric scalar!") + } + if (is.na(value)) { + stop(name, " must be a non-NA numeric scalar!") + } +} + +# INTERNAL +# @title Validating character scalar args +# @param value character scalar +# @param name character of the argument +# @return No return value; called for side effects. +validate_character_scalar_arg <- function(value, name) { + if ( + is.null(value) || + !is.character(value) || + length(value) != 1L || + is.na(value) + ) { + stop(name, " must be a length-1 non-NA character string!") + } +} + +# INTERNAL +# @title Validating metadata argument and possibly converting it to raw +# @param metadata \code{NULL}, character, or raw argument +# @return \code{NULL} when metadata is \code{NULL} and raw vector otherwise. +validate_metadata_arg <- function(metadata) { + if (is.null(metadata)) { + return(NULL) + } + if ( + is.character(metadata) && + length(metadata) == 1L && + !is.na(metadata) + ) { + return(charToRaw(metadata)) + } + if (is.raw(metadata)) { + return(metadata) + } + stop( + "metadata must be NULL, a length-1 non-NA character string, or a raw vector!" + ) +} + +# INTERNAL # @title Converting load arguments to \code{tskit} bitwise options # @param skip_tables logical # @param skip_reference_sequence logical @@ -141,7 +398,7 @@ load_args_to_options <- function( #' @param skip_reference_sequence logical; if \code{TRUE}, skip loading #' reference genome sequence information. #' @details See the \code{tskit Python} equivalent at -#' \url{https://tskit.dev/tskit/docs/latest/python-api.html#tskit.load}. +#' \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.load}. #' @return A \code{\link{TreeSequence}} object. #' @seealso \code{\link[=TreeSequence]{TreeSequence$new}} #' @examples diff --git a/RcppTskit/inst/examples/create_test.trees.py b/RcppTskit/inst/examples/create_test.trees.py index dab1845..c1af24a 100644 --- a/RcppTskit/inst/examples/create_test.trees.py +++ b/RcppTskit/inst/examples/create_test.trees.py @@ -10,6 +10,8 @@ ) ts = msprime.sim_mutations(ts, rate=2e-2, random_seed=42) ts +# os.getcwd() +# ts = tskit.load("RcppTskit/inst/examples/test.trees") print(ts) ts.num_provenances # 2 ts.num_populations # 1 @@ -26,6 +28,15 @@ ts.min_time # 0.0 ts.max_time # 6.961993337190808 +ts.samples() +# array([ 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15], +# dtype=int32) + +ts.tables.nodes[0] +# NodeTableRow(flags=1, time=0.0, population=0, individual=0, metadata=b'') +ts.tables.nodes[38] +# NodeTableRow(flags=0, time=6.961993337190808, population=0, individual=-1, metadata=b'') + ts.metadata # b'' type(ts.metadata) # bytes len(ts.metadata) # 0 @@ -63,6 +74,14 @@ # test_trees_file_uuid <- "79ec383f-a57d-b44f-2a5c-f0feecbbcb32" # ts = tskit.load("RcppTskit/inst/examples/test.trees") +# Tiny non-sorted table-collection example used to test TableCollection.sort() +tc_unsorted = ts.dump_tables() +tc_unsorted.sites.add_row( + position=tc_unsorted.sites.position[-1] / 2, + ancestral_state="A", +) +tc_unsorted.dump("RcppTskit/inst/examples/test_unsorted.trees") + # ----------------------------------------------------------------------------- # Create a second tree sequence with metadata in some tables diff --git a/RcppTskit/inst/examples/test_unsorted.trees b/RcppTskit/inst/examples/test_unsorted.trees new file mode 100644 index 0000000..338b71a Binary files /dev/null and b/RcppTskit/inst/examples/test_unsorted.trees differ diff --git a/RcppTskit/inst/include/RcppTskit_public.hpp b/RcppTskit/inst/include/RcppTskit_public.hpp index 878a870..f6f83f1 100644 --- a/RcppTskit/inst/include/RcppTskit_public.hpp +++ b/RcppTskit/inst/include/RcppTskit_public.hpp @@ -18,12 +18,19 @@ void rtsk_table_collection_dump(SEXP tc, const std::string &filename, int options = 0); SEXP rtsk_treeseq_copy_tables(SEXP ts, int options = 0); SEXP rtsk_treeseq_init(SEXP tc, int options = 0); +SEXP rtsk_treeseq_init_variants_iterator( + SEXP ts, Rcpp::Nullable samples = R_NilValue, + bool isolated_as_missing = true, + Rcpp::Nullable alleles = R_NilValue, + double left = 0.0, double right = NA_REAL); +SEXP rtsk_treeseq_next_variant(SEXP iterator); SEXP rtsk_treeseq_get_num_provenances(SEXP ts); SEXP rtsk_treeseq_get_num_populations(SEXP ts); SEXP rtsk_treeseq_get_num_migrations(SEXP ts); SEXP rtsk_treeseq_get_num_individuals(SEXP ts); SEXP rtsk_treeseq_get_num_samples(SEXP ts); +Rcpp::IntegerVector rtsk_treeseq_get_samples(SEXP ts); SEXP rtsk_treeseq_get_num_nodes(SEXP ts); SEXP rtsk_treeseq_get_num_edges(SEXP ts); SEXP rtsk_treeseq_get_num_trees(SEXP ts); @@ -55,6 +62,12 @@ Rcpp::String rtsk_table_collection_get_file_uuid(SEXP tc); bool rtsk_table_collection_has_index(SEXP tc, int options = 0); void rtsk_table_collection_build_index(SEXP tc, int options = 0); void rtsk_table_collection_drop_index(SEXP tc, int options = 0); +void rtsk_table_collection_sort(SEXP tc, int start_edges = 0, + int start_sites = 0, int start_mutations = 0, + int options = 0); +Rcpp::IntegerVector rtsk_table_collection_simplify( + SEXP tc, Rcpp::Nullable samples = R_NilValue, + int options = 0); Rcpp::List rtsk_table_collection_summary(SEXP tc); Rcpp::List rtsk_table_collection_metadata_length(SEXP tc); int rtsk_individual_table_add_row( @@ -62,18 +75,33 @@ int rtsk_individual_table_add_row( Rcpp::Nullable location = R_NilValue, Rcpp::Nullable parents = R_NilValue, Rcpp::Nullable metadata = R_NilValue); +Rcpp::List rtsk_individual_table_get_row(SEXP tc, int index); int rtsk_node_table_add_row( SEXP tc, int flags = 0, double time = 0, int population = -1, int individual = -1, Rcpp::Nullable metadata = R_NilValue); +Rcpp::List rtsk_node_table_get_row(SEXP tc, int index); int rtsk_edge_table_add_row( SEXP tc, double left, double right, int parent, int child, Rcpp::Nullable metadata = R_NilValue); +Rcpp::List rtsk_edge_table_get_row(SEXP tc, int index); int rtsk_site_table_add_row( SEXP tc, double position, const std::string &ancestral_state, Rcpp::Nullable metadata = R_NilValue); +Rcpp::List rtsk_site_table_get_row(SEXP tc, int index); int rtsk_mutation_table_add_row( SEXP tc, int site, int node, int parent, double time, const std::string &derived_state, Rcpp::Nullable metadata = R_NilValue); +Rcpp::List rtsk_mutation_table_get_row(SEXP tc, int index); +int rtsk_population_table_add_row( + SEXP tc, Rcpp::Nullable metadata = R_NilValue); +Rcpp::List rtsk_population_table_get_row(SEXP tc, int index); +int rtsk_migration_table_add_row( + SEXP tc, double left, double right, int node, int source, int dest, + double time, Rcpp::Nullable metadata = R_NilValue); +Rcpp::List rtsk_migration_table_get_row(SEXP tc, int index); +int rtsk_provenance_table_add_row(SEXP tc, const std::string ×tamp, + const std::string &record); +Rcpp::List rtsk_provenance_table_get_row(SEXP tc, int index); #endif diff --git a/RcppTskit/inst/include/tskit/tskit/VERSION_kastore.txt b/RcppTskit/inst/include/tskit/tskit/VERSION_kastore.txt index eca07e4..ac2cdeb 100644 --- a/RcppTskit/inst/include/tskit/tskit/VERSION_kastore.txt +++ b/RcppTskit/inst/include/tskit/tskit/VERSION_kastore.txt @@ -1 +1 @@ -2.1.2 +2.1.3 diff --git a/RcppTskit/inst/include/tskit/tskit/kastore.h b/RcppTskit/inst/include/tskit/tskit/kastore.h index 3acc01a..0861f9b 100644 --- a/RcppTskit/inst/include/tskit/tskit/kastore.h +++ b/RcppTskit/inst/include/tskit/tskit/kastore.h @@ -157,7 +157,7 @@ to the API or ABI are introduced, i.e., the addition of a new function. The library patch version. Incremented when any changes not relevant to the to the API or ABI are introduced, i.e., internal refactors of bugfixes. */ -#define KAS_VERSION_PATCH 2 +#define KAS_VERSION_PATCH 3 /** @} */ #define KAS_HEADER_SIZE 64 diff --git a/RcppTskit/jarl.toml b/RcppTskit/jarl.toml index 57ea069..b3ddb4f 100644 --- a/RcppTskit/jarl.toml +++ b/RcppTskit/jarl.toml @@ -1,6 +1,4 @@ [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/RcppTskit/man/RcppTskit-package.Rd b/RcppTskit/man/RcppTskit-package.Rd index 04ddd16..10ef01f 100644 --- a/RcppTskit/man/RcppTskit-package.Rd +++ b/RcppTskit/man/RcppTskit-package.Rd @@ -20,11 +20,13 @@ as described at \url{https://tskit.dev/tutorials/tskitr.html}. where the \code{reticulate} option is not optimal; for example; high-performance or low-level work with tree sequences. Currently, \code{RcppTskit} provides a limited set of \code{R} functions because the \code{Python} API and -\code{reticulate} already covers most needs. The provided \code{RcppTskit R} -API mirrors the \code{tskit Python} API, while the \code{RcppTskit C++} API -mirrors the \code{tskit C} API. Users should explore the \code{RcppTskit} -help pages of \code{R} functions, while developers should explore the provided -\code{RcppTskit:::rtsk_*} low-level \code{R} and \code{C++} functions. +\code{reticulate} already covers most needs. The \code{RcppTskit R} API +combines an \code{R6} object model inspired by the \code{tskit Python} API +with operations that map directly to the \code{tskit C} API. The +\code{RcppTskit C++} API closely mirrors the \code{tskit C} API. Users should +explore the \code{RcppTskit} help pages of \code{R} functions, while +developers should explore the provided \code{RcppTskit:::rtsk_*} low-level +\code{R} and \code{C++} functions. } \examples{ vignette("RcppTskit_intro") @@ -42,6 +44,8 @@ Useful links: Other contributors: \itemize{ + \item Jinyang Liang (\href{https://orcid.org/0009-0007-4015-6228}{ORCID}) [contributor] + \item Hannes Becher (\href{https://orcid.org/0000-0003-3700-2942}{ORCID}) [contributor] \item Tskit Developers (Authors of included tskit C library) [copyright holder] } diff --git a/RcppTskit/man/TableCollection.Rd b/RcppTskit/man/TableCollection.Rd index 97a86d9..9600186 100644 --- a/RcppTskit/man/TableCollection.Rd +++ b/RcppTskit/man/TableCollection.Rd @@ -41,6 +41,27 @@ tc <- TableCollection$new(file = ts_file) ts <- tc$tree_sequence() is(ts) +## ------------------------------------------------ +## Method `TableCollection$sort` +## ------------------------------------------------ + +unsorted_file <- system.file("examples/test_unsorted.trees", package = "RcppTskit") +tc <- tc_load(unsorted_file) +inherits(try(tc$tree_sequence(), silent = TRUE), "try-error") +tc$sort() +ts <- tc$tree_sequence() +is(ts) + +## ------------------------------------------------ +## Method `TableCollection$simplify` +## ------------------------------------------------ + +ts_file <- system.file("examples/test.trees", package = "RcppTskit") +tc <- tc_load(ts_file) +nodes_before <- as.integer(tc$num_nodes()) +node_map <- tc$simplify(samples = c(0L, 1L, 2L, 3L)) +c(before = nodes_before, after = as.integer(tc$num_nodes())) + ## ------------------------------------------------ ## Method `TableCollection$num_provenances` ## ------------------------------------------------ @@ -49,6 +70,29 @@ tc_file <- system.file("examples/test.trees", package = "RcppTskit") tc <- tc_load(tc_file) tc$num_provenances() +## ------------------------------------------------ +## Method `TableCollection$provenance_table_add_row` +## ------------------------------------------------ + +ts_file <- system.file("examples/test.trees", package = "RcppTskit") +tc <- tc_load(ts_file) +new_id <- tc$provenance_table_add_row( + record = "{\"software\":\"RcppTskit\"}", + timestamp = "2025-01-01T00:00:00Z" +) +tc$provenance_table_get_row(new_id) + +## ------------------------------------------------ +## Method `TableCollection$provenance_table_get_row` +## ------------------------------------------------ + +ts_file <- system.file("examples/test.trees", package = "RcppTskit") +tc <- tc_load(ts_file) +id <- tc$provenance_table_add_row( + record = "{}", timestamp = "2025-01-01T00:00:00Z" +) +tc$provenance_table_get_row(id) + ## ------------------------------------------------ ## Method `TableCollection$num_populations` ## ------------------------------------------------ @@ -57,6 +101,23 @@ tc_file <- system.file("examples/test.trees", package = "RcppTskit") tc <- tc_load(tc_file) tc$num_populations() +## ------------------------------------------------ +## Method `TableCollection$population_table_add_row` +## ------------------------------------------------ + +ts_file <- system.file("examples/test.trees", package = "RcppTskit") +tc <- tc_load(ts_file) +new_id <- tc$population_table_add_row(metadata = "abc") +tc$population_table_get_row(new_id) + +## ------------------------------------------------ +## Method `TableCollection$population_table_get_row` +## ------------------------------------------------ + +ts_file <- system.file("examples/test.trees", package = "RcppTskit") +tc <- tc_load(ts_file) +tc$population_table_get_row(0) + ## ------------------------------------------------ ## Method `TableCollection$num_migrations` ## ------------------------------------------------ @@ -65,6 +126,38 @@ tc_file <- system.file("examples/test.trees", package = "RcppTskit") tc <- tc_load(tc_file) tc$num_migrations() +## ------------------------------------------------ +## Method `TableCollection$migration_table_add_row` +## ------------------------------------------------ + +ts_file <- system.file("examples/test.trees", package = "RcppTskit") +tc <- tc_load(ts_file) +new_population <- tc$population_table_add_row(metadata = "new-population") +migrating_node <- tc$node_table_add_row(time = 0.5, population = new_population) +new_id <- tc$migration_table_add_row( + left = 0, + right = 1, + node = migrating_node, + source = 0L, + dest = new_population, + time = 1.0, + metadata = "abc" +) +tc$migration_table_get_row(new_id) + +## ------------------------------------------------ +## Method `TableCollection$migration_table_get_row` +## ------------------------------------------------ + +ts_file <- system.file("examples/test.trees", package = "RcppTskit") +tc <- tc_load(ts_file) +if (tc$num_migrations() == 0L) { + tc$migration_table_add_row( + left = 0, right = 1, node = 0L, source = 0L, dest = 0L, time = 1 + ) +} +tc$migration_table_get_row(0) + ## ------------------------------------------------ ## Method `TableCollection$num_individuals` ## ------------------------------------------------ @@ -79,14 +172,21 @@ tc$num_individuals() ts_file <- system.file("examples/test.trees", package = "RcppTskit") tc <- tc_load(ts_file) -(n_before <- tc$num_individuals()) -new_id <- tc$individual_table_add_row() -new_id <- tc$individual_table_add_row(location = c(5, 8)) -new_id <- tc$individual_table_add_row(flags = 0L) -new_id <- tc$individual_table_add_row(parents = c(0L, 2L)) -new_id <- tc$individual_table_add_row(metadata = "abc") -new_id <- tc$individual_table_add_row(metadata = charToRaw("cba")) -(n_after <- tc$num_individuals()) +new_id <- tc$individual_table_add_row( + flags = 3L, + location = c(2, 11), + parents = c(1L, 3L), + metadata = "abc" +) +tc$individual_table_get_row(new_id) + +## ------------------------------------------------ +## Method `TableCollection$individual_table_get_row` +## ------------------------------------------------ + +ts_file <- system.file("examples/test.trees", package = "RcppTskit") +tc <- tc_load(ts_file) +tc$individual_table_get_row(0) ## ------------------------------------------------ ## Method `TableCollection$num_nodes` @@ -102,14 +202,20 @@ tc$num_nodes() ts_file <- system.file("examples/test.trees", package = "RcppTskit") tc <- tc_load(ts_file) -(n_before <- tc$num_nodes()) -new_id <- tc$node_table_add_row() -new_id <- tc$node_table_add_row(time = 2.5) -new_id <- tc$node_table_add_row(flags = 1L, time = 3.5, population = 0L) -new_id <- tc$node_table_add_row(flags = 1L, time = 4.5, individual = 0L) -new_id <- tc$node_table_add_row(metadata = "abc") -new_id <- tc$node_table_add_row(metadata = charToRaw("cba")) -(n_after <- tc$num_nodes()) +new_id <- tc$node_table_add_row( + flags = 1L, time = 3.5, individual = 0L, metadata = "abc" +) +tc$node_table_get_row(new_id) + +## ------------------------------------------------ +## Method `TableCollection$node_table_get_row` +## ------------------------------------------------ + +ts_file <- system.file("examples/test.trees", package = "RcppTskit") +tc <- tc_load(ts_file) +tc$node_table_get_row(0L) +(last_node <- as.integer(tc$num_nodes()) - 1L) +tc$node_table_get_row(last_node) ## ------------------------------------------------ ## Method `TableCollection$num_edges` @@ -126,17 +232,18 @@ tc$num_edges() ts_file <- system.file("examples/test.trees", package = "RcppTskit") tc <- tc_load(ts_file) child <- tc$node_table_add_row(time = 0.0) -(n_before <- tc$num_edges()) -new_id <- tc$edge_table_add_row( - left = 0, right = 50, parent = 16L, child = child -) new_id <- tc$edge_table_add_row( - left = 50, right = 75, parent = 17L, child = child, metadata = "abc" + left = 0, right = 50, parent = 16L, child = child, metadata = "abc" ) -new_id <- tc$edge_table_add_row( - left = 75, right = 100, parent = 18L, child = child, metadata = charToRaw("cba") -) -(n_after <- tc$num_edges()) +tc$edge_table_get_row(new_id) + +## ------------------------------------------------ +## Method `TableCollection$edge_table_get_row` +## ------------------------------------------------ + +ts_file <- system.file("examples/test.trees", package = "RcppTskit") +tc <- tc_load(ts_file) +tc$edge_table_get_row(0) ## ------------------------------------------------ ## Method `TableCollection$num_sites` @@ -152,10 +259,18 @@ tc$num_sites() ts_file <- system.file("examples/test.trees", package = "RcppTskit") tc <- tc_load(ts_file) -(n_before <- tc$num_sites()) -new_id <- tc$site_table_add_row(position = 0.5, ancestral_state = "A") -new_id <- tc$site_table_add_row(position = 2.5, ancestral_state = "T", metadata = "abc") -(n_after <- tc$num_sites()) +new_id <- tc$site_table_add_row( + position = 2.5, ancestral_state = "T", metadata = "abc" +) +tc$site_table_get_row(new_id) + +## ------------------------------------------------ +## Method `TableCollection$site_table_get_row` +## ------------------------------------------------ + +ts_file <- system.file("examples/test.trees", package = "RcppTskit") +tc <- tc_load(ts_file) +tc$site_table_get_row(0) ## ------------------------------------------------ ## Method `TableCollection$num_mutations` @@ -171,21 +286,18 @@ tc$num_mutations() ts_file <- system.file("examples/test.trees", package = "RcppTskit") tc <- tc_load(ts_file) -(n_before <- tc$num_mutations()) -# From inspection of tc we have: -# node13(time=0) <- node16(time=0.02...) <- node20(time=0.08...) -# Add mutation above 16L -m0 <- tc$mutation_table_add_row(site = 0L, node = 16L, derived_state = "T", time = 0.03) -# Add mutation above 13L -m1 <- tc$mutation_table_add_row( - site = 0L, - node = 13L, - parent = m0, - time = 0.01, - derived_state = "C", - metadata = "abc" +new_id <- tc$mutation_table_add_row( + site = 0L, node = 16L, derived_state = "T", metadata = "abc" ) -(n_after <- tc$num_mutations()) +tc$mutation_table_get_row(new_id) + +## ------------------------------------------------ +## Method `TableCollection$mutation_table_get_row` +## ------------------------------------------------ + +ts_file <- system.file("examples/test.trees", package = "RcppTskit") +tc <- tc_load(ts_file) +tc$mutation_table_get_row(0) ## ------------------------------------------------ ## Method `TableCollection$sequence_length` @@ -302,19 +414,32 @@ tc \item \href{#method-TableCollection-dump}{\code{TableCollection$dump()}} \item \href{#method-TableCollection-write}{\code{TableCollection$write()}} \item \href{#method-TableCollection-tree_sequence}{\code{TableCollection$tree_sequence()}} +\item \href{#method-TableCollection-sort}{\code{TableCollection$sort()}} +\item \href{#method-TableCollection-simplify}{\code{TableCollection$simplify()}} \item \href{#method-TableCollection-num_provenances}{\code{TableCollection$num_provenances()}} +\item \href{#method-TableCollection-provenance_table_add_row}{\code{TableCollection$provenance_table_add_row()}} +\item \href{#method-TableCollection-provenance_table_get_row}{\code{TableCollection$provenance_table_get_row()}} \item \href{#method-TableCollection-num_populations}{\code{TableCollection$num_populations()}} +\item \href{#method-TableCollection-population_table_add_row}{\code{TableCollection$population_table_add_row()}} +\item \href{#method-TableCollection-population_table_get_row}{\code{TableCollection$population_table_get_row()}} \item \href{#method-TableCollection-num_migrations}{\code{TableCollection$num_migrations()}} +\item \href{#method-TableCollection-migration_table_add_row}{\code{TableCollection$migration_table_add_row()}} +\item \href{#method-TableCollection-migration_table_get_row}{\code{TableCollection$migration_table_get_row()}} \item \href{#method-TableCollection-num_individuals}{\code{TableCollection$num_individuals()}} \item \href{#method-TableCollection-individual_table_add_row}{\code{TableCollection$individual_table_add_row()}} +\item \href{#method-TableCollection-individual_table_get_row}{\code{TableCollection$individual_table_get_row()}} \item \href{#method-TableCollection-num_nodes}{\code{TableCollection$num_nodes()}} \item \href{#method-TableCollection-node_table_add_row}{\code{TableCollection$node_table_add_row()}} +\item \href{#method-TableCollection-node_table_get_row}{\code{TableCollection$node_table_get_row()}} \item \href{#method-TableCollection-num_edges}{\code{TableCollection$num_edges()}} \item \href{#method-TableCollection-edge_table_add_row}{\code{TableCollection$edge_table_add_row()}} +\item \href{#method-TableCollection-edge_table_get_row}{\code{TableCollection$edge_table_get_row()}} \item \href{#method-TableCollection-num_sites}{\code{TableCollection$num_sites()}} \item \href{#method-TableCollection-site_table_add_row}{\code{TableCollection$site_table_add_row()}} +\item \href{#method-TableCollection-site_table_get_row}{\code{TableCollection$site_table_get_row()}} \item \href{#method-TableCollection-num_mutations}{\code{TableCollection$num_mutations()}} \item \href{#method-TableCollection-mutation_table_add_row}{\code{TableCollection$mutation_table_add_row()}} +\item \href{#method-TableCollection-mutation_table_get_row}{\code{TableCollection$mutation_table_get_row()}} \item \href{#method-TableCollection-sequence_length}{\code{TableCollection$sequence_length()}} \item \href{#method-TableCollection-time_units}{\code{TableCollection$time_units()}} \item \href{#method-TableCollection-has_index}{\code{TableCollection$has_index()}} @@ -357,9 +482,7 @@ reference genome sequence information.} } \subsection{Details}{ See the \code{tskit Python} equivalent at - \url{https://github.com/tskit-dev/tskit/blob/dc394d72d121c99c6dcad88f7a4873880924dd72/python/tskit/tables.py#L3463}. - TODO: Update URL to TableCollection.load() method #104 - https://github.com/HighlanderLab/RcppTskit/issues/104 + \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.TableCollection.load}. } \subsection{Returns}{ @@ -395,7 +518,7 @@ Write a table collection to a file. } \subsection{Details}{ See the \code{tskit Python} equivalent at - \url{https://tskit.dev/tskit/docs/latest/python-api.html#tskit.TableCollection.dump}. + \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.TableCollection.dump}. } \subsection{Returns}{ @@ -443,7 +566,7 @@ Create a \code{\link{TreeSequence}} from this table collection. \subsection{Details}{ See the \code{tskit Python} equivalent at - \url{https://tskit.dev/tskit/docs/latest/python-api.html#tskit.TableCollection.tree_sequence}. + \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.TableCollection.tree_sequence}. } \subsection{Returns}{ @@ -460,6 +583,139 @@ is(ts) } +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-TableCollection-sort}{}}} +\subsection{Method \code{sort()}}{ +Sort this table collection in place. +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{TableCollection$sort(edge_start = 0L, site_start = 0L, mutation_start = 0L)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{edge_start}}{integer or integer-valued numeric scalar edge-table +start row index (0-based).} + +\item{\code{site_start}}{integer or integer-valued numeric scalar site-table +start row index (0-based).} + +\item{\code{mutation_start}}{integer or integer-valued numeric scalar +mutation-table start row index (0-based).} +} +\if{html}{\out{
}} +} +\subsection{Details}{ +See the \code{tskit Python} equivalent at + \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.TableCollection.sort}. +} + +\subsection{Returns}{ +No return value; called for side effects. +} +\subsection{Examples}{ +\if{html}{\out{
}} +\preformatted{unsorted_file <- system.file("examples/test_unsorted.trees", package = "RcppTskit") +tc <- tc_load(unsorted_file) +inherits(try(tc$tree_sequence(), silent = TRUE), "try-error") +tc$sort() +ts <- tc$tree_sequence() +is(ts) +} +\if{html}{\out{
}} + +} + +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-TableCollection-simplify}{}}} +\subsection{Method \code{simplify()}}{ +Simplify this table collection in place. +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{TableCollection$simplify( + samples = NULL, + reduce_to_site_topology = FALSE, + filter_populations = NULL, + filter_individuals = NULL, + filter_sites = NULL, + filter_nodes = NULL, + update_sample_flags = NULL, + keep_unary = FALSE, + keep_unary_in_individuals = NULL, + keep_input_roots = FALSE, + record_provenance = TRUE +)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{samples}}{optional integer vector of distinct node IDs to retain as +samples. If \code{NULL}, use the nodes currently marked as samples.} + +\item{\code{reduce_to_site_topology}}{logical; if \code{TRUE}, retain only +topology needed to represent trees containing sites.} + +\item{\code{filter_populations}}{optional logical; if \code{TRUE}, remove +populations no longer referenced by nodes. If \code{NULL}, treated as +\code{TRUE}.} + +\item{\code{filter_individuals}}{optional logical; if \code{TRUE}, remove +individuals no longer referenced by nodes. If \code{NULL}, treated as +\code{TRUE}.} + +\item{\code{filter_sites}}{optional logical; if \code{TRUE}, remove sites no +longer referenced by mutations. If \code{NULL}, treated as +\code{TRUE}.} + +\item{\code{filter_nodes}}{optional logical; if \code{TRUE}, remove nodes no +longer referenced by edges. If \code{NULL}, treated as +\code{TRUE}.} + +\item{\code{update_sample_flags}}{optional logical; if \code{TRUE}, update node +flags so exactly the requested samples carry the sample flag. If +\code{NULL}, treated as \code{TRUE}.} + +\item{\code{keep_unary}}{logical; if \code{TRUE}, retain unary nodes on paths +from samples to roots.} + +\item{\code{keep_unary_in_individuals}}{optional logical; if \code{TRUE}, retain +unary nodes that are associated with an individual, while other unary +nodes may still be removed. Cannot be used with +\code{keep_unary = TRUE}. If \code{NULL}, treated as \code{FALSE}.} + +\item{\code{keep_input_roots}}{logical; if \code{TRUE}, retain topology back to +the roots in the input tables rather than stopping at samples' MRCAs.} + +\item{\code{record_provenance}}{logical; if \code{TRUE}, append a +provenance row describing this simplify call.} +} +\if{html}{\out{
}} +} +\subsection{Details}{ +See the \code{tskit Python} equivalent at + \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.TableCollection.simplify}. +} + +\subsection{Returns}{ +Integer vector mapping input node IDs to simplified node IDs. + Removed nodes map to \code{-1}. +} +\subsection{Examples}{ +\if{html}{\out{
}} +\preformatted{ts_file <- system.file("examples/test.trees", package = "RcppTskit") +tc <- tc_load(ts_file) +nodes_before <- as.integer(tc$num_nodes()) +node_map <- tc$simplify(samples = c(0L, 1L, 2L, 3L)) +c(before = nodes_before, after = as.integer(tc$num_nodes())) +} +\if{html}{\out{
}} + +} + } \if{html}{\out{
}} \if{html}{\out{}} @@ -483,6 +739,91 @@ tc$num_provenances() } +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-TableCollection-provenance_table_add_row}{}}} +\subsection{Method \code{provenance_table_add_row()}}{ +Add a row to the provenance table. +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{TableCollection$provenance_table_add_row(record, timestamp = NULL)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{record}}{character string record for the new provenance.} + +\item{\code{timestamp}}{optional character string timestamp for the new +provenance. If provided, it should be in ISO8601 form. If +\code{NULL}, a current UTC timestamp in ISO8601 form is generated.} +} +\if{html}{\out{
}} +} +\subsection{Details}{ +See the \code{tskit Python} equivalent at + \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.ProvenanceTable.add_row}. +} + +\subsection{Returns}{ +An integer row index and hence ID (0-based) of the newly added provenance. +} +\subsection{Examples}{ +\if{html}{\out{
}} +\preformatted{ts_file <- system.file("examples/test.trees", package = "RcppTskit") +tc <- tc_load(ts_file) +new_id <- tc$provenance_table_add_row( + record = "{\"software\":\"RcppTskit\"}", + timestamp = "2025-01-01T00:00:00Z" +) +tc$provenance_table_get_row(new_id) +} +\if{html}{\out{
}} + +} + +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-TableCollection-provenance_table_get_row}{}}} +\subsection{Method \code{provenance_table_get_row()}}{ +Get one row from the provenance table. +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{TableCollection$provenance_table_get_row(index)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{index}}{integer or numeric scalar row index (0-based).} +} +\if{html}{\out{
}} +} +\subsection{Details}{ +See the \code{tskit Python} equivalent at + \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.ProvenanceTable.__getitem__}. + The function accepts numeric \code{index} for ease of use, but converts + it to integer after checking that conversion to 32-bit integer succeeds. + Unlike Python table indexing, negative indices are not supported. +} + +\subsection{Returns}{ +A named list with fields \code{id}, \code{timestamp}, + and \code{record}. +} +\subsection{Examples}{ +\if{html}{\out{
}} +\preformatted{ts_file <- system.file("examples/test.trees", package = "RcppTskit") +tc <- tc_load(ts_file) +id <- tc$provenance_table_add_row( + record = "{}", timestamp = "2025-01-01T00:00:00Z" +) +tc$provenance_table_get_row(id) +} +\if{html}{\out{
}} + +} + } \if{html}{\out{
}} \if{html}{\out{}} @@ -506,6 +847,84 @@ tc$num_populations() } +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-TableCollection-population_table_add_row}{}}} +\subsection{Method \code{population_table_add_row()}}{ +Add a row to the population table. +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{TableCollection$population_table_add_row(metadata = NULL)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{metadata}}{for the new population; accepts \code{NULL}, +a raw vector, or a character vector of length 1. Values are stored as +raw bytes without metadata-schema validation or encoding.} +} +\if{html}{\out{
}} +} +\subsection{Details}{ +See the \code{tskit Python} equivalent at + \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.PopulationTable.add_row}. + Metadata schemas are not currently applied. +} + +\subsection{Returns}{ +An integer row index and hence ID (0-based) of the newly added population. +} +\subsection{Examples}{ +\if{html}{\out{
}} +\preformatted{ts_file <- system.file("examples/test.trees", package = "RcppTskit") +tc <- tc_load(ts_file) +new_id <- tc$population_table_add_row(metadata = "abc") +tc$population_table_get_row(new_id) +} +\if{html}{\out{
}} + +} + +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-TableCollection-population_table_get_row}{}}} +\subsection{Method \code{population_table_get_row()}}{ +Get one row from the population table. +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{TableCollection$population_table_get_row(index)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{index}}{integer or numeric scalar row index (0-based).} +} +\if{html}{\out{
}} +} +\subsection{Details}{ +See the \code{tskit Python} equivalent at + \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.PopulationTable.__getitem__}. + The function accepts numeric \code{index} for ease of use, but converts + it to integer after checking that conversion to 32-bit integer succeeds. + Unlike Python table indexing, negative indices are not supported. +} + +\subsection{Returns}{ +A named list with fields \code{id} and \code{metadata} + (as raw bytes without metadata-schema decoding). +} +\subsection{Examples}{ +\if{html}{\out{
}} +\preformatted{ts_file <- system.file("examples/test.trees", package = "RcppTskit") +tc <- tc_load(ts_file) +tc$population_table_get_row(0) +} +\if{html}{\out{
}} + +} + } \if{html}{\out{
}} \if{html}{\out{}} @@ -529,6 +948,124 @@ tc$num_migrations() } +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-TableCollection-migration_table_add_row}{}}} +\subsection{Method \code{migration_table_add_row()}}{ +Add a row to the migration table. +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{TableCollection$migration_table_add_row( + left, + right, + node, + source, + dest, + time, + metadata = NULL +)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{left}}{numeric scalar left coordinate (inclusive) for the new +migration.} + +\item{\code{right}}{numeric scalar right coordinate (exclusive) for the new +migration.} + +\item{\code{node}}{integer or integer-valued numeric scalar node ID (0-based).} + +\item{\code{source}}{integer or integer-valued numeric scalar source population +ID (0-based).} + +\item{\code{dest}}{integer or integer-valued numeric scalar destination +population ID (0-based).} + +\item{\code{time}}{numeric scalar time of the migration event.} + +\item{\code{metadata}}{for the new migration; accepts \code{NULL}, +a raw vector, or a character vector of length 1. Values are stored as +raw bytes without metadata-schema validation or encoding.} +} +\if{html}{\out{
}} +} +\subsection{Details}{ +See the \code{tskit Python} equivalent at + \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.MigrationTable.add_row}. + Metadata schemas are not currently applied. +} + +\subsection{Returns}{ +An integer row index and hence ID (0-based) of the newly added migration. +} +\subsection{Examples}{ +\if{html}{\out{
}} +\preformatted{ts_file <- system.file("examples/test.trees", package = "RcppTskit") +tc <- tc_load(ts_file) +new_population <- tc$population_table_add_row(metadata = "new-population") +migrating_node <- tc$node_table_add_row(time = 0.5, population = new_population) +new_id <- tc$migration_table_add_row( + left = 0, + right = 1, + node = migrating_node, + source = 0L, + dest = new_population, + time = 1.0, + metadata = "abc" +) +tc$migration_table_get_row(new_id) +} +\if{html}{\out{
}} + +} + +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-TableCollection-migration_table_get_row}{}}} +\subsection{Method \code{migration_table_get_row()}}{ +Get one row from the migration table. +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{TableCollection$migration_table_get_row(index)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{index}}{integer or numeric scalar row index (0-based).} +} +\if{html}{\out{
}} +} +\subsection{Details}{ +See the \code{tskit Python} equivalent at + \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.MigrationTable.__getitem__}. + The function accepts numeric \code{index} for ease of use, but converts + it to integer after checking that conversion to 32-bit integer succeeds. + Unlike Python table indexing, negative indices are not supported. +} + +\subsection{Returns}{ +A named list with fields \code{id}, \code{left}, \code{right}, + \code{node}, \code{source}, \code{dest}, \code{time}, and + \code{metadata} (as raw bytes without metadata-schema decoding). +} +\subsection{Examples}{ +\if{html}{\out{
}} +\preformatted{ts_file <- system.file("examples/test.trees", package = "RcppTskit") +tc <- tc_load(ts_file) +if (tc$num_migrations() == 0L) { + tc$migration_table_add_row( + left = 0, right = 1, node = 0L, source = 0L, dest = 0L, time = 1 + ) +} +tc$migration_table_get_row(0) +} +\if{html}{\out{
}} + +} + } \if{html}{\out{
}} \if{html}{\out{}} @@ -557,7 +1094,7 @@ tc$num_individuals() \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-TableCollection-individual_table_add_row}{}}} \subsection{Method \code{individual_table_add_row()}}{ -Add a row to the individuals table. +Add a row to the individual table. \subsection{Usage}{ \if{html}{\out{
}}\preformatted{TableCollection$individual_table_add_row( flags = 0L, @@ -570,39 +1107,81 @@ Add a row to the individuals table. \subsection{Arguments}{ \if{html}{\out{
}} \describe{ -\item{\code{flags}}{integer scalar flags for the new individual.} +\item{\code{flags}}{integer or integer-valued numeric scalar bitwise flags for +the new individual. Values from 0 through 2^31 - 1 are supported.} \item{\code{location}}{numeric vector with the location of the new individual; -can be \code{NULL} if unknown.} +\code{NULL} stores an empty location.} -\item{\code{parents}}{integer vector with parent individual IDs (0-based); -can be \code{NULL} if unknown} +\item{\code{parents}}{integer or integer-valued numeric vector with parent +individual IDs (0-based); \code{NULL} stores no parents.} \item{\code{metadata}}{for the new individual; accepts \code{NULL}, -a raw vector, or a character of length 1.} +a raw vector, or a character vector of length 1. Values are stored as +raw bytes without metadata-schema validation or encoding.} } \if{html}{\out{
}} } \subsection{Details}{ See the \code{tskit Python} equivalent at \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.IndividualTable.add_row}. + Metadata schemas are not currently applied. } \subsection{Returns}{ -Integer row ID (0-based) of the newly added individual. +An integer row index and hence ID (0-based) of the newly added individual. } \subsection{Examples}{ \if{html}{\out{
}} \preformatted{ts_file <- system.file("examples/test.trees", package = "RcppTskit") tc <- tc_load(ts_file) -(n_before <- tc$num_individuals()) -new_id <- tc$individual_table_add_row() -new_id <- tc$individual_table_add_row(location = c(5, 8)) -new_id <- tc$individual_table_add_row(flags = 0L) -new_id <- tc$individual_table_add_row(parents = c(0L, 2L)) -new_id <- tc$individual_table_add_row(metadata = "abc") -new_id <- tc$individual_table_add_row(metadata = charToRaw("cba")) -(n_after <- tc$num_individuals()) +new_id <- tc$individual_table_add_row( + flags = 3L, + location = c(2, 11), + parents = c(1L, 3L), + metadata = "abc" +) +tc$individual_table_get_row(new_id) +} +\if{html}{\out{
}} + +} + +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-TableCollection-individual_table_get_row}{}}} +\subsection{Method \code{individual_table_get_row()}}{ +Get one row from the individual table. +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{TableCollection$individual_table_get_row(index)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{index}}{integer or numeric scalar row index (0-based).} +} +\if{html}{\out{
}} +} +\subsection{Details}{ +See the \code{tskit Python} equivalent at + \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.IndividualTable.__getitem__}. + The function accepts numeric \code{index} for ease of use, but converts + it to integer after checking that conversion to 32-bit integer succeeds. + Unlike Python table indexing, negative indices are not supported. +} + +\subsection{Returns}{ +A named list with fields \code{id}, \code{flags}, + \code{location}, \code{parents}, and \code{metadata} + (as raw bytes without metadata-schema decoding). +} +\subsection{Examples}{ +\if{html}{\out{
}} +\preformatted{ts_file <- system.file("examples/test.trees", package = "RcppTskit") +tc <- tc_load(ts_file) +tc$individual_table_get_row(0) } \if{html}{\out{
}} @@ -636,7 +1215,7 @@ tc$num_nodes() \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-TableCollection-node_table_add_row}{}}} \subsection{Method \code{node_table_add_row()}}{ -Add a row to the nodes table. +Add a row to the node table. \subsection{Usage}{ \if{html}{\out{
}}\preformatted{TableCollection$node_table_add_row( flags = 0L, @@ -650,41 +1229,85 @@ Add a row to the nodes table. \subsection{Arguments}{ \if{html}{\out{
}} \describe{ -\item{\code{flags}}{integer scalar flags for the new node.} +\item{\code{flags}}{integer or integer-valued numeric scalar bitwise flags for +the new node. Values from 0 through 2^31 - 1 are supported.} -\item{\code{time}}{numeric scalar time value for the new node.} +\item{\code{time}}{numeric scalar birth time for the new node.} -\item{\code{population}}{integer scalar population row ID (0-based); -use \code{-1} if not known - \code{NULL} maps to \code{-1} (\code{TSK_NULL}).} +\item{\code{population}}{integer or integer-valued numeric scalar population ID +(0-based); use \code{-1} or \code{NULL} if unknown. Both store +\code{TSK_NULL}.} -\item{\code{individual}}{integer scalar individual row ID (0-based); -use \code{-1} if not known - \code{NULL} maps to \code{-1} (\code{TSK_NULL}).} +\item{\code{individual}}{integer or integer-valued numeric scalar individual ID +(0-based); use \code{-1} or \code{NULL} if unknown. Both store +\code{TSK_NULL}.} \item{\code{metadata}}{for the new node; accepts \code{NULL}, -a raw vector, or a character of length 1.} +a raw vector, or a character vector of length 1. Values are stored as +raw bytes without metadata-schema validation or encoding.} } \if{html}{\out{
}} } \subsection{Details}{ See the \code{tskit Python} equivalent at \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.NodeTable.add_row}. + Metadata schemas are not currently applied. +} + +\subsection{Returns}{ +An integer row index and hence ID (0-based) of the newly added node. +} +\subsection{Examples}{ +\if{html}{\out{
}} +\preformatted{ts_file <- system.file("examples/test.trees", package = "RcppTskit") +tc <- tc_load(ts_file) +new_id <- tc$node_table_add_row( + flags = 1L, time = 3.5, individual = 0L, metadata = "abc" +) +tc$node_table_get_row(new_id) +} +\if{html}{\out{
}} + +} + +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-TableCollection-node_table_get_row}{}}} +\subsection{Method \code{node_table_get_row()}}{ +Get one row from the node table. +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{TableCollection$node_table_get_row(index)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{index}}{integer or numeric scalar row index (0-based).} +} +\if{html}{\out{
}} +} +\subsection{Details}{ +In \code{tskit Python}, rows are accessed by indexing a + \code{NodeTable}, for example \code{tables.nodes[index]}; see + \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.NodeTable}. + The function accepts numeric \code{index} for ease of use, but converts + it to integer after checking that conversion to 32-bit integer succeeds. + Unlike Python table indexing, negative indices are not supported. } \subsection{Returns}{ -Integer row ID (0-based) of the newly added node. +A named list with fields \code{id}, \code{flags}, \code{time}, + \code{population}, \code{individual}, and \code{metadata} + (as raw bytes without metadata-schema decoding). } \subsection{Examples}{ \if{html}{\out{
}} \preformatted{ts_file <- system.file("examples/test.trees", package = "RcppTskit") tc <- tc_load(ts_file) -(n_before <- tc$num_nodes()) -new_id <- tc$node_table_add_row() -new_id <- tc$node_table_add_row(time = 2.5) -new_id <- tc$node_table_add_row(flags = 1L, time = 3.5, population = 0L) -new_id <- tc$node_table_add_row(flags = 1L, time = 4.5, individual = 0L) -new_id <- tc$node_table_add_row(metadata = "abc") -new_id <- tc$node_table_add_row(metadata = charToRaw("cba")) -(n_after <- tc$num_nodes()) +tc$node_table_get_row(0L) +(last_node <- as.integer(tc$num_nodes()) - 1L) +tc$node_table_get_row(last_node) } \if{html}{\out{
}} @@ -718,7 +1341,7 @@ tc$num_edges() \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-TableCollection-edge_table_add_row}{}}} \subsection{Method \code{edge_table_add_row()}}{ -Add a row to the edges table. +Add a row to the edge table. \subsection{Usage}{ \if{html}{\out{
}}\preformatted{TableCollection$edge_table_add_row(left, right, parent, child, metadata = NULL)}\if{html}{\out{
}} } @@ -726,43 +1349,81 @@ Add a row to the edges table. \subsection{Arguments}{ \if{html}{\out{
}} \describe{ -\item{\code{left}}{numeric scalar left coordinate for the new edge.} +\item{\code{left}}{numeric scalar left coordinate (inclusive) for the new edge.} -\item{\code{right}}{numeric scalar right coordinate for the new edge.} +\item{\code{right}}{numeric scalar right coordinate (exclusive) for the new +edge.} -\item{\code{parent}}{integer scalar parent node row ID (0-based).} +\item{\code{parent}}{integer or integer-valued numeric scalar parent node ID +(0-based).} -\item{\code{child}}{integer scalar child node row ID (0-based).} +\item{\code{child}}{integer or integer-valued numeric scalar child node ID +(0-based).} \item{\code{metadata}}{for the new edge; accepts \code{NULL}, -a raw vector, or a character of length 1.} +a raw vector, or a character vector of length 1. Values are stored as +raw bytes without metadata-schema validation or encoding.} } \if{html}{\out{
}} } \subsection{Details}{ See the \code{tskit Python} equivalent at \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.EdgeTable.add_row}. + Metadata schemas are not currently applied. } \subsection{Returns}{ -Integer row ID (0-based) of the newly added edge. +An integer row index and hence ID (0-based) of the newly added edge. } \subsection{Examples}{ \if{html}{\out{
}} \preformatted{ts_file <- system.file("examples/test.trees", package = "RcppTskit") tc <- tc_load(ts_file) child <- tc$node_table_add_row(time = 0.0) -(n_before <- tc$num_edges()) -new_id <- tc$edge_table_add_row( - left = 0, right = 50, parent = 16L, child = child -) -new_id <- tc$edge_table_add_row( - left = 50, right = 75, parent = 17L, child = child, metadata = "abc" -) new_id <- tc$edge_table_add_row( - left = 75, right = 100, parent = 18L, child = child, metadata = charToRaw("cba") + left = 0, right = 50, parent = 16L, child = child, metadata = "abc" ) -(n_after <- tc$num_edges()) +tc$edge_table_get_row(new_id) +} +\if{html}{\out{
}} + +} + +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-TableCollection-edge_table_get_row}{}}} +\subsection{Method \code{edge_table_get_row()}}{ +Get one row from the edge table. +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{TableCollection$edge_table_get_row(index)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{index}}{integer or numeric scalar row index (0-based).} +} +\if{html}{\out{
}} +} +\subsection{Details}{ +See the \code{tskit Python} equivalent at + \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.EdgeTable.__getitem__}. + The function accepts numeric \code{index} for ease of use, but converts + it to integer after checking that conversion to 32-bit integer succeeds. + Unlike Python table indexing, negative indices are not supported. +} + +\subsection{Returns}{ +A named list with fields \code{id}, \code{left}, \code{right}, + \code{parent}, \code{child}, and \code{metadata} + (as raw bytes without metadata-schema decoding). +} +\subsection{Examples}{ +\if{html}{\out{
}} +\preformatted{ts_file <- system.file("examples/test.trees", package = "RcppTskit") +tc <- tc_load(ts_file) +tc$edge_table_get_row(0) } \if{html}{\out{
}} @@ -796,7 +1457,7 @@ tc$num_sites() \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-TableCollection-site_table_add_row}{}}} \subsection{Method \code{site_table_add_row()}}{ -Add a row to the sites table. +Add a row to the site table. \subsection{Usage}{ \if{html}{\out{
}}\preformatted{TableCollection$site_table_add_row(position, ancestral_state, metadata = NULL)}\if{html}{\out{
}} } @@ -804,31 +1465,73 @@ Add a row to the sites table. \subsection{Arguments}{ \if{html}{\out{
}} \describe{ -\item{\code{position}}{numeric scalar site position.} +\item{\code{position}}{numeric scalar position for the new site.} -\item{\code{ancestral_state}}{character string for the new site.} +\item{\code{ancestral_state}}{character string with the ancestral state.} \item{\code{metadata}}{for the new site; accepts \code{NULL}, -a raw vector, or a character of length 1.} +a raw vector, or a character vector of length 1. Values are stored as +raw bytes without metadata-schema validation or encoding.} } \if{html}{\out{
}} } \subsection{Details}{ See the \code{tskit Python} equivalent at \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.SiteTable.add_row}. + Metadata schemas are not currently applied. +} + +\subsection{Returns}{ +An integer row index and hence ID (0-based) of the newly added site. +} +\subsection{Examples}{ +\if{html}{\out{
}} +\preformatted{ts_file <- system.file("examples/test.trees", package = "RcppTskit") +tc <- tc_load(ts_file) +new_id <- tc$site_table_add_row( + position = 2.5, ancestral_state = "T", metadata = "abc" +) +tc$site_table_get_row(new_id) +} +\if{html}{\out{
}} + +} + +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-TableCollection-site_table_get_row}{}}} +\subsection{Method \code{site_table_get_row()}}{ +Get one row from the site table. +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{TableCollection$site_table_get_row(index)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{index}}{integer or numeric scalar row index (0-based).} +} +\if{html}{\out{
}} +} +\subsection{Details}{ +See the \code{tskit Python} equivalent at + \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.SiteTable.__getitem__}. + The function accepts numeric \code{index} for ease of use, but converts + it to integer after checking that conversion to 32-bit integer succeeds. + Unlike Python table indexing, negative indices are not supported. } \subsection{Returns}{ -Integer row ID (0-based) of the newly added site. +A named list with fields \code{id}, \code{position}, + \code{ancestral_state}, and \code{metadata} + (as raw bytes without metadata-schema decoding). } \subsection{Examples}{ \if{html}{\out{
}} \preformatted{ts_file <- system.file("examples/test.trees", package = "RcppTskit") tc <- tc_load(ts_file) -(n_before <- tc$num_sites()) -new_id <- tc$site_table_add_row(position = 0.5, ancestral_state = "A") -new_id <- tc$site_table_add_row(position = 2.5, ancestral_state = "T", metadata = "abc") -(n_after <- tc$num_sites()) +tc$site_table_get_row(0) } \if{html}{\out{
}} @@ -862,7 +1565,7 @@ tc$num_mutations() \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-TableCollection-mutation_table_add_row}{}}} \subsection{Method \code{mutation_table_add_row()}}{ -Add a row to the mutations table. +Add a row to the mutation table. \subsection{Usage}{ \if{html}{\out{
}}\preformatted{TableCollection$mutation_table_add_row( site, @@ -870,57 +1573,89 @@ Add a row to the mutations table. derived_state, parent = -1L, metadata = NULL, - time = NaN + time = NULL )}\if{html}{\out{
}} } \subsection{Arguments}{ \if{html}{\out{
}} \describe{ -\item{\code{site}}{integer scalar site row ID (0-based).} +\item{\code{site}}{integer or integer-valued numeric scalar site ID (0-based).} -\item{\code{node}}{integer scalar node row ID (0-based).} +\item{\code{node}}{integer or integer-valued numeric scalar node ID (0-based).} -\item{\code{derived_state}}{character string for the new mutation.} +\item{\code{derived_state}}{character string with the derived state.} -\item{\code{parent}}{integer scalar parent mutation row ID (0-based); -use \code{-1} if not known - \code{NULL} maps to \code{-1} (\code{TSK_NULL}).} +\item{\code{parent}}{integer or integer-valued numeric scalar parent mutation ID +(0-based); use \code{-1} or \code{NULL} if unknown. Both store +\code{TSK_NULL}.} \item{\code{metadata}}{for the new mutation; accepts \code{NULL}, -a raw vector, or a character of length 1.} +a raw vector, or a character vector of length 1. Values are stored as +raw bytes without metadata-schema validation or encoding.} -\item{\code{time}}{numeric scalar mutation time; -use \code{NaN} if not known - \code{NULL} maps to \code{NaN} (\code{TSK_UNKNOWN_TIME}).} +\item{\code{time}}{numeric scalar mutation time. Use \code{NULL} (the default) +or \code{NaN} if unknown; both store \code{TSK_UNKNOWN_TIME}.} } \if{html}{\out{
}} } \subsection{Details}{ See the \code{tskit Python} equivalent at \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.MutationTable.add_row}. + Metadata schemas are not currently applied. } \subsection{Returns}{ -Integer row ID (0-based) of the newly added mutation. +An integer row index and hence ID (0-based) of the newly added mutation. } \subsection{Examples}{ \if{html}{\out{
}} \preformatted{ts_file <- system.file("examples/test.trees", package = "RcppTskit") tc <- tc_load(ts_file) -(n_before <- tc$num_mutations()) -# From inspection of tc we have: -# node13(time=0) <- node16(time=0.02...) <- node20(time=0.08...) -# Add mutation above 16L -m0 <- tc$mutation_table_add_row(site = 0L, node = 16L, derived_state = "T", time = 0.03) -# Add mutation above 13L -m1 <- tc$mutation_table_add_row( - site = 0L, - node = 13L, - parent = m0, - time = 0.01, - derived_state = "C", - metadata = "abc" +new_id <- tc$mutation_table_add_row( + site = 0L, node = 16L, derived_state = "T", metadata = "abc" ) -(n_after <- tc$num_mutations()) +tc$mutation_table_get_row(new_id) +} +\if{html}{\out{
}} + +} + +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-TableCollection-mutation_table_get_row}{}}} +\subsection{Method \code{mutation_table_get_row()}}{ +Get one row from the mutation table. +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{TableCollection$mutation_table_get_row(index)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{index}}{integer or numeric scalar row index (0-based).} +} +\if{html}{\out{
}} +} +\subsection{Details}{ +See the \code{tskit Python} equivalent at + \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.MutationTable.__getitem__}. + The function accepts numeric \code{index} for ease of use, but converts + it to integer after checking that conversion to 32-bit integer succeeds. + Unlike Python table indexing, negative indices are not supported. +} + +\subsection{Returns}{ +A named list with fields \code{id}, \code{site}, \code{node}, + \code{derived_state}, \code{parent}, \code{metadata} + (as raw bytes without metadata-schema decoding), and \code{time}. +} +\subsection{Examples}{ +\if{html}{\out{
}} +\preformatted{ts_file <- system.file("examples/test.trees", package = "RcppTskit") +tc <- tc_load(ts_file) +tc$mutation_table_get_row(0) } \if{html}{\out{
}} @@ -1007,7 +1742,7 @@ Build edge indexes for this table collection. \subsection{Details}{ See the \code{tskit Python} equivalent at - \url{https://tskit.dev/tskit/docs/latest/python-api.html#tskit.TableCollection.build_index}. + \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.TableCollection.build_index}. } \subsection{Returns}{ @@ -1039,7 +1774,7 @@ Drop edge indexes for this table collection. \subsection{Details}{ See the \code{tskit Python} equivalent at - \url{https://tskit.dev/tskit/docs/latest/python-api.html#tskit.TableCollection.drop_index}. + \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.TableCollection.drop_index}. } \subsection{Returns}{ diff --git a/RcppTskit/man/TreeSequence.Rd b/RcppTskit/man/TreeSequence.Rd index 2ab1eba..ff90051 100644 --- a/RcppTskit/man/TreeSequence.Rd +++ b/RcppTskit/man/TreeSequence.Rd @@ -45,6 +45,16 @@ ts <- ts_load(ts_file) tc <- ts$dump_tables() is(tc) +## ------------------------------------------------ +## Method `TreeSequence$simplify` +## ------------------------------------------------ + +ts_file <- system.file("examples/test.trees", package = "RcppTskit") +ts <- ts_load(ts_file) +ts_simplified <- ts$simplify(samples = c(0L, 1L, 2L, 3L)) +c(before = ts$num_nodes(), + after = ts_simplified$num_nodes()) + ## ------------------------------------------------ ## Method `TreeSequence$print` ## ------------------------------------------------ @@ -78,6 +88,18 @@ ts } } +## ------------------------------------------------ +## Method `TreeSequence$variants` +## ------------------------------------------------ + +ts_file <- system.file("examples/test.trees", package = "RcppTskit") +ts <- ts_load(ts_file) +it <- ts$variants() +v1 <- it$next_variant() +v2 <- it$next_variant() +is.list(v1) +is.list(v2) + ## ------------------------------------------------ ## Method `TreeSequence$num_provenances` ## ------------------------------------------------ @@ -118,6 +140,14 @@ ts_file <- system.file("examples/test.trees", package = "RcppTskit") ts <- ts_load(ts_file) ts$num_samples() +## ------------------------------------------------ +## Method `TreeSequence$samples` +## ------------------------------------------------ + +ts_file <- system.file("examples/test.trees", package = "RcppTskit") +ts <- ts_load(ts_file) +ts$samples() + ## ------------------------------------------------ ## Method `TreeSequence$num_nodes` ## ------------------------------------------------ @@ -259,13 +289,16 @@ ts$file_uuid() \item \href{#method-TreeSequence-dump}{\code{TreeSequence$dump()}} \item \href{#method-TreeSequence-write}{\code{TreeSequence$write()}} \item \href{#method-TreeSequence-dump_tables}{\code{TreeSequence$dump_tables()}} +\item \href{#method-TreeSequence-simplify}{\code{TreeSequence$simplify()}} \item \href{#method-TreeSequence-print}{\code{TreeSequence$print()}} \item \href{#method-TreeSequence-r_to_py}{\code{TreeSequence$r_to_py()}} +\item \href{#method-TreeSequence-variants}{\code{TreeSequence$variants()}} \item \href{#method-TreeSequence-num_provenances}{\code{TreeSequence$num_provenances()}} \item \href{#method-TreeSequence-num_populations}{\code{TreeSequence$num_populations()}} \item \href{#method-TreeSequence-num_migrations}{\code{TreeSequence$num_migrations()}} \item \href{#method-TreeSequence-num_individuals}{\code{TreeSequence$num_individuals()}} \item \href{#method-TreeSequence-num_samples}{\code{TreeSequence$num_samples()}} +\item \href{#method-TreeSequence-samples}{\code{TreeSequence$samples()}} \item \href{#method-TreeSequence-num_nodes}{\code{TreeSequence$num_nodes()}} \item \href{#method-TreeSequence-num_edges}{\code{TreeSequence$num_edges()}} \item \href{#method-TreeSequence-num_trees}{\code{TreeSequence$num_trees()}} @@ -314,7 +347,7 @@ reference genome sequence information.} } \subsection{Details}{ See the \code{tskit Python} equivalent at - \url{https://tskit.dev/tskit/docs/latest/python-api.html#tskit.load}. + \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.load}. } \subsection{Returns}{ @@ -354,7 +387,7 @@ Write a tree sequence to a file. } \subsection{Details}{ See the \code{tskit Python} equivalent at - \url{https://tskit.dev/tskit/docs/latest/python-api.html#tskit.TreeSequence.dump}. + \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.TreeSequence.dump}. } \subsection{Returns}{ @@ -402,7 +435,7 @@ Copy the tables into a \code{\link{TableCollection}}. \subsection{Details}{ See the \code{tskit Python} equivalent at - \url{https://tskit.dev/tskit/docs/latest/python-api.html#tskit.TreeSequence.dump_tables}. + \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.TreeSequence.dump_tables}. } \subsection{Returns}{ @@ -419,6 +452,101 @@ is(tc) } +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-TreeSequence-simplify}{}}} +\subsection{Method \code{simplify()}}{ +Return a simplified copy of this tree sequence. +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{TreeSequence$simplify( + samples = NULL, + map_nodes = FALSE, + reduce_to_site_topology = FALSE, + filter_populations = NULL, + filter_individuals = NULL, + filter_sites = NULL, + filter_nodes = NULL, + update_sample_flags = NULL, + keep_unary = FALSE, + keep_unary_in_individuals = NULL, + keep_input_roots = FALSE, + record_provenance = TRUE +)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{samples}}{optional integer vector of distinct node IDs to retain as +samples. If \code{NULL}, use the nodes currently marked as samples.} + +\item{\code{map_nodes}}{logical; if \code{TRUE}, also return the mapping from +input node IDs to output node IDs (see also return section).} + +\item{\code{reduce_to_site_topology}}{logical; if \code{TRUE}, retain only +topology needed to represent trees containing sites.} + +\item{\code{filter_populations}}{optional logical; if \code{TRUE}, remove +populations no longer referenced by nodes. If \code{NULL}, treated as +\code{TRUE}.} + +\item{\code{filter_individuals}}{optional logical; if \code{TRUE}, remove +individuals no longer referenced by nodes. If \code{NULL}, treated as +\code{TRUE}.} + +\item{\code{filter_sites}}{optional logical; if \code{TRUE}, remove sites no +longer referenced by mutations. If \code{NULL}, treated as +\code{TRUE}.} + +\item{\code{filter_nodes}}{optional logical; if \code{TRUE}, remove nodes no +longer referenced by edges. If \code{NULL}, treated as +\code{TRUE}.} + +\item{\code{update_sample_flags}}{optional logical; if \code{TRUE}, update node +flags so exactly the requested samples carry the sample flag. If +\code{NULL}, treated as \code{TRUE}.} + +\item{\code{keep_unary}}{logical; if \code{TRUE}, retain unary nodes on paths +from samples to roots.} + +\item{\code{keep_unary_in_individuals}}{optional logical; if \code{TRUE}, retain +unary nodes that are associated with an individual, while other unary +nodes may still be removed. Cannot be used with +\code{keep_unary = TRUE}. If \code{NULL}, treated as \code{FALSE}.} + +\item{\code{keep_input_roots}}{logical; retain topology back to the roots in the +input tree sequence rather than stopping at samples' MRCAs.} + +\item{\code{record_provenance}}{logical; record this simplify call in the +returned tree sequence.} +} +\if{html}{\out{
}} +} +\subsection{Details}{ +See the \code{tskit Python} equivalent at + \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.TreeSequence.simplify}. + The input tree sequence is unchanged. +} + +\subsection{Returns}{ +A simplified \code{\link{TreeSequence}}. If + \code{map_nodes = TRUE}, return a named list containing + \code{tree_sequence} and the integer \code{node_map}; + removed nodes map to \code{-1}. +} +\subsection{Examples}{ +\if{html}{\out{
}} +\preformatted{ts_file <- system.file("examples/test.trees", package = "RcppTskit") +ts <- ts_load(ts_file) +ts_simplified <- ts$simplify(samples = c(0L, 1L, 2L, 3L)) +c(before = ts$num_nodes(), + after = ts_simplified$num_nodes()) +} +\if{html}{\out{
}} + +} + } \if{html}{\out{
}} \if{html}{\out{}} @@ -498,6 +626,71 @@ By default, it calls \code{\link{get_tskit_py}} to obtain the module.} } +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-TreeSequence-variants}{}}} +\subsection{Method \code{variants()}}{ +Iterate over sites as decoded variants. +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{TreeSequence$variants( + samples = NULL, + isolated_as_missing = TRUE, + alleles = NULL, + impute_missing_data = NULL, + copy = TRUE, + left = 0, + right = NULL +)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{samples}}{Optional integer vector of sample node IDs to decode.} + +\item{\code{isolated_as_missing}}{Logical; decode isolated samples as missing +data (\code{TRUE}, default) or as ancestral state (\code{FALSE}).} + +\item{\code{alleles}}{Optional character vector of allele states; when set, +genotypes are indexed to this allele order.} + +\item{\code{impute_missing_data}}{Deprecated alias for +\code{!isolated_as_missing}.} + +\item{\code{copy}}{Logical; currently only \code{TRUE} is supported.} + +\item{\code{left}}{Left genomic coordinate (inclusive).} + +\item{\code{right}}{Right genomic coordinate (exclusive). \code{NULL} means +sequence length.} +} +\if{html}{\out{
}} +} +\subsection{Details}{ +See the \code{tskit Python} equivalent at + \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.TreeSequence.variants}. +} + +\subsection{Returns}{ +A simple iterator object with methods \code{next()} and + \code{next_variant()} that each return either a variant list or + \code{NULL} at end. +} +\subsection{Examples}{ +\if{html}{\out{
}} +\preformatted{ts_file <- system.file("examples/test.trees", package = "RcppTskit") +ts <- ts_load(ts_file) +it <- ts$variants() +v1 <- it$next_variant() +v2 <- it$next_variant() +is.list(v1) +is.list(v2) +} +\if{html}{\out{
}} + +} + } \if{html}{\out{
}} \if{html}{\out{}} @@ -510,7 +703,7 @@ Get the number of provenances in a tree sequence. \subsection{Details}{ See the \code{tskit Python} equivalent at - \url{https://tskit.dev/tskit/docs/latest/python-api.html#tskit.TreeSequence.num_provenances}. + \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.TreeSequence.num_provenances}. } \subsection{Returns}{ @@ -538,7 +731,7 @@ Get the number of populations in a tree sequence. \subsection{Details}{ See the \code{tskit Python} equivalent at - \url{https://tskit.dev/tskit/docs/latest/python-api.html#tskit.TreeSequence.num_populations}. + \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.TreeSequence.num_populations}. } \subsection{Returns}{ @@ -566,7 +759,7 @@ Get the number of migrations in a tree sequence. \subsection{Details}{ See the \code{tskit Python} equivalent at - \url{https://tskit.dev/tskit/docs/latest/python-api.html#tskit.TreeSequence.num_migrations}. + \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.TreeSequence.num_migrations}. } \subsection{Returns}{ @@ -594,7 +787,7 @@ Get the number of individuals in a tree sequence. \subsection{Details}{ See the \code{tskit Python} equivalent at - \url{https://tskit.dev/tskit/docs/latest/python-api.html#tskit.TreeSequence.num_individuals}. + \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.TreeSequence.num_individuals}. } \subsection{Returns}{ @@ -622,7 +815,7 @@ Get the number of samples (of nodes) in a tree sequence. \subsection{Details}{ See the \code{tskit Python} equivalent at - \url{https://tskit.dev/tskit/docs/latest/python-api.html#tskit.TreeSequence.num_samples}. + \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.TreeSequence.num_samples}. } \subsection{Returns}{ @@ -638,6 +831,50 @@ ts$num_samples() } +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-TreeSequence-samples}{}}} +\subsection{Method \code{samples()}}{ +Get sample node IDs in this tree sequence. +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{TreeSequence$samples(population = NULL, time = NULL)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{population}}{integer or integer-valued numeric scalar population ID +(0-based) used to filter samples. If \code{NULL}, do not filter by +population.} + +\item{\code{time}}{numeric scalar or numeric vector of length 2 used to filter +samples by node time. A scalar selects samples with approximately equal +node time. A pair \code{c(min_time, max_time)} selects samples in the +half-open interval \code{min_time <= time < max_time}. If \code{NULL}, +do not filter by time.} +} +\if{html}{\out{
}} +} +\subsection{Details}{ +See the \code{tskit Python} equivalent at + \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.TreeSequence.samples}. +} + +\subsection{Returns}{ +An integer vector containing the sample node IDs (0-based) in + numerical order. +} +\subsection{Examples}{ +\if{html}{\out{
}} +\preformatted{ts_file <- system.file("examples/test.trees", package = "RcppTskit") +ts <- ts_load(ts_file) +ts$samples() +} +\if{html}{\out{
}} + +} + } \if{html}{\out{
}} \if{html}{\out{}} @@ -650,7 +887,7 @@ Get the number of nodes in a tree sequence. \subsection{Details}{ See the \code{tskit Python} equivalent at - \url{https://tskit.dev/tskit/docs/latest/python-api.html#tskit.TreeSequence.num_nodes}. + \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.TreeSequence.num_nodes}. } \subsection{Returns}{ @@ -678,7 +915,7 @@ Get the number of edges in a tree sequence. \subsection{Details}{ See the \code{tskit Python} equivalent at - \url{https://tskit.dev/tskit/docs/latest/python-api.html#tskit.TreeSequence.num_nodes}. + \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.TreeSequence.num_nodes}. } \subsection{Returns}{ @@ -706,7 +943,7 @@ Get the number of trees in a tree sequence. \subsection{Details}{ See the \code{tskit Python} equivalent at - \url{https://tskit.dev/tskit/docs/latest/python-api.html#tskit.TreeSequence.num_trees}. + \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.TreeSequence.num_trees}. } \subsection{Returns}{ @@ -734,7 +971,7 @@ Get the number of sites in a tree sequence. \subsection{Details}{ See the \code{tskit Python} equivalent at - \url{https://tskit.dev/tskit/docs/latest/python-api.html#tskit.TreeSequence.num_sites}. + \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.TreeSequence.num_sites}. } \subsection{Returns}{ @@ -762,7 +999,7 @@ Get the number of mutations in a tree sequence. \subsection{Details}{ See the \code{tskit Python} equivalent at - \url{https://tskit.dev/tskit/docs/latest/python-api.html#tskit.TreeSequence.num_mutations}. + \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.TreeSequence.num_mutations}. } \subsection{Returns}{ @@ -790,7 +1027,7 @@ Get the sequence length. \subsection{Details}{ See the \code{tskit Python} equivalent at - \url{https://tskit.dev/tskit/docs/latest/python-api.html#tskit.TreeSequence.sequence_length}. + \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.TreeSequence.sequence_length}. } \subsection{Returns}{ @@ -822,7 +1059,7 @@ Returns \code{TRUE} if all genomic coordinates in the tree See the \code{tskit Python} equivalent at - \url{https://tskit.dev/tskit/docs/latest/python-api.html#tskit.TreeSequence.discrete_genome}. + \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.TreeSequence.discrete_genome}. } \subsection{Returns}{ @@ -853,7 +1090,7 @@ Get whether the tree sequence has a reference genome sequence. \subsection{Details}{ See the \code{tskit Python} equivalent at - \url{https://tskit.dev/tskit/docs/latest/python-api.html#tskit.TreeSequence.has_reference_sequence}. + \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.TreeSequence.has_reference_sequence}. } \subsection{Returns}{ @@ -884,7 +1121,7 @@ Get the time units string. \subsection{Details}{ See the \code{tskit Python} equivalent at - \url{https://tskit.dev/tskit/docs/latest/python-api.html#tskit.TreeSequence.time_units}. + \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.TreeSequence.time_units}. } \subsection{Returns}{ @@ -916,7 +1153,7 @@ Returns \code{TRUE} if all time values in the tree sequence are See the \code{tskit Python} equivalent at - \url{https://tskit.dev/tskit/docs/latest/python-api.html#tskit.TreeSequence.discrete_time}. + \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.TreeSequence.discrete_time}. } \subsection{Returns}{ @@ -947,7 +1184,7 @@ Get the min time in node table and mutation table. \subsection{Details}{ See the \code{tskit Python} equivalent at - \url{https://tskit.dev/tskit/docs/latest/python-api.html#tskit.TreeSequence.min_time}. + \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.TreeSequence.min_time}. } \subsection{Returns}{ @@ -975,7 +1212,7 @@ Get the max time in node table and mutation table. \subsection{Details}{ See the \code{tskit Python} equivalent at - \url{https://tskit.dev/tskit/docs/latest/python-api.html#tskit.TreeSequence.max_time}. + \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.TreeSequence.max_time}. } \subsection{Returns}{ diff --git a/RcppTskit/man/ts_load.Rd b/RcppTskit/man/ts_load.Rd index 618abc8..99914e1 100644 --- a/RcppTskit/man/ts_load.Rd +++ b/RcppTskit/man/ts_load.Rd @@ -25,7 +25,7 @@ Load a tree sequence from a file } \details{ See the \code{tskit Python} equivalent at - \url{https://tskit.dev/tskit/docs/latest/python-api.html#tskit.load}. + \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.load}. } \section{Functions}{ \itemize{ diff --git a/RcppTskit/notes_pkg_dev.Rmd b/RcppTskit/notes_pkg_dev.Rmd index a3e6cbc..4bb575e 100644 --- a/RcppTskit/notes_pkg_dev.Rmd +++ b/RcppTskit/notes_pkg_dev.Rmd @@ -2,12 +2,48 @@ ## Next TODOs -If needed, consider a Python-style logical argument on the R method for -mutation-parent computation instead of exposing bitwise flags, e.g. -`compute_mutation_parents = FALSE`, while still translating to -`TSK_TS_INIT_COMPUTE_MUTATION_PARENTS` inside the low-level wrapper layer. +### Review and polish variants work -// TODO: This will go into AlphaSimR +struct rtsk_variant_iterator_state_t + +static void rtsk_variant_iterator_free + +void validate_variant_site_index_range + +std::pair compute_variant_iteration_bounds + +SEXP rtsk_treeseq_init_variants_iterator( + SEXP ts, Rcpp::Nullable samples = R_NilValue, + bool isolated_as_missing = true, + Rcpp::Nullable alleles = R_NilValue, + double left = 0.0, double right = NA_REAL) { + std::unique_ptr state_ptr( + new rtsk_variant_iterator_state_t(ts)); + +SEXP rtsk_treeseq_next_variant(SEXP iterator) + +void test_rtsk_variant_iterator_force_null_first_allele(bool enabled) + +void test_rtsk_variant_iterator_set_site_bounds(SEXP iterator, int next_site_id, + int stop_site_id) + +void test_variant_site_index_range + +SEXP ts_sexp = R_NilValue; // TODO: remove? + +// \item{\code{ts_sexp}}{Preserved \code{R} external-pointer object that +// keeps the tree sequence alive while the iterator exists. It remains +// \code{R_NilValue} until it is preserved.} + +I would, however, rename the external-pointer alias: +using rtsk_variant_iterator_xptr_t = Rcpp::XPtr<...>; +instead of rtsk_variant_iterator_t, which currently sounds like the underlying state type. + +One important issue surfaced while documenting this: variant_initialized is set only after successful tsk_variant_init(). The tskit lifecycle rules require tsk_variant_free() even when initialization returns an error, because partial allocation may have occurred. Our unique_ptr error path currently only deletes the state and does not call tsk_variant_free(). We should address that immediately after settling the docstring and names. + +rtsk_variant_iterator_init mention copy is not implemented (a note from my postit)!? + +### This type of code will go into AlphaSimR Tskit examples of building tree sequence in C extern/tskit/c/tests/testlib.c has lots of examples of constructing a tree sequence using C @@ -63,7 +99,6 @@ SEXP tc_grow(SEXP tc) { (it saves various ts information as attributes) https://github.com/bodkan/slendr/pull/191/changes#diff-f46eb0da2f9267022ecc6e09316598fde6bdcd2f980963906dc041b5096f344f - ## NEWS template ``` @@ -140,13 +175,13 @@ install.packages("covr") # https://usethis.r-lib.org/reference/use_coverage.html usethis::use_coverage(type = "codecov") -# Build the report & report +# Build the report & display interactive HTML cov <- covr::package_coverage(clean = TRUE); covr::report(cov) # Build the report cov <- covr::package_coverage(clean = TRUE) -# Interactive HTML report with uncovered lines highlighted +# Display interactive HTML report covr::report(cov) # List lines with zero coverage per file diff --git a/RcppTskit/src/RcppExports.cpp b/RcppTskit/src/RcppExports.cpp index 74f3a06..301d1b0 100644 --- a/RcppTskit/src/RcppExports.cpp +++ b/RcppTskit/src/RcppExports.cpp @@ -10,6 +10,66 @@ Rcpp::Rostream& Rcpp::Rcout = Rcpp::Rcpp_cout_get(); Rcpp::Rostream& Rcpp::Rcerr = Rcpp::Rcpp_cerr_get(); #endif +// rtsk_treeseq_init_variants_iterator +SEXP rtsk_treeseq_init_variants_iterator(SEXP ts, Rcpp::Nullable samples, bool isolated_as_missing, Rcpp::Nullable alleles, double left, double right); +RcppExport SEXP _RcppTskit_rtsk_treeseq_init_variants_iterator(SEXP tsSEXP, SEXP samplesSEXP, SEXP isolated_as_missingSEXP, SEXP allelesSEXP, SEXP leftSEXP, SEXP rightSEXP) { +BEGIN_RCPP + Rcpp::RObject rcpp_result_gen; + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< SEXP >::type ts(tsSEXP); + Rcpp::traits::input_parameter< Rcpp::Nullable >::type samples(samplesSEXP); + Rcpp::traits::input_parameter< bool >::type isolated_as_missing(isolated_as_missingSEXP); + Rcpp::traits::input_parameter< Rcpp::Nullable >::type alleles(allelesSEXP); + Rcpp::traits::input_parameter< double >::type left(leftSEXP); + Rcpp::traits::input_parameter< double >::type right(rightSEXP); + rcpp_result_gen = Rcpp::wrap(rtsk_treeseq_init_variants_iterator(ts, samples, isolated_as_missing, alleles, left, right)); + return rcpp_result_gen; +END_RCPP +} +// rtsk_treeseq_next_variant +SEXP rtsk_treeseq_next_variant(SEXP iterator); +RcppExport SEXP _RcppTskit_rtsk_treeseq_next_variant(SEXP iteratorSEXP) { +BEGIN_RCPP + Rcpp::RObject rcpp_result_gen; + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< SEXP >::type iterator(iteratorSEXP); + rcpp_result_gen = Rcpp::wrap(rtsk_treeseq_next_variant(iterator)); + return rcpp_result_gen; +END_RCPP +} +// test_rtsk_variant_iterator_force_null_first_allele +void test_rtsk_variant_iterator_force_null_first_allele(bool enabled); +RcppExport SEXP _RcppTskit_test_rtsk_variant_iterator_force_null_first_allele(SEXP enabledSEXP) { +BEGIN_RCPP + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< bool >::type enabled(enabledSEXP); + test_rtsk_variant_iterator_force_null_first_allele(enabled); + return R_NilValue; +END_RCPP +} +// test_rtsk_variant_iterator_set_site_bounds +void test_rtsk_variant_iterator_set_site_bounds(SEXP iterator, int next_site_id, int stop_site_id); +RcppExport SEXP _RcppTskit_test_rtsk_variant_iterator_set_site_bounds(SEXP iteratorSEXP, SEXP next_site_idSEXP, SEXP stop_site_idSEXP) { +BEGIN_RCPP + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< SEXP >::type iterator(iteratorSEXP); + Rcpp::traits::input_parameter< int >::type next_site_id(next_site_idSEXP); + Rcpp::traits::input_parameter< int >::type stop_site_id(stop_site_idSEXP); + test_rtsk_variant_iterator_set_site_bounds(iterator, next_site_id, stop_site_id); + return R_NilValue; +END_RCPP +} +// test_variant_site_index_range +void test_variant_site_index_range(const std::string& start, const std::string& stop); +RcppExport SEXP _RcppTskit_test_variant_site_index_range(SEXP startSEXP, SEXP stopSEXP) { +BEGIN_RCPP + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< const std::string& >::type start(startSEXP); + Rcpp::traits::input_parameter< const std::string& >::type stop(stopSEXP); + test_variant_site_index_range(start, stop); + return R_NilValue; +END_RCPP +} // test_validate_options int test_validate_options(int options, int supported); RcppExport SEXP _RcppTskit_test_validate_options(SEXP optionsSEXP, SEXP supportedSEXP) { @@ -22,6 +82,17 @@ BEGIN_RCPP return rcpp_result_gen; END_RCPP } +// test_rtsk_wrap_tsk_flags_as_int +int test_rtsk_wrap_tsk_flags_as_int(double value); +RcppExport SEXP _RcppTskit_test_rtsk_wrap_tsk_flags_as_int(SEXP valueSEXP) { +BEGIN_RCPP + Rcpp::RObject rcpp_result_gen; + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< double >::type value(valueSEXP); + rcpp_result_gen = Rcpp::wrap(test_rtsk_wrap_tsk_flags_as_int(value)); + return rcpp_result_gen; +END_RCPP +} // test_rtsk_wrap_tsk_size_t_as_integer64 SEXP test_rtsk_wrap_tsk_size_t_as_integer64(const std::string& value, bool force_range_error); RcppExport SEXP _RcppTskit_test_rtsk_wrap_tsk_size_t_as_integer64(SEXP valueSEXP, SEXP force_range_errorSEXP) { @@ -181,6 +252,28 @@ BEGIN_RCPP return rcpp_result_gen; END_RCPP } +// rtsk_treeseq_get_samples +Rcpp::IntegerVector rtsk_treeseq_get_samples(SEXP ts); +RcppExport SEXP _RcppTskit_rtsk_treeseq_get_samples(SEXP tsSEXP) { +BEGIN_RCPP + Rcpp::RObject rcpp_result_gen; + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< SEXP >::type ts(tsSEXP); + rcpp_result_gen = Rcpp::wrap(rtsk_treeseq_get_samples(ts)); + return rcpp_result_gen; +END_RCPP +} +// rtsk_treeseq_get_sample_node_data +Rcpp::List rtsk_treeseq_get_sample_node_data(SEXP ts); +RcppExport SEXP _RcppTskit_rtsk_treeseq_get_sample_node_data(SEXP tsSEXP) { +BEGIN_RCPP + Rcpp::RObject rcpp_result_gen; + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< SEXP >::type ts(tsSEXP); + rcpp_result_gen = Rcpp::wrap(rtsk_treeseq_get_sample_node_data(ts)); + return rcpp_result_gen; +END_RCPP +} // rtsk_treeseq_get_num_nodes SEXP rtsk_treeseq_get_num_nodes(SEXP ts); RcppExport SEXP _RcppTskit_rtsk_treeseq_get_num_nodes(SEXP tsSEXP) { @@ -512,6 +605,33 @@ BEGIN_RCPP return R_NilValue; END_RCPP } +// rtsk_table_collection_sort +void rtsk_table_collection_sort(SEXP tc, int start_edges, int start_sites, int start_mutations, int options); +RcppExport SEXP _RcppTskit_rtsk_table_collection_sort(SEXP tcSEXP, SEXP start_edgesSEXP, SEXP start_sitesSEXP, SEXP start_mutationsSEXP, SEXP optionsSEXP) { +BEGIN_RCPP + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< SEXP >::type tc(tcSEXP); + Rcpp::traits::input_parameter< int >::type start_edges(start_edgesSEXP); + Rcpp::traits::input_parameter< int >::type start_sites(start_sitesSEXP); + Rcpp::traits::input_parameter< int >::type start_mutations(start_mutationsSEXP); + Rcpp::traits::input_parameter< int >::type options(optionsSEXP); + rtsk_table_collection_sort(tc, start_edges, start_sites, start_mutations, options); + return R_NilValue; +END_RCPP +} +// rtsk_table_collection_simplify +Rcpp::IntegerVector rtsk_table_collection_simplify(SEXP tc, Rcpp::Nullable samples, int options); +RcppExport SEXP _RcppTskit_rtsk_table_collection_simplify(SEXP tcSEXP, SEXP samplesSEXP, SEXP optionsSEXP) { +BEGIN_RCPP + Rcpp::RObject rcpp_result_gen; + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< SEXP >::type tc(tcSEXP); + Rcpp::traits::input_parameter< Rcpp::Nullable >::type samples(samplesSEXP); + Rcpp::traits::input_parameter< int >::type options(optionsSEXP); + rcpp_result_gen = Rcpp::wrap(rtsk_table_collection_simplify(tc, samples, options)); + return rcpp_result_gen; +END_RCPP +} // rtsk_table_collection_summary Rcpp::List rtsk_table_collection_summary(SEXP tc); RcppExport SEXP _RcppTskit_rtsk_table_collection_summary(SEXP tcSEXP) { @@ -549,6 +669,18 @@ BEGIN_RCPP return rcpp_result_gen; END_RCPP } +// rtsk_individual_table_get_row +Rcpp::List rtsk_individual_table_get_row(SEXP tc, int index); +RcppExport SEXP _RcppTskit_rtsk_individual_table_get_row(SEXP tcSEXP, SEXP indexSEXP) { +BEGIN_RCPP + Rcpp::RObject rcpp_result_gen; + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< SEXP >::type tc(tcSEXP); + Rcpp::traits::input_parameter< int >::type index(indexSEXP); + rcpp_result_gen = Rcpp::wrap(rtsk_individual_table_get_row(tc, index)); + return rcpp_result_gen; +END_RCPP +} // rtsk_node_table_add_row int rtsk_node_table_add_row(SEXP tc, int flags, double time, int population, int individual, Rcpp::Nullable metadata); RcppExport SEXP _RcppTskit_rtsk_node_table_add_row(SEXP tcSEXP, SEXP flagsSEXP, SEXP timeSEXP, SEXP populationSEXP, SEXP individualSEXP, SEXP metadataSEXP) { @@ -565,6 +697,18 @@ BEGIN_RCPP return rcpp_result_gen; END_RCPP } +// rtsk_node_table_get_row +Rcpp::List rtsk_node_table_get_row(SEXP tc, int index); +RcppExport SEXP _RcppTskit_rtsk_node_table_get_row(SEXP tcSEXP, SEXP indexSEXP) { +BEGIN_RCPP + Rcpp::RObject rcpp_result_gen; + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< SEXP >::type tc(tcSEXP); + Rcpp::traits::input_parameter< int >::type index(indexSEXP); + rcpp_result_gen = Rcpp::wrap(rtsk_node_table_get_row(tc, index)); + return rcpp_result_gen; +END_RCPP +} // rtsk_edge_table_add_row int rtsk_edge_table_add_row(SEXP tc, double left, double right, int parent, int child, Rcpp::Nullable metadata); RcppExport SEXP _RcppTskit_rtsk_edge_table_add_row(SEXP tcSEXP, SEXP leftSEXP, SEXP rightSEXP, SEXP parentSEXP, SEXP childSEXP, SEXP metadataSEXP) { @@ -581,6 +725,18 @@ BEGIN_RCPP return rcpp_result_gen; END_RCPP } +// rtsk_edge_table_get_row +Rcpp::List rtsk_edge_table_get_row(SEXP tc, int index); +RcppExport SEXP _RcppTskit_rtsk_edge_table_get_row(SEXP tcSEXP, SEXP indexSEXP) { +BEGIN_RCPP + Rcpp::RObject rcpp_result_gen; + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< SEXP >::type tc(tcSEXP); + Rcpp::traits::input_parameter< int >::type index(indexSEXP); + rcpp_result_gen = Rcpp::wrap(rtsk_edge_table_get_row(tc, index)); + return rcpp_result_gen; +END_RCPP +} // rtsk_site_table_add_row int rtsk_site_table_add_row(SEXP tc, double position, const std::string& ancestral_state, Rcpp::Nullable metadata); RcppExport SEXP _RcppTskit_rtsk_site_table_add_row(SEXP tcSEXP, SEXP positionSEXP, SEXP ancestral_stateSEXP, SEXP metadataSEXP) { @@ -595,6 +751,18 @@ BEGIN_RCPP return rcpp_result_gen; END_RCPP } +// rtsk_site_table_get_row +Rcpp::List rtsk_site_table_get_row(SEXP tc, int index); +RcppExport SEXP _RcppTskit_rtsk_site_table_get_row(SEXP tcSEXP, SEXP indexSEXP) { +BEGIN_RCPP + Rcpp::RObject rcpp_result_gen; + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< SEXP >::type tc(tcSEXP); + Rcpp::traits::input_parameter< int >::type index(indexSEXP); + rcpp_result_gen = Rcpp::wrap(rtsk_site_table_get_row(tc, index)); + return rcpp_result_gen; +END_RCPP +} // rtsk_mutation_table_add_row int rtsk_mutation_table_add_row(SEXP tc, int site, int node, int parent, double time, const std::string& derived_state, Rcpp::Nullable metadata); RcppExport SEXP _RcppTskit_rtsk_mutation_table_add_row(SEXP tcSEXP, SEXP siteSEXP, SEXP nodeSEXP, SEXP parentSEXP, SEXP timeSEXP, SEXP derived_stateSEXP, SEXP metadataSEXP) { @@ -612,6 +780,97 @@ BEGIN_RCPP return rcpp_result_gen; END_RCPP } +// rtsk_mutation_table_get_row +Rcpp::List rtsk_mutation_table_get_row(SEXP tc, int index); +RcppExport SEXP _RcppTskit_rtsk_mutation_table_get_row(SEXP tcSEXP, SEXP indexSEXP) { +BEGIN_RCPP + Rcpp::RObject rcpp_result_gen; + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< SEXP >::type tc(tcSEXP); + Rcpp::traits::input_parameter< int >::type index(indexSEXP); + rcpp_result_gen = Rcpp::wrap(rtsk_mutation_table_get_row(tc, index)); + return rcpp_result_gen; +END_RCPP +} +// rtsk_population_table_add_row +int rtsk_population_table_add_row(SEXP tc, Rcpp::Nullable metadata); +RcppExport SEXP _RcppTskit_rtsk_population_table_add_row(SEXP tcSEXP, SEXP metadataSEXP) { +BEGIN_RCPP + Rcpp::RObject rcpp_result_gen; + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< SEXP >::type tc(tcSEXP); + Rcpp::traits::input_parameter< Rcpp::Nullable >::type metadata(metadataSEXP); + rcpp_result_gen = Rcpp::wrap(rtsk_population_table_add_row(tc, metadata)); + return rcpp_result_gen; +END_RCPP +} +// rtsk_population_table_get_row +Rcpp::List rtsk_population_table_get_row(SEXP tc, int index); +RcppExport SEXP _RcppTskit_rtsk_population_table_get_row(SEXP tcSEXP, SEXP indexSEXP) { +BEGIN_RCPP + Rcpp::RObject rcpp_result_gen; + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< SEXP >::type tc(tcSEXP); + Rcpp::traits::input_parameter< int >::type index(indexSEXP); + rcpp_result_gen = Rcpp::wrap(rtsk_population_table_get_row(tc, index)); + return rcpp_result_gen; +END_RCPP +} +// rtsk_migration_table_add_row +int rtsk_migration_table_add_row(SEXP tc, double left, double right, int node, int source, int dest, double time, Rcpp::Nullable metadata); +RcppExport SEXP _RcppTskit_rtsk_migration_table_add_row(SEXP tcSEXP, SEXP leftSEXP, SEXP rightSEXP, SEXP nodeSEXP, SEXP sourceSEXP, SEXP destSEXP, SEXP timeSEXP, SEXP metadataSEXP) { +BEGIN_RCPP + Rcpp::RObject rcpp_result_gen; + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< SEXP >::type tc(tcSEXP); + Rcpp::traits::input_parameter< double >::type left(leftSEXP); + Rcpp::traits::input_parameter< double >::type right(rightSEXP); + Rcpp::traits::input_parameter< int >::type node(nodeSEXP); + Rcpp::traits::input_parameter< int >::type source(sourceSEXP); + Rcpp::traits::input_parameter< int >::type dest(destSEXP); + Rcpp::traits::input_parameter< double >::type time(timeSEXP); + Rcpp::traits::input_parameter< Rcpp::Nullable >::type metadata(metadataSEXP); + rcpp_result_gen = Rcpp::wrap(rtsk_migration_table_add_row(tc, left, right, node, source, dest, time, metadata)); + return rcpp_result_gen; +END_RCPP +} +// rtsk_migration_table_get_row +Rcpp::List rtsk_migration_table_get_row(SEXP tc, int index); +RcppExport SEXP _RcppTskit_rtsk_migration_table_get_row(SEXP tcSEXP, SEXP indexSEXP) { +BEGIN_RCPP + Rcpp::RObject rcpp_result_gen; + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< SEXP >::type tc(tcSEXP); + Rcpp::traits::input_parameter< int >::type index(indexSEXP); + rcpp_result_gen = Rcpp::wrap(rtsk_migration_table_get_row(tc, index)); + return rcpp_result_gen; +END_RCPP +} +// rtsk_provenance_table_add_row +int rtsk_provenance_table_add_row(SEXP tc, const std::string& timestamp, const std::string& record); +RcppExport SEXP _RcppTskit_rtsk_provenance_table_add_row(SEXP tcSEXP, SEXP timestampSEXP, SEXP recordSEXP) { +BEGIN_RCPP + Rcpp::RObject rcpp_result_gen; + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< SEXP >::type tc(tcSEXP); + Rcpp::traits::input_parameter< const std::string& >::type timestamp(timestampSEXP); + Rcpp::traits::input_parameter< const std::string& >::type record(recordSEXP); + rcpp_result_gen = Rcpp::wrap(rtsk_provenance_table_add_row(tc, timestamp, record)); + return rcpp_result_gen; +END_RCPP +} +// rtsk_provenance_table_get_row +Rcpp::List rtsk_provenance_table_get_row(SEXP tc, int index); +RcppExport SEXP _RcppTskit_rtsk_provenance_table_get_row(SEXP tcSEXP, SEXP indexSEXP) { +BEGIN_RCPP + Rcpp::RObject rcpp_result_gen; + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< SEXP >::type tc(tcSEXP); + Rcpp::traits::input_parameter< int >::type index(indexSEXP); + rcpp_result_gen = Rcpp::wrap(rtsk_provenance_table_get_row(tc, index)); + return rcpp_result_gen; +END_RCPP +} // test_tsk_bug_assert_c void test_tsk_bug_assert_c(); RcppExport SEXP _RcppTskit_test_tsk_bug_assert_c() { @@ -740,9 +999,45 @@ BEGIN_RCPP return R_NilValue; END_RCPP } +// test_rtsk_population_table_add_row_forced_error +void test_rtsk_population_table_add_row_forced_error(SEXP tc); +RcppExport SEXP _RcppTskit_test_rtsk_population_table_add_row_forced_error(SEXP tcSEXP) { +BEGIN_RCPP + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< SEXP >::type tc(tcSEXP); + test_rtsk_population_table_add_row_forced_error(tc); + return R_NilValue; +END_RCPP +} +// test_rtsk_migration_table_add_row_forced_error +void test_rtsk_migration_table_add_row_forced_error(SEXP tc); +RcppExport SEXP _RcppTskit_test_rtsk_migration_table_add_row_forced_error(SEXP tcSEXP) { +BEGIN_RCPP + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< SEXP >::type tc(tcSEXP); + test_rtsk_migration_table_add_row_forced_error(tc); + return R_NilValue; +END_RCPP +} +// test_rtsk_provenance_table_add_row_forced_error +void test_rtsk_provenance_table_add_row_forced_error(SEXP tc); +RcppExport SEXP _RcppTskit_test_rtsk_provenance_table_add_row_forced_error(SEXP tcSEXP) { +BEGIN_RCPP + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< SEXP >::type tc(tcSEXP); + test_rtsk_provenance_table_add_row_forced_error(tc); + return R_NilValue; +END_RCPP +} static const R_CallMethodDef CallEntries[] = { + {"_RcppTskit_rtsk_treeseq_init_variants_iterator", (DL_FUNC) &_RcppTskit_rtsk_treeseq_init_variants_iterator, 6}, + {"_RcppTskit_rtsk_treeseq_next_variant", (DL_FUNC) &_RcppTskit_rtsk_treeseq_next_variant, 1}, + {"_RcppTskit_test_rtsk_variant_iterator_force_null_first_allele", (DL_FUNC) &_RcppTskit_test_rtsk_variant_iterator_force_null_first_allele, 1}, + {"_RcppTskit_test_rtsk_variant_iterator_set_site_bounds", (DL_FUNC) &_RcppTskit_test_rtsk_variant_iterator_set_site_bounds, 3}, + {"_RcppTskit_test_variant_site_index_range", (DL_FUNC) &_RcppTskit_test_variant_site_index_range, 2}, {"_RcppTskit_test_validate_options", (DL_FUNC) &_RcppTskit_test_validate_options, 2}, + {"_RcppTskit_test_rtsk_wrap_tsk_flags_as_int", (DL_FUNC) &_RcppTskit_test_rtsk_wrap_tsk_flags_as_int, 1}, {"_RcppTskit_test_rtsk_wrap_tsk_size_t_as_integer64", (DL_FUNC) &_RcppTskit_test_rtsk_wrap_tsk_size_t_as_integer64, 2}, {"_RcppTskit_kastore_version", (DL_FUNC) &_RcppTskit_kastore_version, 0}, {"_RcppTskit_tskit_version", (DL_FUNC) &_RcppTskit_tskit_version, 0}, @@ -757,6 +1052,8 @@ static const R_CallMethodDef CallEntries[] = { {"_RcppTskit_rtsk_treeseq_get_num_migrations", (DL_FUNC) &_RcppTskit_rtsk_treeseq_get_num_migrations, 1}, {"_RcppTskit_rtsk_treeseq_get_num_individuals", (DL_FUNC) &_RcppTskit_rtsk_treeseq_get_num_individuals, 1}, {"_RcppTskit_rtsk_treeseq_get_num_samples", (DL_FUNC) &_RcppTskit_rtsk_treeseq_get_num_samples, 1}, + {"_RcppTskit_rtsk_treeseq_get_samples", (DL_FUNC) &_RcppTskit_rtsk_treeseq_get_samples, 1}, + {"_RcppTskit_rtsk_treeseq_get_sample_node_data", (DL_FUNC) &_RcppTskit_rtsk_treeseq_get_sample_node_data, 1}, {"_RcppTskit_rtsk_treeseq_get_num_nodes", (DL_FUNC) &_RcppTskit_rtsk_treeseq_get_num_nodes, 1}, {"_RcppTskit_rtsk_treeseq_get_num_edges", (DL_FUNC) &_RcppTskit_rtsk_treeseq_get_num_edges, 1}, {"_RcppTskit_rtsk_treeseq_get_num_trees", (DL_FUNC) &_RcppTskit_rtsk_treeseq_get_num_trees, 1}, @@ -787,13 +1084,26 @@ static const R_CallMethodDef CallEntries[] = { {"_RcppTskit_rtsk_table_collection_has_index", (DL_FUNC) &_RcppTskit_rtsk_table_collection_has_index, 2}, {"_RcppTskit_rtsk_table_collection_build_index", (DL_FUNC) &_RcppTskit_rtsk_table_collection_build_index, 2}, {"_RcppTskit_rtsk_table_collection_drop_index", (DL_FUNC) &_RcppTskit_rtsk_table_collection_drop_index, 2}, + {"_RcppTskit_rtsk_table_collection_sort", (DL_FUNC) &_RcppTskit_rtsk_table_collection_sort, 5}, + {"_RcppTskit_rtsk_table_collection_simplify", (DL_FUNC) &_RcppTskit_rtsk_table_collection_simplify, 3}, {"_RcppTskit_rtsk_table_collection_summary", (DL_FUNC) &_RcppTskit_rtsk_table_collection_summary, 1}, {"_RcppTskit_rtsk_table_collection_metadata_length", (DL_FUNC) &_RcppTskit_rtsk_table_collection_metadata_length, 1}, {"_RcppTskit_rtsk_individual_table_add_row", (DL_FUNC) &_RcppTskit_rtsk_individual_table_add_row, 5}, + {"_RcppTskit_rtsk_individual_table_get_row", (DL_FUNC) &_RcppTskit_rtsk_individual_table_get_row, 2}, {"_RcppTskit_rtsk_node_table_add_row", (DL_FUNC) &_RcppTskit_rtsk_node_table_add_row, 6}, + {"_RcppTskit_rtsk_node_table_get_row", (DL_FUNC) &_RcppTskit_rtsk_node_table_get_row, 2}, {"_RcppTskit_rtsk_edge_table_add_row", (DL_FUNC) &_RcppTskit_rtsk_edge_table_add_row, 6}, + {"_RcppTskit_rtsk_edge_table_get_row", (DL_FUNC) &_RcppTskit_rtsk_edge_table_get_row, 2}, {"_RcppTskit_rtsk_site_table_add_row", (DL_FUNC) &_RcppTskit_rtsk_site_table_add_row, 4}, + {"_RcppTskit_rtsk_site_table_get_row", (DL_FUNC) &_RcppTskit_rtsk_site_table_get_row, 2}, {"_RcppTskit_rtsk_mutation_table_add_row", (DL_FUNC) &_RcppTskit_rtsk_mutation_table_add_row, 7}, + {"_RcppTskit_rtsk_mutation_table_get_row", (DL_FUNC) &_RcppTskit_rtsk_mutation_table_get_row, 2}, + {"_RcppTskit_rtsk_population_table_add_row", (DL_FUNC) &_RcppTskit_rtsk_population_table_add_row, 2}, + {"_RcppTskit_rtsk_population_table_get_row", (DL_FUNC) &_RcppTskit_rtsk_population_table_get_row, 2}, + {"_RcppTskit_rtsk_migration_table_add_row", (DL_FUNC) &_RcppTskit_rtsk_migration_table_add_row, 8}, + {"_RcppTskit_rtsk_migration_table_get_row", (DL_FUNC) &_RcppTskit_rtsk_migration_table_get_row, 2}, + {"_RcppTskit_rtsk_provenance_table_add_row", (DL_FUNC) &_RcppTskit_rtsk_provenance_table_add_row, 3}, + {"_RcppTskit_rtsk_provenance_table_get_row", (DL_FUNC) &_RcppTskit_rtsk_provenance_table_get_row, 2}, {"_RcppTskit_test_tsk_bug_assert_c", (DL_FUNC) &_RcppTskit_test_tsk_bug_assert_c, 0}, {"_RcppTskit_test_tsk_bug_assert_cpp", (DL_FUNC) &_RcppTskit_test_tsk_bug_assert_cpp, 0}, {"_RcppTskit_test_tsk_trace_error_c", (DL_FUNC) &_RcppTskit_test_tsk_trace_error_c, 0}, @@ -807,6 +1117,9 @@ static const R_CallMethodDef CallEntries[] = { {"_RcppTskit_test_rtsk_edge_table_add_row_forced_error", (DL_FUNC) &_RcppTskit_test_rtsk_edge_table_add_row_forced_error, 1}, {"_RcppTskit_test_rtsk_site_table_add_row_forced_error", (DL_FUNC) &_RcppTskit_test_rtsk_site_table_add_row_forced_error, 1}, {"_RcppTskit_test_rtsk_mutation_table_add_row_forced_error", (DL_FUNC) &_RcppTskit_test_rtsk_mutation_table_add_row_forced_error, 1}, + {"_RcppTskit_test_rtsk_population_table_add_row_forced_error", (DL_FUNC) &_RcppTskit_test_rtsk_population_table_add_row_forced_error, 1}, + {"_RcppTskit_test_rtsk_migration_table_add_row_forced_error", (DL_FUNC) &_RcppTskit_test_rtsk_migration_table_add_row_forced_error, 1}, + {"_RcppTskit_test_rtsk_provenance_table_add_row_forced_error", (DL_FUNC) &_RcppTskit_test_rtsk_provenance_table_add_row_forced_error, 1}, {NULL, NULL, 0} }; diff --git a/RcppTskit/src/RcppTskit.cpp b/RcppTskit/src/RcppTskit.cpp index 71755cb..a299585 100644 --- a/RcppTskit/src/RcppTskit.cpp +++ b/RcppTskit/src/RcppTskit.cpp @@ -4,10 +4,12 @@ // they are synced! #define RCPPTSKIT_IMPL #include +#include #include #include #include #include +#include #include #include @@ -22,6 +24,15 @@ constexpr tsk_flags_t kCopyTablesSupportedFlags = TSK_COPY_FILE_UUID; constexpr tsk_flags_t kTreeseqInitSupportedFlags = TSK_TS_INIT_BUILD_INDEXES | TSK_TS_INIT_COMPUTE_MUTATION_PARENTS; +constexpr tsk_flags_t kTableSortSupportedFlags = TSK_NO_CHECK_INTEGRITY; + +constexpr tsk_flags_t kTableSimplifySupportedFlags = + TSK_SIMPLIFY_FILTER_SITES | TSK_SIMPLIFY_FILTER_POPULATIONS | + TSK_SIMPLIFY_FILTER_INDIVIDUALS | TSK_SIMPLIFY_REDUCE_TO_SITE_TOPOLOGY | + TSK_SIMPLIFY_KEEP_UNARY | TSK_SIMPLIFY_KEEP_INPUT_ROOTS | + TSK_SIMPLIFY_KEEP_UNARY_IN_INDIVIDUALS | TSK_SIMPLIFY_NO_FILTER_NODES | + TSK_SIMPLIFY_NO_UPDATE_SAMPLE_FLAGS; + // INTERNAL // @title Validate load options // @param options passed to load functions @@ -138,9 +149,104 @@ tsk_flags_t validate_options(int options, tsk_flags_t supported, return flags; } +tsk_flags_t validate_supported_options(int options, tsk_flags_t supported, + const char *caller) { + if (options < 0) { + Rcpp::stop("%s does not support negative options", caller); + } + const tsk_flags_t flags = static_cast(options); + const tsk_flags_t unsupported = flags & ~supported; + if (unsupported != 0) { + Rcpp::stop("%s only supports options 0x%X; unsupported bits: 0x%X", caller, + static_cast(supported), + static_cast(unsupported)); + } + return flags; +} + constexpr tsk_size_t kMaxBit64Integer64 = static_cast(std::numeric_limits::max()); +// R integer storage is C int. Fail at compile time if tsk_id_t changes width +// or signedness (for example under _TSK_BIG_TABLES) before the wrapper API is +// extended to integer64. +static_assert(std::numeric_limits::is_signed && + std::numeric_limits::is_signed && + sizeof(tsk_id_t) == sizeof(int) && + std::numeric_limits::min() == + std::numeric_limits::min() && + std::numeric_limits::max() == + std::numeric_limits::max(), + "RcppTskit currently requires tsk_id_t to match R integer " + "storage. Builds with widened tsk_id_t (for example " + "_TSK_BIG_TABLES) need an integer64-based wrapper before they " + "are supported."); + +// INTERNAL +// @title State for an \code{RcppTskit} variant iterator +// @description Stores a tree-sequence reference, variant decoder, and site-ID +// bounds needed to decode successive variants. +// @section Members: +// \describe{ +// \item{\code{ts_xptr}}{External-pointer wrapper providing access to the +// underlying \code{tsk_treeseq_t} used for variant decoding.} +// \item{\code{ts_sexp}}{Preserved \code{R} external-pointer object that +// keeps the tree sequence alive while the iterator exists. It remains +// \code{R_NilValue} until it is preserved.} +// \item{\code{variant}}{Reusable \code{tskit C} variant decoder populated +// for successive sites by \code{tsk_variant_decode()}.} +// \item{\code{variant_initialized}}{Whether \code{tsk_variant_init()} +// completed successfully and \code{variant} must be released by +// \code{tsk_variant_free()}.} +// \item{\code{next_site_id}}{0-based ID of the next site to decode.} +// \item{\code{stop_site_id}}{Exclusive 0-based upper bound on site IDs +// to decode.} +// } +// @details This is an \code{RcppTskit}-owned iterator state with no direct +// equivalent in the \code{tskit C} API. It combines a +// \code{tsk_variant_t} decoder with the half-open range of site IDs used by +// \code{rtsk_treeseq_next_variant()}. +// +// The \code{variant} decoder is initialised with +// \code{tsk_variant_init()}, reused by \code{tsk_variant_decode()}, and +// released with \code{tsk_variant_free()}. +// See \url{https://tskit.dev/tskit/docs/stable/c-api.html#c.tsk_variant_t}. +// +// A \code{tsk_variant_t} stores an unowned reference to its tree sequence, +// so this state keeps the originating \code{R} tree-sequence external pointer +// alive for the complete lifetime of the iterator. +// +// The remaining site-ID range is represented as +// \code{[next_site_id, stop_site_id)}, with \code{stop_site_id} excluded. +struct rtsk_variant_iterator_state_t { + rtsk_treeseq_t ts_xptr; + SEXP ts_sexp = R_NilValue; // TODO: remove? + tsk_variant_t variant = {}; + bool variant_initialized = false; + tsk_id_t next_site_id = 0; + tsk_id_t stop_site_id = 0; + explicit rtsk_variant_iterator_state_t(SEXP ts) : ts_xptr(ts) {} +}; + +// TODO: Document!? +static void rtsk_variant_iterator_free(rtsk_variant_iterator_state_t *ptr) { + if (ptr != NULL) { + if (ptr->variant_initialized) { + tsk_variant_free(&ptr->variant); + } + if (ptr->ts_sexp != R_NilValue) { + R_ReleaseObject(ptr->ts_sexp); + } + delete ptr; + } +} + +using rtsk_variant_iterator_t = + Rcpp::XPtr; + +bool g_test_force_null_first_allele = false; + // INTERNAL // @title Convert \code{Rcpp::Nullable} vector to empty-or-value vector // @param value nullable vector from \code{R} @@ -154,7 +260,7 @@ VectorT nullable_to_vector_or_empty(const Rcpp::Nullable &value) { } // INTERNAL -// @title Convert \code{integer} vector to \code{tsk_id_t} vector +// @title Convert \code{Rcpp::IntegerVector} to \code{tsk_id_t} vector // @param ids \code{integer} values. // @details \code{tsk_id_t} is \code{int32_t} (a standard integer) // \url{https://tskit.dev/tskit/docs/stable/c-api.html#c.tsk_id_t} @@ -169,20 +275,99 @@ int_vector_to_tsk_id_vector(const Rcpp::IntegerVector &ids) { return out; } +// TODO: Document!? +void validate_variant_site_index_range(tsk_size_t start, tsk_size_t stop) { + const tsk_size_t max_id = + static_cast(std::numeric_limits::max()); + if (start > max_id || stop > max_id) { + Rcpp::stop("Site index exceeds tsk_id_t range"); + } +} + +// TODO: Document!? +std::pair +compute_variant_iteration_bounds(rtsk_treeseq_t &ts_xptr, double left, + double right) { + if (!std::isfinite(left) || !std::isfinite(right)) { + Rcpp::stop("left and right must be finite numbers"); + } + if (left < 0 || right < 0) { + Rcpp::stop("left and right must be >= 0"); + } + + const double sequence_length = tsk_treeseq_get_sequence_length(ts_xptr); + if (left > sequence_length || right > sequence_length) { + Rcpp::stop("left and right must be <= sequence length (%f)", + sequence_length); + } + if (left > right) { + Rcpp::stop("left must be <= right"); + } + + const tsk_size_t num_sites = tsk_treeseq_get_num_sites(ts_xptr); + const tsk_site_table_t *sites = &ts_xptr->tables->sites; + const double *begin = sites->position; + const double *end = begin + num_sites; + + const tsk_size_t start = + static_cast(std::lower_bound(begin, end, left) - begin); + const tsk_size_t stop = + static_cast(std::lower_bound(begin, end, right) - begin); + validate_variant_site_index_range(start, stop); + + return std::make_pair(static_cast(start), + static_cast(stop)); +} + +// INTERNAL +// @title Wrap \code{C tsk_flags_t / uint32_t} as a \code{C++ int} +// @param value \code{C tsk_flags_t / uint32_t} +// @param caller function name +// @details \code{tsk_flags_t} is \code{uint32_t}; see +// \url{https://tskit.dev/tskit/docs/stable/c-api.html#c.tsk_flags_t}. +// It is an unsigned 32 bit integer with range from 0 to 2^32 - 1 +// (that is, 0 to 4,294,967,295). +// On the other hand, the \code{C++ int} used by \code{RcppTskit} is +// a signed 32 bit integer with range from -2^31 to 2^31 - 1 +// (that is, -2,147,483,648 to 2,147,483,647). +// \code{Rcpp} maps a \code{C++ int} to an \code{R integer}. +// In \code{R}, the lowest signed 32 bit value is reserved for +// \code{NA_integer_} (try running \code{as.integer(-2^31)}). Flags are +// nonnegative, so \code{RcppTskit} represents values from 0 to 2^31 - 1 as +// \code{C++ int} values and hence as \code{R integers}. +// So, values from 2^31 through 2^32 - 1 are not supported. +// A checked conversion is therefore required because converting an +// out-of-range \code{tsk_flags_t} to a \code{C++ int} is +// implementation-defined and could yield a negative \code{int}; +// \code{Rcpp} would then expose it as a negative \code{R integer} or +// \code{NA_integer_}. +// @return A \code{C++ int}, which \code{Rcpp} maps to an \code{R integer}. +int rtsk_wrap_tsk_flags_as_int(tsk_flags_t value, const char *caller) { + const tsk_flags_t max_r_int = + static_cast(std::numeric_limits::max()); + if (value > max_r_int) { + Rcpp::stop("%s cannot represent tsk_flags_t value %u as a C++ int " + "(and hence as an R integer); " + "maximum supported value is %d", + caller, static_cast(value), + std::numeric_limits::max()); + } + return static_cast(value); +} + // INTERNAL // @title Wrap \code{C tsk_size_t / uint64_t} to \code{R bit64::integer64} -// @param value \code{C tsk_size_t / uint64_t} value +// @param value \code{C tsk_size_t / uint64_t} // @param caller function name -// @details \code{tsk_id_t} is \code{uint64_t} -// \url{https://tskit.dev/tskit/docs/stable/c-api.html#c.tsk_size_t}, -// an unsigned 64 bit integer with range from 0 to 2^64 - 1 +// @details \code{tsk_size_t} is \code{uint64_t}; see +// \url{https://tskit.dev/tskit/docs/stable/c-api.html#c.tsk_size_t}. +// It is an unsigned 64 bit integer with range from 0 to 2^64 - 1 // (that is, 0 to 18,446,744,073,709,551,615). -// On the other hand, the R bit64::integer64 is +// On the other hand, the \code{R bit64::integer64} is // a signed 64 bit integer with range from -2^63 to 2^63 - 1 // (that is, -9,223,372,036,854,775,808 to 9,223,372,036,854,775,807) // @return \code{R bit64::integer64} object. -SEXP rtsk_wrap_tsk_size_t_as_integer64(const tsk_size_t value, - const char *caller) { +SEXP rtsk_wrap_tsk_size_t_as_integer64(tsk_size_t value, const char *caller) { const std::string value_str = std::to_string(static_cast(value)); if (value > kMaxBit64Integer64) { @@ -199,6 +384,150 @@ SEXP rtsk_wrap_tsk_size_t_as_integer64(const tsk_size_t value, } // namespace +// PUBLIC, low-level iterator init for tsk_variant_t decode +// [[Rcpp::export]] +SEXP rtsk_treeseq_init_variants_iterator( + SEXP ts, Rcpp::Nullable samples = R_NilValue, + bool isolated_as_missing = true, + Rcpp::Nullable alleles = R_NilValue, + double left = 0.0, double right = NA_REAL) { + std::unique_ptr state_ptr( + new rtsk_variant_iterator_state_t(ts)); + + const tsk_flags_t options = + isolated_as_missing ? 0 : TSK_ISOLATED_NOT_MISSING; + + const Rcpp::IntegerVector samples_int = + nullable_to_vector_or_empty(samples); + const std::vector samples_vec = + int_vector_to_tsk_id_vector(samples_int); + const bool samples_was_null = samples.isNull(); + tsk_id_t empty_samples_sentinel = 0; + const tsk_id_t *samples_ptr = nullptr; + if (!samples_was_null) { + samples_ptr = + samples_vec.empty() ? &empty_samples_sentinel : samples_vec.data(); + } + const tsk_size_t num_samples = + samples_was_null ? 0 : static_cast(samples_vec.size()); + + const Rcpp::CharacterVector alleles_chr = + nullable_to_vector_or_empty(alleles); + std::vector allele_storage; + std::vector allele_ptrs; + const char **alleles_ptr = nullptr; + if (alleles_chr.size() > 0) { + allele_storage.reserve(alleles_chr.size()); + for (const SEXP allele : alleles_chr) { + if (allele == NA_STRING) { + Rcpp::stop("alleles cannot contain NA"); + } + allele_storage.push_back(Rcpp::as(allele)); + } + allele_ptrs.reserve(allele_storage.size() + 1); + for (const std::string &allele : allele_storage) { + allele_ptrs.push_back(allele.c_str()); + } + allele_ptrs.push_back(nullptr); + alleles_ptr = allele_ptrs.data(); + } + + const double effective_right = + Rcpp::NumericVector::is_na(right) + ? tsk_treeseq_get_sequence_length(state_ptr->ts_xptr) + : right; + const auto bounds = compute_variant_iteration_bounds(state_ptr->ts_xptr, left, + effective_right); + state_ptr->next_site_id = bounds.first; + state_ptr->stop_site_id = bounds.second; + + int ret = tsk_variant_init(&state_ptr->variant, state_ptr->ts_xptr, + samples_ptr, num_samples, alleles_ptr, options); + if (ret != 0) { + Rcpp::stop(tsk_strerror(ret)); + } + state_ptr->variant_initialized = true; + state_ptr->ts_sexp = ts; + R_PreserveObject(ts); + + rtsk_variant_iterator_t iterator_xptr(state_ptr.release(), true); + return iterator_xptr; +} + +// PUBLIC, low-level iterator next for tsk_variant_t decode +// [[Rcpp::export]] +SEXP rtsk_treeseq_next_variant(SEXP iterator) { + rtsk_variant_iterator_t iterator_xptr(iterator); + if (iterator_xptr->next_site_id >= iterator_xptr->stop_site_id) { + return R_NilValue; + } + + const tsk_id_t site_id = iterator_xptr->next_site_id; + iterator_xptr->next_site_id += 1; + int ret = tsk_variant_decode(&iterator_xptr->variant, site_id, 0); + if (ret != 0) { + Rcpp::stop(tsk_strerror(ret)); + } + + const tsk_variant_t &variant = iterator_xptr->variant; + if (g_test_force_null_first_allele && variant.num_alleles > 0) { + iterator_xptr->variant.alleles[0] = nullptr; + g_test_force_null_first_allele = false; + } + + Rcpp::IntegerVector genotypes(variant.num_samples); + for (tsk_size_t j = 0; j < variant.num_samples; ++j) { + genotypes[j] = variant.genotypes[j]; + } + + Rcpp::CharacterVector out_alleles(variant.num_alleles); + for (tsk_size_t j = 0; j < variant.num_alleles; ++j) { + if (variant.alleles[j] == nullptr) { + out_alleles[j] = NA_STRING; + continue; + } + out_alleles[j] = std::string(variant.alleles[j], variant.allele_lengths[j]); + } + + return Rcpp::List::create( + Rcpp::_["site_id"] = variant.site.id, + Rcpp::_["position"] = variant.site.position, + Rcpp::_["genotypes"] = genotypes, Rcpp::_["alleles"] = out_alleles, + Rcpp::_["has_missing_data"] = variant.has_missing_data); +} + +// TEST-ONLY +// [[Rcpp::export]] +void test_rtsk_variant_iterator_force_null_first_allele(bool enabled) { + g_test_force_null_first_allele = enabled; +} + +// TEST-ONLY +// [[Rcpp::export]] +void test_rtsk_variant_iterator_set_site_bounds(SEXP iterator, int next_site_id, + int stop_site_id) { + rtsk_variant_iterator_t iterator_xptr(iterator); + iterator_xptr->next_site_id = static_cast(next_site_id); + iterator_xptr->stop_site_id = static_cast(stop_site_id); +} + +// TEST-ONLY +// [[Rcpp::export]] +void test_variant_site_index_range(const std::string &start, + const std::string &stop) { + unsigned long long start_parsed = 0; + unsigned long long stop_parsed = 0; + try { + start_parsed = std::stoull(start); + stop_parsed = std::stoull(stop); + } catch (const std::exception &) { + Rcpp::stop("start and stop must be valid base-10 unsigned integer strings"); + } + const tsk_size_t start_size = static_cast(start_parsed); + const tsk_size_t stop_size = static_cast(stop_parsed); + validate_variant_site_index_range(start_size, stop_size); +} + // TEST-ONLY // @title Test helper for validating tskit flags // @param options that will be validated @@ -211,6 +540,20 @@ int test_validate_options(int options, int supported) { return static_cast(out); } +// TEST-ONLY +// @title Test helper for wrapping \code{tsk_flags_t} as an R integer +// @param value nonnegative integer-valued numeric flag value +// @return Flag value as an R integer. +// [[Rcpp::export]] +int test_rtsk_wrap_tsk_flags_as_int(double value) { + if (!std::isfinite(value) || value < 0 || std::floor(value) != value || + value > static_cast(std::numeric_limits::max())) { + Rcpp::stop("value must be an integer within the tsk_flags_t range"); + } + return rtsk_wrap_tsk_flags_as_int(static_cast(value), + "test_rtsk_wrap_tsk_flags_as_int"); +} + // TEST-ONLY // @title Test helper for integer64 wrapping of \code{tsk_size_t} // @param value character representation of unsigned integer @@ -296,7 +639,7 @@ SEXP rtsk_treeseq_load(const std::string &filename, int options = 0) { // tsk_treeseq_t ts; // on stack, destroyed end of func, must free resources tsk_treeseq_t *ts_ptr = new tsk_treeseq_t(); // on heap, persists function // See also https://tskit.dev/tskit/docs/stable/c-api.html#api-structure - int ret = tsk_treeseq_load(ts_ptr, filename.c_str(), flags); + const int ret = tsk_treeseq_load(ts_ptr, filename.c_str(), flags); if (ret != 0) { tsk_treeseq_free(ts_ptr); delete ts_ptr; @@ -334,7 +677,7 @@ SEXP rtsk_table_collection_load(const std::string &filename, int options = 0) { const tsk_flags_t flags = validate_load_options(options, "rtsk_table_collection_load"); tsk_table_collection_t *tc_ptr = new tsk_table_collection_t(); - int ret = tsk_table_collection_load(tc_ptr, filename.c_str(), flags); + const int ret = tsk_table_collection_load(tc_ptr, filename.c_str(), flags); if (ret != 0) { tsk_table_collection_free(tc_ptr); delete tc_ptr; @@ -366,7 +709,7 @@ SEXP rtsk_table_collection_load(const std::string &filename, int options = 0) { void rtsk_treeseq_dump(SEXP ts, const std::string &filename, int options = 0) { const tsk_flags_t flags = validate_options(options, 0, "rtsk_treeseq_dump"); rtsk_treeseq_t ts_xptr(ts); - int ret = tsk_treeseq_dump(ts_xptr, filename.c_str(), flags); + const int ret = tsk_treeseq_dump(ts_xptr, filename.c_str(), flags); if (ret != 0) { Rcpp::stop(tsk_strerror(ret)); } @@ -394,7 +737,7 @@ void rtsk_table_collection_dump(SEXP tc, const std::string &filename, const tsk_flags_t flags = validate_options(options, 0, "rtsk_table_collection_dump"); rtsk_table_collection_t tc_xptr(tc); - int ret = tsk_table_collection_dump(tc_xptr, filename.c_str(), flags); + const int ret = tsk_table_collection_dump(tc_xptr, filename.c_str(), flags); if (ret != 0) { Rcpp::stop(tsk_strerror(ret)); } @@ -429,7 +772,7 @@ SEXP rtsk_treeseq_copy_tables(SEXP ts, int options = 0) { validate_copy_tables_options(options, "rtsk_treeseq_copy_tables"); rtsk_treeseq_t ts_xptr(ts); tsk_table_collection_t *tc_ptr = new tsk_table_collection_t(); - int ret = tsk_treeseq_copy_tables(ts_xptr, tc_ptr, flags); + const int ret = tsk_treeseq_copy_tables(ts_xptr, tc_ptr, flags); if (ret != 0) { tsk_table_collection_free(tc_ptr); delete tc_ptr; @@ -477,7 +820,7 @@ SEXP rtsk_treeseq_init(SEXP tc, int options = 0) { validate_treeseq_init_options(options, "rtsk_treeseq_init"); rtsk_table_collection_t tc_xptr(tc); tsk_treeseq_t *ts_ptr = new tsk_treeseq_t(); - int ret = tsk_treeseq_init(ts_ptr, tc_xptr, flags); + const int ret = tsk_treeseq_init(ts_ptr, tc_xptr, flags); if (ret != 0) { tsk_treeseq_free(ts_ptr); delete ts_ptr; @@ -567,8 +910,7 @@ SEXP rtsk_treeseq_get_num_individuals(SEXP ts) { // PUBLIC, wrapper for tsk_treeseq_get_num_samples // @describeIn rtsk_treeseq_summary Get the number of samples (of nodes) in a -// tree -// sequence +// tree sequence // [[Rcpp::export]] SEXP rtsk_treeseq_get_num_samples(SEXP ts) { rtsk_treeseq_t ts_xptr(ts); @@ -576,6 +918,66 @@ SEXP rtsk_treeseq_get_num_samples(SEXP ts) { "rtsk_treeseq_get_num_samples"); } +// PUBLIC, wrapper for tsk_treeseq_get_samples +// @title Get sample node IDs in tree sequence +// @param ts an external pointer to tree sequence as a \code{tsk_treeseq_t} +// object. +// @details This function calls +// \url{https://tskit.dev/tskit/docs/stable/c-api.html#c.tsk_treeseq_get_samples}. +// @return An \code{R}-owned integer vector containing an independent copy of +// the sample node IDs (0-based), listed in numerical order. The underlying +// \code{C} array remains owned by the tree sequence. +// @examples +// ts_file <- system.file("examples/test.trees", package = "RcppTskit") +// ts_xptr <- RcppTskit:::rtsk_treeseq_load(ts_file) +// RcppTskit:::rtsk_treeseq_get_samples(ts_xptr) +// RcppTskit:::rtsk_treeseq_get_num_samples(ts_xptr) +// [[Rcpp::export]] +Rcpp::IntegerVector rtsk_treeseq_get_samples(SEXP ts) { + rtsk_treeseq_t ts_xptr(ts); + const tsk_id_t *samples = tsk_treeseq_get_samples(ts_xptr); + const tsk_size_t num_samples = tsk_treeseq_get_num_samples(ts_xptr); + Rcpp::IntegerVector out(num_samples); + if (num_samples > 0) { + std::copy_n(samples, num_samples, out.begin()); + } + return out; +} + +// PUBLIC, RcppTskit extension +// @title Get sample node data needed to filter tree-sequence samples +// @param ts an external pointer to a tree sequence as a +// \code{tsk_treeseq_t} object. +// @return A named list of aligned, \code{R}-owned vectors: integer sample node +// IDs, integer population IDs, and numeric node times. +// @examples +// ts_file <- system.file("examples/test.trees", package = "RcppTskit") +// ts_xptr <- RcppTskit:::rtsk_treeseq_load(ts_file) +// RcppTskit:::rtsk_treeseq_get_sample_node_data(ts_xptr) +// [[Rcpp::export]] +Rcpp::List rtsk_treeseq_get_sample_node_data(SEXP ts) { + rtsk_treeseq_t ts_xptr(ts); + const tsk_size_t num_samples = tsk_treeseq_get_num_samples(ts_xptr); + Rcpp::IntegerVector samples(num_samples); + Rcpp::IntegerVector population(num_samples); + Rcpp::NumericVector time(num_samples); + + if (num_samples > 0) { + const tsk_id_t *sample_ids = tsk_treeseq_get_samples(ts_xptr); + const tsk_node_table_t &nodes = ts_xptr->tables->nodes; + for (tsk_size_t j = 0; j < num_samples; ++j) { + const tsk_id_t node_id = sample_ids[j]; + samples[j] = node_id; + population[j] = nodes.population[node_id]; + time[j] = nodes.time[node_id]; + } + } + + return Rcpp::List::create(Rcpp::_["samples"] = samples, + Rcpp::_["population"] = population, + Rcpp::_["time"] = time); +} + // PUBLIC, wrapper for tsk_treeseq_get_num_nodes // @describeIn rtsk_treeseq_summary Get the number of nodes in a tree sequence // [[Rcpp::export]] @@ -659,7 +1061,7 @@ bool rtsk_treeseq_has_reference_sequence(SEXP ts) { Rcpp::String rtsk_treeseq_get_time_units(SEXP ts) { rtsk_treeseq_t ts_xptr(ts); const char *p = tsk_treeseq_get_time_units(ts_xptr); - tsk_size_t n = tsk_treeseq_get_time_units_length(ts_xptr); + const tsk_size_t n = tsk_treeseq_get_time_units_length(ts_xptr); std::string time_units; if (n > 0 && p != NULL) { time_units.assign(p, p + n); @@ -731,6 +1133,8 @@ Rcpp::String rtsk_treeseq_get_file_uuid(SEXP ts) { // \url{https://tskit.dev/tskit/docs/stable/c-api.html#c.tsk_treeseq_get_max_time}, // and // \url{https://tskit.dev/tskit/docs/stable/c-api.html#c.tsk_treeseq_get_file_uuid}, +// This composite summary helper is an RcppTskit extension with no single +// upstream \code{tsk_*} equivalent. // @return \code{rtsk_treeseq_summary} returns a named list with numbers and // values, while functions \code{rtsk_treeseq_*} return the number or value // for each item. Count-like values are returned as \code{R bit64::integer64} @@ -758,7 +1162,6 @@ Rcpp::String rtsk_treeseq_get_file_uuid(SEXP ts) { // RcppTskit:::rtsk_treeseq_get_min_time(ts_xptr) // RcppTskit:::rtsk_treeseq_get_max_time(ts_xptr) // RcppTskit:::rtsk_treeseq_get_file_uuid(ts_xptr) -// EXTENSION: composite summary helper (no single tsk_* equivalent). // [[Rcpp::export]] Rcpp::List rtsk_treeseq_summary(SEXP ts) { return Rcpp::List::create( @@ -847,7 +1250,7 @@ Rcpp::List rtsk_treeseq_metadata_length(SEXP ts) { Rcpp::String rtsk_treeseq_get_metadata(SEXP ts) { rtsk_treeseq_t ts_xptr(ts); const char *p = tsk_treeseq_get_metadata(ts_xptr); - tsk_size_t n = tsk_treeseq_get_metadata_length(ts_xptr); + const tsk_size_t n = tsk_treeseq_get_metadata_length(ts_xptr); std::string metadata; if (n > 0 && p != NULL) { metadata.assign(p, p + n); @@ -1015,7 +1418,7 @@ bool rtsk_table_collection_has_reference_sequence(SEXP tc) { Rcpp::String rtsk_table_collection_get_time_units(SEXP tc) { rtsk_table_collection_t tc_xptr(tc); const char *p = tc_xptr->time_units; - tsk_size_t n = tc_xptr->time_units_length; + const tsk_size_t n = tc_xptr->time_units_length; std::string time_units; if (n > 0 && p != NULL) { time_units.assign(p, p + n); @@ -1066,7 +1469,7 @@ void rtsk_table_collection_build_index(SEXP tc, int options = 0) { const tsk_flags_t flags = validate_options(options, 0, "rtsk_table_collection_build_index"); rtsk_table_collection_t tc_xptr(tc); - int ret = tsk_table_collection_build_index(tc_xptr, flags); + const int ret = tsk_table_collection_build_index(tc_xptr, flags); if (ret != 0) { Rcpp::stop(tsk_strerror(ret)); } @@ -1092,7 +1495,7 @@ void rtsk_table_collection_drop_index(SEXP tc, int options = 0) { const tsk_flags_t flags = validate_options(options, 0, "rtsk_table_collection_drop_index"); rtsk_table_collection_t tc_xptr(tc); - int ret = tsk_table_collection_drop_index(tc_xptr, flags); + const int ret = tsk_table_collection_drop_index(tc_xptr, flags); // tsk_table_collection_drop_index() currently documents always returning 0; // so we test for possible future failures, but we cannot unit-test this // path. # nocov start @@ -1102,8 +1505,102 @@ void rtsk_table_collection_drop_index(SEXP tc, int options = 0) { // # nocov end } -// TODO: Do we have to add TableCollection$sort() method? #99 -// https://github.com/HighlanderLab/RcppTskit/issues/99 +// PUBLIC, wrapper for tsk_table_collection_sort +// @title Sort a table collection +// @param tc an external pointer to table collection as a +// \code{tsk_table_collection_t} object. +// @param start_edges integer scalar edge-table start row index (0-based). +// @param start_sites integer scalar site-table start row index (0-based). +// @param start_mutations mutation-table start row index (0-based). +// @param options passed to \code{tskit C}; this wrapper supports +// \code{TSK_NO_CHECK_INTEGRITY}. +// @details This function calls +// \url{https://tskit.dev/tskit/docs/stable/c-api.html#c.tsk_table_collection_sort}, +// using the same edge/site/mutation start inputs used by +// \url{https://tskit.dev/tskit/docs/stable/python-api.html#tskit.TableCollection.sort} +// (we create the \code{tskit C API's tsk_bookmark_t *start} inside +// \code{rtsk_table_collection_sort}). +// @return No return value; called for side effects. +// @examples +// ts_file <- system.file("examples/test.trees", package = "RcppTskit") +// tc_xptr <- RcppTskit:::rtsk_table_collection_load(ts_file) +// RcppTskit:::rtsk_table_collection_sort(tc_xptr) +// [[Rcpp::export]] +void rtsk_table_collection_sort(SEXP tc, int start_edges = 0, + int start_sites = 0, int start_mutations = 0, + int options = 0) { + const tsk_flags_t flags = validate_supported_options( + options, kTableSortSupportedFlags, "rtsk_table_collection_sort"); + if (start_edges < 0 || start_sites < 0 || start_mutations < 0) { + Rcpp::stop("rtsk_table_collection_sort start offsets must be non-negative"); + } + rtsk_table_collection_t tc_xptr(tc); + tsk_bookmark_t start = {0}; + start.edges = static_cast(start_edges); + start.sites = static_cast(start_sites); + start.mutations = static_cast(start_mutations); + const int ret = tsk_table_collection_sort(tc_xptr, &start, flags); + if (ret != 0) { + if (ret == TSK_ERR_SORT_OFFSET_NOT_SUPPORTED) { + Rcpp::stop("Sort offsets for sites and mutations must be either 0 or the " + "length of the respective tables. Intermediate values are not " + "supported. (TSK_ERR_SORT_OFFSET_NOT_SUPPORTED)"); + } + Rcpp::stop(tsk_strerror(ret)); + } +} + +// PUBLIC, wrapper for tsk_table_collection_simplify +// @title Simplify a table collection +// @param tc an external pointer to table collection as a +// \code{tsk_table_collection_t} object. +// @param samples either \code{NULL} or integer vector of node IDs to retain as +// samples. +// @param options simplify options passed to \code{tskit C}. +// @details This function calls +// \url{https://tskit.dev/tskit/docs/stable/c-api.html#c.tsk_table_collection_simplify}. +// @return Integer vector mapping input node IDs to output node IDs; dropped +// nodes map to \code{-1}. +// @examples +// ts_file <- system.file("examples/test.trees", package = "RcppTskit") +// tc_xptr <- RcppTskit:::rtsk_table_collection_load(ts_file) +// node_map <- RcppTskit:::rtsk_table_collection_simplify( +// tc_xptr, +// samples = c(0L, 1L, 2L, 3L) +// ) +// node_map +// [[Rcpp::export]] +Rcpp::IntegerVector rtsk_table_collection_simplify( + SEXP tc, Rcpp::Nullable samples = R_NilValue, + int options = 0) { + const tsk_flags_t flags = validate_supported_options( + options, kTableSimplifySupportedFlags, "rtsk_table_collection_simplify"); + rtsk_table_collection_t tc_xptr(tc); + const tsk_size_t num_nodes = tc_xptr->nodes.num_rows; + Rcpp::IntegerVector node_map(num_nodes); + tsk_id_t *node_map_ptr = node_map.begin(); + + const Rcpp::IntegerVector samples_int = + nullable_to_vector_or_empty(samples); + const std::vector samples_vec = + int_vector_to_tsk_id_vector(samples_int); + const bool samples_was_null = samples.isNull(); + tsk_id_t empty_samples_sentinel = 0; + const tsk_id_t *samples_ptr = nullptr; + if (!samples_was_null) { + samples_ptr = + samples_vec.empty() ? &empty_samples_sentinel : samples_vec.data(); + } + const tsk_size_t num_samples = + samples_was_null ? 0 : static_cast(samples_vec.size()); + + const int ret = tsk_table_collection_simplify( + tc_xptr, samples_ptr, num_samples, flags, node_map_ptr); + if (ret != 0) { + Rcpp::stop(tsk_strerror(ret)); + } + return node_map; +} // TODO: Do we need any other method on table collection to produce a valid // ts? #100 @@ -1128,16 +1625,14 @@ void rtsk_table_collection_drop_index(SEXP tc, int options = 0) { // ts_file <- system.file("examples/test.trees", package = "RcppTskit") // tc_xptr <- RcppTskit:::rtsk_table_collection_load(ts_file) // RcppTskit:::rtsk_table_collection_summary(tc_xptr) -// RcppTskit:::rtsk_table_collection_get_num_provenances(ts_xptr) -// RcppTskit:::rtsk_table_collection_get_num_populations(ts_xptr) -// RcppTskit:::rtsk_table_collection_get_num_migrations(ts_xptr) -// RcppTskit:::rtsk_table_collection_get_num_individuals(ts_xptr) -// RcppTskit:::rtsk_table_collection_get_num_samples(ts_xptr) -// RcppTskit:::rtsk_table_collection_get_num_nodes(ts_xptr) -// RcppTskit:::rtsk_table_collection_get_num_edges(ts_xptr) -// RcppTskit:::rtsk_table_collection_get_num_trees(ts_xptr) -// RcppTskit:::rtsk_table_collection_get_num_sites(ts_xptr) -// RcppTskit:::rtsk_table_collection_get_num_mutations(ts_xptr) +// RcppTskit:::rtsk_table_collection_get_num_provenances(tc_xptr) +// RcppTskit:::rtsk_table_collection_get_num_populations(tc_xptr) +// RcppTskit:::rtsk_table_collection_get_num_migrations(tc_xptr) +// RcppTskit:::rtsk_table_collection_get_num_individuals(tc_xptr) +// RcppTskit:::rtsk_table_collection_get_num_nodes(tc_xptr) +// RcppTskit:::rtsk_table_collection_get_num_edges(tc_xptr) +// RcppTskit:::rtsk_table_collection_get_num_sites(tc_xptr) +// RcppTskit:::rtsk_table_collection_get_num_mutations(tc_xptr) // RcppTskit:::rtsk_table_collection_get_sequence_length(tc_xptr) // RcppTskit:::rtsk_table_collection_has_reference_sequence(tc_xptr) // RcppTskit:::rtsk_table_collection_get_time_units(tc_xptr) @@ -1170,6 +1665,8 @@ Rcpp::List rtsk_table_collection_summary(SEXP tc) { // @title Get the length of metadata in a table collection and its tables // @param tc an external pointer to table collection as a // \code{tsk_table_collection_t} object. +// @details This metadata-length summary across tables is an RcppTskit +// extension with no single upstream \code{tsk_*} equivalent. // @return A named list with the length of metadata as \code{R // bit64::integer64} // values to approach range in \code{C tsk_size_t / uint64_t} @@ -1178,8 +1675,6 @@ Rcpp::List rtsk_table_collection_summary(SEXP tc) { // ts_file <- system.file("examples/test.trees", package = "RcppTskit") // tc_xptr <- RcppTskit:::rtsk_table_collection_load(ts_file) // RcppTskit:::rtsk_table_collection_metadata_length(tc_xptr) -// EXTENSION: metadata-length summary across tables (no single tsk_* -// equivalent). // [[Rcpp::export]] Rcpp::List rtsk_table_collection_metadata_length(SEXP tc) { rtsk_table_collection_t tc_xptr(tc); @@ -1235,58 +1730,25 @@ Rcpp::List rtsk_table_collection_metadata_length(SEXP tc) { // @title Add a row to the individual table in a table collection // @param tc an external pointer to table collection as a // \code{tsk_table_collection_t} object. -// @param flags passed to \code{tskit C}. +// @param flags integer scalar bitwise flags for the new individual. Values +// from 0 through 2^31 - 1 are supported. // @param location numeric vector with the location of the new individual -// (can be \code{NULL}). +// (can be \code{NULL}, which stores an empty location). // @param parents integer vector with parent individual IDs (0-based) -// (can be \code{NULL}). -// @param metadata raw vector with metadata bytes -// (can be \code{NULL}). +// (can be \code{NULL}, which stores no parents). +// @param metadata raw vector with metadata bytes (can be \code{NULL}, which +// stores empty metadata). Metadata schemas are not interpreted or applied. // @details This function calls // \url{https://tskit.dev/tskit/docs/stable/c-api.html#c.tsk_individual_table_add_row} -// on the individuals table of \code{tc}. -// @return The row ID (0-based) of the newly added individual. +// on the individual table of \code{tc}. +// @return An integer row index and hence ID (0-based) of the newly added +// individual. // @examples // ts_file <- system.file("examples/test.trees", package = "RcppTskit") // tc_xptr <- RcppTskit:::rtsk_table_collection_load(ts_file) -// (n_before <- RcppTskit:::rtsk_table_collection_get_num_individuals(tc_xptr)) -// (m_before -// <- RcppTskit:::rtsk_table_collection_metadata_length(tc_xptr)$individuals) -// tc_py <- RcppTskit:::rtsk_table_collection_r_to_py(tc_xptr) -// tc_py$individuals$max_rows -// tc_py$individuals["flags"] -// tc_py$individuals["location"] -// tc_py$individuals["location_offset"] -// tc_py$individuals["parents"] -// tc_py$individuals["parents_offset"] -// tc_py$individuals["metadata"] -// tc_py$individuals["metadata_offset"] -// new_id <- RcppTskit:::rtsk_individual_table_add_row(tc = tc_xptr) -// new_id <- RcppTskit:::rtsk_individual_table_add_row(tc = tc_xptr, -// location = c(5, 8)) -// new_id <- RcppTskit:::rtsk_individual_table_add_row(tc = tc_xptr, flags = 0L, -// location = c(1, 2)) -// new_id <- RcppTskit:::rtsk_individual_table_add_row(tc = tc_xptr, flags = 1L, -// location = c(11, 3)) -// new_id <- RcppTskit:::rtsk_individual_table_add_row(tc = tc_xptr, flags = 2L, -// location = c(7, 8), parents = c(0L)) // new_id <- RcppTskit:::rtsk_individual_table_add_row(tc = tc_xptr, flags = 3L, // location = c(2, 11), parents = c(1L, 3L), metadata = charToRaw("abc")) -// (n_after <- RcppTskit:::rtsk_table_collection_get_num_individuals(tc_xptr)) -// (m_after <- -// RcppTskit:::rtsk_table_collection_metadata_length(tc_xptr)$individuals) -// new_id == n_after - 1L -// n_after == n_before + 6L -// m_after == m_before + 3L -// tc_py <- RcppTskit:::rtsk_table_collection_r_to_py(tc_xptr) -// tc_py$individuals$max_rows -// tc_py$individuals["flags"] -// tc_py$individuals["location"] -// tc_py$individuals["location_offset"] -// tc_py$individuals["parents"] -// tc_py$individuals["parents_offset"] -// tc_py$individuals["metadata"] -// tc_py$individuals["metadata_offset"] +// RcppTskit:::rtsk_individual_table_get_row(tc_xptr, new_id) // [[Rcpp::export]] int rtsk_individual_table_add_row( SEXP tc, int flags = 0, @@ -1332,58 +1794,88 @@ int rtsk_individual_table_add_row( return static_cast(row_id); } +// PUBLIC, wrapper for tsk_individual_table_get_row +// @title Get a row from the individual table in a table collection +// @param tc an external pointer to table collection as a +// \code{tsk_table_collection_t} object. +// @param index integer scalar individual ID (0-based). +// @details This function calls +// \url{https://tskit.dev/tskit/docs/stable/c-api.html#c.tsk_individual_table_get_row} +// on the individual table of \code{tc}. +// @return A named list with fields \code{id}, \code{flags}, \code{location}, +// \code{parents}, \code{metadata}, and \code{nodes}. +// The \code{nodes} field is \code{integer(0)} because node references are +// stored through individual IDs in the node table, not directly in the +// individual table. Therefore, \code{tsk_individual_table_get_row()} leaves +// this field empty; \code{tsk_treeseq_get_individual()} instead populates it +// from the node table. +// @examples +// ts_file <- system.file("examples/test.trees", package = "RcppTskit") +// tc_xptr <- RcppTskit:::rtsk_table_collection_load(ts_file) +// RcppTskit:::rtsk_individual_table_get_row(tc_xptr, 0L) +// [[Rcpp::export]] +Rcpp::List rtsk_individual_table_get_row(SEXP tc, int index) { + rtsk_table_collection_t tc_xptr(tc); + tsk_individual_t row; + const tsk_id_t index_tsk = static_cast(index); + const int ret = + tsk_individual_table_get_row(&tc_xptr->individuals, index_tsk, &row); + if (ret != 0) { + Rcpp::stop(tsk_strerror(ret)); + } + + Rcpp::NumericVector location(row.location_length); + for (tsk_size_t j = 0; j < row.location_length; ++j) { + location[j] = row.location[j]; + } + + Rcpp::IntegerVector parents(row.parents_length); + for (tsk_size_t j = 0; j < row.parents_length; ++j) { + parents[j] = static_cast(row.parents[j]); + } + + Rcpp::RawVector metadata(row.metadata_length); + for (tsk_size_t j = 0; j < row.metadata_length; ++j) { + metadata[j] = static_cast(row.metadata[j]); + } + + // tsk_individual_table_get_row() does not populate node references; those + // are available only from tsk_treeseq_get_individual(). + const Rcpp::IntegerVector nodes(0); + + return Rcpp::List::create( + Rcpp::_["id"] = static_cast(row.id), + Rcpp::_["flags"] = rtsk_wrap_tsk_flags_as_int( + row.flags, "rtsk_individual_table_get_row"), + Rcpp::_["location"] = location, Rcpp::_["parents"] = parents, + Rcpp::_["metadata"] = metadata, Rcpp::_["nodes"] = nodes); +} + // PUBLIC, wrapper for tsk_node_table_add_row // @title Add a row to the node table in a table collection // @param tc an external pointer to table collection as a // \code{tsk_table_collection_t} object. -// @param flags passed to \code{tskit C}. -// @param time numeric time value for the new node. -// @param population integer population row ID (0-based); +// @param flags integer scalar bitwise flags for the new node. Values from 0 +// through 2^31 - 1 are supported. +// @param time numeric birth time for the new node. +// @param population integer population ID (0-based); // use \code{-1} when unknown, which will map to \code{TSK_NULL}. -// @param individual integer individual row ID (0-based); +// @param individual integer individual ID (0-based); // use \code{-1} when unknown, which will map to \code{TSK_NULL}. -// @param metadata raw vector with metadata bytes -// (can be \code{NULL}). +// @param metadata raw vector with metadata bytes (can be \code{NULL}, which +// stores empty metadata). Metadata schemas are not interpreted or applied. // @details This function calls // \url{https://tskit.dev/tskit/docs/stable/c-api.html#c.tsk_node_table_add_row} -// on the nodes table of \code{tc}. -// @return The row ID (0-based) of the newly added node. +// on the node table of \code{tc}. +// @return An integer row index and hence ID (0-based) of the newly added node. // @examples // ts_file <- system.file("examples/test.trees", package = "RcppTskit") // tc_xptr <- RcppTskit:::rtsk_table_collection_load(ts_file) -// (n_before <- RcppTskit:::rtsk_table_collection_get_num_nodes(tc_xptr)) -// (m_before <- -// RcppTskit:::rtsk_table_collection_metadata_length(tc_xptr)$nodes) -// tc_py <- RcppTskit:::rtsk_table_collection_r_to_py(tc_xptr) -// tc_py$nodes$max_rows -// tc_py$nodes["flags"] -// tc_py$nodes["time"] -// tc_py$nodes["population"] -// tc_py$nodes["individual"] -// tc_py$nodes["metadata"] -// tc_py$nodes["metadata_offset"] -// new_id <- RcppTskit:::rtsk_node_table_add_row(tc = tc_xptr) -// new_id <- RcppTskit:::rtsk_node_table_add_row(tc = tc_xptr, time = 1.5) -// new_id <- RcppTskit:::rtsk_node_table_add_row( -// tc = tc_xptr, flags = 1L, time = 2.25, population = 0L -// ) // new_id <- RcppTskit:::rtsk_node_table_add_row( // tc = tc_xptr, flags = 1L, time = 3.5, individual = 0L, // metadata = charToRaw("abc") // ) -// (n_after <- RcppTskit:::rtsk_table_collection_get_num_nodes(tc_xptr)) -// (m_after <- RcppTskit:::rtsk_table_collection_metadata_length(tc_xptr)$nodes) -// new_id == n_after - 1L -// n_after == n_before + 4L -// m_after == m_before + 3L -// tc_py <- RcppTskit:::rtsk_table_collection_r_to_py(tc_xptr) -// tc_py$nodes$max_rows -// tc_py$nodes["flags"] -// tc_py$nodes["time"] -// tc_py$nodes["population"] -// tc_py$nodes["individual"] -// tc_py$nodes["metadata"] -// tc_py$nodes["metadata_offset"] +// RcppTskit:::rtsk_node_table_get_row(tc_xptr, new_id) // [[Rcpp::export]] int rtsk_node_table_add_row( SEXP tc, int flags = 0, double time = 0, int population = -1, @@ -1416,55 +1908,71 @@ int rtsk_node_table_add_row( return static_cast(row_id); } +// PUBLIC, wrapper for tsk_node_table_get_row +// @title Get a row from the node table in a table collection +// @param tc an external pointer to table collection as a +// \code{tsk_table_collection_t} object. +// @param index integer scalar node ID (0-based). +// @details This function calls +// \url{https://tskit.dev/tskit/docs/stable/c-api.html#c.tsk_node_table_get_row} +// on the node table of \code{tc}. +// @return A named list with fields \code{id}, \code{flags}, \code{time}, +// \code{population}, \code{individual}, and \code{metadata}. +// @examples +// ts_file <- system.file("examples/test.trees", package = "RcppTskit") +// tc_xptr <- RcppTskit:::rtsk_table_collection_load(ts_file) +// RcppTskit:::rtsk_node_table_get_row(tc_xptr, 0L) +// (last_node <- +// as.integer(RcppTskit:::rtsk_table_collection_get_num_nodes(tc_xptr)) - 1L) +// RcppTskit:::rtsk_node_table_get_row(tc_xptr, last_node) +// [[Rcpp::export]] +Rcpp::List rtsk_node_table_get_row(SEXP tc, int index) { + rtsk_table_collection_t tc_xptr(tc); + tsk_node_t row; + const tsk_id_t index_tsk = static_cast(index); + const int ret = tsk_node_table_get_row(&tc_xptr->nodes, index_tsk, &row); + if (ret != 0) { + Rcpp::stop(tsk_strerror(ret)); + } + + Rcpp::RawVector metadata(row.metadata_length); + for (tsk_size_t j = 0; j < row.metadata_length; ++j) { + metadata[j] = static_cast(row.metadata[j]); + } + + return Rcpp::List::create( + Rcpp::_["id"] = static_cast(row.id), + Rcpp::_["flags"] = + rtsk_wrap_tsk_flags_as_int(row.flags, "rtsk_node_table_get_row"), + Rcpp::_["time"] = row.time, + Rcpp::_["population"] = static_cast(row.population), + Rcpp::_["individual"] = static_cast(row.individual), + Rcpp::_["metadata"] = metadata); +} + // PUBLIC, wrapper for tsk_edge_table_add_row // @title Add a row to the edge table in a table collection // @param tc an external pointer to table collection as a // \code{tsk_table_collection_t} object. -// @param left numeric scalar left coordinate for the new edge. -// @param right numeric scalar right coordinate for the new edge. -// @param parent integer parent node row ID (0-based). -// @param child integer child node row ID (0-based). -// @param metadata raw vector with metadata bytes -// (can be \code{NULL}). +// @param left numeric scalar left coordinate (inclusive) for the new edge. +// @param right numeric scalar right coordinate (exclusive) for the new edge. +// @param parent integer parent node ID (0-based). +// @param child integer child node ID (0-based). +// @param metadata raw vector with metadata bytes (can be \code{NULL}, which +// stores empty metadata). Metadata schemas are not interpreted or applied. // @details This function calls // \url{https://tskit.dev/tskit/docs/stable/c-api.html#c.tsk_edge_table_add_row} -// on the edges table of \code{tc}. -// @return The row ID (0-based) of the newly added edge. +// on the edge table of \code{tc}. +// @return An integer row index and hence ID (0-based) of the newly added edge. // @examples // ts_file <- system.file("examples/test.trees", package = "RcppTskit") // tc_xptr <- RcppTskit:::rtsk_table_collection_load(ts_file) -// child <- rtsk_node_table_add_row(tc_xptr, time = 0.0) -// (n_before <- RcppTskit:::rtsk_table_collection_get_num_edges(tc_xptr)) -// (m_before <- -// RcppTskit:::rtsk_table_collection_metadata_length(tc_xptr)$edges) -// tc_py <- RcppTskit:::rtsk_table_collection_r_to_py(tc_xptr) -// tc_py$edges$max_rows -// tc_py$edges["left"] -// tc_py$edges["right"] -// tc_py$edges["parent"] -// tc_py$edges["child"] -// tc_py$edges["metadata"] -// tc_py$edges["metadata_offset"] -// new_id <-RcppTskit:::rtsk_edge_table_add_row( -// tc = tc_xptr, left = 0, right = 50, parent = 16L, child = child -// ) +// child <- RcppTskit:::rtsk_node_table_add_row(tc_xptr, time = 0.0) // new_id <- RcppTskit:::rtsk_edge_table_add_row( -// tc = tc_xptr, left = 50, right = 75, parent = 17L, child = child, +// tc = tc_xptr, left = 0, right = 50, parent = 16L, child = child, // metadata = charToRaw("cba") // ) -// (n_after <- RcppTskit:::rtsk_table_collection_get_num_edges(tc_xptr)) -// (m_after <- RcppTskit:::rtsk_table_collection_metadata_length(tc_xptr)$edges) -// new_id == n_after - 1L -// n_after == n_before + 2L -// m_after == m_before + 3L -// tc_py <- RcppTskit:::rtsk_table_collection_r_to_py(tc_xptr) -// tc_py$edges$max_rows -// tc_py$edges["left"] -// tc_py$edges["right"] -// tc_py$edges["parent"] -// tc_py$edges["child"] -// tc_py$edges["metadata"] -// tc_py$edges["metadata_offset"] +// RcppTskit:::rtsk_edge_table_get_row(tc_xptr, new_id) // [[Rcpp::export]] int rtsk_edge_table_add_row( SEXP tc, double left, double right, int parent, int child, @@ -1490,55 +1998,63 @@ int rtsk_edge_table_add_row( return static_cast(row_id); } +// PUBLIC, wrapper for tsk_edge_table_get_row +// @title Get a row from the edge table in a table collection +// @param tc an external pointer to table collection as a +// \code{tsk_table_collection_t} object. +// @param index integer scalar edge ID (0-based). +// @details This function calls +// \url{https://tskit.dev/tskit/docs/stable/c-api.html#c.tsk_edge_table_get_row} +// on the edge table of \code{tc}. +// @return A named list with fields \code{id}, \code{left}, \code{right}, +// \code{parent}, \code{child}, and \code{metadata}. +// @examples +// ts_file <- system.file("examples/test.trees", package = "RcppTskit") +// tc_xptr <- RcppTskit:::rtsk_table_collection_load(ts_file) +// RcppTskit:::rtsk_edge_table_get_row(tc_xptr, 0L) +// [[Rcpp::export]] +Rcpp::List rtsk_edge_table_get_row(SEXP tc, int index) { + rtsk_table_collection_t tc_xptr(tc); + tsk_edge_t row; + const tsk_id_t index_tsk = static_cast(index); + const int ret = tsk_edge_table_get_row(&tc_xptr->edges, index_tsk, &row); + if (ret != 0) { + Rcpp::stop(tsk_strerror(ret)); + } + + Rcpp::RawVector metadata(row.metadata_length); + for (tsk_size_t j = 0; j < row.metadata_length; ++j) { + metadata[j] = static_cast(row.metadata[j]); + } + + return Rcpp::List::create(Rcpp::_["id"] = static_cast(row.id), + Rcpp::_["left"] = row.left, + Rcpp::_["right"] = row.right, + Rcpp::_["parent"] = static_cast(row.parent), + Rcpp::_["child"] = static_cast(row.child), + Rcpp::_["metadata"] = metadata); +} + // PUBLIC, wrapper for tsk_site_table_add_row // @title Add a row to the site table in a table collection // @param tc an external pointer to table collection as a // \code{tsk_table_collection_t} object. // @param position numeric scalar site position. -// @param ancestral_state character string with ancestral-state. -// @param metadata raw vector with metadata bytes -// (can be \code{NULL}). +// @param ancestral_state character string with the ancestral state. +// @param metadata raw vector with metadata bytes (can be \code{NULL}, which +// stores empty metadata). Metadata schemas are not interpreted or applied. // @details This function calls // \url{https://tskit.dev/tskit/docs/stable/c-api.html#c.tsk_site_table_add_row} -// on the sites table of \code{tc}. -// @return The row ID (0-based) of the newly added site. +// on the site table of \code{tc}. +// @return An integer row index and hence ID (0-based) of the newly added site. // @examples // ts_file <- system.file("examples/test.trees", package = "RcppTskit") // tc_xptr <- RcppTskit:::rtsk_table_collection_load(ts_file) -// (n_before <- RcppTskit:::rtsk_table_collection_get_num_sites(tc_xptr)) -// (m_before <- -// RcppTskit:::rtsk_table_collection_metadata_length(tc_xptr)$sites) -// tc_py <- RcppTskit:::rtsk_table_collection_r_to_py(tc_xptr) -// tc_py$sites$max_rows -// tc_py$sites["position"] -// tc_py$sites["ancestral_state"] -// tc_py$sites["ancestral_state_offset"] -// tc_py$sites["metadata"] -// tc_py$sites["metadata_offset"] -// new_id <- RcppTskit:::rtsk_site_table_add_row( -// tc = tc_xptr, position = 0.5, ancestral_state = "A" -// ) // new_id <- RcppTskit:::rtsk_site_table_add_row( // tc = tc_xptr, position = 1.5, ancestral_state = "G", // metadata = charToRaw("abc") // ) -// (n_after <- RcppTskit:::rtsk_table_collection_get_num_sites(tc_xptr)) -// (m_after <- -// RcppTskit:::rtsk_table_collection_metadata_length(tc_xptr)$sites) -// new_id == n_after - 1L -// n_after == n_before + 2L -// m_after == m_before + 3L -// tc_py <- RcppTskit:::rtsk_table_collection_r_to_py(tc_xptr) -// tc_py$sites$max_rows -// tc_py$sites["position"] -// tc_py$sites["ancestral_state"] -// tc_py$sites["ancestral_state_offset"] -// tc_py$sites["metadata"] -// tc_py$sites["metadata_offset"] -// i <- length(tc_py$sites["ancestral_state_offset"]) - 1L -// start <- tc_py$sites["ancestral_state_offset"][i] + 1L -// end <- tc_py$sites["ancestral_state_offset"][i + 1L] -// rawToChar(as.raw(tc_py$sites["ancestral_state"][start:end])) +// RcppTskit:::rtsk_site_table_get_row(tc_xptr, new_id) // [[Rcpp::export]] int rtsk_site_table_add_row( SEXP tc, double position, const std::string &ancestral_state, @@ -1567,64 +2083,80 @@ int rtsk_site_table_add_row( return static_cast(row_id); } +// PUBLIC, wrapper for tsk_site_table_get_row +// @title Get a row from the site table in a table collection +// @param tc an external pointer to table collection as a +// \code{tsk_table_collection_t} object. +// @param index integer scalar site ID (0-based). +// @details This function calls +// \url{https://tskit.dev/tskit/docs/stable/c-api.html#c.tsk_site_table_get_row} +// on the site table of \code{tc}. +// @return A named list with fields \code{id}, \code{position}, +// \code{ancestral_state}, \code{metadata}, and \code{mutations}. +// The \code{mutations} field is \code{NULL} because mutation references are +// stored through site IDs in the mutation table, not directly in the site +// table. Therefore, \code{tsk_site_table_get_row()} leaves this field empty; +// \code{tsk_treeseq_get_site()} instead populates it from the mutation table. +// @examples +// ts_file <- system.file("examples/test.trees", package = "RcppTskit") +// tc_xptr <- RcppTskit:::rtsk_table_collection_load(ts_file) +// RcppTskit:::rtsk_site_table_get_row(tc_xptr, 0L) +// [[Rcpp::export]] +Rcpp::List rtsk_site_table_get_row(SEXP tc, int index) { + rtsk_table_collection_t tc_xptr(tc); + tsk_site_t row; + const tsk_id_t index_tsk = static_cast(index); + const int ret = tsk_site_table_get_row(&tc_xptr->sites, index_tsk, &row); + if (ret != 0) { + Rcpp::stop(tsk_strerror(ret)); + } + + const Rcpp::String ancestral_state = + row.ancestral_state_length > 0 + ? Rcpp::String( + std::string(row.ancestral_state, row.ancestral_state_length)) + : Rcpp::String(""); + + Rcpp::RawVector metadata(row.metadata_length); + for (tsk_size_t j = 0; j < row.metadata_length; ++j) { + metadata[j] = static_cast(row.metadata[j]); + } + + return Rcpp::List::create(Rcpp::_["id"] = static_cast(row.id), + Rcpp::_["position"] = row.position, + Rcpp::_["ancestral_state"] = ancestral_state, + Rcpp::_["metadata"] = metadata, + Rcpp::_["mutations"] = R_NilValue); +} + // PUBLIC, wrapper for tsk_mutation_table_add_row // @title Add a row to the mutation table in a table collection // @param tc an external pointer to table collection as a // \code{tsk_table_collection_t} object. -// @param site integer site row ID (0-based). -// @param node integer node row ID (0-based). -// @param parent integer parent mutation row ID (0-based); +// @param site integer site ID (0-based). +// @param node integer node ID (0-based). +// @param parent integer parent mutation ID (0-based); // use \code{-1} when unknown, which will map to \code{TSK_NULL}. // @param time numeric mutation time value; -// use \code{nan} when unknown, which will map to \code{TSK_UNKNOWN_TIME}. -// @param derived_state character string with derived-state. -// @param metadata raw vector with metadata bytes -// (can be \code{NULL}). +// use \code{NaN} when unknown, which will map to \code{TSK_UNKNOWN_TIME}. +// @param derived_state character string with the derived state. +// @param metadata raw vector with metadata bytes (can be \code{NULL}, which +// stores empty metadata). Metadata schemas are not interpreted or applied. // @details This function calls // \url{https://tskit.dev/tskit/docs/stable/c-api.html#c.tsk_mutation_table_add_row} -// on the mutations table of \code{tc}. -// @return The row ID (0-based) of the newly added mutation. +// on the mutation table of \code{tc}. +// @return An integer row index and hence ID (0-based) of the newly added +// mutation. // @examples // ts_file <- system.file("examples/test.trees", package = "RcppTskit") // tc_xptr <- RcppTskit:::rtsk_table_collection_load(ts_file) -// (n_before <- RcppTskit:::rtsk_table_collection_get_num_mutations(tc_xptr)) -// (m_before <- -// RcppTskit:::rtsk_table_collection_metadata_length(tc_xptr)$mutations) -// tc_py <- RcppTskit:::rtsk_table_collection_r_to_py(tc_xptr) -// tc_py$mutations$max_rows -// tc_py$mutations["site"] -// tc_py$mutations["node"] -// tc_py$mutations["time"] -// tc_py$mutations["derived_state"] -// tc_py$mutations["derived_state_offset"] -// tc_py$mutations["parent"] -// tc_py$mutations["metadata"] -// tc_py$mutations["metadata_offset"] -// # From inspection of tc we have: -// # node13(time=0) <- node16(time=0.02...) <- node20(time=0.08...) -// # Add mutation above 16L // m0 <- RcppTskit:::rtsk_mutation_table_add_row(tc = tc_xptr, site = 0L, // node = 16L, parent = -1, derived_state = "T", time = 0.03) +// RcppTskit:::rtsk_mutation_table_get_row(tc_xptr, m0) // m1 <- RcppTskit:::rtsk_mutation_table_add_row(tc = tc_xptr, site = 0L, -// node = 13L, parent = m0, time = 0.01, derived_state = "C", +// node = 13L, parent = m0, time = NaN, derived_state = "C", // metadata = charToRaw("abc")) -// (n_after <- RcppTskit:::rtsk_table_collection_get_num_mutations(tc_xptr)) -// (m_after <- -// RcppTskit:::rtsk_table_collection_metadata_length(tc_xptr)$mutations) -// m1 == n_after - 1L -// n_after == n_before + 2L -// m_after == m_before + 3L -// tc_py <- RcppTskit:::rtsk_table_collection_r_to_py(tc_xptr) -// tc_py$mutations$max_rows -// tc_py$mutations["site"] -// tc_py$mutations["node"] -// tc_py$mutations["time"] -// tc_py$mutations["derived_state"] -// tc_py$mutations["derived_state_offset"] -// tc_py$mutations["parent"] -// tc_py$mutations[tc_py$mutations["parent"][tc_py$mutations$max_rows]] -// tc_py$mutations["metadata"] -// tc_py$mutations["metadata_offset"] +// RcppTskit:::rtsk_mutation_table_get_row(tc_xptr, m1) // [[Rcpp::export]] int rtsk_mutation_table_add_row( SEXP tc, int site, int node, int parent, double time, @@ -1658,3 +2190,312 @@ int rtsk_mutation_table_add_row( } return static_cast(row_id); } + +// PUBLIC, wrapper for tsk_mutation_table_get_row +// @title Get a row from the mutation table in a table collection +// @param tc an external pointer to table collection as a +// \code{tsk_table_collection_t} object. +// @param index integer scalar mutation ID (0-based). +// @details This function calls +// \url{https://tskit.dev/tskit/docs/stable/c-api.html#c.tsk_mutation_table_get_row} +// on the mutation table of \code{tc}. +// @return A named list with fields \code{id}, \code{site}, \code{node}, +// \code{parent}, \code{time}, \code{derived_state}, \code{metadata}, +// \code{edge}, and \code{inherited_state}. The \code{edge} and +// \code{inherited_state} values are not stored in the mutation table, so +// table access returns \code{-1} and \code{NULL}, respectively; +// \code{tsk_treeseq_get_mutation()} instead populates them from the tree +// sequence. +// @examples +// ts_file <- system.file("examples/test.trees", package = "RcppTskit") +// tc_xptr <- RcppTskit:::rtsk_table_collection_load(ts_file) +// RcppTskit:::rtsk_mutation_table_get_row(tc_xptr, 0L) +// [[Rcpp::export]] +Rcpp::List rtsk_mutation_table_get_row(SEXP tc, int index) { + rtsk_table_collection_t tc_xptr(tc); + tsk_mutation_t row; + const tsk_id_t index_tsk = static_cast(index); + const int ret = + tsk_mutation_table_get_row(&tc_xptr->mutations, index_tsk, &row); + if (ret != 0) { + Rcpp::stop(tsk_strerror(ret)); + } + + const Rcpp::String derived_state = + row.derived_state_length > 0 + ? Rcpp::String( + std::string(row.derived_state, row.derived_state_length)) + : Rcpp::String(""); + + Rcpp::RawVector metadata(row.metadata_length); + for (tsk_size_t j = 0; j < row.metadata_length; ++j) { + metadata[j] = static_cast(row.metadata[j]); + } + + return Rcpp::List::create(Rcpp::_["id"] = static_cast(row.id), + Rcpp::_["site"] = static_cast(row.site), + Rcpp::_["node"] = static_cast(row.node), + Rcpp::_["parent"] = static_cast(row.parent), + Rcpp::_["time"] = row.time, + Rcpp::_["derived_state"] = derived_state, + Rcpp::_["metadata"] = metadata, + Rcpp::_["edge"] = static_cast(row.edge), + Rcpp::_["inherited_state"] = R_NilValue); +} + +// PUBLIC, wrapper for tsk_population_table_add_row +// @title Add a row to the population table in a table collection +// @param tc an external pointer to table collection as a +// \code{tsk_table_collection_t} object. +// @param metadata raw vector with metadata bytes (can be \code{NULL}, which +// stores empty metadata). Metadata schemas are not interpreted or applied. +// @details This function calls +// \url{https://tskit.dev/tskit/docs/stable/c-api.html#c.tsk_population_table_add_row} +// on the population table of \code{tc}. +// @return An integer row index and hence ID (0-based) of the newly added +// population. +// @examples +// ts_file <- system.file("examples/test.trees", package = "RcppTskit") +// tc_xptr <- RcppTskit:::rtsk_table_collection_load(ts_file) +// new_id <- RcppTskit:::rtsk_population_table_add_row( +// tc = tc_xptr, metadata = charToRaw("abc") +// ) +// RcppTskit:::rtsk_population_table_get_row(tc_xptr, new_id) +// [[Rcpp::export]] +int rtsk_population_table_add_row( + SEXP tc, Rcpp::Nullable metadata = R_NilValue) { + rtsk_table_collection_t tc_xptr(tc); + + const Rcpp::RawVector metadata_vec = + nullable_to_vector_or_empty(metadata); + const tsk_size_t metadata_length = + static_cast(metadata_vec.size()); + const char *metadata_ptr = + metadata_length > 0 ? reinterpret_cast(RAW(metadata_vec)) + : nullptr; + + const tsk_id_t row_id = tsk_population_table_add_row( + &tc_xptr->populations, metadata_ptr, metadata_length); + if (row_id < 0) { + Rcpp::stop(tsk_strerror(row_id)); + } + return static_cast(row_id); +} + +// PUBLIC, wrapper for tsk_population_table_get_row +// @title Get a row from the population table in a table collection +// @param tc an external pointer to table collection as a +// \code{tsk_table_collection_t} object. +// @param index integer scalar population ID (0-based). +// @details This function calls +// \url{https://tskit.dev/tskit/docs/stable/c-api.html#c.tsk_population_table_get_row} +// on the population table of \code{tc}. +// @return A named list with fields \code{id} and \code{metadata}. +// @examples +// ts_file <- system.file("examples/test.trees", package = "RcppTskit") +// tc_xptr <- RcppTskit:::rtsk_table_collection_load(ts_file) +// RcppTskit:::rtsk_population_table_get_row(tc_xptr, 0L) +// [[Rcpp::export]] +Rcpp::List rtsk_population_table_get_row(SEXP tc, int index) { + rtsk_table_collection_t tc_xptr(tc); + tsk_population_t row; + const tsk_id_t index_tsk = static_cast(index); + const int ret = + tsk_population_table_get_row(&tc_xptr->populations, index_tsk, &row); + if (ret != 0) { + Rcpp::stop(tsk_strerror(ret)); + } + + Rcpp::RawVector metadata(row.metadata_length); + for (tsk_size_t j = 0; j < row.metadata_length; ++j) { + metadata[j] = static_cast(row.metadata[j]); + } + + return Rcpp::List::create(Rcpp::_["id"] = static_cast(row.id), + Rcpp::_["metadata"] = metadata); +} + +// PUBLIC, wrapper for tsk_migration_table_add_row +// @title Add a row to the migration table in a table collection +// @param tc an external pointer to table collection as a +// \code{tsk_table_collection_t} object. +// @param left numeric scalar left coordinate (inclusive) for the new +// migration. +// @param right numeric scalar right coordinate (exclusive) for the new +// migration. +// @param node integer node ID (0-based). +// @param source integer source population ID (0-based). +// @param dest integer destination population ID (0-based). +// @param time numeric scalar time for the migration. +// @param metadata raw vector with metadata bytes. \code{NULL} stores empty +// metadata. Metadata schemas are not interpreted or applied. +// @details This function calls +// \url{https://tskit.dev/tskit/docs/stable/c-api.html#c.tsk_migration_table_add_row} +// on the migration table of \code{tc}. +// @return An integer row index and hence ID (0-based) of the newly added +// migration. +// @examples +// ts_file <- system.file("examples/test.trees", package = "RcppTskit") +// tc_xptr <- RcppTskit:::rtsk_table_collection_load(ts_file) +// new_population <- RcppTskit:::rtsk_population_table_add_row( +// tc = tc_xptr, metadata = charToRaw("new-population") +// ) +// migrating_node <- RcppTskit:::rtsk_node_table_add_row( +// tc = tc_xptr, time = 0.5, population = new_population +// ) +// new_id <- RcppTskit:::rtsk_migration_table_add_row( +// tc = tc_xptr, left = 0, right = 1, node = migrating_node, +// source = 0L, dest = new_population, time = 1.0, +// metadata = charToRaw("abc") +// ) +// RcppTskit:::rtsk_migration_table_get_row(tc_xptr, new_id) +// [[Rcpp::export]] +int rtsk_migration_table_add_row( + SEXP tc, double left, double right, int node, int source, int dest, + double time, Rcpp::Nullable metadata = R_NilValue) { + const tsk_id_t row_node = static_cast(node); + const tsk_id_t row_source = static_cast(source); + const tsk_id_t row_dest = static_cast(dest); + rtsk_table_collection_t tc_xptr(tc); + + const Rcpp::RawVector metadata_vec = + nullable_to_vector_or_empty(metadata); + const tsk_size_t metadata_length = + static_cast(metadata_vec.size()); + const char *metadata_ptr = + metadata_length > 0 ? reinterpret_cast(RAW(metadata_vec)) + : nullptr; + + const tsk_id_t row_id = tsk_migration_table_add_row( + &tc_xptr->migrations, left, right, row_node, row_source, row_dest, time, + metadata_ptr, metadata_length); + if (row_id < 0) { + Rcpp::stop(tsk_strerror(row_id)); + } + return static_cast(row_id); +} + +// PUBLIC, wrapper for tsk_migration_table_get_row +// @title Get a row from the migration table in a table collection +// @param tc an external pointer to table collection as a +// \code{tsk_table_collection_t} object. +// @param index integer scalar migration ID (0-based). +// @details This function calls +// \url{https://tskit.dev/tskit/docs/stable/c-api.html#c.tsk_migration_table_get_row} +// on the migration table of \code{tc}. +// @return A named list with fields \code{id}, \code{left}, \code{right}, +// \code{node}, \code{source}, \code{dest}, \code{time}, and \code{metadata}. +// @examples +// ts_file <- system.file("examples/test.trees", package = "RcppTskit") +// tc_xptr <- RcppTskit:::rtsk_table_collection_load(ts_file) +// migration_id <- RcppTskit:::rtsk_migration_table_add_row( +// tc = tc_xptr, left = 0, right = 1, node = 0L, source = 0L, dest = 0L, +// time = 1 +// ) +// RcppTskit:::rtsk_migration_table_get_row(tc_xptr, migration_id) +// [[Rcpp::export]] +Rcpp::List rtsk_migration_table_get_row(SEXP tc, int index) { + rtsk_table_collection_t tc_xptr(tc); + tsk_migration_t row; + const tsk_id_t index_tsk = static_cast(index); + const int ret = + tsk_migration_table_get_row(&tc_xptr->migrations, index_tsk, &row); + if (ret != 0) { + Rcpp::stop(tsk_strerror(ret)); + } + + Rcpp::RawVector metadata(row.metadata_length); + for (tsk_size_t j = 0; j < row.metadata_length; ++j) { + metadata[j] = static_cast(row.metadata[j]); + } + + return Rcpp::List::create( + Rcpp::_["id"] = static_cast(row.id), Rcpp::_["left"] = row.left, + Rcpp::_["right"] = row.right, + Rcpp::_["node"] = static_cast(row.node), + Rcpp::_["source"] = static_cast(row.source), + Rcpp::_["dest"] = static_cast(row.dest), Rcpp::_["time"] = row.time, + Rcpp::_["metadata"] = metadata); +} + +// PUBLIC, wrapper for tsk_provenance_table_add_row +// @title Add a row to the provenance table in a table collection +// @param tc an external pointer to table collection as a +// \code{tsk_table_collection_t} object. +// @param timestamp character string timestamp for the new provenance. +// @param record character string record for the new provenance. +// @details This function calls +// \url{https://tskit.dev/tskit/docs/stable/c-api.html#c.tsk_provenance_table_add_row} +// on the provenance table of \code{tc}. +// @return An integer row index and hence ID (0-based) of the newly added +// provenance. +// @examples +// ts_file <- system.file("examples/test.trees", package = "RcppTskit") +// tc_xptr <- RcppTskit:::rtsk_table_collection_load(ts_file) +// new_id <- RcppTskit:::rtsk_provenance_table_add_row( +// tc = tc_xptr, +// timestamp = "2025-01-01T00:00:00Z", +// record = "{\"software\":\"RcppTskit\"}" +// ) +// RcppTskit:::rtsk_provenance_table_get_row(tc_xptr, new_id) +// [[Rcpp::export]] +int rtsk_provenance_table_add_row(SEXP tc, const std::string ×tamp, + const std::string &record) { + rtsk_table_collection_t tc_xptr(tc); + const tsk_size_t timestamp_length = static_cast(timestamp.size()); + const char *timestamp_ptr = + timestamp_length > 0 ? timestamp.c_str() : nullptr; + const tsk_size_t record_length = static_cast(record.size()); + const char *record_ptr = record_length > 0 ? record.c_str() : nullptr; + + const tsk_id_t row_id = + tsk_provenance_table_add_row(&tc_xptr->provenances, timestamp_ptr, + timestamp_length, record_ptr, record_length); + if (row_id < 0) { + Rcpp::stop(tsk_strerror(row_id)); + } + return static_cast(row_id); +} + +// PUBLIC, wrapper for tsk_provenance_table_get_row +// @title Get a row from the provenance table in a table collection +// @param tc an external pointer to table collection as a +// \code{tsk_table_collection_t} object. +// @param index integer scalar provenance ID (0-based). +// @details This function calls +// \url{https://tskit.dev/tskit/docs/stable/c-api.html#c.tsk_provenance_table_get_row} +// on the provenance table of \code{tc}. +// @return A named list with fields \code{id}, \code{timestamp}, and +// \code{record}. +// @examples +// ts_file <- system.file("examples/test.trees", package = "RcppTskit") +// tc_xptr <- RcppTskit:::rtsk_table_collection_load(ts_file) +// id <- RcppTskit:::rtsk_provenance_table_add_row( +// tc_xptr, "2025-01-01T00:00:00Z", "{}" +// ) +// RcppTskit:::rtsk_provenance_table_get_row(tc_xptr, id) +// [[Rcpp::export]] +Rcpp::List rtsk_provenance_table_get_row(SEXP tc, int index) { + rtsk_table_collection_t tc_xptr(tc); + tsk_provenance_t row; + const tsk_id_t index_tsk = static_cast(index); + const int ret = + tsk_provenance_table_get_row(&tc_xptr->provenances, index_tsk, &row); + if (ret != 0) { + Rcpp::stop(tsk_strerror(ret)); + } + + const Rcpp::String timestamp = + row.timestamp_length > 0 + ? Rcpp::String(std::string(row.timestamp, row.timestamp_length)) + : Rcpp::String(""); + + const Rcpp::String record = + row.record_length > 0 + ? Rcpp::String(std::string(row.record, row.record_length)) + : Rcpp::String(""); + + return Rcpp::List::create(Rcpp::_["id"] = static_cast(row.id), + Rcpp::_["timestamp"] = timestamp, + Rcpp::_["record"] = record); +} diff --git a/RcppTskit/src/tests.cpp b/RcppTskit/src/tests.cpp index ab93240..c769400 100644 --- a/RcppTskit/src/tests.cpp +++ b/RcppTskit/src/tests.cpp @@ -107,7 +107,7 @@ SEXP test_rtsk_treeseq_init_forced_error(SEXP tc) { void test_rtsk_table_collection_build_index_forced_error(SEXP tc) { rtsk_table_collection_t tc_xptr(tc); tsk_edge_table_t &edges = tc_xptr->edges; - tsk_id_t saved_parent = edges.parent[0]; + const tsk_id_t saved_parent = edges.parent[0]; edges.parent[0] = (tsk_id_t)tc_xptr->nodes.num_rows; try { rtsk_table_collection_build_index(tc, 0); @@ -131,8 +131,8 @@ void test_rtsk_table_collection_build_index_forced_error(SEXP tc) { void test_rtsk_individual_table_add_row_forced_error(SEXP tc) { rtsk_table_collection_t tc_xptr(tc); tsk_individual_table_t &individuals = tc_xptr->individuals; - tsk_size_t saved_max_rows = individuals.max_rows; - tsk_size_t saved_max_rows_increment = individuals.max_rows_increment; + const tsk_size_t saved_max_rows = individuals.max_rows; + const tsk_size_t saved_max_rows_increment = individuals.max_rows_increment; individuals.max_rows = 1; individuals.max_rows_increment = static_cast(TSK_MAX_ID) + 1; try { @@ -159,8 +159,8 @@ void test_rtsk_individual_table_add_row_forced_error(SEXP tc) { void test_rtsk_node_table_add_row_forced_error(SEXP tc) { rtsk_table_collection_t tc_xptr(tc); tsk_node_table_t &nodes = tc_xptr->nodes; - tsk_size_t saved_max_rows = nodes.max_rows; - tsk_size_t saved_max_rows_increment = nodes.max_rows_increment; + const tsk_size_t saved_max_rows = nodes.max_rows; + const tsk_size_t saved_max_rows_increment = nodes.max_rows_increment; nodes.max_rows = 1; nodes.max_rows_increment = static_cast(TSK_MAX_ID) + 1; try { @@ -187,8 +187,8 @@ void test_rtsk_node_table_add_row_forced_error(SEXP tc) { void test_rtsk_edge_table_add_row_forced_error(SEXP tc) { rtsk_table_collection_t tc_xptr(tc); tsk_edge_table_t &edges = tc_xptr->edges; - tsk_size_t saved_max_rows = edges.max_rows; - tsk_size_t saved_max_rows_increment = edges.max_rows_increment; + const tsk_size_t saved_max_rows = edges.max_rows; + const tsk_size_t saved_max_rows_increment = edges.max_rows_increment; edges.max_rows = 1; edges.max_rows_increment = static_cast(TSK_MAX_ID) + 1; try { @@ -216,8 +216,8 @@ void test_rtsk_edge_table_add_row_forced_error(SEXP tc) { void test_rtsk_site_table_add_row_forced_error(SEXP tc) { rtsk_table_collection_t tc_xptr(tc); tsk_site_table_t &sites = tc_xptr->sites; - tsk_size_t saved_max_rows = sites.max_rows; - tsk_size_t saved_max_rows_increment = sites.max_rows_increment; + const tsk_size_t saved_max_rows = sites.max_rows; + const tsk_size_t saved_max_rows_increment = sites.max_rows_increment; sites.max_rows = 1; sites.max_rows_increment = static_cast(TSK_MAX_ID) + 1; const std::string ancestral_state = "A"; @@ -245,8 +245,8 @@ void test_rtsk_site_table_add_row_forced_error(SEXP tc) { void test_rtsk_mutation_table_add_row_forced_error(SEXP tc) { rtsk_table_collection_t tc_xptr(tc); tsk_mutation_table_t &mutations = tc_xptr->mutations; - tsk_size_t saved_max_rows = mutations.max_rows; - tsk_size_t saved_max_rows_increment = mutations.max_rows_increment; + const tsk_size_t saved_max_rows = mutations.max_rows; + const tsk_size_t saved_max_rows_increment = mutations.max_rows_increment; mutations.max_rows = 1; mutations.max_rows_increment = static_cast(TSK_MAX_ID) + 1; const tsk_id_t site = @@ -270,3 +270,89 @@ void test_rtsk_mutation_table_add_row_forced_error(SEXP tc) { throw; } } + +// TEST-ONLY +// @title Force tskit-level error path in \\code{rtsk_population_table_add_row} +// @param tc an external pointer to table collection as a +// \code{tsk_table_collection_t} object. +// @return No return value; called for side effects - testing. +// [[Rcpp::export]] +void test_rtsk_population_table_add_row_forced_error(SEXP tc) { + rtsk_table_collection_t tc_xptr(tc); + tsk_population_table_t &populations = tc_xptr->populations; + const tsk_size_t saved_max_rows = populations.max_rows; + const tsk_size_t saved_max_rows_increment = populations.max_rows_increment; + populations.max_rows = 1; + populations.max_rows_increment = static_cast(TSK_MAX_ID) + 1; + try { + (void)rtsk_population_table_add_row(tc, R_NilValue); + // Lines below not hit by tests because rtsk_population_table_add_row() + // throws error # nocov start + populations.max_rows = saved_max_rows; + populations.max_rows_increment = saved_max_rows_increment; + return; + // # nocov end + } catch (...) { + populations.max_rows = saved_max_rows; + populations.max_rows_increment = saved_max_rows_increment; + throw; + } +} + +// TEST-ONLY +// @title Force tskit-level error path in \\code{rtsk_migration_table_add_row} +// @param tc an external pointer to table collection as a +// \code{tsk_table_collection_t} object. +// @return No return value; called for side effects - testing. +// [[Rcpp::export]] +void test_rtsk_migration_table_add_row_forced_error(SEXP tc) { + rtsk_table_collection_t tc_xptr(tc); + tsk_migration_table_t &migrations = tc_xptr->migrations; + const tsk_size_t saved_max_rows = migrations.max_rows; + const tsk_size_t saved_max_rows_increment = migrations.max_rows_increment; + migrations.max_rows = 1; + migrations.max_rows_increment = static_cast(TSK_MAX_ID) + 1; + try { + (void)rtsk_migration_table_add_row(tc, 0.0, 1.0, 0, 0, 0, 1.0, R_NilValue); + // Lines below not hit by tests because rtsk_migration_table_add_row() + // throws error # nocov start + migrations.max_rows = saved_max_rows; + migrations.max_rows_increment = saved_max_rows_increment; + return; + // # nocov end + } catch (...) { + migrations.max_rows = saved_max_rows; + migrations.max_rows_increment = saved_max_rows_increment; + throw; + } +} + +// TEST-ONLY +// @title Force tskit-level error path in \\code{rtsk_provenance_table_add_row} +// @param tc an external pointer to table collection as a +// \code{tsk_table_collection_t} object. +// @return No return value; called for side effects - testing. +// [[Rcpp::export]] +void test_rtsk_provenance_table_add_row_forced_error(SEXP tc) { + rtsk_table_collection_t tc_xptr(tc); + tsk_provenance_table_t &provenances = tc_xptr->provenances; + const tsk_size_t saved_max_rows = provenances.max_rows; + const tsk_size_t saved_max_rows_increment = provenances.max_rows_increment; + provenances.max_rows = 1; + provenances.max_rows_increment = static_cast(TSK_MAX_ID) + 1; + const std::string timestamp = "2025-01-01T00:00:00Z"; + const std::string record = "{\"software\":\"RcppTskit\"}"; + try { + (void)rtsk_provenance_table_add_row(tc, timestamp, record); + // Lines below not hit by tests because rtsk_provenance_table_add_row() + // throws error # nocov start + provenances.max_rows = saved_max_rows; + provenances.max_rows_increment = saved_max_rows_increment; + return; + // # nocov end + } catch (...) { + provenances.max_rows = saved_max_rows; + provenances.max_rows_increment = saved_max_rows_increment; + throw; + } +} diff --git a/RcppTskit/src/tskit/VERSION_kastore.txt b/RcppTskit/src/tskit/VERSION_kastore.txt index eca07e4..ac2cdeb 100644 --- a/RcppTskit/src/tskit/VERSION_kastore.txt +++ b/RcppTskit/src/tskit/VERSION_kastore.txt @@ -1 +1 @@ -2.1.2 +2.1.3 diff --git a/RcppTskit/src/tskit/kastore.c b/RcppTskit/src/tskit/kastore.c index 1f7143b..5305c10 100644 --- a/RcppTskit/src/tskit/kastore.c +++ b/RcppTskit/src/tskit/kastore.c @@ -4,6 +4,7 @@ #include #include #include +#include #include "kastore.h" @@ -292,12 +293,21 @@ kastore_read_descriptors(kastore_t *self) goto out; } self->items[j].type = (int) type; - if (key_start + key_len > self->file_size) { + if (key_len == 0) { + /* Keys must be non-empty, matching the write-side invariant. */ + goto out; + } + /* The bounds checks below are written using subtraction and division so + * that they cannot themselves overflow on these attacker-controlled + * 64-bit values (e.g. key_start + key_len or array_len * type_size + * wrapping around past file_size). */ + if (key_start > self->file_size || key_len > self->file_size - key_start) { goto out; } self->items[j].key_start = (size_t) key_start; self->items[j].key_len = (size_t) key_len; - if (array_start + array_len * type_size(type) > self->file_size) { + if (array_start > self->file_size + || array_len > (self->file_size - array_start) / type_size(type)) { goto out; } self->items[j].array_start = (size_t) array_start; @@ -387,11 +397,11 @@ kastore_read_file(kastore_t *self) offset = KAS_HEADER_SIZE + self->num_items * KAS_ITEM_DESCRIPTOR_SIZE; - /* Read in up to the start of first array. This will contain all the keys. */ - size = self->items[0].array_start; - - assert(size > offset); - size -= offset; + /* Read in up to the start of first array. This will contain all the keys. + * kastore_read_descriptors rejects zero-length keys and validates the key + * and array packing, so items[0].array_start is always strictly greater + * than offset and the subtraction below cannot underflow. */ + size = self->items[0].array_start - offset; self->key_read_buffer = (char *) malloc(size); if (self->key_read_buffer == NULL) { @@ -445,6 +455,12 @@ kastore_read_item(kastore_t *self, kaitem_t *item) goto out; } if (size > 0) { + /* array_start is a size_t but fseek takes a long, which is only 32 bits + * on LLP64 platforms (e.g. 64-bit Windows). Guard against truncation. */ + if (item->array_start > (size_t) (LONG_MAX - self->file_offset)) { + ret = KAS_ERR_IO; + goto out; + } err = fseek(self->file, self->file_offset + (long) item->array_start, SEEK_SET); if (err != 0) { ret = KAS_ERR_IO; diff --git a/RcppTskit/tests/testthat/test_TableCollection.R b/RcppTskit/tests/testthat/test_TableCollection.R index 4e811b8..e8524c1 100644 --- a/RcppTskit/tests/testthat/test_TableCollection.R +++ b/RcppTskit/tests/testthat/test_TableCollection.R @@ -277,6 +277,480 @@ test_that("TableCollection index lifecycle and tree_sequence index handling work expect_true(tc$has_index()) }) +test_that("TableCollection$sort validates inputs and sorts a non-sorted example", { + ts_file <- system.file("examples/test.trees", package = "RcppTskit") + tc_xptr <- rtsk_table_collection_load(ts_file) + tc <- TableCollection$new(xptr = tc_xptr) + + expect_error( + rtsk_table_collection_sort(tc_xptr, start_edges = -1L), + regexp = "start offsets must be non-negative" + ) + expect_error( + rtsk_table_collection_sort(tc_xptr, start_sites = -1L), + regexp = "start offsets must be non-negative" + ) + expect_error( + rtsk_table_collection_sort(tc_xptr, start_mutations = -1L), + regexp = "start offsets must be non-negative" + ) + expect_error( + rtsk_table_collection_sort(tc_xptr, options = -1L), + regexp = "does not support negative options" + ) + expect_error( + rtsk_table_collection_sort(tc_xptr, options = 1L), + regexp = "only supports options" + ) + + expect_error( + tc$sort(edge_start = NA_integer_), + regexp = "edge_start must be a non-NA, non-negative integer scalar no greater than [.]Machine[$]integer[.]max!" + ) + expect_error( + tc$sort(edge_start = -1L), + regexp = "edge_start must be a non-NA, non-negative integer scalar no greater than [.]Machine[$]integer[.]max!" + ) + expect_error( + tc$sort(site_start = NA_integer_), + regexp = "site_start must be a non-NA, non-negative integer scalar no greater than [.]Machine[$]integer[.]max!" + ) + expect_error( + tc$sort(mutation_start = NA_integer_), + regexp = "mutation_start must be a non-NA, non-negative integer scalar no greater than [.]Machine[$]integer[.]max!" + ) + expect_error( + tc$sort(edge_start = 0.5), + regexp = "edge_start must be a non-NA, non-negative integer scalar no greater than [.]Machine[$]integer[.]max!" + ) + expect_error( + tc$sort(site_start = 1L), + regexp = "Sort offset not supported|site_start and mutation_start must be 0|TSK_ERR_SORT_OFFSET_NOT_SUPPORTED" + ) + expect_error( + tc$sort(edge_start = as.integer(tc$num_edges()) + 1L), + regexp = "Edge out of bounds|TSK_ERR_EDGE_OUT_OF_BOUNDS" + ) + expect_invisible(tc$sort()) + expect_no_error(tc$sort( + edge_start = 0, + site_start = 0, + mutation_start = 0 + )) + expect_no_error(tc$sort( + edge_start = as.integer(tc$num_edges()), + site_start = as.integer(tc$num_sites()), + mutation_start = as.integer(tc$num_mutations()) + )) + + tc$build_index() + expect_true(tc$has_index()) + tc$sort() + expect_false(tc$has_index()) + expect_no_error(tc$sort( + edge_start = 0L, + site_start = 0L, + mutation_start = 0L + )) + + unsorted_file <- system.file( + "examples/test_unsorted.trees", + package = "RcppTskit" + ) + tc_unsorted <- tc_load(unsorted_file) + n_sites <- as.integer(tc_unsorted$num_sites()) + expect_true(n_sites >= 2L) + + last_pos <- tc_unsorted$site_table_get_row(n_sites - 1L)$position + prev_pos <- tc_unsorted$site_table_get_row(n_sites - 2L)$position + expect_lt(last_pos, prev_pos) + + expect_error( + tc_unsorted$tree_sequence(), + regexp = "TSK_ERR_UNSORTED_SITES|strictly increasing" + ) + + expect_no_error(tc_unsorted$sort()) + + site_positions <- vapply( + seq.int(0L, n_sites - 1L), + function(i) { + tc_unsorted$site_table_get_row(i)$position + }, + numeric(1) + ) + expect_true(all(diff(site_positions) > 0)) + + expect_no_error(tc_unsorted$tree_sequence()) + ts_sorted <- tc_unsorted$tree_sequence() + expect_true(is(ts_sorted, "TreeSequence")) +}) + +test_that("TableCollection$sort forwards edge_start and sorts the edge suffix", { + ts_file <- system.file("examples/test.trees", package = "RcppTskit") + tc <- tc_load(ts_file) + edge_start <- as.integer(tc$num_edges()) + prefix_before <- lapply( + seq.int(0L, edge_start - 1L), + tc$edge_table_get_row + ) + + child_a <- tc$node_table_add_row(time = 0) + child_b <- tc$node_table_add_row(time = 0) + parent <- tc$node_table_add_row(time = 100) + tc$edge_table_add_row( + left = 0, + right = tc$sequence_length(), + parent = parent, + child = child_b + ) + tc$edge_table_add_row( + left = 0, + right = tc$sequence_length(), + parent = parent, + child = child_a + ) + + expect_equal( + vapply( + edge_start:(edge_start + 1L), + function(i) { + tc$edge_table_get_row(i)$child + }, + integer(1) + ), + c(child_b, child_a) + ) + + tc$sort(edge_start = edge_start) + + prefix_after <- lapply( + seq.int(0L, edge_start - 1L), + tc$edge_table_get_row + ) + expect_equal(prefix_after, prefix_before) + expect_equal( + vapply( + edge_start:(edge_start + 1L), + function(i) { + tc$edge_table_get_row(i)$child + }, + integer(1) + ), + c(child_a, child_b) + ) +}) + +test_that("TableCollection$sort can skip site and mutation sorting together", { + unsorted_file <- system.file( + "examples/test_unsorted.trees", + package = "RcppTskit" + ) + tc <- tc_load(unsorted_file) + num_sites <- as.integer(tc$num_sites()) + num_mutations <- as.integer(tc$num_mutations()) + sites_before <- lapply( + seq.int(0L, num_sites - 1L), + tc$site_table_get_row + ) + mutations_before <- lapply( + seq.int(0L, num_mutations - 1L), + tc$mutation_table_get_row + ) + + expect_gt( + sites_before[[num_sites - 1L]]$position, + sites_before[[num_sites]]$position + ) + + tc$sort( + edge_start = as.integer(tc$num_edges()), + site_start = num_sites, + mutation_start = num_mutations + ) + + sites_after <- lapply( + seq.int(0L, num_sites - 1L), + tc$site_table_get_row + ) + mutations_after <- lapply( + seq.int(0L, num_mutations - 1L), + tc$mutation_table_get_row + ) + expect_equal(sites_after, sites_before) + expect_equal(mutations_after, mutations_before) +}) + +test_that("rtsk_table_collection_simplify validates options and returns node map", { + ts_file <- system.file("examples/test.trees", package = "RcppTskit") + tc_xptr <- rtsk_table_collection_load(ts_file) + n_nodes_before <- as.integer(rtsk_table_collection_get_num_nodes(tc_xptr)) + + expect_error( + rtsk_table_collection_simplify(tc_xptr, options = -1L), + regexp = "rtsk_table_collection_simplify does not support negative options" + ) + expect_error( + rtsk_table_collection_simplify(tc_xptr, options = bitwShiftL(1L, 30)), + regexp = "rtsk_table_collection_simplify only supports options" + ) + expect_error( + rtsk_table_collection_simplify( + rtsk_table_collection_load(ts_file), + samples = -1L + ), + regexp = "Node out of bounds|TSK_ERR_NODE_OUT_OF_BOUNDS" + ) + expect_error( + rtsk_table_collection_simplify( + rtsk_table_collection_load(ts_file), + samples = c(0L, 0L) + ), + regexp = "Duplicate sample|TSK_ERR_DUPLICATE_SAMPLE" + ) + + node_map <- rtsk_table_collection_simplify( + tc = tc_xptr, + samples = c(0L, 1L, 2L, 3L), + options = 0L + ) + expect_type(node_map, "integer") + expect_length(node_map, n_nodes_before) + expect_equal(node_map[c(1L, 2L, 3L, 4L)], 0:3) + expect_false(rtsk_table_collection_has_index(tc_xptr)) + + tc_xptr_empty <- rtsk_table_collection_load(ts_file) + n_nodes_before_empty <- as.integer(rtsk_table_collection_get_num_nodes( + tc_xptr_empty + )) + node_map_empty <- rtsk_table_collection_simplify( + tc = tc_xptr_empty, + samples = integer(), + options = 0L + ) + expect_length(node_map_empty, n_nodes_before_empty) + expect_true(all(node_map_empty == -1L)) + expect_equal( + as.integer(rtsk_table_collection_get_num_nodes(tc_xptr_empty)), + 0L + ) + + tc_null <- rtsk_table_collection_load(ts_file) + tc_explicit <- rtsk_table_collection_load(ts_file) + sample_ids <- which(vapply( + seq.int(0L, n_nodes_before - 1L), + function(i) { + bitwAnd(rtsk_node_table_get_row(tc_explicit, i)$flags, 1L) != 0L + }, + logical(1) + )) - + 1L + expect_equal( + rtsk_table_collection_simplify(tc_null), + rtsk_table_collection_simplify(tc_explicit, samples = sample_ids) + ) +}) + +test_that("TableCollection$simplify follows Python-style argument semantics", { + ts_file <- system.file("examples/test.trees", package = "RcppTskit") + tc <- tc_load(ts_file) + n_nodes_before <- as.integer(tc$num_nodes()) + n_provenances_before <- as.integer(tc$num_provenances()) + + expect_error( + tc$simplify(samples = c(0L, NA_integer_)), + regexp = "samples must be NULL or an integer vector with no NA values within 32-bit range!" + ) + expect_error( + tc$simplify(filter_nodes = "yes"), + regexp = "filter_nodes must be TRUE/FALSE!" + ) + tc_keep_sites <- tc_load(ts_file) + expect_no_error(tc_keep_sites$simplify( + samples = c(0L, 1L, 2L, 3L), + filter_sites = FALSE, + record_provenance = FALSE + )) + expect_equal(as.integer(tc_keep_sites$num_sites()), 25L) + expect_error( + tc$simplify(keep_unary = TRUE, keep_unary_in_individuals = TRUE), + regexp = "keep_unary and keep_unary_in_individuals cannot both be TRUE!" + ) + + node_map <- tc$simplify(samples = c(0L, 1L, 2L, 3L)) + expect_type(node_map, "integer") + expect_length(node_map, n_nodes_before) + expect_equal(node_map[c(1L, 2L, 3L, 4L)], 0:3) + expect_true(as.integer(tc$num_nodes()) < n_nodes_before) + expect_false(tc$has_index()) + expect_equal(as.integer(tc$num_provenances()), n_provenances_before + 1L) + provenance <- tc$provenance_table_get_row( + as.integer(tc$num_provenances()) - 1L + )$record + expect_match(provenance, '^\\{"schema_version":"1.0.0"') + expect_match(provenance, '"command":"simplify"', fixed = TRUE) + expect_match(provenance, '"samples":[0,1,2,3]', fixed = TRUE) + expect_match(provenance, '"filter_sites":true', fixed = TRUE) + expect_match(provenance, '"environment":{}', fixed = TRUE) + + tc_null_samples <- tc_load(ts_file) + tc_null_samples$simplify() + null_samples_provenance <- tc_null_samples$provenance_table_get_row( + as.integer(tc_null_samples$num_provenances()) - 1L + )$record + expect_match(null_samples_provenance, '"samples":null', fixed = TRUE) + + tc_no_provenance <- tc_load(ts_file) + n_provenances_before_no_prov <- as.integer(tc_no_provenance$num_provenances()) + expect_no_error(tc_no_provenance$simplify( + samples = c(0L, 1L, 2L, 3L), + record_provenance = FALSE + )) + expect_equal( + as.integer(tc_no_provenance$num_provenances()), + n_provenances_before_no_prov + ) +}) + +test_that("TableCollection$simplify options have their upstream semantics", { + ts_file <- system.file("examples/test.trees", package = "RcppTskit") + samples <- 0:3 + + simplify_fresh <- function(...) { + tc <- tc_load(ts_file) + node_map <- tc$simplify( + samples = samples, + record_provenance = FALSE, + ... + ) + list(tc = tc, node_map = node_map) + } + + default <- simplify_fresh() + keep_unary <- simplify_fresh(keep_unary = TRUE) + expect_gt( + as.integer(keep_unary$tc$num_nodes()), + as.integer(default$tc$num_nodes()) + ) + expect_gt( + as.integer(keep_unary$tc$num_edges()), + as.integer(default$tc$num_edges()) + ) + + keep_roots <- simplify_fresh(keep_input_roots = TRUE) + expect_gt( + as.integer(keep_roots$tc$num_nodes()), + as.integer(default$tc$num_nodes()) + ) + + keep_individuals <- simplify_fresh(filter_individuals = FALSE) + expect_equal(as.integer(keep_individuals$tc$num_individuals()), 8L) + expect_gt( + as.integer(keep_individuals$tc$num_individuals()), + as.integer(default$tc$num_individuals()) + ) + + filtered_populations <- tc_load(ts_file) + filtered_populations$population_table_add_row(metadata = "unreferenced") + filtered_populations$simplify( + samples = samples, + record_provenance = FALSE + ) + kept_populations <- tc_load(ts_file) + kept_populations$population_table_add_row(metadata = "unreferenced") + kept_populations$simplify( + samples = samples, + filter_populations = FALSE, + record_provenance = FALSE + ) + expect_equal(as.integer(filtered_populations$num_populations()), 1L) + expect_equal(as.integer(kept_populations$num_populations()), 2L) + + all_samples <- tc_load(ts_file) + all_sample_ids <- which(vapply( + seq.int(0L, as.integer(all_samples$num_nodes()) - 1L), + function(i) { + bitwAnd(all_samples$node_table_get_row(i)$flags, 1L) != 0L + }, + logical(1) + )) - + 1L + all_samples$simplify( + samples = all_sample_ids, + record_provenance = FALSE + ) + reduced <- tc_load(ts_file) + reduced$simplify( + samples = all_sample_ids, + reduce_to_site_topology = TRUE, + record_provenance = FALSE + ) + expect_lt( + as.integer(reduced$num_edges()), + as.integer(all_samples$num_edges()) + ) + + no_node_filter <- simplify_fresh(filter_nodes = FALSE) + expect_equal(as.integer(no_node_filter$tc$num_nodes()), 39L) + expect_equal(no_node_filter$node_map, seq.int(0L, 38L)) + + unchanged_flags <- tc_load(ts_file) + flags_before <- vapply( + seq.int(0L, as.integer(unchanged_flags$num_nodes()) - 1L), + function(i) unchanged_flags$node_table_get_row(i)$flags, + integer(1) + ) + unchanged_flags$simplify( + samples = 16L, + filter_nodes = FALSE, + update_sample_flags = FALSE, + record_provenance = FALSE + ) + flags_after <- vapply( + seq.int(0L, as.integer(unchanged_flags$num_nodes()) - 1L), + function(i) unchanged_flags$node_table_get_row(i)$flags, + integer(1) + ) + expect_equal(flags_after, flags_before) + + make_individual_unary_path <- function() { + tc <- tc_load(ts_file) + individual <- tc$individual_table_add_row() + child <- tc$node_table_add_row(time = 0) + unary <- tc$node_table_add_row(time = 100, individual = individual) + root <- tc$node_table_add_row(time = 101) + tc$edge_table_add_row( + left = 0, + right = tc$sequence_length(), + parent = unary, + child = child + ) + tc$edge_table_add_row( + left = 0, + right = tc$sequence_length(), + parent = root, + child = unary + ) + tc$sort() + list(tc = tc, child = child) + } + collapsed_path <- make_individual_unary_path() + collapsed_path$tc$simplify( + samples = collapsed_path$child, + keep_input_roots = TRUE, + record_provenance = FALSE + ) + retained_path <- make_individual_unary_path() + retained_path$tc$simplify( + samples = retained_path$child, + keep_input_roots = TRUE, + keep_unary_in_individuals = TRUE, + record_provenance = FALSE + ) + expect_equal(as.integer(collapsed_path$tc$num_nodes()), 2L) + expect_equal(as.integer(retained_path$tc$num_nodes()), 3L) +}) + test_that("individual_table_add_row wrapper expands the table collection and handles inputs", { ts_file <- system.file("examples/test.trees", package = "RcppTskit") tc_xptr <- rtsk_table_collection_load(ts_file) @@ -289,26 +763,45 @@ test_that("individual_table_add_row wrapper expands the table collection and han regexp = "rtsk_individual_table_add_row does not support negative flags" ) + binary_metadata <- as.raw(c(0x00, 0x7f, 0x80, 0xff)) new_id <- rtsk_individual_table_add_row( tc = tc_xptr, - flags = 0L, + flags = .Machine$integer.max, location = c(1.25, -2.5), - metadata = charToRaw("abc") + parents = c(0L, 1L), + metadata = binary_metadata ) - expect_equal(new_id, as.integer(n_before)) # since IDs are 0-based - expect_equal( + expect_identical(new_id, as.integer(n_before)) # IDs are 0-based + expect_identical( + rtsk_individual_table_get_row(tc_xptr, new_id), + list( + id = new_id, + flags = .Machine$integer.max, + location = c(1.25, -2.5), + parents = c(0L, 1L), + metadata = binary_metadata, + nodes = integer() + ) + ) + expect_identical( as.integer(rtsk_table_collection_get_num_individuals(tc_xptr)), as.integer(n_before) + 1L ) - expect_equal( + expect_identical( as.integer(rtsk_table_collection_metadata_length(tc_xptr)$individuals), - as.integer(m_before) + 3L + as.integer(m_before) + length(binary_metadata) ) tc <- TableCollection$new(xptr = tc_xptr) n_before_method <- tc$num_individuals() - new_id_method <- tc$individual_table_add_row() + new_id_method <- tc$individual_table_add_row( + flags = as.numeric(.Machine$integer.max) + ) expect_equal(new_id_method, as.integer(n_before_method)) + expect_identical( + tc$individual_table_get_row(new_id_method)$flags, + .Machine$integer.max + ) expect_equal( as.integer(tc$num_individuals()), as.integer(n_before_method) + 1L @@ -361,7 +854,15 @@ test_that("individual_table_add_row wrapper expands the table collection and han metadata = NULL ) ) - expect_equal(as.integer(tc$num_individuals()), n_before_method + 1L) + expect_no_error( + tc$individual_table_add_row( + flags = 0, + location = NULL, + parents = as.numeric(c(id1, id2)), + metadata = NULL + ) + ) + expect_equal(as.integer(tc$num_individuals()), n_before_method + 2L) m_before_char <- as.integer( rtsk_table_collection_metadata_length(tc$xptr)$individuals @@ -380,16 +881,35 @@ test_that("individual_table_add_row wrapper expands the table collection and han m_before_raw + 3L ) expect_error( - tc$individual_table_add_row(flags = -1L), - regexp = "flags must be a non-NA zero or positive integer scalar!" + tc$individual_table_add_row(flags = NULL), + regexp = "flags cannot be NULL" ) + invalid_flags <- list( + NA_integer_, + -1L, + 0.5, + Inf, + c(0L, 1L), + "0", + as.numeric(.Machine$integer.max) + 1 + ) + for (flags in invalid_flags) { + expect_error( + tc$individual_table_add_row(flags = flags), + regexp = "flags must be a non-NA, non-negative integer scalar no greater than [.]Machine[$]integer[.]max!" + ) + } expect_error( tc$individual_table_add_row(location = c(1, NA_real_)), regexp = "location must be NULL or a numeric vector with no NA values!" ) expect_error( tc$individual_table_add_row(parents = c(NA_integer_)), - regexp = "parents must be NULL or an integer vector with no NA values!" + regexp = "parents must be NULL or an integer vector with no NA values within 32-bit range!" + ) + expect_error( + tc$individual_table_add_row(parents = c(0.5, 1)), + regexp = "parents must be NULL or an integer vector with no NA values within 32-bit range!" ) expect_error( test_rtsk_individual_table_add_row_forced_error(tc$xptr), @@ -398,15 +918,15 @@ test_that("individual_table_add_row wrapper expands the table collection and han expect_error( tc$individual_table_add_row(metadata = c("a", "b")), - regexp = "metadata must be NULL, a raw vector, or a length-1 non-NA character string!" + regexp = "metadata must be NULL, a length-1 non-NA character string, or a raw vector!" ) expect_error( tc$individual_table_add_row(metadata = NA_character_), - regexp = "metadata must be NULL, a raw vector, or a length-1 non-NA character string!" + regexp = "metadata must be NULL, a length-1 non-NA character string, or a raw vector!" ) expect_error( tc$individual_table_add_row(metadata = 1L), - regexp = "metadata must be NULL, a raw vector, or a length-1 non-NA character string!" + regexp = "metadata must be NULL, a length-1 non-NA character string, or a raw vector!" ) }) @@ -422,28 +942,55 @@ test_that("node_table_add_row wrapper expands the table collection and handles i regexp = "rtsk_node_table_add_row does not support negative flags" ) + binary_metadata <- as.raw(c(0x00, 0x7f, 0x80, 0xff)) new_id <- rtsk_node_table_add_row( tc = tc_xptr, - flags = 1L, - time = 1.25, + flags = .Machine$integer.max, + time = -1.25, population = 0L, individual = 0L, - metadata = charToRaw("abc") + metadata = binary_metadata ) - expect_equal(new_id, as.integer(n_before)) # since IDs are 0-based - expect_equal( + expect_identical(new_id, as.integer(n_before)) # IDs are 0-based + expect_identical( + rtsk_node_table_get_row(tc_xptr, new_id), + list( + id = new_id, + flags = .Machine$integer.max, + time = -1.25, + population = 0L, + individual = 0L, + metadata = binary_metadata + ) + ) + expect_identical( as.integer(rtsk_table_collection_get_num_nodes(tc_xptr)), as.integer(n_before) + 1L ) - expect_equal( + expect_identical( as.integer(rtsk_table_collection_metadata_length(tc_xptr)$nodes), - as.integer(m_before) + 3L + as.integer(m_before) + length(binary_metadata) ) tc <- TableCollection$new(xptr = tc_xptr) n_before_method <- tc$num_nodes() - new_id_method <- tc$node_table_add_row() - expect_equal(new_id_method, as.integer(n_before_method)) + new_id_method <- tc$node_table_add_row( + flags = as.numeric(.Machine$integer.max), + population = 0, + individual = 0 + ) + expect_identical(new_id_method, as.integer(n_before_method)) + expect_identical( + tc$node_table_get_row(new_id_method), + list( + id = new_id_method, + flags = .Machine$integer.max, + time = 0, + population = 0L, + individual = 0L, + metadata = raw() + ) + ) expect_equal( as.integer(tc$num_nodes()), as.integer(n_before_method) + 1L @@ -489,8 +1036,18 @@ test_that("node_table_add_row wrapper expands the table collection and handles i ) ) expect_equal(as.integer(tc$num_nodes()), n_before_method + 1L) - expect_no_error(tc$node_table_add_row(population = NULL, individual = NULL)) + expect_no_error( + tc$node_table_add_row( + flags = 1, + time = 4.5, + population = 0, + individual = -1, + metadata = NULL + ) + ) expect_equal(as.integer(tc$num_nodes()), n_before_method + 2L) + expect_no_error(tc$node_table_add_row(population = NULL, individual = NULL)) + expect_equal(as.integer(tc$num_nodes()), n_before_method + 3L) m_before_char <- as.integer( rtsk_table_collection_metadata_length(tc$xptr)$nodes @@ -509,33 +1066,64 @@ test_that("node_table_add_row wrapper expands the table collection and handles i m_before_raw + 3L ) - expect_error( - tc$node_table_add_row(flags = -1L), - regexp = "flags must be a non-NA zero or positive integer scalar!" - ) - expect_error( - tc$node_table_add_row(time = NA_real_), - regexp = "time must be a non-NA numeric scalar!" - ) - expect_error( - tc$node_table_add_row(population = NA_integer_), - regexp = "population must be -1L, NULL, or a non-NA integer scalar!" - ) - expect_error( - tc$node_table_add_row(individual = NA_integer_), - regexp = "individual must be -1L, NULL, or a non-NA integer scalar!" - ) + expect_error(tc$node_table_add_row(flags = NULL), "flags cannot be NULL") + invalid_flags <- list( + NA_integer_, + -1L, + 0.5, + Inf, + c(0L, 1L), + "0", + as.numeric(.Machine$integer.max) + 1 + ) + for (flags in invalid_flags) { + expect_error( + tc$node_table_add_row(flags = flags), + regexp = "flags must be a non-NA, non-negative integer scalar no greater than [.]Machine[$]integer[.]max!" + ) + } + + invalid_times <- list(NULL, NA_real_, NaN, c(0, 1), "0") + for (time in invalid_times) { + expect_error( + tc$node_table_add_row(time = time), + regexp = "time must be a non-NA numeric scalar!" + ) + } + + invalid_ids <- list( + NA_integer_, + -2L, + 0.5, + Inf, + c(0L, 1L), + "0", + as.numeric(.Machine$integer.max) + 1 + ) + for (name in c("population", "individual")) { + for (value in invalid_ids) { + args <- list() + args[[name]] <- value + expect_error( + do.call(tc$node_table_add_row, args), + regexp = paste0( + name, + " must be NULL or a non-NA integer scalar within 32-bit range \\(>= -1\\)!" + ) + ) + } + } expect_error( tc$node_table_add_row(metadata = c("a", "b")), - regexp = "metadata must be NULL, a raw vector, or a length-1 non-NA character string!" + regexp = "metadata must be NULL, a length-1 non-NA character string, or a raw vector!" ) expect_error( tc$node_table_add_row(metadata = NA_character_), - regexp = "metadata must be NULL, a raw vector, or a length-1 non-NA character string!" + regexp = "metadata must be NULL, a length-1 non-NA character string, or a raw vector!" ) expect_error( tc$node_table_add_row(metadata = 1L), - regexp = "metadata must be NULL, a raw vector, or a length-1 non-NA character string!" + regexp = "metadata must be NULL, a length-1 non-NA character string, or a raw vector!" ) expect_error( test_rtsk_node_table_add_row_forced_error(tc$xptr), @@ -543,84 +1131,841 @@ test_that("node_table_add_row wrapper expands the table collection and handles i ) }) -test_that("edge_table_add_row wrapper expands the table collection and handles inputs", { +test_that("individual_table_get_row returns row fields and validates IDs", { ts_file <- system.file("examples/test.trees", package = "RcppTskit") tc_xptr <- rtsk_table_collection_load(ts_file) + tc <- TableCollection$new(xptr = tc_xptr) - n_before <- rtsk_table_collection_get_num_edges(tc_xptr) - m_before <- rtsk_table_collection_metadata_length(tc_xptr)$edges + empty_id <- tc$individual_table_add_row() + empty_low <- rtsk_individual_table_get_row(tc_xptr, empty_id) + empty_method <- tc$individual_table_get_row(empty_id) + expect_identical( + empty_low, + list( + id = empty_id, + flags = 0L, + location = numeric(), + parents = integer(), + metadata = raw(), + nodes = integer() + ) + ) + expect_identical( + empty_method, + empty_low[c("id", "flags", "location", "parents", "metadata")] + ) + expect_false("nodes" %in% names(empty_method)) - parent <- 0L - child <- 1L + binary_metadata <- as.raw(c(0x00, 0x7f, 0x80, 0xff)) + populated_id <- tc$individual_table_add_row( + flags = 3L, + location = c(1.25, -2.5), + parents = c(0L, 1L), + metadata = binary_metadata + ) + populated_low <- rtsk_individual_table_get_row(tc_xptr, populated_id) + populated_method <- tc$individual_table_get_row(populated_id) + expect_identical(populated_low$id, populated_id) + expect_identical(populated_low$flags, 3L) + expect_identical(populated_low$location, c(1.25, -2.5)) + expect_identical(populated_low$parents, c(0L, 1L)) + expect_identical(populated_low$metadata, binary_metadata) + expect_identical(populated_low$nodes, integer()) + expect_identical( + populated_method, + populated_low[c("id", "flags", "location", "parents", "metadata")] + ) - new_id <- rtsk_edge_table_add_row( - tc = tc_xptr, - left = 0, - right = 1, - parent = parent, - child = child, - metadata = charToRaw("abc") + expect_error( + rtsk_individual_table_get_row(tc_xptr, NA_integer_), + regexp = "TSK_ERR_INDIVIDUAL_OUT_OF_BOUNDS" ) - expect_equal(new_id, as.integer(n_before)) # since IDs are 0-based - expect_equal( - as.integer(rtsk_table_collection_get_num_edges(tc_xptr)), - as.integer(n_before) + 1L + expect_error( + rtsk_individual_table_get_row(tc_xptr, -1L), + regexp = "TSK_ERR_INDIVIDUAL_OUT_OF_BOUNDS" ) - expect_equal( - as.integer(rtsk_table_collection_metadata_length(tc_xptr)$edges), - as.integer(m_before) + 3L + expect_error( + rtsk_individual_table_get_row(tc_xptr, 999999L), + regexp = "TSK_ERR_INDIVIDUAL_OUT_OF_BOUNDS" ) - tc <- TableCollection$new(xptr = tc_xptr) - n_before_method <- tc$num_edges() - new_id_method <- tc$edge_table_add_row( - left = 1, - right = 2, - parent = parent, - child = child - ) - expect_equal(new_id_method, as.integer(n_before_method)) - expect_equal( - as.integer(tc$num_edges()), - as.integer(n_before_method) + 1L + expect_error( + tc$individual_table_get_row(NULL), + regexp = "index cannot be NULL" ) + invalid_indices <- list(NA_integer_, -1L, 0.5, Inf, c(0L, 1L), "0") + for (index in invalid_indices) { + expect_error( + tc$individual_table_get_row(index), + regexp = "index must be a non-NA, non-negative integer scalar no greater than [.]Machine[$]integer[.]max!" + ) + } +}) +test_that("node_table_get_row wrapper returns node row fields and validates IDs", { + ts_file <- system.file("examples/test.trees", package = "RcppTskit") tc_xptr <- rtsk_table_collection_load(ts_file) + tc <- TableCollection$new(xptr = tc_xptr) + last_node <- as.integer(rtsk_table_collection_get_num_nodes(tc_xptr)) - 1L - n0 <- as.integer(rtsk_table_collection_get_num_edges(tc_xptr)) - m0 <- as.integer(rtsk_table_collection_metadata_length(tc_xptr)$edges) + first_row_low <- rtsk_node_table_get_row(tc_xptr, 0L) + first_row_method <- tc$node_table_get_row(0L) + last_row_low <- rtsk_node_table_get_row(tc_xptr, last_node) + last_row_method <- tc$node_table_get_row(last_node) - # Explicit NULL metadata should be accepted. - id0 <- rtsk_edge_table_add_row( - tc = tc_xptr, - left = 0, - right = 1, - parent = parent, - child = child, - metadata = NULL - ) - expect_equal(id0, n0) + # we got these values from inst/examples/create_test.trees.py expect_equal( - as.integer(rtsk_table_collection_get_num_edges(tc_xptr)), - n0 + 1L + first_row_low, + list( + id = 0L, + flags = 1L, + time = 0, + population = 0L, + individual = 0L, + metadata = raw(0) + ) ) + expect_equal(first_row_method, first_row_low) + # we got these values from inst/examples/create_test.trees.py expect_equal( - as.integer(rtsk_table_collection_metadata_length(tc_xptr)$edges), - m0 + last_row_low, + list( + id = 38L, + flags = 0L, + time = 6.96199333719081, + population = 0L, + individual = -1L, + metadata = raw(0) + ) ) + expect_equal(last_row_method, last_row_low) - tc <- TableCollection$new(xptr = tc_xptr) - n_before_method <- as.integer(tc$num_edges()) - expect_no_error( - tc$edge_table_add_row( - left = 2, - right = 3, - parent = parent, + expect_error( + rtsk_node_table_get_row(tc_xptr, NA_integer_), + regexp = "TSK_ERR_NODE_OUT_OF_BOUNDS" + ) + expect_error( + rtsk_node_table_get_row(tc_xptr, -1L), + regexp = "TSK_ERR_NODE_OUT_OF_BOUNDS" + ) + expect_error( + tc$node_table_get_row(NA_integer_), + regexp = "index must be a non-NA, non-negative integer scalar no greater than [.]Machine[$]integer[.]max!" + ) + expect_error( + tc$node_table_get_row(-1L), + regexp = "index must be a non-NA, non-negative integer scalar no greater than [.]Machine[$]integer[.]max!" + ) + expect_error(tc$node_table_get_row(NULL), regexp = "index cannot be NULL") + invalid_indices <- list(0.5, Inf, c(0L, 1L)) + for (index in invalid_indices) { + expect_error( + tc$node_table_get_row(index), + regexp = "index must be a non-NA, non-negative integer scalar no greater than [.]Machine[$]integer[.]max!" + ) + } + expect_equal(tc$node_table_get_row(0), first_row_low) + expect_error( + rtsk_node_table_get_row(tc_xptr, 999999L), + regexp = "TSK_ERR_NODE_OUT_OF_BOUNDS" + ) + + new_id <- tc$node_table_add_row( + flags = 1L, + time = 12.5, + population = 0L, + individual = -1L, + metadata = charToRaw("abc") + ) + row_low <- rtsk_node_table_get_row(tc_xptr, new_id) + row_method <- tc$node_table_get_row(new_id) + + expect_equal( + sort(names(row_low)), + c("flags", "id", "individual", "metadata", "population", "time") + ) + expect_equal(row_low$id, new_id) + expect_equal(row_low$flags, 1L) + expect_equal(row_low$time, 12.5) + expect_equal(row_low$population, 0L) + expect_equal(row_low$individual, -1L) + expect_equal(row_low$metadata, charToRaw("abc")) + expect_equal(row_method, row_low) + + null_id <- tc$node_table_add_row( + time = 13.5, + population = NULL, + individual = NULL + ) + null_row <- tc$node_table_get_row(null_id) + expect_equal(null_row$id, null_id) + expect_equal(null_row$population, -1L) + expect_equal(null_row$individual, -1L) + + binary_metadata <- as.raw(c(0x00, 0x7f, 0x80, 0xff)) + binary_id <- tc$node_table_add_row(metadata = binary_metadata) + binary_row_low <- rtsk_node_table_get_row(tc_xptr, binary_id) + binary_row_method <- tc$node_table_get_row(binary_id) + expect_identical(binary_row_low$metadata, binary_metadata) + expect_identical(binary_row_method$metadata, binary_metadata) +}) + +test_that("edge_table_get_row returns row fields and validates IDs", { + ts_file <- system.file("examples/test.trees", package = "RcppTskit") + tc_xptr <- rtsk_table_collection_load(ts_file) + tc <- TableCollection$new(xptr = tc_xptr) + last_edge <- as.integer(rtsk_table_collection_get_num_edges(tc_xptr)) - 1L + + first_row_low <- rtsk_edge_table_get_row(tc_xptr, 0L) + first_row_method <- tc$edge_table_get_row(0) + last_row_low <- rtsk_edge_table_get_row(tc_xptr, last_edge) + last_row_method <- tc$edge_table_get_row(last_edge) + + # we got these values from inst/examples/create_test.trees.py + expect_identical( + first_row_low, + list( + id = 0L, + left = 0, + right = 100, + parent = 16L, + child = 13L, + metadata = raw() + ) + ) + expect_identical(first_row_method, first_row_low) + # we got these values from inst/examples/create_test.trees.py + expect_identical( + last_row_low, + list( + id = 58L, + left = 0, + right = 29, + parent = 38L, + child = 34L, + metadata = raw() + ) + ) + expect_identical(last_row_method, last_row_low) + + binary_metadata <- as.raw(c(0x00, 0x7f, 0x80, 0xff)) + new_id <- tc$edge_table_add_row( + left = 12.5, + right = 25.75, + parent = 16L, + child = 13L, + metadata = binary_metadata + ) + new_row_low <- rtsk_edge_table_get_row(tc_xptr, new_id) + new_row_method <- tc$edge_table_get_row(new_id) + expect_identical( + new_row_low, + list( + id = new_id, + left = 12.5, + right = 25.75, + parent = 16L, + child = 13L, + metadata = binary_metadata + ) + ) + expect_identical(new_row_method, new_row_low) + + expect_error( + rtsk_edge_table_get_row(tc_xptr, NA_integer_), + regexp = "TSK_ERR_EDGE_OUT_OF_BOUNDS" + ) + expect_error( + rtsk_edge_table_get_row(tc_xptr, -1L), + regexp = "TSK_ERR_EDGE_OUT_OF_BOUNDS" + ) + expect_error( + rtsk_edge_table_get_row(tc_xptr, 999999L), + regexp = "TSK_ERR_EDGE_OUT_OF_BOUNDS" + ) + + expect_error(tc$edge_table_get_row(NULL), regexp = "index cannot be NULL") + invalid_indices <- list(NA_integer_, -1L, 0.5, Inf, c(0L, 1L), "0") + for (index in invalid_indices) { + expect_error( + tc$edge_table_get_row(index), + regexp = "index must be a non-NA, non-negative integer scalar no greater than [.]Machine[$]integer[.]max!" + ) + } + expect_error( + tc$edge_table_get_row(999999L), + regexp = "TSK_ERR_EDGE_OUT_OF_BOUNDS" + ) +}) + +test_that("site_table_get_row returns row fields and validates IDs", { + ts_file <- system.file("examples/test.trees", package = "RcppTskit") + tc_xptr <- rtsk_table_collection_load(ts_file) + tc <- TableCollection$new(xptr = tc_xptr) + last_site <- as.integer(rtsk_table_collection_get_num_sites(tc_xptr)) - 1L + + first_row_low <- rtsk_site_table_get_row(tc_xptr, 0L) + first_row_method <- tc$site_table_get_row(0) + last_row_low <- rtsk_site_table_get_row(tc_xptr, last_site) + last_row_method <- tc$site_table_get_row(last_site) + + # we got these values from inst/examples/create_test.trees.py + expect_identical( + first_row_low, + list( + id = 0L, + position = 0, + ancestral_state = "G", + metadata = raw(), + mutations = NULL + ) + ) + expect_identical( + first_row_method, + first_row_low[c("id", "position", "ancestral_state", "metadata")] + ) + expect_false("mutations" %in% names(first_row_method)) + # we got these values from inst/examples/create_test.trees.py + expect_identical( + last_row_low, + list( + id = 24L, + position = 99, + ancestral_state = "G", + metadata = raw(), + mutations = NULL + ) + ) + expect_identical( + last_row_method, + last_row_low[c("id", "position", "ancestral_state", "metadata")] + ) + + empty_state_id <- tc$site_table_add_row( + position = 100.5, + ancestral_state = "" + ) + empty_state_low <- rtsk_site_table_get_row(tc_xptr, empty_state_id) + expect_identical(empty_state_low$ancestral_state, "") + expect_identical(empty_state_low$metadata, raw()) + expect_null(empty_state_low$mutations) + + binary_metadata <- as.raw(c(0x00, 0x7f, 0x80, 0xff)) + new_id <- tc$site_table_add_row( + position = 101.25, + ancestral_state = "AC", + metadata = binary_metadata + ) + new_row_low <- rtsk_site_table_get_row(tc_xptr, new_id) + new_row_method <- tc$site_table_get_row(new_id) + expect_identical( + new_row_low, + list( + id = new_id, + position = 101.25, + ancestral_state = "AC", + metadata = binary_metadata, + mutations = NULL + ) + ) + expect_identical( + new_row_method, + new_row_low[c("id", "position", "ancestral_state", "metadata")] + ) + + expect_error( + rtsk_site_table_get_row(tc_xptr, NA_integer_), + regexp = "TSK_ERR_SITE_OUT_OF_BOUNDS" + ) + expect_error( + rtsk_site_table_get_row(tc_xptr, -1L), + regexp = "TSK_ERR_SITE_OUT_OF_BOUNDS" + ) + expect_error( + rtsk_site_table_get_row(tc_xptr, 999999L), + regexp = "TSK_ERR_SITE_OUT_OF_BOUNDS" + ) + + expect_error(tc$site_table_get_row(NULL), regexp = "index cannot be NULL") + invalid_indices <- list(NA_integer_, -1L, 0.5, Inf, c(0L, 1L), "0") + for (index in invalid_indices) { + expect_error( + tc$site_table_get_row(index), + regexp = "index must be a non-NA, non-negative integer scalar no greater than [.]Machine[$]integer[.]max!" + ) + } + expect_error( + tc$site_table_get_row(999999L), + regexp = "TSK_ERR_SITE_OUT_OF_BOUNDS" + ) +}) + +test_that("mutation_table_get_row returns row fields and validates IDs", { + ts_file <- system.file("examples/test.trees", package = "RcppTskit") + tc_xptr <- rtsk_table_collection_load(ts_file) + tc <- TableCollection$new(xptr = tc_xptr) + last_mutation <- + as.integer(rtsk_table_collection_get_num_mutations(tc_xptr)) - 1L + + first_row_low <- rtsk_mutation_table_get_row(tc_xptr, 0L) + first_row_method <- tc$mutation_table_get_row(0) + last_row_low <- rtsk_mutation_table_get_row(tc_xptr, last_mutation) + last_row_method <- tc$mutation_table_get_row(last_mutation) + + # we got these values from inst/examples/create_test.trees.py + expect_equal( + first_row_low, + list( + id = 0L, + site = 0L, + node = 34L, + parent = -1L, + time = 5.96733256969776, + derived_state = "T", + metadata = raw(), + edge = -1L, + inherited_state = NULL + ) + ) + expect_identical( + first_row_method, + first_row_low[c( + "id", + "site", + "node", + "derived_state", + "parent", + "metadata", + "time" + )] + ) + expect_false(any(c("edge", "inherited_state") %in% names(first_row_method))) + # we got these values from inst/examples/create_test.trees.py + expect_equal( + last_row_low, + list( + id = 29L, + site = 24L, + node = 33L, + parent = -1L, + time = 2.44107265855989, + derived_state = "C", + metadata = raw(), + edge = -1L, + inherited_state = NULL + ) + ) + expect_identical( + last_row_method, + last_row_low[c( + "id", + "site", + "node", + "derived_state", + "parent", + "metadata", + "time" + )] + ) + + empty_state_id <- tc$mutation_table_add_row( + site = 0L, + node = 0L, + derived_state = "" + ) + empty_state_low <- rtsk_mutation_table_get_row(tc_xptr, empty_state_id) + expect_identical(empty_state_low$derived_state, "") + expect_identical(empty_state_low$parent, -1L) + expect_true(is.nan(empty_state_low$time)) + expect_identical(empty_state_low$metadata, raw()) + expect_identical(empty_state_low$edge, -1L) + expect_null(empty_state_low$inherited_state) + + binary_metadata <- as.raw(c(0x00, 0x7f, 0x80, 0xff)) + new_id <- tc$mutation_table_add_row( + site = 0L, + node = 1L, + derived_state = "AC", + parent = empty_state_id, + metadata = binary_metadata, + time = 0.125 + ) + new_row_low <- rtsk_mutation_table_get_row(tc_xptr, new_id) + new_row_method <- tc$mutation_table_get_row(new_id) + expect_identical( + new_row_low, + list( + id = new_id, + site = 0L, + node = 1L, + parent = empty_state_id, + time = 0.125, + derived_state = "AC", + metadata = binary_metadata, + edge = -1L, + inherited_state = NULL + ) + ) + expect_identical( + new_row_method, + new_row_low[c( + "id", + "site", + "node", + "derived_state", + "parent", + "metadata", + "time" + )] + ) + + expect_error( + rtsk_mutation_table_get_row(tc_xptr, NA_integer_), + regexp = "TSK_ERR_MUTATION_OUT_OF_BOUNDS" + ) + expect_error( + rtsk_mutation_table_get_row(tc_xptr, -1L), + regexp = "TSK_ERR_MUTATION_OUT_OF_BOUNDS" + ) + expect_error( + rtsk_mutation_table_get_row(tc_xptr, 999999L), + regexp = "TSK_ERR_MUTATION_OUT_OF_BOUNDS" + ) + + expect_error(tc$mutation_table_get_row(NULL), regexp = "index cannot be NULL") + invalid_indices <- list(NA_integer_, -1L, 0.5, Inf, c(0L, 1L), "0") + for (index in invalid_indices) { + expect_error( + tc$mutation_table_get_row(index), + regexp = "index must be a non-NA, non-negative integer scalar no greater than [.]Machine[$]integer[.]max!" + ) + } + expect_error( + tc$mutation_table_get_row(999999L), + regexp = "TSK_ERR_MUTATION_OUT_OF_BOUNDS" + ) +}) + +test_that("population_table_get_row returns row fields and validates IDs", { + ts_file <- system.file("examples/test.trees", package = "RcppTskit") + tc_xptr <- rtsk_table_collection_load(ts_file) + tc <- TableCollection$new(xptr = tc_xptr) + + first_row_low <- rtsk_population_table_get_row(tc_xptr, 0L) + first_row_method <- tc$population_table_get_row(0) + # we got this value from inst/examples/create_test.trees.py + expect_identical( + first_row_low, + list( + id = 0L, + metadata = charToRaw('{"description":"","name":"pop_0"}') + ) + ) + expect_identical(first_row_method, first_row_low) + + empty_id <- tc$population_table_add_row() + empty_row_low <- rtsk_population_table_get_row(tc_xptr, empty_id) + empty_row_method <- tc$population_table_get_row(empty_id) + expect_identical(empty_row_low, list(id = empty_id, metadata = raw())) + expect_identical(empty_row_method, empty_row_low) + + binary_metadata <- as.raw(c(0x00, 0x7f, 0x80, 0xff)) + binary_id <- tc$population_table_add_row(metadata = binary_metadata) + binary_row_low <- rtsk_population_table_get_row(tc_xptr, binary_id) + binary_row_method <- tc$population_table_get_row(binary_id) + expect_identical( + binary_row_low, + list(id = binary_id, metadata = binary_metadata) + ) + expect_identical(binary_row_method, binary_row_low) + + expect_error( + rtsk_population_table_get_row(tc_xptr, NA_integer_), + regexp = "TSK_ERR_POPULATION_OUT_OF_BOUNDS" + ) + expect_error( + rtsk_population_table_get_row(tc_xptr, -1L), + regexp = "TSK_ERR_POPULATION_OUT_OF_BOUNDS" + ) + expect_error( + rtsk_population_table_get_row(tc_xptr, 999999L), + regexp = "TSK_ERR_POPULATION_OUT_OF_BOUNDS" + ) + + expect_error( + tc$population_table_get_row(NULL), + regexp = "index cannot be NULL" + ) + invalid_indices <- list(NA_integer_, -1L, 0.5, Inf, c(0L, 1L), "0") + for (index in invalid_indices) { + expect_error( + tc$population_table_get_row(index), + regexp = "index must be a non-NA, non-negative integer scalar no greater than [.]Machine[$]integer[.]max!" + ) + } + expect_error( + tc$population_table_get_row(999999L), + regexp = "TSK_ERR_POPULATION_OUT_OF_BOUNDS" + ) +}) + +test_that("migration_table_get_row returns row fields and validates IDs", { + ts_file <- system.file("examples/test.trees", package = "RcppTskit") + tc_xptr <- rtsk_table_collection_load(ts_file) + tc <- TableCollection$new(xptr = tc_xptr) + dest <- tc$population_table_add_row() + + empty_id <- tc$migration_table_add_row( + left = 0, + right = 1, + node = 0L, + source = 0L, + dest = dest, + time = 1.25 + ) + empty_row_low <- rtsk_migration_table_get_row(tc_xptr, empty_id) + empty_row_method <- tc$migration_table_get_row(0) + expect_identical( + empty_row_low, + list( + id = empty_id, + left = 0, + right = 1, + node = 0L, + source = 0L, + dest = dest, + time = 1.25, + metadata = raw() + ) + ) + expect_identical(empty_row_method, empty_row_low) + + binary_metadata <- as.raw(c(0x00, 0x7f, 0x80, 0xff)) + binary_id <- tc$migration_table_add_row( + left = 1.5, + right = 2.75, + node = 1L, + source = dest, + dest = 0L, + time = 3.5, + metadata = binary_metadata + ) + binary_row_low <- rtsk_migration_table_get_row(tc_xptr, binary_id) + binary_row_method <- tc$migration_table_get_row(binary_id) + expect_identical( + binary_row_low, + list( + id = binary_id, + left = 1.5, + right = 2.75, + node = 1L, + source = dest, + dest = 0L, + time = 3.5, + metadata = binary_metadata + ) + ) + expect_identical(binary_row_method, binary_row_low) + + expect_error( + rtsk_migration_table_get_row(tc_xptr, NA_integer_), + regexp = "TSK_ERR_MIGRATION_OUT_OF_BOUNDS" + ) + expect_error( + rtsk_migration_table_get_row(tc_xptr, -1L), + regexp = "TSK_ERR_MIGRATION_OUT_OF_BOUNDS" + ) + expect_error( + rtsk_migration_table_get_row(tc_xptr, 999999L), + regexp = "TSK_ERR_MIGRATION_OUT_OF_BOUNDS" + ) + + expect_error( + tc$migration_table_get_row(NULL), + regexp = "index cannot be NULL" + ) + invalid_indices <- list(NA_integer_, -1L, 0.5, Inf, c(0L, 1L), "0") + for (index in invalid_indices) { + expect_error( + tc$migration_table_get_row(index), + regexp = "index must be a non-NA, non-negative integer scalar no greater than [.]Machine[$]integer[.]max!" + ) + } + expect_error( + tc$migration_table_get_row(999999L), + regexp = "TSK_ERR_MIGRATION_OUT_OF_BOUNDS" + ) +}) + +test_that("provenance_table_get_row returns row fields and validates IDs", { + ts_file <- system.file("examples/test.trees", package = "RcppTskit") + tc_xptr <- rtsk_table_collection_load(ts_file) + tc <- TableCollection$new(xptr = tc_xptr) + + empty_id <- tc$provenance_table_add_row(record = "", timestamp = "") + empty_row_low <- rtsk_provenance_table_get_row(tc_xptr, empty_id) + empty_row_method <- tc$provenance_table_get_row(as.numeric(empty_id)) + expect_identical( + empty_row_low, + list(id = empty_id, timestamp = "", record = "") + ) + expect_identical(empty_row_method, empty_row_low) + + timestamp <- "2026-02-03T04:05:06Z" + record <- '{"software":"RcppTskit","action":"getter-test"}' + row_id <- tc$provenance_table_add_row( + record = record, + timestamp = timestamp + ) + row_low <- rtsk_provenance_table_get_row(tc_xptr, row_id) + row_method <- tc$provenance_table_get_row(row_id) + expect_identical( + row_low, + list(id = row_id, timestamp = timestamp, record = record) + ) + expect_identical(row_method, row_low) + + expect_error( + rtsk_provenance_table_get_row(tc_xptr, NA_integer_), + regexp = "TSK_ERR_PROVENANCE_OUT_OF_BOUNDS" + ) + expect_error( + rtsk_provenance_table_get_row(tc_xptr, -1L), + regexp = "TSK_ERR_PROVENANCE_OUT_OF_BOUNDS" + ) + expect_error( + rtsk_provenance_table_get_row(tc_xptr, 999999L), + regexp = "TSK_ERR_PROVENANCE_OUT_OF_BOUNDS" + ) + + expect_error( + tc$provenance_table_get_row(NULL), + regexp = "index cannot be NULL" + ) + invalid_indices <- list(NA_integer_, -1L, 0.5, Inf, c(0L, 1L), "0") + for (index in invalid_indices) { + expect_error( + tc$provenance_table_get_row(index), + regexp = "index must be a non-NA, non-negative integer scalar no greater than [.]Machine[$]integer[.]max!" + ) + } + expect_error( + tc$provenance_table_get_row(999999L), + regexp = "TSK_ERR_PROVENANCE_OUT_OF_BOUNDS" + ) +}) + +test_that("edge_table_add_row wrapper expands the table collection and handles inputs", { + ts_file <- system.file("examples/test.trees", package = "RcppTskit") + tc_xptr <- rtsk_table_collection_load(ts_file) + + n_before <- rtsk_table_collection_get_num_edges(tc_xptr) + m_before <- rtsk_table_collection_metadata_length(tc_xptr)$edges + + parent <- 16L + child <- 13L + + binary_metadata <- as.raw(c(0x00, 0x7f, 0x80, 0xff)) + new_id <- rtsk_edge_table_add_row( + tc = tc_xptr, + left = 0.25, + right = 0.75, + parent = parent, + child = child, + metadata = binary_metadata + ) + expect_identical(new_id, as.integer(n_before)) # IDs are 0-based + expect_identical( + rtsk_edge_table_get_row(tc_xptr, new_id), + list( + id = new_id, + left = 0.25, + right = 0.75, + parent = parent, + child = child, + metadata = binary_metadata + ) + ) + expect_identical( + as.integer(rtsk_table_collection_get_num_edges(tc_xptr)), + as.integer(n_before) + 1L + ) + expect_identical( + as.integer(rtsk_table_collection_metadata_length(tc_xptr)$edges), + as.integer(m_before) + length(binary_metadata) + ) + + tc <- TableCollection$new(xptr = tc_xptr) + n_before_method <- tc$num_edges() + new_id_method <- tc$edge_table_add_row( + left = 1, + right = 2, + parent = as.numeric(parent), + child = as.numeric(child) + ) + expect_identical(new_id_method, as.integer(n_before_method)) + expect_identical( + tc$edge_table_get_row(new_id_method), + list( + id = new_id_method, + left = 1, + right = 2, + parent = parent, + child = child, + metadata = raw() + ) + ) + expect_equal( + as.integer(tc$num_edges()), + as.integer(n_before_method) + 1L + ) + + tc_xptr <- rtsk_table_collection_load(ts_file) + + n0 <- as.integer(rtsk_table_collection_get_num_edges(tc_xptr)) + m0 <- as.integer(rtsk_table_collection_metadata_length(tc_xptr)$edges) + + # Explicit NULL metadata should be accepted. + id0 <- rtsk_edge_table_add_row( + tc = tc_xptr, + left = 0, + right = 1, + parent = parent, + child = child, + metadata = NULL + ) + expect_equal(id0, n0) + expect_equal( + as.integer(rtsk_table_collection_get_num_edges(tc_xptr)), + n0 + 1L + ) + expect_equal( + as.integer(rtsk_table_collection_metadata_length(tc_xptr)$edges), + m0 + ) + + tc <- TableCollection$new(xptr = tc_xptr) + n_before_method <- as.integer(tc$num_edges()) + expect_no_error( + tc$edge_table_add_row( + left = 2, + right = 3, + parent = parent, child = child, metadata = NULL ) ) expect_equal(as.integer(tc$num_edges()), n_before_method + 1L) + expect_no_error( + tc$edge_table_add_row( + left = 2, + right = 3, + parent = as.numeric(parent), + child = as.numeric(child), + metadata = NULL + ) + ) + expect_equal(as.integer(tc$num_edges()), n_before_method + 2L) m_before_char <- as.integer( rtsk_table_collection_metadata_length(tc$xptr)$edges @@ -654,42 +1999,37 @@ test_that("edge_table_add_row wrapper expands the table collection and handles i as.integer(rtsk_table_collection_metadata_length(tc$xptr)$edges), m_before_raw + 3L ) - expect_error( - tc$edge_table_add_row( - left = NULL, - right = 6, - parent = parent, - child = child - ), - regexp = "left must be a non-NA numeric scalar!" - ) - expect_error( - tc$edge_table_add_row( - left = c(5, 6), - right = 6, - parent = parent, - child = child - ), - regexp = "left must be a non-NA numeric scalar!" - ) + invalid_coordinates <- list(NULL, NA_real_, NaN, c(0, 1), "0") + for (name in c("left", "right")) { + for (value in invalid_coordinates) { + args <- list(left = 5, right = 6, parent = parent, child = child) + args[name] <- list(value) + expect_error( + do.call(tc$edge_table_add_row, args), + regexp = paste0(name, " must be a non-NA numeric scalar!") + ) + } + } + expect_error( tc$edge_table_add_row( left = 6, - right = NULL, + right = 6, parent = parent, child = child ), - regexp = "right must be a non-NA numeric scalar!" + regexp = "left must be strictly less than right!" ) expect_error( tc$edge_table_add_row( - left = 6, + left = 7, right = 6, parent = parent, child = child ), regexp = "left must be strictly less than right!" ) + expect_error( tc$edge_table_add_row( left = 6, @@ -697,7 +2037,7 @@ test_that("edge_table_add_row wrapper expands the table collection and handles i parent = NULL, child = child ), - regexp = "parent must be a non-NA integer scalar!" + regexp = "parent cannot be NULL\\." ) expect_error( tc$edge_table_add_row( @@ -706,26 +2046,30 @@ test_that("edge_table_add_row wrapper expands the table collection and handles i parent = parent, child = NULL ), - regexp = "child must be a non-NA integer scalar!" - ) - expect_error( - tc$edge_table_add_row( - left = 5, - right = 6, - parent = NA_integer_, - child = child - ), - regexp = "parent must be a non-NA integer scalar!" - ) - expect_error( - tc$edge_table_add_row( - left = 5, - right = 6, - parent = parent, - child = NA_integer_ - ), - regexp = "child must be a non-NA integer scalar!" - ) + regexp = "child cannot be NULL\\." + ) + invalid_ids <- list( + NA_integer_, + -1L, + 0.5, + Inf, + c(0L, 1L), + "0", + as.numeric(.Machine$integer.max) + 1 + ) + for (name in c("parent", "child")) { + for (value in invalid_ids) { + args <- list(left = 5, right = 6, parent = parent, child = child) + args[[name]] <- value + expect_error( + do.call(tc$edge_table_add_row, args), + regexp = paste0( + name, + " must be a non-NA, non-negative integer scalar no greater than [.]Machine[$]integer[.]max!" + ) + ) + } + } expect_error( tc$edge_table_add_row( left = 6, @@ -734,7 +2078,7 @@ test_that("edge_table_add_row wrapper expands the table collection and handles i child = child, metadata = c("a", "b") ), - regexp = "metadata must be NULL, a raw vector, or a length-1 non-NA character string!" + regexp = "metadata must be NULL, a length-1 non-NA character string, or a raw vector!" ) expect_error( tc$edge_table_add_row( @@ -744,7 +2088,7 @@ test_that("edge_table_add_row wrapper expands the table collection and handles i child = child, metadata = NA_character_ ), - regexp = "metadata must be NULL, a raw vector, or a length-1 non-NA character string!" + regexp = "metadata must be NULL, a length-1 non-NA character string, or a raw vector!" ) expect_error( tc$edge_table_add_row( @@ -754,7 +2098,7 @@ test_that("edge_table_add_row wrapper expands the table collection and handles i child = child, metadata = 1L ), - regexp = "metadata must be NULL, a raw vector, or a length-1 non-NA character string!" + regexp = "metadata must be NULL, a length-1 non-NA character string, or a raw vector!" ) expect_error( test_rtsk_edge_table_add_row_forced_error(tc$xptr), @@ -769,27 +2113,47 @@ test_that("site_table_add_row wrapper expands the table collection and handles i n_before <- rtsk_table_collection_get_num_sites(tc_xptr) m_before <- rtsk_table_collection_metadata_length(tc_xptr)[["sites"]] + binary_metadata <- as.raw(c(0x00, 0x7f, 0x80, 0xff)) new_id <- rtsk_site_table_add_row( tc = tc_xptr, position = 0.5, - ancestral_state = "A", - metadata = charToRaw("abc") + ancestral_state = "AC", + metadata = binary_metadata ) - expect_equal(new_id, as.integer(n_before)) # since IDs are 0-based - expect_equal( + expect_identical(new_id, as.integer(n_before)) # IDs are 0-based + expect_identical( + rtsk_site_table_get_row(tc_xptr, new_id), + list( + id = new_id, + position = 0.5, + ancestral_state = "AC", + metadata = binary_metadata, + mutations = NULL + ) + ) + expect_identical( as.integer(rtsk_table_collection_get_num_sites(tc_xptr)), as.integer(n_before) + 1L ) - expect_equal( + expect_identical( as.integer(rtsk_table_collection_metadata_length(tc_xptr)[["sites"]]), - as.integer(m_before) + 3L + as.integer(m_before) + length(binary_metadata) ) tc <- TableCollection$new(xptr = tc_xptr) n_before_method <- tc$num_sites() new_id_method <- tc$site_table_add_row(position = 1.5, ancestral_state = "G") - expect_equal(new_id_method, as.integer(n_before_method)) - expect_equal( + expect_identical(new_id_method, as.integer(n_before_method)) + expect_identical( + tc$site_table_get_row(new_id_method), + list( + id = new_id_method, + position = 1.5, + ancestral_state = "G", + metadata = raw() + ) + ) + expect_identical( as.integer(tc$num_sites()), as.integer(n_before_method) + 1L ) @@ -805,12 +2169,22 @@ test_that("site_table_add_row wrapper expands the table collection and handles i ancestral_state = "", metadata = NULL ) - expect_equal(id0, n0) - expect_equal( + expect_identical(id0, n0) + expect_identical( + rtsk_site_table_get_row(tc_xptr, id0), + list( + id = id0, + position = 2.5, + ancestral_state = "", + metadata = raw(), + mutations = NULL + ) + ) + expect_identical( as.integer(rtsk_table_collection_get_num_sites(tc_xptr)), n0 + 1L ) - expect_equal( + expect_identical( as.integer(rtsk_table_collection_metadata_length(tc_xptr)[["sites"]]), m0 ) @@ -828,13 +2202,17 @@ test_that("site_table_add_row wrapper expands the table collection and handles i m_before_char <- as.integer(rtsk_table_collection_metadata_length(tc$xptr)[[ "sites" ]]) - expect_no_warning( + character_metadata_id <- expect_no_warning( tc$site_table_add_row( position = 4.5, ancestral_state = "T", metadata = "abc" ) ) + expect_identical( + tc$site_table_get_row(character_metadata_id)$metadata, + charToRaw("abc") + ) expect_equal( as.integer(rtsk_table_collection_metadata_length(tc$xptr)[["sites"]]), m_before_char + 3L @@ -842,50 +2220,59 @@ test_that("site_table_add_row wrapper expands the table collection and handles i m_before_raw <- as.integer(rtsk_table_collection_metadata_length(tc$xptr)[[ "sites" ]]) - expect_no_error( + raw_metadata_id <- expect_no_error( tc$site_table_add_row( position = 5.5, ancestral_state = "C", metadata = charToRaw("xyz") ) ) + expect_identical( + tc$site_table_get_row(raw_metadata_id)$metadata, + charToRaw("xyz") + ) expect_equal( as.integer(rtsk_table_collection_metadata_length(tc$xptr)[["sites"]]), m_before_raw + 3L ) - - expect_error( - tc$site_table_add_row(position = NULL, ancestral_state = "A"), - regexp = "position must be a non-NA numeric scalar!" - ) - expect_error( - tc$site_table_add_row(position = NaN, ancestral_state = "A"), - regexp = "position must be a non-NA numeric scalar!" - ) - expect_error( - tc$site_table_add_row(position = 6.5, ancestral_state = c("A", "B")), - regexp = "ancestral_state must be a length-1 non-NA character string!" - ) - expect_error( - tc$site_table_add_row(position = 6.5, ancestral_state = NA_character_), - regexp = "ancestral_state must be a length-1 non-NA character string!" - ) - expect_error( - tc$site_table_add_row(position = 6.5, ancestral_state = charToRaw("A")), - regexp = "ancestral_state must be a length-1 non-NA character string!" - ) - expect_error( - tc$site_table_add_row(position = 6.5, ancestral_state = 1L), - regexp = "ancestral_state must be a length-1 non-NA character string!" - ) - expect_error( - tc$site_table_add_row( - position = 6.5, - ancestral_state = "A", - metadata = c("a", "b") - ), - regexp = "metadata must be NULL, a raw vector, or a length-1 non-NA character string!" - ) + + invalid_positions <- list(NULL, NA_real_, NaN, c(0, 1), "0") + for (position in invalid_positions) { + expect_error( + tc$site_table_add_row(position = position, ancestral_state = "A"), + regexp = "position must be a non-NA numeric scalar!" + ) + } + + invalid_states <- list( + NULL, + NA_character_, + character(), + c("A", "B"), + charToRaw("A"), + 1L + ) + for (ancestral_state in invalid_states) { + expect_error( + tc$site_table_add_row( + position = 6.5, + ancestral_state = ancestral_state + ), + regexp = "ancestral_state must be a length-1 non-NA character string!" + ) + } + + invalid_metadata <- list(c("a", "b"), NA_character_, 1L) + for (metadata in invalid_metadata) { + expect_error( + tc$site_table_add_row( + position = 6.5, + ancestral_state = "A", + metadata = metadata + ), + regexp = "metadata must be NULL, a length-1 non-NA character string, or a raw vector!" + ) + } expect_error( test_rtsk_site_table_add_row_forced_error(tc$xptr), regexp = "TSK_ERR_TABLE_OVERFLOW" @@ -903,34 +2290,63 @@ test_that("mutation_table_add_row wrapper expands the table collection and handl n_before <- rtsk_table_collection_get_num_mutations(tc_xptr) m_before <- rtsk_table_collection_metadata_length(tc_xptr)[["mutations"]] + binary_metadata <- as.raw(c(0x00, 0x7f, 0x80, 0xff)) new_id <- rtsk_mutation_table_add_row( tc = tc_xptr, site = site, node = node, parent = -1L, - time = NaN, - derived_state = "T", - metadata = charToRaw("abc") + time = 0.125, + derived_state = "AC", + metadata = binary_metadata ) - expect_equal(new_id, as.integer(n_before)) # since IDs are 0-based - expect_equal( + expect_identical(new_id, as.integer(n_before)) # IDs are 0-based + expect_identical( + rtsk_mutation_table_get_row(tc_xptr, new_id), + list( + id = new_id, + site = site, + node = node, + parent = -1L, + time = 0.125, + derived_state = "AC", + metadata = binary_metadata, + edge = -1L, + inherited_state = NULL + ) + ) + expect_identical( as.integer(rtsk_table_collection_get_num_mutations(tc_xptr)), as.integer(n_before) + 1L ) - expect_equal( + expect_identical( as.integer(rtsk_table_collection_metadata_length(tc_xptr)[["mutations"]]), - as.integer(m_before) + 3L + as.integer(m_before) + length(binary_metadata) ) tc <- TableCollection$new(xptr = tc_xptr) n_before_method <- tc$num_mutations() new_id_method <- tc$mutation_table_add_row( - site = site, - node = node, - derived_state = "C" + site = as.numeric(site), + node = as.numeric(node + 1L), + derived_state = "C", + parent = as.numeric(new_id) + ) + expect_identical(new_id_method, as.integer(n_before_method)) + new_row_method <- tc$mutation_table_get_row(new_id_method) + expect_identical( + new_row_method[names(new_row_method) != "time"], + list( + id = new_id_method, + site = site, + node = node + 1L, + derived_state = "C", + parent = new_id, + metadata = raw() + ) ) - expect_equal(new_id_method, as.integer(n_before_method)) - expect_equal( + expect_true(is.nan(new_row_method$time)) + expect_identical( as.integer(tc$num_mutations()), as.integer(n_before_method) + 1L ) @@ -953,19 +2369,34 @@ test_that("mutation_table_add_row wrapper expands the table collection and handl derived_state = "", metadata = NULL ) - expect_equal(id0, n0) - expect_equal( + expect_identical(id0, n0) + empty_row <- rtsk_mutation_table_get_row(tc_xptr, id0) + expect_identical( + empty_row[names(empty_row) != "time"], + list( + id = id0, + site = site, + node = node, + parent = -1L, + derived_state = "", + metadata = raw(), + edge = -1L, + inherited_state = NULL + ) + ) + expect_true(is.nan(empty_row$time)) + expect_identical( as.integer(rtsk_table_collection_get_num_mutations(tc_xptr)), n0 + 1L ) - expect_equal( + expect_identical( as.integer(rtsk_table_collection_metadata_length(tc_xptr)[["mutations"]]), m0 ) tc <- TableCollection$new(xptr = tc_xptr) n_before_method <- as.integer(tc$num_mutations()) - expect_no_error( + null_id <- expect_no_error( tc$mutation_table_add_row( site = site, node = node, @@ -975,12 +2406,29 @@ test_that("mutation_table_add_row wrapper expands the table collection and handl metadata = NULL ) ) - expect_equal(as.integer(tc$num_mutations()), n_before_method + 1L) + null_row <- tc$mutation_table_get_row(null_id) + expect_identical(null_row$parent, -1L) + expect_true(is.nan(null_row$time)) + expect_identical(null_row$metadata, raw()) + expect_identical(as.integer(tc$num_mutations()), n_before_method + 1L) + + nan_id <- expect_no_error( + tc$mutation_table_add_row( + site = as.numeric(site), + node = as.numeric(node), + parent = -1, + time = NaN, + derived_state = "T", + metadata = NULL + ) + ) + expect_true(is.nan(tc$mutation_table_get_row(nan_id)$time)) + expect_identical(as.integer(tc$num_mutations()), n_before_method + 2L) m_before_char <- as.integer(rtsk_table_collection_metadata_length(tc$xptr)[[ "mutations" ]]) - expect_no_warning( + character_metadata_id <- expect_no_warning( tc$mutation_table_add_row( site = site, node = node, @@ -988,6 +2436,10 @@ test_that("mutation_table_add_row wrapper expands the table collection and handl metadata = "abc" ) ) + expect_identical( + tc$mutation_table_get_row(character_metadata_id)$metadata, + charToRaw("abc") + ) expect_equal( as.integer(rtsk_table_collection_metadata_length(tc$xptr)[["mutations"]]), m_before_char + 3L @@ -995,7 +2447,7 @@ test_that("mutation_table_add_row wrapper expands the table collection and handl m_before_raw <- as.integer(rtsk_table_collection_metadata_length(tc$xptr)[[ "mutations" ]]) - expect_no_error( + raw_metadata_id <- expect_no_error( tc$mutation_table_add_row( site = site, node = node, @@ -1003,6 +2455,10 @@ test_that("mutation_table_add_row wrapper expands the table collection and handl metadata = charToRaw("xyz") ) ) + expect_identical( + tc$mutation_table_get_row(raw_metadata_id)$metadata, + charToRaw("xyz") + ) expect_equal( as.integer(rtsk_table_collection_metadata_length(tc$xptr)[["mutations"]]), m_before_raw + 3L @@ -1010,87 +2466,797 @@ test_that("mutation_table_add_row wrapper expands the table collection and handl expect_error( tc$mutation_table_add_row(site = NULL, node = node, derived_state = "T"), - regexp = "site must be a non-NA integer scalar!" + regexp = "site cannot be NULL\\." ) expect_error( tc$mutation_table_add_row(site = site, node = NULL, derived_state = "T"), - regexp = "node must be a non-NA integer scalar!" + regexp = "node cannot be NULL\\." + ) + + invalid_ids <- list( + NA_integer_, + -1L, + 0.5, + Inf, + c(0L, 1L), + "0", + as.numeric(.Machine$integer.max) + 1 + ) + for (name in c("site", "node")) { + for (value in invalid_ids) { + args <- list(site = site, node = node, derived_state = "T") + args[[name]] <- value + expect_error( + do.call(tc$mutation_table_add_row, args), + regexp = paste0( + name, + " must be a non-NA, non-negative integer scalar no greater than [.]Machine[$]integer[.]max!" + ) + ) + } + } + + invalid_parents <- list( + NA_integer_, + -2L, + 0.5, + Inf, + c(-1L, 0L), + "0", + as.numeric(.Machine$integer.max) + 1 + ) + for (parent in invalid_parents) { + expect_error( + tc$mutation_table_add_row( + site = site, + node = node, + parent = parent, + derived_state = "T" + ), + regexp = "parent must be NULL or a non-NA integer scalar within 32-bit range \\(>= -1\\)!" + ) + } + + invalid_times <- list(NA_real_, c(0, 1), "foo", TRUE) + for (time in invalid_times) { + expect_error( + tc$mutation_table_add_row( + site = site, + node = node, + time = time, + derived_state = "T" + ), + regexp = "time must be NaN, NULL, or a non-NA numeric scalar!" + ) + } + + invalid_states <- list( + NULL, + NA_character_, + character(), + c("a", "b"), + charToRaw("A"), + 1L + ) + for (derived_state in invalid_states) { + expect_error( + tc$mutation_table_add_row( + site = site, + node = node, + derived_state = derived_state + ), + regexp = "derived_state must be a length-1 non-NA character string!" + ) + } + + invalid_metadata <- list(c("a", "b"), NA_character_, 1L) + for (metadata in invalid_metadata) { + expect_error( + tc$mutation_table_add_row( + site = site, + node = node, + derived_state = "T", + metadata = metadata + ), + regexp = "metadata must be NULL, a length-1 non-NA character string, or a raw vector!" + ) + } + expect_error( + test_rtsk_mutation_table_add_row_forced_error(tc$xptr), + regexp = "TSK_ERR_TABLE_OVERFLOW" + ) +}) + +test_that("population_table_add_row wrapper expands the table collection and handles inputs", { + ts_file <- system.file("examples/test.trees", package = "RcppTskit") + tc_xptr <- rtsk_table_collection_load(ts_file) + + n_before <- rtsk_table_collection_get_num_populations(tc_xptr) + m_before <- rtsk_table_collection_metadata_length(tc_xptr)$populations + + binary_metadata <- as.raw(c(0x00, 0x7f, 0x80, 0xff)) + new_id <- rtsk_population_table_add_row( + tc_xptr, + metadata = binary_metadata + ) + expect_identical(new_id, as.integer(n_before)) # IDs are 0-based + expect_identical( + rtsk_population_table_get_row(tc_xptr, new_id), + list(id = new_id, metadata = binary_metadata) + ) + expect_identical( + as.integer(rtsk_table_collection_get_num_populations(tc_xptr)), + as.integer(n_before) + 1L ) + expect_identical( + as.integer(rtsk_table_collection_metadata_length(tc_xptr)$populations), + as.integer(m_before) + length(binary_metadata) + ) + + tc <- TableCollection$new(xptr = tc_xptr) + n_before_method <- as.integer(tc$num_populations()) + empty_id <- expect_no_error(tc$population_table_add_row()) + expect_identical(empty_id, n_before_method) + expect_identical( + tc$population_table_get_row(empty_id), + list(id = empty_id, metadata = raw()) + ) + expect_identical(as.integer(tc$num_populations()), n_before_method + 1L) + + m_before_char <- as.integer( + rtsk_table_collection_metadata_length(tc$xptr)$populations + ) + character_metadata_id <- expect_no_warning( + tc$population_table_add_row(metadata = "xyz") + ) + expect_identical( + tc$population_table_get_row(character_metadata_id)$metadata, + charToRaw("xyz") + ) + expect_identical( + as.integer(rtsk_table_collection_metadata_length(tc$xptr)$populations), + m_before_char + 3L + ) + + raw_metadata <- charToRaw("raw") + raw_metadata_id <- expect_no_error( + tc$population_table_add_row(metadata = raw_metadata) + ) + expect_identical( + tc$population_table_get_row(raw_metadata_id)$metadata, + raw_metadata + ) + + invalid_metadata <- list(c("a", "b"), NA_character_, 1L) + for (metadata in invalid_metadata) { + expect_error( + tc$population_table_add_row(metadata = metadata), + regexp = "metadata must be NULL, a length-1 non-NA character string, or a raw vector!" + ) + } expect_error( - tc$mutation_table_add_row( - site = site, - node = node, - parent = NA_integer_, - derived_state = "T" - ), - regexp = "parent must be -1L, NULL, or a non-NA integer scalar!" + test_rtsk_population_table_add_row_forced_error(tc$xptr), + regexp = "TSK_ERR_TABLE_OVERFLOW" + ) +}) + +test_that("migration_table_add_row wrapper expands the table collection and handles inputs", { + ts_file <- system.file("examples/test.trees", package = "RcppTskit") + tc_xptr <- rtsk_table_collection_load(ts_file) + + n_before <- rtsk_table_collection_get_num_migrations(tc_xptr) + m_before <- rtsk_table_collection_metadata_length(tc_xptr)$migrations + + binary_metadata <- as.raw(c(0x00, 0x7f, 0x80, 0xff)) + new_id <- rtsk_migration_table_add_row( + tc = tc_xptr, + left = 0.25, + right = 1.75, + node = 0L, + source = 0L, + dest = 0L, + time = 1.25, + metadata = binary_metadata + ) + expect_identical(new_id, as.integer(n_before)) # IDs are 0-based + expect_identical( + rtsk_migration_table_get_row(tc_xptr, new_id), + list( + id = new_id, + left = 0.25, + right = 1.75, + node = 0L, + source = 0L, + dest = 0L, + time = 1.25, + metadata = binary_metadata + ) + ) + expect_identical( + as.integer(rtsk_table_collection_get_num_migrations(tc_xptr)), + as.integer(n_before) + 1L + ) + expect_identical( + as.integer(rtsk_table_collection_metadata_length(tc_xptr)$migrations), + as.integer(m_before) + length(binary_metadata) + ) + + tc <- TableCollection$new(xptr = tc_xptr) + n_before_method <- as.integer(tc$num_migrations()) + empty_id <- tc$migration_table_add_row( + left = 2, + right = 3, + node = 1, + source = 0, + dest = 0, + time = 2.5 + ) + expect_identical(empty_id, n_before_method) + expect_identical( + tc$migration_table_get_row(empty_id), + list( + id = empty_id, + left = 2, + right = 3, + node = 1L, + source = 0L, + dest = 0L, + time = 2.5, + metadata = raw() + ) + ) + expect_identical(as.integer(tc$num_migrations()), n_before_method + 1L) + + character_metadata_id <- tc$migration_table_add_row( + left = 3, + right = 4, + node = 0L, + source = 0L, + dest = 0L, + time = 3, + metadata = "abc" + ) + expect_identical( + tc$migration_table_get_row(character_metadata_id)$metadata, + charToRaw("abc") + ) + + invalid_coordinates <- list(NULL, NA_real_, NaN, c(0, 1), "0", TRUE) + for (name in c("left", "right")) { + for (value in invalid_coordinates) { + args <- list( + left = 4, + right = 5, + node = 0L, + source = 0L, + dest = 0L, + time = 1 + ) + args[name] <- list(value) + expect_error( + do.call(tc$migration_table_add_row, args), + regexp = paste0(name, " must be a non-NA numeric scalar!") + ) + } + } + + for (right in c(4, 3)) { + expect_error( + tc$migration_table_add_row( + left = 4, + right = right, + node = 0L, + source = 0L, + dest = 0L, + time = 1 + ), + regexp = "left must be strictly less than right!" + ) + } + + for (name in c("node", "source", "dest")) { + args <- list( + left = 4, + right = 5, + node = 0L, + source = 0L, + dest = 0L, + time = 1 + ) + args[name] <- list(NULL) + expect_error( + do.call(tc$migration_table_add_row, args), + regexp = paste0(name, " cannot be NULL\\.") + ) + } + + invalid_ids <- list( + NA_integer_, + -1L, + 0.5, + Inf, + c(0L, 1L), + "0", + as.numeric(.Machine$integer.max) + 1 + ) + for (name in c("node", "source", "dest")) { + for (value in invalid_ids) { + args <- list( + left = 4, + right = 5, + node = 0L, + source = 0L, + dest = 0L, + time = 1 + ) + args[[name]] <- value + expect_error( + do.call(tc$migration_table_add_row, args), + regexp = paste0( + name, + " must be a non-NA, non-negative integer scalar no greater than [.]Machine[$]integer[.]max!" + ) + ) + } + } + + invalid_times <- list(NULL, NA_real_, NaN, c(0, 1), "1", TRUE) + for (time in invalid_times) { + args <- list( + left = 4, + right = 5, + node = 0L, + source = 0L, + dest = 0L, + time = time + ) + expect_error( + do.call(tc$migration_table_add_row, args), + regexp = "time must be a non-NA numeric scalar!" + ) + } + + invalid_metadata <- list(c("a", "b"), NA_character_, 1L) + for (metadata in invalid_metadata) { + expect_error( + tc$migration_table_add_row( + left = 4, + right = 5, + node = 0L, + source = 0L, + dest = 0L, + time = 1, + metadata = metadata + ), + regexp = "metadata must be NULL, a length-1 non-NA character string, or a raw vector!" + ) + } + + raw_metadata <- charToRaw("raw") + raw_metadata_id <- tc$migration_table_add_row( + left = 4, + right = 5, + node = 0L, + source = 0L, + dest = 0L, + time = 4, + metadata = raw_metadata + ) + expect_identical( + tc$migration_table_get_row(raw_metadata_id)$metadata, + raw_metadata ) + expect_error( - tc$mutation_table_add_row( - site = site, - node = node, - time = c(0, 1), - derived_state = "T" - ), - regexp = "time must be NaN, NULL, or a non-NA numeric scalar!" + test_rtsk_migration_table_add_row_forced_error(tc$xptr), + regexp = "TSK_ERR_TABLE_OVERFLOW" + ) +}) + +test_that("provenance_table_add_row wrapper expands the table collection and handles inputs", { + ts_file <- system.file("examples/test.trees", package = "RcppTskit") + tc_xptr <- rtsk_table_collection_load(ts_file) + + n_before <- rtsk_table_collection_get_num_provenances(tc_xptr) + timestamp <- "2025-01-01T00:00:00Z" + record <- '{"software":"RcppTskit"}' + new_id <- rtsk_provenance_table_add_row( + tc = tc_xptr, + timestamp = timestamp, + record = record + ) + expect_identical(new_id, as.integer(n_before)) # IDs are 0-based + expect_identical( + rtsk_provenance_table_get_row(tc_xptr, new_id), + list(id = new_id, timestamp = timestamp, record = record) + ) + expect_identical( + as.integer(rtsk_table_collection_get_num_provenances(tc_xptr)), + as.integer(n_before) + 1L ) + + tc <- TableCollection$new(xptr = tc_xptr) + n_before_method <- as.integer(tc$num_provenances()) + timestamp_method <- "2025-01-02T00:00:00Z" + record_method <- '{"software":"RcppTskit","action":"test"}' + prov_id_method <- tc$provenance_table_add_row( + record = record_method, + timestamp = timestamp_method + ) + expect_identical(prov_id_method, n_before_method) + expect_identical( + tc$provenance_table_get_row(prov_id_method), + list( + id = prov_id_method, + timestamp = timestamp_method, + record = record_method + ) + ) + expect_identical(as.integer(tc$num_provenances()), n_before_method + 1L) + + # Positional args follow Python API order: record, timestamp + positional_record <- '{"software":"RcppTskit","action":"positional"}' + positional_timestamp <- "2025-01-03T00:00:00Z" + prov_id_positional <- tc$provenance_table_add_row( + positional_record, + positional_timestamp + ) + expect_identical( + tc$provenance_table_get_row(prov_id_positional), + list( + id = prov_id_positional, + timestamp = positional_timestamp, + record = positional_record + ) + ) + + # If timestamp is omitted, method generates current UTC ISO8601 timestamp. + auto_record <- '{"software":"RcppTskit","action":"auto-ts"}' + prov_id_auto_ts <- tc$provenance_table_add_row( + record = auto_record + ) + prov_row_auto_ts <- tc$provenance_table_get_row(prov_id_auto_ts) + expect_identical(prov_row_auto_ts$id, prov_id_auto_ts) + expect_identical(prov_row_auto_ts$record, auto_record) + expect_match( + prov_row_auto_ts$timestamp, + "^[0-9]{4}-[0-9]{2}-[0-9]{2}T[0-9]{2}:[0-9]{2}:[0-9]{2}\\.[0-9]{6}Z$" + ) + + invalid_records <- list( + NULL, + NA_character_, + character(), + c("{}", "{}"), + charToRaw("{}"), + 1L + ) + for (record in invalid_records) { + expect_error( + tc$provenance_table_add_row(record = record), + regexp = "record must be a length-1 non-NA character string!" + ) + } + + invalid_timestamps <- list( + NA_character_, + character(), + c("2025-01-01", "2025-01-02"), + charToRaw("2025-01-01"), + 1L + ) + for (timestamp in invalid_timestamps) { + expect_error( + tc$provenance_table_add_row(record = "{}", timestamp = timestamp), + regexp = "timestamp must be a length-1 non-NA character string!" + ) + } + expect_error( - tc$mutation_table_add_row( - site = site, - node = node, - time = NA_real_, - derived_state = "T" - ), - regexp = "time must be NaN, NULL, or a non-NA numeric scalar!" + test_rtsk_provenance_table_add_row_forced_error(tc$xptr), + regexp = "TSK_ERR_TABLE_OVERFLOW" + ) +}) + +test_that("get_row wrappers return expected fields and validate indices", { + ts_file <- system.file("examples/test.trees", package = "RcppTskit") + tc_xptr <- rtsk_table_collection_load(ts_file) + tc <- TableCollection$new(xptr = tc_xptr) + + indiv_low <- rtsk_individual_table_get_row(tc_xptr, 0L) + indiv_method <- tc$individual_table_get_row(0) + expect_equal( + sort(names(indiv_low)), + c("flags", "id", "location", "metadata", "nodes", "parents") + ) + expect_equal( + sort(names(indiv_method)), + c("flags", "id", "location", "metadata", "parents") + ) + expect_equal( + indiv_method, + indiv_low[c("id", "flags", "location", "parents", "metadata")] + ) + + edge_low <- rtsk_edge_table_get_row(tc_xptr, 0L) + edge_method <- tc$edge_table_get_row(0) + expect_equal( + sort(names(edge_low)), + c("child", "id", "left", "metadata", "parent", "right") + ) + expect_equal(edge_method, edge_low) + + site_low <- rtsk_site_table_get_row(tc_xptr, 0L) + site_method <- tc$site_table_get_row(0) + expect_equal( + sort(names(site_low)), + c("ancestral_state", "id", "metadata", "mutations", "position") + ) + expect_equal( + sort(names(site_method)), + c("ancestral_state", "id", "metadata", "position") + ) + expect_equal( + site_method, + site_low[c("id", "position", "ancestral_state", "metadata")] + ) + expect_null(site_low$mutations) + + mut_low <- rtsk_mutation_table_get_row(tc_xptr, 0L) + mut_method <- tc$mutation_table_get_row(0) + expect_equal( + sort(names(mut_low)), + c( + "derived_state", + "edge", + "id", + "inherited_state", + "metadata", + "node", + "parent", + "site", + "time" + ) + ) + expect_equal( + sort(names(mut_method)), + c("derived_state", "id", "metadata", "node", "parent", "site", "time") + ) + expect_equal( + mut_method, + mut_low[c( + "id", + "site", + "node", + "derived_state", + "parent", + "metadata", + "time" + )] + ) + + pop_low <- rtsk_population_table_get_row(tc_xptr, 0L) + pop_method <- tc$population_table_get_row(0) + expect_equal(sort(names(pop_low)), c("id", "metadata")) + expect_equal(pop_method, pop_low) + + if (tc$num_migrations() == 0L) { + tc$migration_table_add_row( + left = 0, + right = 1, + node = 0L, + source = 0L, + dest = 0L, + time = 1 + ) + } + mig_low <- rtsk_migration_table_get_row(tc_xptr, 0L) + mig_method <- tc$migration_table_get_row(0) + expect_equal( + sort(names(mig_low)), + c("dest", "id", "left", "metadata", "node", "right", "source", "time") + ) + expect_equal(mig_method, mig_low) + + if (tc$num_provenances() == 0L) { + tc$provenance_table_add_row( + record = "{\"software\":\"RcppTskit\"}", + timestamp = "2025-01-01T00:00:00Z" + ) + } + prov_low <- rtsk_provenance_table_get_row(tc_xptr, 0L) + prov_method <- tc$provenance_table_get_row(0) + expect_equal(sort(names(prov_low)), c("id", "record", "timestamp")) + expect_equal(prov_method, prov_low) + + # exercise metadata/location/parents copy paths in individual get_row + indiv_new <- tc$individual_table_add_row( + location = c(1.25, -2.5), + parents = 0L, + metadata = charToRaw("imd") + ) + indiv_new_low <- rtsk_individual_table_get_row(tc_xptr, indiv_new) + expect_equal(indiv_new_low$location, c(1.25, -2.5)) + expect_equal(indiv_new_low$parents, 0L) + expect_equal(indiv_new_low$metadata, charToRaw("imd")) + expect_length(indiv_new_low$nodes, 0L) + + # exercise metadata copy path in edge get_row + edge_new <- tc$edge_table_add_row( + left = 0, + right = 0.25, + parent = 0L, + child = 1L, + metadata = charToRaw("emd") + ) + edge_new_low <- rtsk_edge_table_get_row(tc_xptr, edge_new) + expect_equal(edge_new_low$metadata, charToRaw("emd")) + + # exercise metadata copy path in site get_row + site_new <- tc$site_table_add_row( + position = 123.5, + ancestral_state = "A", + metadata = charToRaw("smd") + ) + site_new_low <- rtsk_site_table_get_row(tc_xptr, site_new) + expect_equal(site_new_low$metadata, charToRaw("smd")) + expect_null(site_new_low$mutations) + + # exercise metadata copy path in mutation get_row + mut_new <- tc$mutation_table_add_row( + site = site_new, + node = 0L, + derived_state = "T", + metadata = charToRaw("mmd") ) + mut_new_low <- rtsk_mutation_table_get_row(tc_xptr, mut_new) + expect_equal(mut_new_low$metadata, charToRaw("mmd")) + expect_equal(mut_new_low$edge, -1L) + + # exercise metadata copy path in population get_row + pop_new <- tc$population_table_add_row(metadata = charToRaw("pmd")) + pop_new_low <- rtsk_population_table_get_row(tc_xptr, pop_new) + expect_equal(pop_new_low$metadata, charToRaw("pmd")) + + # exercise metadata copy path in migration get_row + mig_new <- tc$migration_table_add_row( + left = 0.5, + right = 0.75, + node = 0L, + source = 0L, + dest = 0L, + time = 2.0, + metadata = charToRaw("gmd") + ) + mig_new_low <- rtsk_migration_table_get_row(tc_xptr, mig_new) + expect_equal(mig_new_low$metadata, charToRaw("gmd")) + expect_error( - tc$mutation_table_add_row( - site = site, - node = node, - time = "foo", - derived_state = "T" - ), - regexp = "time must be NaN, NULL, or a non-NA numeric scalar!" + tc$individual_table_get_row(0.5), + regexp = "index must be a non-NA, non-negative integer scalar no greater than [.]Machine[$]integer[.]max!" ) expect_error( - tc$mutation_table_add_row( - site = site, - node = node, - derived_state = c("a", "b") - ), - regexp = "derived_state must be a length-1 non-NA character string!" + rtsk_individual_table_get_row(tc_xptr, 999999L), + regexp = "OUT_OF_BOUNDS" ) + expect_error(rtsk_edge_table_get_row(tc_xptr, -1L), regexp = "OUT_OF_BOUNDS") expect_error( - tc$mutation_table_add_row( - site = site, - node = node, - derived_state = NA_character_ - ), - regexp = "derived_state must be a length-1 non-NA character string!" + rtsk_site_table_get_row(tc_xptr, 999999L), + regexp = "OUT_OF_BOUNDS" ) expect_error( - tc$mutation_table_add_row( - site = site, - node = node, - derived_state = charToRaw("A") - ), - regexp = "derived_state must be a length-1 non-NA character string!" + rtsk_mutation_table_get_row(tc_xptr, -1L), + regexp = "OUT_OF_BOUNDS" ) expect_error( - tc$mutation_table_add_row(site = site, node = node, derived_state = 1L), - regexp = "derived_state must be a length-1 non-NA character string!" + rtsk_population_table_get_row(tc_xptr, -1L), + regexp = "OUT_OF_BOUNDS" ) expect_error( - tc$mutation_table_add_row( - site = site, - node = node, - derived_state = "T", - metadata = c("a", "b") - ), - regexp = "metadata must be NULL, a raw vector, or a length-1 non-NA character string!" + rtsk_migration_table_get_row(tc_xptr, -1L), + regexp = "OUT_OF_BOUNDS" ) expect_error( - test_rtsk_mutation_table_add_row_forced_error(tc$xptr), - regexp = "TSK_ERR_TABLE_OVERFLOW" + rtsk_provenance_table_get_row(tc_xptr, -1L), + regexp = "OUT_OF_BOUNDS" ) }) + +test_that("add_row and get_row round-trip works across tables", { + ts_file <- system.file("examples/test.trees", package = "RcppTskit") + tc <- tc_load(ts_file) + + ind_id <- tc$individual_table_add_row( + flags = 1L, + location = c(9.5, -3.25), + parents = 0L, + metadata = "imd" + ) + ind_row <- tc$individual_table_get_row(ind_id) + expect_equal(ind_row$id, ind_id) + expect_equal(ind_row$flags, 1L) + expect_equal(ind_row$location, c(9.5, -3.25)) + expect_equal(ind_row$parents, 0L) + expect_equal(ind_row$metadata, charToRaw("imd")) + + node_id <- tc$node_table_add_row( + flags = 0L, + time = 0.125, + population = 0L, + individual = ind_id, + metadata = "nmd" + ) + node_row <- tc$node_table_get_row(node_id) + expect_equal(node_row$id, node_id) + expect_equal(node_row$time, 0.125) + expect_equal(node_row$population, 0L) + expect_equal(node_row$individual, ind_id) + expect_equal(node_row$metadata, charToRaw("nmd")) + + edge_id <- tc$edge_table_add_row( + left = 0, + right = 0.5, + parent = 16L, + child = node_id, + metadata = "emd" + ) + edge_row <- tc$edge_table_get_row(edge_id) + expect_equal(edge_row$id, edge_id) + expect_equal(edge_row$parent, 16L) + expect_equal(edge_row$child, node_id) + expect_equal(edge_row$metadata, charToRaw("emd")) + + site_id <- tc$site_table_add_row( + position = 9.75, + ancestral_state = "A", + metadata = "smd" + ) + site_row <- tc$site_table_get_row(site_id) + expect_equal(site_row$id, site_id) + expect_equal(site_row$position, 9.75) + expect_equal(site_row$ancestral_state, "A") + expect_equal(site_row$metadata, charToRaw("smd")) + + mut_id <- tc$mutation_table_add_row( + site = site_id, + node = node_id, + derived_state = "T", + parent = -1L, + metadata = "mmd", + time = 0.1 + ) + mut_row <- tc$mutation_table_get_row(mut_id) + expect_equal(mut_row$id, mut_id) + expect_equal(mut_row$site, site_id) + expect_equal(mut_row$node, node_id) + expect_equal(mut_row$derived_state, "T") + expect_equal(mut_row$metadata, charToRaw("mmd")) + + pop_id <- tc$population_table_add_row(metadata = "pmd") + pop_row <- tc$population_table_get_row(pop_id) + expect_equal(pop_row$id, pop_id) + expect_equal(pop_row$metadata, charToRaw("pmd")) + + mig_id <- tc$migration_table_add_row( + left = 0, + right = 0.5, + node = node_id, + source = 0L, + dest = 0L, + time = 0.2, + metadata = "gmd" + ) + mig_row <- tc$migration_table_get_row(mig_id) + expect_equal(mig_row$id, mig_id) + expect_equal(mig_row$node, node_id) + expect_equal(mig_row$metadata, charToRaw("gmd")) + + prov_id <- tc$provenance_table_add_row( + record = "{\"software\":\"RcppTskit\"}", + timestamp = "2026-01-01T00:00:00Z" + ) + prov_row <- tc$provenance_table_get_row(prov_id) + expect_equal(prov_row$id, prov_id) + expect_equal(prov_row$timestamp, "2026-01-01T00:00:00Z") + expect_equal(prov_row$record, "{\"software\":\"RcppTskit\"}") +}) diff --git a/RcppTskit/tests/testthat/test_TreeSequence.R b/RcppTskit/tests/testthat/test_TreeSequence.R index 1b55303..8c70c2e 100644 --- a/RcppTskit/tests/testthat/test_TreeSequence.R +++ b/RcppTskit/tests/testthat/test_TreeSequence.R @@ -40,3 +40,317 @@ test_that("TreeSequence$new() works", { regexp = "external pointer \\(xptr\\) must be an object of externalptr class!" ) }) + +test_that("TreeSequence$simplify returns a new tree sequence and optional map", { + ts_file <- system.file("examples/test.trees", package = "RcppTskit") + ts <- ts_load(ts_file) + nodes_before <- as.integer(ts$num_nodes()) + samples_before <- ts$samples() + provenances_before <- as.integer(ts$num_provenances()) + + simplified <- ts$simplify(samples = 0:3) + expect_true(is(simplified, "TreeSequence")) + expect_lt(as.integer(simplified$num_nodes()), nodes_before) + expect_equal(simplified$samples(), 0:3) + expect_equal( + as.integer(simplified$num_provenances()), + provenances_before + 1L + ) + + expect_equal(as.integer(ts$num_nodes()), nodes_before) + expect_equal(ts$samples(), samples_before) + expect_equal(as.integer(ts$num_provenances()), provenances_before) + + mapped <- ts$simplify(samples = 0:3, map_nodes = TRUE) + expect_named(mapped, c("tree_sequence", "node_map")) + expect_true(is(mapped$tree_sequence, "TreeSequence")) + expect_type(mapped$node_map, "integer") + expect_length(mapped$node_map, nodes_before) + expect_equal(mapped$node_map[1:4], 0:3) + expect_true(all(mapped$node_map[-(1:4)] >= -1L)) + expect_true(any(mapped$node_map == -1L)) + + without_provenance <- ts$simplify( + samples = 0:3, + record_provenance = FALSE + ) + expect_equal( + as.integer(without_provenance$num_provenances()), + provenances_before + ) +}) + +test_that("TreeSequence$simplify validates and forwards options", { + ts_file <- system.file("examples/test.trees", package = "RcppTskit") + ts <- ts_load(ts_file) + + expect_error(ts$simplify(map_nodes = NA), "map_nodes must be TRUE/FALSE!") + expect_error( + ts$simplify(samples = c(0L, 0L)), + "Duplicate sample|TSK_ERR_DUPLICATE_SAMPLE" + ) + expect_error( + ts$simplify(keep_unary = TRUE, keep_unary_in_individuals = TRUE), + "keep_unary and keep_unary_in_individuals cannot both be TRUE!" + ) + + default <- ts$simplify(samples = 0:3, record_provenance = FALSE) + keep_unary <- ts$simplify( + samples = 0:3, + keep_unary = TRUE, + record_provenance = FALSE + ) + expect_gt(as.integer(keep_unary$num_nodes()), as.integer(default$num_nodes())) + + unfiltered_nodes <- ts$simplify( + samples = 0:3, + filter_nodes = FALSE, + map_nodes = TRUE, + record_provenance = FALSE + ) + expect_equal(as.integer(unfiltered_nodes$tree_sequence$num_nodes()), 39L) + expect_equal(unfiltered_nodes$node_map, seq.int(0L, 38L)) +}) + +test_that("TreeSequence$variants() iterates over sites", { + ts_file <- system.file("examples/test.trees", package = "RcppTskit") + ts <- ts_load(ts_file) + n_sites <- as.integer(ts$num_sites()) + + it <- ts$variants() + seen <- 0L + repeat { + v <- it$next_variant() + if (is.null(v)) { + break + } + seen <- seen + 1L + expect_equal( + sort(names(v)), + c("alleles", "genotypes", "has_missing_data", "position", "site_id") + ) + } + expect_equal(seen, n_sites) +}) + +test_that("TreeSequence$variants() supports interval and samples", { + ts_file <- system.file("examples/test.trees", package = "RcppTskit") + ts <- ts_load(ts_file) + + full_it <- ts$variants() + first <- full_it$next_variant() + second <- full_it$next_variant() + expect_false(is.null(first)) + expect_false(is.null(second)) + + it_interval <- ts$variants( + left = first$position, + right = second$position + 1e-12 + ) + v1 <- it_interval$next_variant() + v2 <- it_interval$next_variant() + v3 <- it_interval$next_variant() + expect_equal(v1$site_id, first$site_id) + expect_equal(v2$site_id, second$site_id) + expect_null(v3) + + it_samples <- ts$variants(samples = c(0L, 1L, 2L)) + v_samples <- it_samples$next_variant() + expect_length(v_samples$genotypes, 3L) +}) + +test_that("TreeSequence$variants() validates compatibility args", { + ts_file <- system.file("examples/test.trees", package = "RcppTskit") + ts <- ts_load(ts_file) + + expect_error(ts$variants(copy = NA), "copy must be TRUE/FALSE") + expect_error(ts$variants(copy = "yes"), "copy must be TRUE/FALSE") + expect_error(ts$variants(copy = FALSE), "copy = FALSE is not supported yet") + expect_error( + ts$variants(impute_missing_data = NA), + "impute_missing_data must be TRUE/FALSE or NULL" + ) + expect_error( + ts$variants(impute_missing_data = "yes"), + "impute_missing_data must be TRUE/FALSE or NULL" + ) + expect_warning( + ts$variants(impute_missing_data = TRUE), + "impute_missing_data is deprecated" + ) + expect_error( + ts$variants(isolated_as_missing = TRUE, impute_missing_data = TRUE), + "inconsistent" + ) +}) + +test_that("TreeSequence$samples() returns sample node IDs and supports filters", { + ts_file <- system.file("examples/test.trees", package = "RcppTskit") + ts <- ts_load(ts_file) + + samples <- ts$samples() + expect_type(samples, "integer") + expect_length(samples, as.integer(ts$num_samples())) + expect_true(all(samples >= 0L)) + # We got the sample ID from inst/examples/create_test.trees.{R,py} + expect_true(all(samples == 0L:15L)) + + samples_low <- rtsk_treeseq_get_samples(ts$xptr) + expect_identical(samples, samples_low) + + expect_error( + ts$samples(population = -1L), + regexp = "population must be NULL or a non-NA, non-negative integer scalar no greater than [.]Machine[$]integer[.]max!" + ) + expect_error( + ts$samples(population = 0.5), + regexp = "population must be NULL or a non-NA, non-negative integer scalar no greater than [.]Machine[$]integer[.]max!" + ) + + tc <- ts$dump_tables() + sample_rows <- lapply(samples, function(id) { + tc$node_table_get_row(as.integer(id)) + }) + sample_population <- vapply( + sample_rows, + function(row) row$population, + integer(1) + ) + sample_time <- vapply(sample_rows, function(row) row$time, numeric(1)) + + expect_identical( + ts$samples(population = 0L), + samples[sample_population == 0L] + ) + expect_false(is.unsorted(ts$samples(population = 0L))) + + time0 <- sample_time[1] + tol0 <- 1e-08 + 1e-05 * abs(time0) + expect_identical( + ts$samples(time = time0), + samples[abs(sample_time - time0) <= tol0] + ) + expect_identical(ts$samples(time = Inf), integer()) + expect_identical(ts$samples(time = -Inf), integer()) + + interval_end <- min(sample_time) + 1e-6 + expect_identical( + ts$samples(time = c(min(sample_time), interval_end)), + samples[sample_time >= min(sample_time) & sample_time < interval_end] + ) + expect_false( + is.unsorted(ts$samples(time = c(min(sample_time), interval_end))) + ) + + expect_error( + ts$samples(time = c(0, 0)), + regexp = "time_interval max is less than or equal to min\\." + ) + expect_error( + ts$samples(time = c(0, 1, 2)), + regexp = "time must be either a single value or a pair of values \\(min_time, max_time\\)\\." + ) + expect_error( + ts$samples(time = NA_real_), + regexp = "time must be either a single value or a pair of values \\(min_time, max_time\\)\\." + ) + expect_error( + ts$samples(time = NaN), + regexp = "time must be either a single value or a pair of values \\(min_time, max_time\\)\\." + ) + expect_error( + ts$samples(time = 1 + 1i), + regexp = "time must be either a single value or a pair of values \\(min_time, max_time\\)\\." + ) + expect_error( + ts$samples(time = matrix(c(0, 1), nrow = 1)), + regexp = "time must be either a single value or a pair of values \\(min_time, max_time\\)\\." + ) + expect_error( + ts$samples(time = array(c(0, 1), dim = c(1, 1, 2))), + regexp = "time must be either a single value or a pair of values \\(min_time, max_time\\)\\." + ) +}) + +test_that("rtsk_treeseq_get_samples() safely copies sample IDs", { + ts_file <- system.file("examples/test.trees", package = "RcppTskit") + ts <- ts_load(ts_file) + + zero_samples <- ts$simplify( + samples = integer(), + record_provenance = FALSE + ) + expect_identical( + rtsk_treeseq_get_samples(zero_samples$xptr), + integer() + ) + + nonconsecutive_samples <- ts$simplify( + samples = c(0L, 2L), + filter_nodes = FALSE, + record_provenance = FALSE + ) + expect_identical( + rtsk_treeseq_get_samples(nonconsecutive_samples$xptr), + c(0L, 2L) + ) + + copied_samples <- rtsk_treeseq_get_samples(nonconsecutive_samples$xptr) + copied_samples[[1L]] <- 999L + expect_identical( + rtsk_treeseq_get_samples(nonconsecutive_samples$xptr), + c(0L, 2L) + ) +}) + +test_that("sample-node data helper returns aligned R-owned vectors", { + ts_file <- system.file("examples/test.trees", package = "RcppTskit") + ts <- ts_load(ts_file) + sample_data <- rtsk_treeseq_get_sample_node_data(ts$xptr) + samples <- rtsk_treeseq_get_samples(ts$xptr) + tc <- ts$dump_tables() + sample_rows <- lapply(samples, tc$node_table_get_row) + + expect_named(sample_data, c("samples", "population", "time")) + expect_type(sample_data$samples, "integer") + expect_type(sample_data$population, "integer") + expect_type(sample_data$time, "double") + expect_length(sample_data$population, length(sample_data$samples)) + expect_length(sample_data$time, length(sample_data$samples)) + expect_identical(sample_data$samples, samples) + expect_identical( + sample_data$population, + vapply(sample_rows, function(row) row$population, integer(1)) + ) + expect_identical( + sample_data$time, + vapply(sample_rows, function(row) row$time, numeric(1)) + ) + + nonconsecutive_samples <- ts$simplify( + samples = c(0L, 2L), + filter_nodes = FALSE, + record_provenance = FALSE + ) + nonconsecutive_data <- rtsk_treeseq_get_sample_node_data( + nonconsecutive_samples$xptr + ) + expect_identical(nonconsecutive_data$samples, c(0L, 2L)) + + zero_samples <- ts$simplify( + samples = integer(), + record_provenance = FALSE + ) + expect_identical( + rtsk_treeseq_get_sample_node_data(zero_samples$xptr), + list(samples = integer(), population = integer(), time = numeric()) + ) + + sample_data$samples[[1L]] <- 999L + sample_data$population[[1L]] <- 999L + sample_data$time[[1L]] <- 999 + expect_false(identical( + rtsk_treeseq_get_sample_node_data(ts$xptr), + sample_data + )) +}) diff --git a/RcppTskit/tests/testthat/test_misc.R b/RcppTskit/tests/testthat/test_misc.R index c6d2dc0..e8b6265 100644 --- a/RcppTskit/tests/testthat/test_misc.R +++ b/RcppTskit/tests/testthat/test_misc.R @@ -2,6 +2,7 @@ test_that("kastore_version() works", { v <- kastore_version() expect_true(is.integer(v)) expect_equal(names(v), c("major", "minor", "patch")) + expect_identical(v, c(major = 2L, minor = 1L, patch = 3L)) }) test_that("tskit_version() works", { @@ -53,6 +54,170 @@ test_that("validate_options() branches are covered", { ) }) +test_that("tsk_flags_t conversion rejects values outside the R integer range", { + # jarl-ignore internal_function: it's just a test + expect_identical( + RcppTskit:::test_rtsk_wrap_tsk_flags_as_int(.Machine$integer.max), + .Machine$integer.max + ) + # jarl-ignore internal_function: it's just a test + expect_error( + RcppTskit:::test_rtsk_wrap_tsk_flags_as_int( + as.numeric(.Machine$integer.max) + 1 + ), + regexp = paste0( + "cannot represent tsk_flags_t value 2147483648 as a C\\+\\+ int ", + "\\(and hence as an R integer\\); maximum supported value is 2147483647" + ) + ) + + invalid_tsk_flags <- c(-1, 1.5, Inf, NaN, 2^32) + for (value in invalid_tsk_flags) { + # jarl-ignore internal_function: it's just a test + expect_error( + RcppTskit:::test_rtsk_wrap_tsk_flags_as_int(value), + regexp = "value must be an integer within the tsk_flags_t range" + ) + } +}) + +test_that("R-side integer and row-index validators cover message branches", { + # jarl-ignore internal_function: it's just a test + expect_no_error(RcppTskit:::validate_integer_scalar_arg(1, "x")) + # jarl-ignore internal_function: it's just a test + expect_equal( + RcppTskit:::validate_integer_scalar_arg(1L, "x", strict = TRUE), + 1L + ) + # jarl-ignore internal_function: it's just a test + expect_error( + RcppTskit:::validate_integer_scalar_arg(1, "x", strict = TRUE), + regexp = "x must be a non-NA integer scalar within 32-bit range!" + ) + # jarl-ignore internal_function: it's just a test + expect_error( + RcppTskit:::validate_integer_scalar_arg(1.5, "x"), + regexp = "x must be a non-NA integer scalar within 32-bit range!" + ) + # jarl-ignore internal_function: it's just a test + expect_error( + RcppTskit:::validate_integer_scalar_arg( + as.numeric(.Machine$integer.max) + 1, + "x" + ), + regexp = "x must be a non-NA integer scalar within 32-bit range!" + ) + # jarl-ignore internal_function: it's just a test + expect_error( + RcppTskit:::validate_integer_scalar_arg(1L, "x", minimum = 2L), + regexp = "x must be a non-NA integer scalar within 32-bit range \\(>= 2\\)!" + ) + # jarl-ignore internal_function: it's just a test + expect_error( + RcppTskit:::validate_integer_scalar_arg( + -as.numeric(.Machine$integer.max) - 2, + "x" + ), + regexp = "x must be a non-NA integer scalar within 32-bit range!" + ) + # jarl-ignore internal_function: it's just a test + expect_error( + RcppTskit:::validate_integer_scalar_arg(NULL, "x"), + regexp = "x cannot be NULL\\." + ) + # jarl-ignore internal_function: it's just a test + expect_no_error( + RcppTskit:::validate_optional_integer_vector_arg(c(1, 2, 3), "ids") + ) + # jarl-ignore internal_function: it's just a test + expect_equal( + RcppTskit:::validate_optional_integer_vector_arg(c(1, 2, 3), "ids"), + invisible(c(1L, 2L, 3L)) + ) + # jarl-ignore internal_function: it's just a test + expect_no_error( + RcppTskit:::validate_optional_integer_vector_arg(c(1.0, 2.0), "ids") + ) + # jarl-ignore internal_function: it's just a test + expect_error( + RcppTskit:::validate_optional_integer_vector_arg( + c(1, 2, 3), + "ids", + strict = TRUE + ), + regexp = "ids must be NULL or an integer vector with no NA values within 32-bit range!" + ) + # jarl-ignore internal_function: it's just a test + expect_error( + RcppTskit:::validate_optional_integer_vector_arg(c(1, 2.5), "ids"), + regexp = "ids must be NULL or an integer vector with no NA values within 32-bit range!" + ) + # jarl-ignore internal_function: it's just a test + expect_error( + RcppTskit:::validate_optional_integer_vector_arg( + c(as.numeric(.Machine$integer.max) + 1), + "ids" + ), + regexp = "ids must be NULL or an integer vector with no NA values within 32-bit range!" + ) + # jarl-ignore internal_function: it's just a test + expect_no_error(RcppTskit:::validate_row_index(NULL, allow_null = TRUE)) +}) + +test_that("optional numeric-vector validator enforces type and length", { + # jarl-ignore internal_function: it's just a test + validator <- RcppTskit:::validate_optional_numeric_vector_arg + + expect_no_error(validator(NULL, "x", lengths = c(1L, 2L))) + expect_no_error(validator(1, "x", lengths = c(1L, 2L))) + expect_no_error(validator(c(1L, 2L), "x", lengths = c(1L, 2L))) + expect_no_error(validator(c(-Inf, Inf), "x", lengths = 2L)) + expect_no_error(validator(numeric(), "x")) + + invalid <- list( + "1", + TRUE, + 1 + 1i, + matrix(1:2, nrow = 1), + array(1:2, dim = c(1, 1, 2)), + NA_real_, + NaN, + numeric(), + 1:3 + ) + for (value in invalid) { + expect_error( + validator(value, "x", lengths = c(1L, 2L)), + "x must be NULL or a numeric vector with no NA values!" + ) + } + + expect_error( + validator( + 1:3, + "x", + lengths = c(1L, 2L), + error_message = "custom message" + ), + "custom message" + ) +}) + +test_that("numeric closeness matches NumPy semantics for finite values and infinities", { + # jarl-ignore internal_function: it's just a test + is_close <- RcppTskit:::numeric_values_are_close + + tolerance <- 1e-08 + 1e-05 * 3 + expect_identical( + is_close(c(3, 3 + tolerance / 2, 3 + tolerance * 2), 3), + c(TRUE, TRUE, FALSE) + ) + expect_identical(is_close(c(1, Inf, -Inf), Inf), c(FALSE, TRUE, FALSE)) + expect_identical(is_close(c(1, Inf, -Inf), -Inf), c(FALSE, FALSE, TRUE)) + expect_identical(is_close(c(NA_real_, NaN), 0), c(FALSE, FALSE)) + expect_identical(is_close(numeric(), 0), logical()) +}) + test_that("rtsk_wrap_tsk_size_t_as_integer64() works", { # jarl-ignore internal_function: it's just a test x <- RcppTskit:::test_rtsk_wrap_tsk_size_t_as_integer64("0") diff --git a/RcppTskit/tests/testthat/test_variant_iterator_low_level.R b/RcppTskit/tests/testthat/test_variant_iterator_low_level.R new file mode 100644 index 0000000..80cf645 --- /dev/null +++ b/RcppTskit/tests/testthat/test_variant_iterator_low_level.R @@ -0,0 +1,146 @@ +test_that("low-level variant iterator decodes all sites", { + ts_file <- system.file("examples/test.trees", package = "RcppTskit") + ts_xptr <- rtsk_treeseq_load(ts_file) + + it <- rtsk_treeseq_init_variants_iterator(ts_xptr) + n_sites <- as.integer(rtsk_treeseq_get_num_sites(ts_xptr)) + + out <- vector("list", n_sites) + for (j in seq_len(n_sites)) { + out[[j]] <- rtsk_treeseq_next_variant(it) + expect_true(is.list(out[[j]])) + expect_equal( + sort(names(out[[j]])), + c("alleles", "genotypes", "has_missing_data", "position", "site_id") + ) + } + expect_null(rtsk_treeseq_next_variant(it)) +}) + +test_that("low-level variant iterator supports left-right site filtering", { + ts_file <- system.file("examples/test.trees", package = "RcppTskit") + ts_xptr <- rtsk_treeseq_load(ts_file) + + full_it <- rtsk_treeseq_init_variants_iterator(ts_xptr) + first <- rtsk_treeseq_next_variant(full_it) + second <- rtsk_treeseq_next_variant(full_it) + expect_false(is.null(first)) + expect_false(is.null(second)) + + left <- first$position + right <- second$position + 1e-12 + + it <- rtsk_treeseq_init_variants_iterator(ts_xptr, left = left, right = right) + v1 <- rtsk_treeseq_next_variant(it) + v2 <- rtsk_treeseq_next_variant(it) + v3 <- rtsk_treeseq_next_variant(it) + + expect_equal(v1$site_id, first$site_id) + expect_equal(v2$site_id, second$site_id) + expect_null(v3) +}) + +test_that("low-level variant iterator supports sample subsets", { + ts_file <- system.file("examples/test.trees", package = "RcppTskit") + ts_xptr <- rtsk_treeseq_load(ts_file) + + samples <- c(0L, 1L, 2L) + it <- rtsk_treeseq_init_variants_iterator(ts_xptr, samples = samples) + v <- rtsk_treeseq_next_variant(it) + + expect_false(is.null(v)) + expect_length(v$genotypes, length(samples)) +}) + +test_that("low-level variant iterator validates bounds", { + ts_file <- system.file("examples/test.trees", package = "RcppTskit") + ts_xptr <- rtsk_treeseq_load(ts_file) + seq_len <- rtsk_treeseq_get_sequence_length(ts_xptr) + + expect_error( + rtsk_treeseq_init_variants_iterator(ts_xptr, left = NaN, right = seq_len), + "left and right must be finite numbers" + ) + expect_error( + rtsk_treeseq_init_variants_iterator(ts_xptr, left = -1, right = seq_len), + "left and right must be >= 0" + ) + expect_error( + rtsk_treeseq_init_variants_iterator( + ts_xptr, + left = seq_len + 1, + right = seq_len + ), + "left and right must be <= sequence length" + ) + expect_error( + rtsk_treeseq_init_variants_iterator(ts_xptr, left = 1, right = 0.5), + "left must be <= right" + ) +}) + +test_that("low-level variant iterator validates site-index range helper", { + expect_no_error(test_variant_site_index_range("0", "0")) + + expect_error( + test_variant_site_index_range("2147483648", "0"), + "Site index exceeds tsk_id_t range" + ) + + expect_error( + test_variant_site_index_range("invalid", "0"), + "start and stop must be valid base-10 unsigned integer strings" + ) +}) + +test_that("low-level variant iterator validates samples and alleles inputs", { + ts_file <- system.file("examples/test.trees", package = "RcppTskit") + ts_xptr <- rtsk_treeseq_load(ts_file) + n_nodes <- as.integer(rtsk_treeseq_get_num_nodes(ts_xptr)) + + expect_error( + rtsk_treeseq_init_variants_iterator(ts_xptr, samples = c(n_nodes + 1L)), + "Node out of bounds" + ) + expect_error( + rtsk_treeseq_init_variants_iterator( + ts_xptr, + alleles = c("A", NA_character_) + ), + "alleles cannot contain NA" + ) + + it <- rtsk_treeseq_init_variants_iterator( + ts_xptr, + alleles = c("A", "C", "G", "T") + ) + v <- rtsk_treeseq_next_variant(it) + expect_false(is.null(v)) +}) + +test_that("low-level variant iterator decode error path can be triggered", { + ts_file <- system.file("examples/test.trees", package = "RcppTskit") + ts_xptr <- rtsk_treeseq_load(ts_file) + n_sites <- as.integer(rtsk_treeseq_get_num_sites(ts_xptr)) + + it <- rtsk_treeseq_init_variants_iterator(ts_xptr) + test_rtsk_variant_iterator_set_site_bounds( + it, + next_site_id = n_sites, + stop_site_id = n_sites + 1L + ) + expect_error( + rtsk_treeseq_next_variant(it), + regexp = "Site out of bounds|Bounds check" + ) +}) + +test_that("low-level variant iterator maps null alleles to NA_character_", { + ts_file <- system.file("examples/test.trees", package = "RcppTskit") + ts_xptr <- rtsk_treeseq_load(ts_file) + it <- rtsk_treeseq_init_variants_iterator(ts_xptr) + test_rtsk_variant_iterator_force_null_first_allele(TRUE) + v <- rtsk_treeseq_next_variant(it) + expect_false(is.null(v)) + expect_true(anyNA(v$alleles)) +}) diff --git a/RcppTskit/tools/clang_tidy.py b/RcppTskit/tools/clang_tidy.py index 55e8880..d8cd7cb 100755 --- a/RcppTskit/tools/clang_tidy.py +++ b/RcppTskit/tools/clang_tidy.py @@ -28,6 +28,29 @@ def find_r(): return None +def find_clang_tidy(): + configured = os.environ.get("CLANG_TIDY") + if configured: + return configured + + path = shutil.which("clang-tidy") + if path: + return path + + # Homebrew's LLVM is keg-only, so GUI Git clients and IDEs commonly do not + # include its bin directory in the PATH inherited by pre-commit. + brew = shutil.which("brew") + if brew: + try: + candidate = Path(run([brew, "--prefix", "llvm"])) / "bin" / "clang-tidy" + if candidate.is_file() and os.access(candidate, os.X_OK): + return str(candidate) + except (OSError, subprocess.CalledProcessError): + pass + + return None + + def r_cmd_config(r_bin, var): return run([r_bin, "CMD", "config", var]) @@ -390,9 +413,11 @@ def main(argv): if not r_bin: return die("R not found on PATH; install R or set PATH accordingly.") - clang_tidy = os.environ.get("CLANG_TIDY") or shutil.which("clang-tidy") + clang_tidy = find_clang_tidy() if not clang_tidy: - return die("clang-tidy not found on PATH; install LLVM/clang-tidy.") + return die( + "clang-tidy not found; install LLVM/clang-tidy or set CLANG_TIDY." + ) root = Path(__file__).resolve().parents[2] exit_code = 0 diff --git a/RcppTskit/vignettes/RcppTskit_intro.qmd b/RcppTskit/vignettes/RcppTskit_intro.qmd index ee4848b..a7bec5c 100644 --- a/RcppTskit/vignettes/RcppTskit_intro.qmd +++ b/RcppTskit/vignettes/RcppTskit_intro.qmd @@ -169,7 +169,7 @@ The four typical use cases are: Examples for all of these cases are provided below after we describe the implemented data and class model, -and API mirroring across the languages. +and API alignment across the languages. ## Data and class model @@ -200,20 +200,19 @@ with the same memory management as `rtsk_treeseq_t`. While tree sequence (`tsk_treeseq_t`) is an immutable object, table collection (`tsk_table_collection_t`) is a mutable object, which can be edited. -No `R` functions for expanding and editing are implemented to date, -so all editing should happen in `C/C++` or `Python`. +Only some `R` functions for expanding and editing are implemented to date, +so use `Python` or `C/C++` for the missing `R` functionality. -## API mirroring across the languages +## API alignment across the languages `RcppTskit` aims to keep naming, arguments, defaults, and behaviour aligned with upstream `tskit` APIs whenever practical. -Specifically, -the `RcppTskit R` API mirrors the `tskit Python` API; -the `R` functions and `R6` classes (with their methods) aim to mirror -`tskit Python` functions and classes (with their methods). -Note that the `RcppTskit R` API is far more limited than the `tskit Python` API. -The `RcppTskit C++` API aims to mirror the `tskit C` API functions and semantics, -but is deliberately `R` oriented. +The `RcppTskit R` API intentionally combines an `R6` object model inspired by +the `tskit Python` API with operations that map directly to the `tskit C` API. +For example, `tc$node_table_add_row()` maps to `tsk_node_table_add_row()` +without recreating Python's nested `tc.nodes.add_row()` object model. +The `RcppTskit C++` API closely mirrors the `tskit C` API functions and +semantics, but is deliberately `R` oriented. When we intentionally deviate (for example, to support `R` idioms or safety), we document the rationale and test the chosen behaviour. @@ -278,7 +277,7 @@ For example, the above `R` function `ts_load()` effectively calls: ```{r} #| label: use_case_1_dev_funcs -# Low-level R function, which further calls the C++ function +# Low-level R function, which calls the C++ function # jarl-ignore internal_function: exposing for demo/doc RcppTskit:::rtsk_treeseq_load @@ -310,7 +309,7 @@ if (check_tskit_py(tskit)) { ts_py <- ts$r_to_py() # ... continue in reticulate Python ... ts_py$num_individuals # 8 - ts2_py = ts_py$simplify(samples = c(0L, 1L, 2L, 3L)) + ts2_py <- ts_py$simplify(samples = c(0L, 1L, 2L, 3L)) ts2_py$num_individuals # 2 ts2_py$num_nodes # 8 ts2_py$tables$nodes$time # 0.0 ... 5.0093910