├── tests ├── core ├── unitizer │ ├── helper │ │ ├── emoji.txt │ │ ├── UTF-8-test.txt │ │ ├── latin-1.R │ │ ├── UTF-8-unicode-10-ex.R │ │ └── UTF-8-critical.R │ ├── eval.unitizer │ │ └── data.rds │ ├── misc.unitizer │ │ └── data.rds │ ├── tev.unitizer │ │ └── data.rds │ ├── type.unitizer │ │ └── data.rds │ ├── _pre │ │ ├── lorem.objs │ │ │ ├── lorem.RDS │ │ │ ├── lorem.cn.RDS │ │ │ ├── lorem.ru.RDS │ │ │ └── lorem.tr.RDS │ │ └── lorem.R │ ├── alike.unitizer │ │ └── data.rds │ ├── all-bw.unitizer │ │ └── data.rds │ ├── classes.unitizer │ │ └── data.rds │ ├── mytests.unitizer │ │ └── data.rds │ ├── notcran.unitizer │ │ └── data.rds │ ├── parse.unitizer │ │ └── data.rds │ ├── abstract.unitizer │ │ └── data.rds │ ├── cstringr.unitizer │ │ └── data.rds │ ├── internal.unitizer │ │ └── data.rds │ ├── language.unitizer │ │ └── data.rds │ ├── validate.unitizer │ │ └── data.rds │ ├── validate.args.unitizer │ │ └── data.rds │ ├── tev.R │ ├── misc.R │ ├── notcran.R │ ├── type.R │ ├── abstract.R │ ├── classes.R │ ├── parse.R │ ├── eval.R │ ├── validate.args.R │ └── language.R ├── Rplots.pdf ├── run.R └── valgrind │ └── run.R ├── .github ├── .gitignore └── workflows │ └── R-CMD-check.yaml ├── extra ├── 020-fast.png ├── 010-like-vapply.png ├── 021-in-functions.png ├── 040-github-banner.png ├── 030-programmable-nse.png ├── 011-handles-complex-objs.png ├── compare-nav.Rmd └── PUBLISH.Rmd ├── src ├── all-bw.h ├── valname.c ├── trackinghash.h ├── settings.h ├── cstringrtest.c ├── pfhash.h ├── backports.h ├── misc.c ├── cstringr.h ├── cstringr-ext.c ├── assumptions.c ├── type.c ├── validate.h ├── r-copied.c ├── recurse.c ├── envtrack.c ├── trackinghash.c └── init.c ├── covr.R ├── .Rbuildignore ├── man ├── vetr-internal.Rd ├── abstract.ggplot.Rd ├── vetr-package.Rd ├── bench_mark.Rd ├── nullify.Rd ├── type_alike.Rd ├── all_bw.Rd ├── abstract.Rd ├── vetr.Rd ├── alike.Rd ├── vetr_settings.Rd ├── vet_token.Rd └── vet.Rd ├── vignettes ├── rmdhunks │ ├── microbenchmark.Rmd │ ├── trust-but-verify.Rmd │ ├── valaddin.Rmd │ ├── vetting-expressions.Rmd │ ├── related-packages.Rmd │ └── declarative-checks.Rmd └── styles.css ├── R ├── templates.R ├── system.R ├── vetr-package.R ├── helper.R ├── type.R ├── all-bw.R ├── benchmark.R ├── misc.R └── alike.R ├── CRAN.md ├── DESCRIPTION ├── NAMESPACE ├── RELEASE.Rmd └── CONTRIBUTING.md /tests/core: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /.github/.gitignore: -------------------------------------------------------------------------------- 1 | *.html 2 | -------------------------------------------------------------------------------- /tests/unitizer/helper/emoji.txt: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /tests/Rplots.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/brodieG/vetr/HEAD/tests/Rplots.pdf -------------------------------------------------------------------------------- /extra/020-fast.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/brodieG/vetr/HEAD/extra/020-fast.png -------------------------------------------------------------------------------- /extra/010-like-vapply.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/brodieG/vetr/HEAD/extra/010-like-vapply.png -------------------------------------------------------------------------------- /extra/021-in-functions.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/brodieG/vetr/HEAD/extra/021-in-functions.png -------------------------------------------------------------------------------- /extra/040-github-banner.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/brodieG/vetr/HEAD/extra/040-github-banner.png -------------------------------------------------------------------------------- /extra/030-programmable-nse.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/brodieG/vetr/HEAD/extra/030-programmable-nse.png -------------------------------------------------------------------------------- /extra/011-handles-complex-objs.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/brodieG/vetr/HEAD/extra/011-handles-complex-objs.png -------------------------------------------------------------------------------- /tests/unitizer/eval.unitizer/data.rds: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/brodieG/vetr/HEAD/tests/unitizer/eval.unitizer/data.rds -------------------------------------------------------------------------------- /tests/unitizer/helper/UTF-8-test.txt: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/brodieG/vetr/HEAD/tests/unitizer/helper/UTF-8-test.txt -------------------------------------------------------------------------------- /tests/unitizer/misc.unitizer/data.rds: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/brodieG/vetr/HEAD/tests/unitizer/misc.unitizer/data.rds -------------------------------------------------------------------------------- /tests/unitizer/tev.unitizer/data.rds: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/brodieG/vetr/HEAD/tests/unitizer/tev.unitizer/data.rds -------------------------------------------------------------------------------- /tests/unitizer/type.unitizer/data.rds: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/brodieG/vetr/HEAD/tests/unitizer/type.unitizer/data.rds -------------------------------------------------------------------------------- /tests/unitizer/_pre/lorem.objs/lorem.RDS: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/brodieG/vetr/HEAD/tests/unitizer/_pre/lorem.objs/lorem.RDS -------------------------------------------------------------------------------- /tests/unitizer/alike.unitizer/data.rds: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/brodieG/vetr/HEAD/tests/unitizer/alike.unitizer/data.rds -------------------------------------------------------------------------------- /tests/unitizer/all-bw.unitizer/data.rds: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/brodieG/vetr/HEAD/tests/unitizer/all-bw.unitizer/data.rds -------------------------------------------------------------------------------- /tests/unitizer/classes.unitizer/data.rds: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/brodieG/vetr/HEAD/tests/unitizer/classes.unitizer/data.rds -------------------------------------------------------------------------------- /tests/unitizer/mytests.unitizer/data.rds: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/brodieG/vetr/HEAD/tests/unitizer/mytests.unitizer/data.rds -------------------------------------------------------------------------------- /tests/unitizer/notcran.unitizer/data.rds: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/brodieG/vetr/HEAD/tests/unitizer/notcran.unitizer/data.rds -------------------------------------------------------------------------------- /tests/unitizer/parse.unitizer/data.rds: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/brodieG/vetr/HEAD/tests/unitizer/parse.unitizer/data.rds -------------------------------------------------------------------------------- /tests/unitizer/abstract.unitizer/data.rds: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/brodieG/vetr/HEAD/tests/unitizer/abstract.unitizer/data.rds -------------------------------------------------------------------------------- /tests/unitizer/cstringr.unitizer/data.rds: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/brodieG/vetr/HEAD/tests/unitizer/cstringr.unitizer/data.rds -------------------------------------------------------------------------------- /tests/unitizer/internal.unitizer/data.rds: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/brodieG/vetr/HEAD/tests/unitizer/internal.unitizer/data.rds -------------------------------------------------------------------------------- /tests/unitizer/language.unitizer/data.rds: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/brodieG/vetr/HEAD/tests/unitizer/language.unitizer/data.rds -------------------------------------------------------------------------------- /tests/unitizer/validate.unitizer/data.rds: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/brodieG/vetr/HEAD/tests/unitizer/validate.unitizer/data.rds -------------------------------------------------------------------------------- /tests/unitizer/_pre/lorem.objs/lorem.cn.RDS: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/brodieG/vetr/HEAD/tests/unitizer/_pre/lorem.objs/lorem.cn.RDS -------------------------------------------------------------------------------- /tests/unitizer/_pre/lorem.objs/lorem.ru.RDS: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/brodieG/vetr/HEAD/tests/unitizer/_pre/lorem.objs/lorem.ru.RDS -------------------------------------------------------------------------------- /tests/unitizer/_pre/lorem.objs/lorem.tr.RDS: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/brodieG/vetr/HEAD/tests/unitizer/_pre/lorem.objs/lorem.tr.RDS -------------------------------------------------------------------------------- /tests/unitizer/validate.args.unitizer/data.rds: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/brodieG/vetr/HEAD/tests/unitizer/validate.args.unitizer/data.rds -------------------------------------------------------------------------------- /src/all-bw.h: -------------------------------------------------------------------------------- 1 | #include "cstringr.h" 2 | 3 | #ifndef _ALLBW_H 4 | #define _ALLBW_H 5 | 6 | SEXP VALC_all_bw(SEXP x, SEXP hi, SEXP lo, SEXP na_rm, SEXP include_bounds); 7 | 8 | #endif 9 | -------------------------------------------------------------------------------- /extra/compare-nav.Rmd: -------------------------------------------------------------------------------- 1 | 2 |
3 | | [Top](#top) | [Overview](#overview) | [Details](#details) | [Benchmarks](#benchmarks) | [Appendix](#appendix) 4 |
5 | 6 | -------------------------------------------------------------------------------- /covr.R: -------------------------------------------------------------------------------- 1 | options(covr.exclude_end="(?://|#)[[:space:]]*nocov[[:space:]]*end") 2 | options(covr.exclude_start="(?://|#)[[:space:]]*nocov[[:space:]]*start") 3 | options(covr.exclude_pattern="(?://|#)[[:space:]]*nocov") 4 | 5 | covr::codecov() 6 | -------------------------------------------------------------------------------- /.Rbuildignore: -------------------------------------------------------------------------------- 1 | ^\. 2 | ^.*\.Rproj$ 3 | ^\.Rproj\.user$ 4 | ^DEVNOTES\.md$ 5 | ^CONTRIBUTING\.md$ 6 | ^CRAN\.md$ 7 | ^\.travis\.yml$ 8 | .Rdata 9 | ^covr\.R 10 | ^extra$ 11 | ^scratch 12 | ^README\.Rmd 13 | ^README\.html 14 | ^RELEASE\.Rmd 15 | notcran 16 | -------------------------------------------------------------------------------- /tests/unitizer/helper/latin-1.R: -------------------------------------------------------------------------------- 1 | # Some latin-1 codes, on own file due to Solaris issues with escaping 2 | 3 | lat.1.1 <- lat.1.2 <- c( 4 | "ni\xF1a", 5 | "hello", 6 | "\xB5 \xB6 \xBF \xC9 \xF4" 7 | ) 8 | Encoding(lat.1.1) <- "latin1" 9 | Encoding(lat.1.2) <- "bytes" 10 | 11 | -------------------------------------------------------------------------------- /man/vetr-internal.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/misc.R 3 | \docType{class} 4 | \name{vetr-interal} 5 | \alias{vetr-interal} 6 | \alias{vetr_bar-class} 7 | \alias{vetr_baz-class} 8 | \title{Test Objects} 9 | \description{ 10 | Objects used for testing purposes only. 11 | } 12 | \keyword{internal} 13 | -------------------------------------------------------------------------------- /tests/unitizer/helper/UTF-8-unicode-10-ex.R: -------------------------------------------------------------------------------- 1 | # These examples cannot be in-line in the unitizer because Solaris fails to 2 | # properly escape them, which then leads to failures. 3 | 4 | # Examples from the Unicode 10.0 docs 5 | 6 | unicode.10 <- c( 7 | "\xC2\x41\x41", 8 | "\x61\xF1\x80\x80", 9 | "\x61\xF1\x80\x80\xE1\x80", 10 | "\x61\xF1\x80\x80\xE1\x80\xC2\x62\x80\x63\x80\xBF\x64" 11 | ) 12 | Encoding(unicode.10) <- "UTF-8" 13 | 14 | -------------------------------------------------------------------------------- /tests/run.R: -------------------------------------------------------------------------------- 1 | cat(getwd(), "\n") 2 | if(suppressWarnings(require('unitizer'))) { 3 | local({ 4 | suppressWarnings(RNGversion("3.5.2")); 5 | on.exit({ 6 | RNGversion(as.character(getRversion())) 7 | }) 8 | pattern <- 'alike' 9 | unitize_dir( 10 | 'unitizer', 11 | # pattern=pattern, 12 | state='recommended' 13 | ) 14 | }) 15 | } else { 16 | warning("Cannot run tests without package `unitizer`") 17 | } 18 | 19 | -------------------------------------------------------------------------------- /man/abstract.ggplot.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/abstract.R 3 | \name{abstract.ggplot} 4 | \alias{abstract.ggplot} 5 | \title{Experimental Abstraction Method for GGPlot} 6 | \usage{ 7 | \method{abstract}{ggplot}(x, ...) 8 | } 9 | \description{ 10 | Not entirely sure this can ever work well since so much of \code{ggplot} is 11 | done with \code{proto} objects and those do not really use meta data, which 12 | makes \code{alike} rather useless. 13 | } 14 | \keyword{internal} 15 | -------------------------------------------------------------------------------- /tests/valgrind/run.R: -------------------------------------------------------------------------------- 1 | # overwrite unitizer_sect to just plain eval stuff 2 | 3 | unitizer_sect <- function( 4 | title = NULL, expr=expression(), details=character(), compare=identical 5 | ) { 6 | expr.sub <- substitute(expr) 7 | for(i in as.list(tail(expr.sub, -1L))) try(eval(i, envir=parent.frame())) 8 | } 9 | 10 | source('unitizer/_pre/lorem.R') 11 | source('unitizer/alike.R', echo=TRUE) 12 | source('unitizer/cstringr.R', echo=TRUE) 13 | source('unitizer/language.R', echo=TRUE) 14 | source('unitizer/validate.R', echo=TRUE) 15 | -------------------------------------------------------------------------------- /vignettes/rmdhunks/microbenchmark.Rmd: -------------------------------------------------------------------------------- 1 | 2 | 3 | ```{r echo=FALSE} 4 | mb <- function(..., times=25) { 5 | if(require(microbenchmark, quietly=TRUE)) { 6 | mb.c <- match.call() 7 | mb.c[[1]] <- quote(microbenchmark::microbenchmark) 8 | res <- eval(mb.c, parent.frame()) 9 | res.sum <- summary(res) 10 | cat(attr(res.sum, "unit"), "\n") 11 | print(res.sum[1:5]) 12 | } else { 13 | warning("Package microbenchmark not available.") 14 | } 15 | } 16 | ``` 17 | -------------------------------------------------------------------------------- /vignettes/rmdhunks/trust-but-verify.Rmd: -------------------------------------------------------------------------------- 1 | ## Trust, but Verify 2 | 3 | ### Easily 4 | 5 | When you write functions that operate on S3 or unclassed objects you can either 6 | trust that your inputs will be structured as expected, or tediously check that 7 | they are. 8 | 9 | `vetr` takes the tedium out of structure verification so that you can trust, 10 | but verify. It lets you express structural requirements declaratively with 11 | templates, and it auto-generates human-friendly error messages as needed. 12 | 13 | ### Quickly 14 | 15 | `vetr` is written in C to minimize overhead from parameter checks in your 16 | functions. It has no dependencies. 17 | 18 | -------------------------------------------------------------------------------- /R/templates.R: -------------------------------------------------------------------------------- 1 | # Copyright (C) 2023 Brodie Gaslam 2 | # 3 | # This file is part of "vetr - Trust, but Verify" 4 | # 5 | # This program is free software: you can redistribute it and/or modify 6 | # it under the terms of the GNU General Public License as published by 7 | # the Free Software Foundation, either version 2 of the License, or 8 | # (at your option) any later version. 9 | # 10 | # This program is distributed in the hope that it will be useful, 11 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | # GNU General Public License for more details. 14 | # 15 | # Go to for a copy of the license. 16 | 17 | ## file currently empty 18 | -------------------------------------------------------------------------------- /vignettes/rmdhunks/valaddin.Rmd: -------------------------------------------------------------------------------- 1 | # Valaddin 2 | 3 | Snippet used to compare `valaddin` to `vetr` performance. This is not actually 4 | generated as part of vignettes because it will then require `valaddin` as part 5 | of the build package, which brings in unwanted dependencies (via suggests) that 6 | make the build process slow on travis. 7 | 8 | ```{r} 9 | secant <- function(f, x, dx) (f(x + dx) - f(x)) / dx 10 | 11 | secant_valaddin <- valaddin::firmly(secant, list(~x, ~dx) ~ is.numeric) 12 | 13 | secant_stopifnot <- function(f, x, dx) { 14 | stopifnot(is.numeric(x), is.numeric(dx)) 15 | secant(f, x, dx) 16 | } 17 | 18 | secant_vetr <- function(f, x, dx) { 19 | vetr(x=numeric(), dx=numeric()) 20 | secant(f, x, dx) 21 | } 22 | 23 | library(microbenchmark) 24 | microbenchmark( 25 | secant_valaddin(log, 1, .1), 26 | secant_stopifnot(log, 1, .1), 27 | secant_vetr(log, 1, .1) 28 | ) 29 | ``` 30 | -------------------------------------------------------------------------------- /CRAN.md: -------------------------------------------------------------------------------- 1 | ## Submission Checklist 2 | 3 | [x] Revdeps 4 | [x] Review CRAN policy 5 | [x] Check version 6 | [x] Run tests with 7 | [x] winbuilder 8 | [x] valgrind 9 | [ ] rchk 10 | [x] Check coverage 11 | [ ] Check build user 12 | 13 | ## Submission Notes: 14 | 15 | This is a minor release primarily intended 16 | to address the outstanding CRAN check warnings, 17 | and fix a minor bug. 18 | 19 | ## R CMD check --as-cran 20 | 21 | Completes with 'Status: OK' 22 | 23 | ## Test Environments 24 | 25 | I have tested this package against the following 26 | environments: 27 | 28 | * Travis Ubuntu 14.04.5 LTS 29 | * R devel (2018-06-20 r74923) 30 | * R version 3.5.0 (2017-01-27) 31 | * R version 3.4.4 (2017-01-27) 32 | * R version 3.2.5 (2017-01-27) 33 | * Winbuilder 34 | * R devel (2018-06-07 r74865) 35 | https://win-builder.r-project.org/T0GxmEvBfRne 36 | * Locally Mac OS 10.13.5 37 | * R Version 3.5.0 (2017-01-27) 38 | 39 | -------------------------------------------------------------------------------- /R/system.R: -------------------------------------------------------------------------------- 1 | # Copyright (C) 2023 Brodie Gaslam 2 | # 3 | # This file is part of "vetr - Trust, but Verify" 4 | # 5 | # This program is free software: you can redistribute it and/or modify 6 | # it under the terms of the GNU General Public License as published by 7 | # the Free Software Foundation, either version 2 of the License, or 8 | # (at your option) any later version. 9 | # 10 | # This program is distributed in the hope that it will be useful, 11 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | # GNU General Public License for more details. 14 | # 15 | # Go to for a copy of the license. 16 | 17 | ## Remove DLLs when package is unloaded 18 | 19 | # nocov start 20 | .onLoad <- function(libname, pkgname) { 21 | # Scheme defaults are fairly complex... 22 | 23 | check_assumptions() 24 | } 25 | 26 | .onUnload <- function(libpath) { 27 | library.dynam.unload("vetr", libpath) 28 | } 29 | # nocov end 30 | -------------------------------------------------------------------------------- /src/valname.c: -------------------------------------------------------------------------------- 1 | /* 2 | Copyright (C) 2023 Brodie Gaslam 3 | 4 | This file is part of "vetr - Trust, but Verify" 5 | 6 | This program is free software: you can redistribute it and/or modify 7 | it under the terms of the GNU General Public License as published by 8 | the Free Software Foundation, either version 2 of the License, or 9 | (at your option) any later version. 10 | 11 | This program is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | GNU General Public License for more details. 15 | 16 | Go to for a copy of the license. 17 | */ 18 | 19 | #include "alike.h" 20 | 21 | /* 22 | * External version for testing. See src/r-copied.c for implementation. 23 | */ 24 | SEXP ALIKEC_is_valid_name_ext(SEXP name) { 25 | if(TYPEOF(name) != STRSXP || XLENGTH(name) != 1) 26 | error("Argument `name` must be character(1L)"); 27 | return ScalarLogical(ALIKEC_is_valid_name(CHAR(asChar(name)))); 28 | } 29 | -------------------------------------------------------------------------------- /man/vetr-package.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/vetr-package.R 3 | \docType{package} 4 | \name{vetr-package} 5 | \alias{vetr-package} 6 | \title{Trust, but Verify} 7 | \description{ 8 | Declarative template-based framework for verifying that objects meet 9 | structural requirements, and auto-composing error messages when they do not. 10 | } 11 | \seealso{ 12 | Useful links: 13 | \itemize{ 14 | \item \url{https://github.com/brodieG/vetr} 15 | \item Report bugs at \url{https://github.com/brodieG/vetr/issues} 16 | } 17 | 18 | } 19 | \author{ 20 | \strong{Maintainer}: Brodie Gaslam \email{brodie.gaslam@yahoo.com} 21 | 22 | Other contributors: 23 | \itemize{ 24 | \item Paxdiablo (Hash table implementation in src/pfhash.h) [copyright holder] 25 | \item R Core Team \email{R-core@r-project.org} (Used/adapted several code snippets from R sources, see src/r-copied.c) [copyright holder] 26 | \item Michael Chirico \email{michaelchirico4@gmail.com} (\href{https://orcid.org/0000-0003-0787-087X}{ORCID}) [contributor] 27 | } 28 | 29 | } 30 | -------------------------------------------------------------------------------- /R/vetr-package.R: -------------------------------------------------------------------------------- 1 | # Copyright (C) 2023 Brodie Gaslam 2 | # 3 | # This file is part of "vetr - Trust, but Verify" 4 | # 5 | # This program is free software: you can redistribute it and/or modify 6 | # it under the terms of the GNU General Public License as published by 7 | # the Free Software Foundation, either version 2 of the License, or 8 | # (at your option) any later version. 9 | # 10 | # This program is distributed in the hope that it will be useful, 11 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | # GNU General Public License for more details. 14 | # 15 | # Go to for a copy of the license. 16 | 17 | #' Trust, but Verify 18 | #' 19 | #' Declarative template-based framework for verifying that objects meet 20 | #' structural requirements, and auto-composing error messages when they do not. 21 | #' 22 | #' @name vetr-package 23 | #' @importFrom methods new 24 | 25 | "_PACKAGE" 26 | 27 | # importFrom methods needed for tests of reference classes because we don't want 28 | # to create the classes in the tests due to the topenv issues. 29 | -------------------------------------------------------------------------------- /tests/unitizer/tev.R: -------------------------------------------------------------------------------- 1 | # Copyright (C) 2023 Brodie Gaslam 2 | # 3 | # This file is part of "vetr - Trust, but Verify" 4 | # 5 | # This program is free software: you can redistribute it and/or modify 6 | # it under the terms of the GNU General Public License as published by 7 | # the Free Software Foundation, either version 2 of the License, or 8 | # (at your option) any later version. 9 | # 10 | # This program is distributed in the hope that it will be useful, 11 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | # GNU General Public License for more details. 14 | # 15 | # Go to for a copy of the license. 16 | 17 | library(vetr) 18 | 19 | unitizer_sect("tev", { 20 | tev(runif(2), numeric(2)) 21 | tev(runif(3), numeric(2)) 22 | 23 | # # we can no longer do this without including magrittr in suggests 24 | # has.magrittr <- suppressWarnings(require(magrittr, quietly=TRUE)) 25 | 26 | # if(has.magrittr) runif(2) %>% tev(numeric(2)) %>% isTRUE else TRUE 27 | # if(has.magrittr) runif(3) %>% tev(numeric(2)) %>% isTRUE else FALSE 28 | }) 29 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: vetr 2 | Title: Trust, but Verify 3 | Description: Declarative template-based framework for verifying that objects 4 | meet structural requirements, and auto-composing error messages when they do 5 | not. 6 | Version: 0.2.19 7 | Authors@R: c( 8 | person("Brodie", "Gaslam", email="brodie.gaslam@yahoo.com", 9 | role=c("aut", "cre")), 10 | person(given="Paxdiablo", role="cph", comment="Hash 11 | table implementation in src/pfhash.h"), 12 | person(given="R Core Team", 13 | email="R-core@r-project.org", role="cph", 14 | comment="Used/adapted several code snippets from R sources, see src/r-copied.c"), 15 | person("Michael","Chirico", role="ctb", 16 | email="michaelchirico4@gmail.com", comment = c(ORCID="0000-0003-0787-087X") 17 | )) 18 | Depends: 19 | R (>= 3.2.0) 20 | License: GPL (>=2) 21 | URL: https://github.com/brodieG/vetr 22 | BugReports: https://github.com/brodieG/vetr/issues 23 | VignetteBuilder: knitr 24 | Imports: 25 | methods, 26 | stats, 27 | utils 28 | Suggests: 29 | knitr, 30 | rmarkdown, 31 | unitizer 32 | RoxygenNote: 7.3.3 33 | Encoding: UTF-8 34 | Roxygen: list(markdown = TRUE, load = "installed") 35 | -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | # Generated by roxygen2: do not edit by hand 2 | 3 | S3method(abstract,array) 4 | S3method(abstract,data.frame) 5 | S3method(abstract,default) 6 | S3method(abstract,environment) 7 | S3method(abstract,ggplot) 8 | S3method(abstract,list) 9 | S3method(abstract,lm) 10 | S3method(abstract,matrix) 11 | S3method(abstract,ts) 12 | S3method(nullify,default) 13 | export(CHR) 14 | export(CHR.1) 15 | export(CPX) 16 | export(CPX.1) 17 | export(GT.0) 18 | export(GTE.0) 19 | export(INT) 20 | export(INT.1) 21 | export(INT.1.NEG) 22 | export(INT.1.NEG.STR) 23 | export(INT.1.POS) 24 | export(INT.1.POS.STR) 25 | export(INT.NEG) 26 | export(INT.NEG.STR) 27 | export(INT.POS) 28 | export(INT.POS.STR) 29 | export(LGL) 30 | export(LGL.1) 31 | export(LT.0) 32 | export(LTE.0) 33 | export(NO.INF) 34 | export(NO.NA) 35 | export(NUM) 36 | export(NUM.1) 37 | export(NUM.1.NEG) 38 | export(NUM.1.POS) 39 | export(NUM.NEG) 40 | export(NUM.POS) 41 | export(abstract) 42 | export(alike) 43 | export(all_bw) 44 | export(bench_mark) 45 | export(nullify) 46 | export(tev) 47 | export(type_alike) 48 | export(type_of) 49 | export(vet) 50 | export(vet_token) 51 | export(vetr) 52 | export(vetr_settings) 53 | importFrom(methods,new) 54 | importFrom(stats,median) 55 | importFrom(utils,modifyList) 56 | useDynLib(vetr, .registration=TRUE, .fixes="VALC_") 57 | -------------------------------------------------------------------------------- /RELEASE.Rmd: -------------------------------------------------------------------------------- 1 | ## Release Steps 2 | 3 | [x] Coverage 100% 4 | 5 | Make sure to check codecov as the algorithms are different (and better?) there. 6 | 7 | [x] R CMD check 8 | [x] Devel / Release / Oldrel (Github Actions) 9 | [ ] winbuilder 10 | [x] Other locale (e.g. 8859-15, not "latin1") 11 | 12 | LC_ALL=ca_FR.ISO8859-15 LANG=ca_FR.ISO8859-15 R CMD check 13 | 14 | [x] Revdep 15 | 16 | 17 | Review the details of revdep: it claims everything is fine, but there are 18 | several failures (could be b/c of 10 minute timeout?). Also, it took ~10 hours 19 | to do the revdeps for 26 packages; what is going on with that? Possibly not 20 | enough RAM causing us to hit swap? Need more RAM for docker? 21 | 22 | Revdepcheck relies on crancache, which hasn't been updated in a while. 23 | 24 | [ ] CRAN policy 25 | 26 | [x] Review documentation 27 | [x] Update DESCRIPTION / NEWS 28 | [x] New README 29 | [x] Re-render vignette 30 | 31 | Compiled code issues (do these last as inevitably we end up making changes). 32 | 33 | [x] Rchk (rhub) 34 | [x] valgrind 35 | [x] Clang UBSAN (Rhub) 36 | [x] Clang ASAN (Rhub) (catches things GCCSAN does not). 37 | 38 | path <- 'vetr_0.2.19.tar.gz' 39 | rhub::rc_submit( 40 | path=path, 41 | platforms=c('clang-asan', 'clang-ubsan', 'valgrind', 'rchk') 42 | ) 43 | 44 | Optional 45 | 46 | [ ] New animation 47 | 48 | 49 | -------------------------------------------------------------------------------- /man/bench_mark.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/benchmark.R 3 | \name{bench_mark} 4 | \alias{bench_mark} 5 | \title{Lightweight Benchmarking Function} 6 | \usage{ 7 | bench_mark(..., times = 1000L, deparse.width = 40) 8 | } 9 | \arguments{ 10 | \item{...}{expressions to benchmark, are captured unevaluated} 11 | 12 | \item{times}{how many times to loop, defaults to 1000} 13 | 14 | \item{deparse.width}{how many characters to deparse for labels} 15 | } 16 | \value{ 17 | NULL, invisibly, reports timings as a side effect as screen output 18 | } 19 | \description{ 20 | Evaluates provided expression in a loop and reports mean evaluation time. 21 | This is inferior to \code{microbenchmark} and other benchmarking tools in many 22 | ways except that it has zero dependencies or suggests which helps with 23 | package build and test times. Used in vignettes. 24 | } 25 | \details{ 26 | Runs \code{\link[=gc]{gc()}} before each expression is evaluated. Expressions are evaluated 27 | in the order provided. Attempts to estimate the overhead of the loop by 28 | running a loop that evaluates \code{NULL} the \code{times} times. 29 | 30 | Unfortunately because this computes the average of all iterations it is very 31 | susceptible to outliers in small sample runs, particularly with fast running 32 | code. For that reason the default number of iterations is one thousand. 33 | } 34 | \examples{ 35 | bench_mark(runif(1000), Sys.sleep(0.001), times=10) 36 | } 37 | -------------------------------------------------------------------------------- /man/nullify.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/abstract.R 3 | \name{nullify} 4 | \alias{nullify} 5 | \alias{nullify.default} 6 | \title{Set Element to NULL Without Removing It} 7 | \usage{ 8 | nullify(obj, index) 9 | 10 | \method{nullify}{default}(obj, index) 11 | } 12 | \arguments{ 13 | \item{obj}{the R object to NULL a value in} 14 | 15 | \item{index}{an indexing vectors of values to NULL} 16 | } 17 | \value{ 18 | object with selected values NULLified 19 | } 20 | \description{ 21 | This function is required because there is no straightforward way to 22 | over-write a value in a list with NULL without completely removing the entry 23 | from the list as well. 24 | } 25 | \details{ 26 | This returns a copy of the object modified with null slots; it does 27 | not modify the input argument. 28 | 29 | Default method will attempt to convert non-list objects to lists 30 | with \code{\link{as.list}}, and then back to whatever they were by using a 31 | function with name \code{paste0("as.", class(obj)[[1L]])} 32 | if it exists and works. If the object cannot be coerced back 33 | to its original type the corresponding list will be returned. 34 | 35 | If this is not appropriate for your object type you can write an S3 method 36 | for it. 37 | } 38 | \note{ 39 | attributes are copied from original object and re-applied to final 40 | object before return, which may 41 | not make sense in some circumstances. 42 | } 43 | \examples{ 44 | nullify(list(1, 2, 3), 2) 45 | nullify(call("fun", 1, 2, 3), 2) 46 | } 47 | -------------------------------------------------------------------------------- /src/trackinghash.h: -------------------------------------------------------------------------------- 1 | /* 2 | Copyright (C) 2023 Brodie Gaslam 3 | 4 | This file is part of "vetr - Trust, but Verify" 5 | 6 | This program is free software: you can redistribute it and/or modify 7 | it under the terms of the GNU General Public License as published by 8 | the Free Software Foundation, either version 2 of the License, or 9 | (at your option) any later version. 10 | 11 | This program is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | GNU General Public License for more details. 15 | 16 | Go to for a copy of the license. 17 | */ 18 | 19 | #include "cstringr.h" 20 | #include "pfhash.h" 21 | #include "settings.h" 22 | 23 | #ifndef _TRACK_HASH_H 24 | #define _TRACK_HASH_H 25 | 26 | /* 27 | * Note: last value written to `contents` is at ->idx - 1, if ->idx is zero, 28 | * then the list is empty 29 | */ 30 | 31 | struct track_hash { 32 | pfHashTable * hash; 33 | char ** contents; // an array of characters 34 | size_t idx; // location after last value in contents 35 | size_t idx_max; // how big the contents are 36 | }; 37 | struct track_hash * VALC_create_track_hash(size_t size_init); 38 | int VALC_add_to_track_hash( 39 | struct track_hash * track_hash, const char * key, const char * value, 40 | size_t max_nchar 41 | ); 42 | void VALC_reset_track_hash( 43 | struct track_hash * track_hash, size_t idx 44 | ); 45 | SEXP VALC_track_hash_test(SEXP keys, SEXP size); 46 | 47 | #endif 48 | -------------------------------------------------------------------------------- /vignettes/rmdhunks/vetting-expressions.Rmd: -------------------------------------------------------------------------------- 1 | You can combine templates with `&&` / `||`: 2 | 3 | ```{r} 4 | vet(numeric(1L) || NULL, NULL) 5 | vet(numeric(1L) || NULL, 42) 6 | vet(numeric(1L) || NULL, "foo") 7 | ``` 8 | 9 | Templates only check structure. When you need to check values use `.` to 10 | refer to the object: 11 | 12 | ```{r} 13 | vet(numeric(1L) && . > 0, -42) # strictly positive scalar numeric 14 | vet(numeric(1L) && . > 0, 42) 15 | ``` 16 | 17 | If you do use the `.` symbol in your vetting expressions in your packages, you 18 | will need to include `utils::globalVariables(".")` as a top-level call to avoid 19 | the "no visible binding for global variable '.'" R CMD check NOTE. 20 | 21 | You can compose vetting expressions as language objects and combine them: 22 | 23 | ```{r} 24 | scalar.num.pos <- quote(numeric(1L) && . > 0) 25 | foo.or.bar <- quote(character(1L) && . %in% c('foo', 'bar')) 26 | vet.exp <- quote(scalar.num.pos || foo.or.bar) 27 | 28 | vet(vet.exp, 42) 29 | vet(vet.exp, "foo") 30 | vet(vet.exp, "baz") 31 | ``` 32 | 33 | `all_bw` is available for value range checks (~10x faster than 34 | `isTRUE(all(. >= x & . <= y))` for large vectors): 35 | 36 | ```{r} 37 | vet(all_bw(., 0, 1), runif(5) + 1) 38 | ``` 39 | 40 | There are a number of predefined vetting tokens you can use in your 41 | vetting expressions such as: 42 | 43 | ```{r} 44 | vet(NUM.POS, -runif(5)) # positive numeric; see `?vet_token` for others 45 | ``` 46 | 47 | Vetting expressions are designed to be intuitive to use, but their 48 | implementation is complex. We recommend you look at `example(vet)` for usage 49 | ideas, or at the ["Non Standard Evaluation" section of the vignette][3] for the 50 | gory details. 51 | 52 | -------------------------------------------------------------------------------- /vignettes/rmdhunks/related-packages.Rmd: -------------------------------------------------------------------------------- 1 | 2 | * `stopifnot` by R Core 3 | * [`vetr`](https://github.com/brodieG/vetr) by Yours Truly 4 | * [`asserthat`](https://github.com/hadley/assertthat) by Hadley Wickham 5 | * [`assertive`](https://www.r-pkg.org/pkg/assertive) by Richie Cotton 6 | * [`checkmate`](https://github.com/mllg/checkmate) by Michel Lang 7 | 8 | The following packages also perform related tasks, although we have not used 9 | them and do not review them: 10 | 11 | * [`valaddin`](https://github.com/egnha/valaddin) v0.1.0 by Eugene Ha, a 12 | framework for augmenting existing functions with validation contracts. 13 | Currently the package is undergoing a major overhaul so we will add it to the 14 | comparison once the new release (v0.3.0) is out. 15 | * [`ensurer`](https://github.com/smbache/ensurer) v1.1 by Stefan M. Bache, a 16 | framework for flexibly creating and combining validation contracts. The 17 | development version adds an experimental method for creating type safe 18 | functions, but it is not published to CRAN so we do not test it here. 19 | * [`validate`](https://github.com/data-cleaning/validate) by Mark van 20 | der Loo and Edwin de Jonge, with a primary focus on validating data in data 21 | frames and similar data structures. 22 | * [`assertr`](https://github.com/tonyfischetti/assertr) by Tony Fischetti, also 23 | focused on data validation in data frames and similar structures. 24 | * [`types`](https://github.com/jimhester/types) by Jim Hester, which implements 25 | but does not enforce type hinting. 26 | * [`argufy`](https://github.com/gaborcsardi/argufy) by Gábor Csárdi, which 27 | implements parameter validation via roxygen tags (not released to CRAN). 28 | * [`typed`](https://moodymudskipper.github.io/typed/) by Antoine Fabri, which 29 | enforces types of symbols, function parameters, and return values. 30 | * [`erify`](https://github.com/flujoo/erify/) by Renfei Mao, with a focus on 31 | readable error messages. 32 | -------------------------------------------------------------------------------- /man/type_alike.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/type.R 3 | \name{type_of} 4 | \alias{type_of} 5 | \alias{type_alike} 6 | \title{Fuzzily Compare Types of Objects} 7 | \usage{ 8 | type_of(object) 9 | 10 | type_alike(target, current, settings = NULL) 11 | } 12 | \arguments{ 13 | \item{object}{the object to check the type of} 14 | 15 | \item{target}{the object to test type alikeness against} 16 | 17 | \item{current}{the object to test the type alikeness of} 18 | 19 | \item{settings}{NULL, or a list as produced by \code{\link[=vetr_settings]{vetr_settings()}}} 20 | } 21 | \value{ 22 | For \code{type_of} character(1L) the type of the object, for \code{type_alike} 23 | either TRUE, or a string describing why the types are not alike. 24 | } 25 | \description{ 26 | Type evaluation and comparison is carried out with special treatment for 27 | numerics, integers, and function types. Whole number NA-free numeric vectors 28 | of sufficiently short length (<100 by default) representable in the integer 29 | type are considered to be type integer. Closures, built-ins, and specials 30 | are all treated as type closure. 31 | } 32 | \details{ 33 | Specific behavior can be tuned with the \code{type.mode} parameter to the 34 | \code{\link[=vetr_settings]{vetr_settings()}} object passed as the \code{settings} parameter to this function. 35 | } 36 | \examples{ 37 | type_of(1.0001) # numeric 38 | type_of(1.0) # integer (`typeof` returns numeric) 39 | type_of(1) # integer (`typeof` returns numeric) 40 | type_of(sum) # closure (`typeof` returns builtin) 41 | type_of(`$`) # closure (`typeof` returns special) 42 | 43 | type_alike(1L, 1) 44 | type_alike(1L, 1.1) 45 | type_alike(integer(), numeric(100)) 46 | type_alike(integer(), numeric(101)) # too long 47 | } 48 | \seealso{ 49 | \code{\link[=alike]{alike()}}, \code{\link[=vetr_settings]{vetr_settings()}}, in particular the section about 50 | the \code{type.mode} parameter which affects how this function behaves. 51 | } 52 | -------------------------------------------------------------------------------- /src/settings.h: -------------------------------------------------------------------------------- 1 | /* 2 | Copyright (C) 2023 Brodie Gaslam 3 | 4 | This file is part of "vetr - Trust, but Verify" 5 | 6 | This program is free software: you can redistribute it and/or modify 7 | it under the terms of the GNU General Public License as published by 8 | the Free Software Foundation, either version 2 of the License, or 9 | (at your option) any later version. 10 | 11 | This program is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | GNU General Public License for more details. 15 | 16 | Go to for a copy of the license. 17 | */ 18 | 19 | #include 20 | 21 | #ifndef _VETR_SET_H 22 | #define _VETR_SET_H 23 | 24 | // QUESTION, WHAT TYPE SHOULD ALL THE NUMBERS HERE BE, LONG? THAT WOULD SEEM 25 | // TO MAKE SENSE 26 | 27 | struct VALC_settings { 28 | // Original alike settings 29 | 30 | int type_mode, attr_mode, lang_mode, fun_mode, rec_mode; 31 | 32 | // Length of numeric vectors to consider for integer-likeness 33 | 34 | int fuzzy_int_max_len; 35 | 36 | int suppress_warnings; 37 | 38 | // internal, track whether we are recursing through attributes 39 | 40 | int in_attr; 41 | 42 | int width; // Tell alike what screen width to assume 43 | 44 | // what env to look for functions to match call in, substitute, etc, used 45 | // both by alike and by vet funs 46 | 47 | SEXP env; 48 | 49 | // Additional vet settings 50 | 51 | size_t env_depth_max; // how many envs to track when searching for env loop 52 | size_t nchar_max; // when do we stop looking for NULL? 53 | size_t symb_sub_depth_max; // how deep recursive substitution can go? 54 | size_t symb_size_max; 55 | size_t track_hash_content_size; 56 | 57 | int result_list_size_init; 58 | int result_list_size_max; 59 | }; 60 | struct VALC_settings VALC_settings_init(void); 61 | struct VALC_settings VALC_settings_vet(SEXP set_list, SEXP env); 62 | 63 | #endif 64 | -------------------------------------------------------------------------------- /tests/unitizer/misc.R: -------------------------------------------------------------------------------- 1 | # Copyright (C) 2023 Brodie Gaslam 2 | # 3 | # This file is part of "vetr - Trust, but Verify" 4 | # 5 | # This program is free software: you can redistribute it and/or modify 6 | # it under the terms of the GNU General Public License as published by 7 | # the Free Software Foundation, either version 2 of the License, or 8 | # (at your option) any later version. 9 | # 10 | # This program is distributed in the hope that it will be useful, 11 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | # GNU General Public License for more details. 14 | # 15 | # Go to for a copy of the license. 16 | 17 | library(vetr) 18 | 19 | unitizer_sect("All", { 20 | vetr:::val_all(1:10) # -2 21 | vetr:::val_all(rep(TRUE, 10)) # 1 22 | vetr:::val_all(c(rep(TRUE, 10), FALSE, TRUE)) # 0 23 | vetr:::val_all(c(rep(TRUE, 5), NA, rep(TRUE, 5))) # -4 24 | vetr:::val_all(FALSE) # -1 25 | vetr:::val_all(TRUE) # 2 26 | vetr:::val_all(logical()) # 3, this used to be -5 27 | vetr:::val_all(NA) # -3 28 | vetr:::val_all(c(TRUE, TRUE, NA, TRUE)) # -4 29 | }) 30 | 31 | unitizer_sect("Hash", { 32 | # these should all equal 193 33 | vetr:::hash_fun(c("f b", "n b", "n d", "t m", "b r", "n w", "q w", "o x")) 34 | }) 35 | unitizer_sect("bench_mark", { 36 | # three different time frames that should trigger all the code, need to remove 37 | # the time piece so that the tests don't fail due to variations 38 | 39 | capt_wo_time <- function(x) { 40 | txt <- capture.output(x) 41 | gsub("~ *-?[0-9.e+\\-]*", "~", txt) 42 | } 43 | capt_wo_time(bench_mark(Sys.sleep(1.2), times=1)) 44 | capt_wo_time(bench_mark(Sys.sleep(.01), times=10)) 45 | capt_wo_time(bench_mark(1 + 1, NULL, times=100)) 46 | }) 47 | unitizer_sect("sort pair lists", { 48 | vetr:::list_as_sorted_vec(pairlist(c=1, a=list(), b=NULL)) 49 | # # equal names not stable, but we should never hit this with attribute lists 50 | # vetr:::list_as_sorted_vec(pairlist(a=1, a=list(), a=NULL)) 51 | vetr:::list_as_sorted_vec(pairlist(b=1, 2, a=3)) 52 | vetr:::list_as_sorted_vec(pairlist()) 53 | vetr:::list_as_sorted_vec(pairlist(a=1)) 54 | }) 55 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | # Contributing 2 | 3 | Thank you for your interest in contributing to this package. To make sure you 4 | do not waste your time or mine, please read and follow the guidelines here. 5 | 6 | ## Reporting Issues 7 | 8 | Please create a: 9 | 10 | * minimal: as little code as possible. 11 | * reproducible: include the **minimal** input data. 12 | * example: include the expected output. 13 | 14 | Additionally: 15 | 16 | * Include output of `sessionInfo()` 17 | * Format the example code so that it can be copy-pasted into an R console 18 | 19 | ## Submitting PRs 20 | 21 | ### Before you Start 22 | 23 | Create an issue that highlights the problem, and describe how you hope to solve 24 | it. Do not be offended if your offer for help is refused. Accepting a PR 25 | creates a maintenance burden that I might not be willing to take on. 26 | 27 | I realize the requirements I lay out here are annoying. If they prevent you 28 | from making a contribution I am sorry and sympathize, having been on the 29 | opposite side of such requirements myself. Nonetheless the requirements stand 30 | to ensure your contribution does not end up creating more work than it 31 | saves. 32 | 33 | ### Requirements 34 | 35 | * Check the diff prior to submitting the PR and make sure there are no 36 | unnecessary changes (e.g. meaningless white space changes, etc.). 37 | * All PRs should be made as a new branch off of the "development" branch. 38 | * Every line of code you contribute should be tested as shown by `covr`. 39 | * Unit tests should be done in `unitizer`. 40 | * You should license all contributions you make with a license compatible with 41 | that of the package, and you should ensure you are the copyright holder for 42 | all the contributions. 43 | 44 | ### Style Guide 45 | 46 | Strict: 47 | 48 | * Wrap text at 80 columns 49 | * Indentations are 2 spaces 50 | * Strip trailing whitespace 51 | 52 | Suggested: 53 | 54 | * function_name() 55 | * object.name 56 | * FormalClassName 57 | * formalMethodName() 58 | 59 | ## Thank You! 60 | 61 | For taking the time to read these contribution guidelines. I apologize if they 62 | seem a little hostile, but time, yours and mine, is precious and it would be a 63 | shame to waste any of it. 64 | -------------------------------------------------------------------------------- /R/helper.R: -------------------------------------------------------------------------------- 1 | # Copyright (C) 2023 Brodie Gaslam 2 | # 3 | # This file is part of "vetr - Trust, but Verify" 4 | # 5 | # This program is free software: you can redistribute it and/or modify 6 | # it under the terms of the GNU General Public License as published by 7 | # the Free Software Foundation, either version 2 of the License, or 8 | # (at your option) any later version. 9 | # 10 | # This program is distributed in the hope that it will be useful, 11 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | # GNU General Public License for more details. 14 | # 15 | # Go to for a copy of the license. 16 | 17 | # This file contains interfaces to internal C functions for use with R based 18 | # unit testing frameworks 19 | 20 | ## Expand variable names to experessions if they contain language 21 | ## 22 | ## @keywords internal 23 | 24 | symb_sub <- function(symb, env=parent.frame()) 25 | .Call(VALC_symb_sub, symb, env) 26 | 27 | 28 | ## Parse Expressions For \code{`validate`} Use 29 | ## 30 | ## Takes expressions provided to \code{`\link{validate}`} and identifies which 31 | ## ones are templates, which ones are normal expressions, and substitutes the 32 | ## actual argument name for \code{`.`}. 33 | ## 34 | ## Internal function exposed for unit testing purposes 35 | ## 36 | ## @keywords internal 37 | ## @param symb an R symbol 38 | ## @param arg_name another R symbol 39 | ## @param an environment to look for language expressions to substitute 40 | ## @return list 41 | 42 | parse_validator <- function(lang, arg_name, rho=parent.frame()) 43 | .Call(VALC_parse, lang, arg_name, rho) 44 | 45 | ## Remove Parens and \code{`.(`} From Calls 46 | ## 47 | ## @keywords internal 48 | 49 | remove_parens <- function(lang) 50 | .Call(VALC_remove_parens, lang) 51 | 52 | ## Evaluates a test 53 | ## 54 | ## For unit testing 55 | ## 56 | ## @keywords internal 57 | 58 | eval_check <- function(lang, arg_name, arg_value, env=parent.frame()) 59 | .Call( 60 | VALC_eval_check, lang, arg_name, arg_name, arg_value, sys.call(), env 61 | ) 62 | 63 | ## Internal version of `all` 64 | ## 65 | ## @keywords internal 66 | 67 | val_all <- function(x) .Call(VALC_all, x) 68 | 69 | 70 | 71 | -------------------------------------------------------------------------------- /src/cstringrtest.c: -------------------------------------------------------------------------------- 1 | /* 2 | Copyright (C) 2023 Brodie Gaslam 3 | 4 | This file is part of "vetr - Trust, but Verify" 5 | 6 | This program is free software: you can redistribute it and/or modify 7 | it under the terms of the GNU General Public License as published by 8 | the Free Software Foundation, either version 2 of the License, or 9 | (at your option) any later version. 10 | 11 | This program is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | GNU General Public License for more details. 15 | 16 | Go to for a copy of the license. 17 | */ 18 | 19 | #include "cstringr.h" 20 | /* 21 | * Functions for testing corner cases in cstringr functions. Here because 22 | * size_t may be system dependent so we cannot test the results directly from R 23 | * where we have no mechanism for generating size_t values. 24 | * 25 | * These are all expected to produce errors 26 | */ 27 | 28 | SEXP CSR_test_strmcpy(void) { 29 | size_t maxlen = 0; 30 | maxlen--; // size_t of max value 31 | CSR_strmcpy("hello", maxlen); 32 | return R_NilValue; // nocov 33 | } 34 | 35 | SEXP CSR_test_strappend(void) { 36 | size_t maxlen = 0; 37 | maxlen--; // size_t of max value 38 | CSR_strappend("hello", "hello", maxlen); 39 | return R_NilValue; // nocov 40 | } 41 | 42 | SEXP CSR_test_add_szt(void) { 43 | size_t maxlen = 0; 44 | maxlen--; // size_t of max value 45 | CSR_add_szt(maxlen, maxlen); 46 | return R_NilValue; // nocov 47 | } 48 | /* 49 | * Make sure all the variations on CSR_smprintf6 actually work 50 | */ 51 | SEXP CSR_test_smprintfx(void) { 52 | return mkString( 53 | CSR_smprintf5( 54 | 10000, "%s\n%s\n%s\n%s\n", 55 | CSR_smprintf4(10000, "%s %s %s %s", "a", "b", "c", "d"), 56 | CSR_smprintf3(10000, "%s %s %s", "a", "b", "c"), 57 | CSR_smprintf2(10000, "%s %s", "a", "b"), 58 | CSR_smprintf1(10000, "%s", "a"), 59 | "the END" 60 | ) 61 | ); 62 | } 63 | // Make sure warning generated correctly 64 | 65 | SEXP CSR_test_strappend2(void) { 66 | char * str_new = R_alloc(20, sizeof(char)); 67 | CSR_strappend(str_new, "hellothere", 5); 68 | return R_NilValue; 69 | } 70 | -------------------------------------------------------------------------------- /src/pfhash.h: -------------------------------------------------------------------------------- 1 | /* 2 | copyright paxdiablo 3 | lifted directly from: http://powerfield-software.com/?p=615 under license: 4 | 5 | > Brodie, the code I hold copyright for in this article (which is the bulk of 6 | > it) is covered by the “do whatever the heck you want with it” licence, the 7 | > official text of which is: 8 | > 9 | > 1/ You are hereby permitted to do whatever the heck you want with it. 10 | > 11 | > I make no representations about the actual hashing functions themselves, 12 | > defaultFnKnR and defaultFnBJ. If you want to ensure you’re safe in respect to 13 | > those, either consult a lawyer, write your own, or see the addendum to this 14 | > article. 15 | */ 16 | /* 17 | Copyright (C) 2023 Brodie Gaslam 18 | 19 | This file is part of "vetr - Trust, but Verify" 20 | 21 | This program is free software: you can redistribute it and/or modify 22 | it under the terms of the GNU General Public License as published by 23 | the Free Software Foundation, either version 2 of the License, or 24 | (at your option) any later version. 25 | 26 | This program is distributed in the hope that it will be useful, 27 | but WITHOUT ANY WARRANTY; without even the implied warranty of 28 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 29 | GNU General Public License for more details. 30 | 31 | Go to for a copy of the license. 32 | */ 33 | 34 | 35 | #include 36 | #include 37 | #include 38 | #include 39 | 40 | #ifndef _PFHASH_H 41 | #define _PFHASH_H 42 | 43 | 44 | typedef struct sPfHashNode { 45 | const char *key; 46 | const char *data; 47 | struct sPfHashNode *next; 48 | } pfHashNode; 49 | 50 | typedef struct { 51 | uint32_t (*fn) (const char *); 52 | pfHashNode *lookup[]; 53 | } pfHashTable; 54 | 55 | pfHashTable *pfHashCreate (uint32_t(*)(const char*)); 56 | // void pfHashDestroy (pfHashTable*); 57 | int pfHashSet (pfHashTable*,const char*,const char*); 58 | int pfHashDel (pfHashTable*,const char*); 59 | const char *pfHashFind (pfHashTable*,const char*); 60 | void pfHashDebug (pfHashTable*,char*); 61 | SEXP pfHashTest(SEXP keys, SEXP values); 62 | SEXP pfHashTest2(SEXP keys, SEXP add); 63 | SEXP VALC_default_hash_fun(SEXP keys); 64 | 65 | #endif 66 | -------------------------------------------------------------------------------- /tests/unitizer/notcran.R: -------------------------------------------------------------------------------- 1 | # Copyright (C) 2023 Brodie Gaslam 2 | # 3 | # This file is part of "vetr - Trust, but Verify" 4 | # 5 | # This program is free software: you can redistribute it and/or modify 6 | # it under the terms of the GNU General Public License as published by 7 | # the Free Software Foundation, either version 2 of the License, or 8 | # (at your option) any later version. 9 | # 10 | # This program is distributed in the hope that it will be useful, 11 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | # GNU General Public License for more details. 14 | # 15 | # Go to for a copy of the license. 16 | 17 | # # Can't keep up with changes in ggplot. Leaving this here for legacy 18 | # # purposes. 19 | # library(vetr) 20 | # 21 | # # this file should be excluded via .Rbuildignore 22 | # 23 | # unitizer_sect("ggplot", { 24 | # # Rather experimental; we store the ggplot objects to avoid the suggests 25 | # df1 <- data.frame(x=runif(20), y=runif(20)) 26 | # df2 <- data.frame(x=runif(20), y=runif(20), z=rep(c("a", "b"), 10)) 27 | # df3 <- data.frame(a=runif(30), b=runif(30)) 28 | # 29 | # if( 30 | # suppressWarnings( 31 | # suppressPackageStartupMessages( 32 | # require(ggplot2, quietly=TRUE) 33 | # ) ) ) { 34 | # # one day this will break, but can't figure out right now how to get the 35 | # # deprecation warnings consistently enough to figure out what to do about 36 | # # them 37 | # 38 | # old.opt <- options(lifecycle_verbose_soft_deprecation=FALSE) 39 | # on.exit(options(old.opt)) 40 | # g1 <- ggplot(df1) + geom_point(aes(x=x, y=y)) 41 | # g2 <- ggplot(df1) + geom_line(aes(x=x, y=y)) 42 | # g3 <- ggplot(df3) + geom_point(aes(x=a, y=b)) 43 | # g4 <- ggplot(df1, aes(x=x, y=y)) + geom_point() + geom_line() 44 | # 45 | # g.abs <- abstract(g1) 46 | # 47 | # list(alike(g.abs, g1), alike(g.abs, g2), alike(g.abs, g3)) 48 | # } else { 49 | # # this is what the result should be so that this works when we skip the 50 | # # tests for lack of ggplot2 51 | # 52 | # list( 53 | # TRUE, 54 | # "`class(g2$layers[[1]]$geom)[2]` should be \"GeomPoint\" (is \"GeomPath\")", 55 | # TRUE 56 | # ) 57 | # } 58 | # }) 59 | # 60 | -------------------------------------------------------------------------------- /src/backports.h: -------------------------------------------------------------------------------- 1 | /* 2 | Copyright (C) 2023 Brodie Gaslam 3 | 4 | This file is part of "vetr - Trust, but Verify" 5 | 6 | This program is free software: you can redistribute it and/or modify 7 | it under the terms of the GNU General Public License as published by 8 | the Free Software Foundation, either version 2 of the License, or 9 | (at your option) any later version. 10 | 11 | This program is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | GNU General Public License for more details. 15 | 16 | Go to for a copy of the license. 17 | 18 | This file contains code copied from the R's Writing R Extensions manual. 19 | Original copyright notices follow. 20 | */ 21 | /* 22 | * R : A Computer Language for Statistical Data Analysis 23 | * Copyright (C) 1999--2025 The R Core Team. 24 | * Copyright (C) 1995, 1996 Robert Gentleman and Ross Ihaka 25 | * 26 | * This program is free software; you can redistribute it and/or modify 27 | * it under the terms of the GNU General Public License as published by 28 | * the Free Software Foundation; either version 2 of the License, or 29 | * (at your option) any later version. 30 | * 31 | * This program is distributed in the hope that it will be useful, 32 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 33 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 34 | * GNU General Public License for more details. 35 | * 36 | * You should have received a copy of the GNU General Public License 37 | * along with this program; if not, a copy is available at 38 | * https://www.R-project.org/Licenses/ 39 | */ 40 | 41 | /* 42 | * Include after R header files 43 | * 44 | * Code necessitated by the API restrictions implemented in R4.6+ 45 | */ 46 | 47 | #include 48 | #if R_VERSION < R_Version(4, 4, 1) 49 | #define allocLang Rf_allocLang 50 | 51 | static SEXP Rf_allocLang(int n) 52 | { 53 | if (n > 0) 54 | return LCONS(R_NilValue, Rf_allocList(n - 1)); 55 | else 56 | return R_NilValue; 57 | } 58 | #endif 59 | 60 | #if R_VERSION < R_Version(4, 5, 0) 61 | # define R_ClosureFormals(x) FORMALS(x) 62 | # define R_ParentEnv(x) ENCLOS(x) 63 | 64 | #endif 65 | -------------------------------------------------------------------------------- /.github/workflows/R-CMD-check.yaml: -------------------------------------------------------------------------------- 1 | on: 2 | push: 3 | branches: 4 | - rc 5 | pull_request: 6 | branches: 7 | - master 8 | - development 9 | 10 | name: R-CMD-check 11 | 12 | env: 13 | cache-version: v2 14 | 15 | jobs: 16 | # Always run release 17 | R-CMD-check-release: 18 | runs-on: ubuntu-latest 19 | name: ubuntu-latest (release) 20 | 21 | env: 22 | R_REMOTES_NO_ERRORS_FROM_WARNINGS: true 23 | _R_CHECK_FORCE_SUGGESTS_: false 24 | 25 | steps: 26 | - uses: actions/checkout@v4 27 | - uses: r-lib/actions/setup-pandoc@v2 28 | - uses: r-lib/actions/setup-r@v2 29 | with: 30 | r-version: 'release' 31 | use-public-rspm: true 32 | - uses: r-lib/actions/setup-r-dependencies@v2 33 | with: 34 | extra-packages: any::rcmdcheck, any::covr 35 | needs: check 36 | - name: Check 37 | uses: r-lib/actions/check-r-package@v2 38 | with: 39 | args: 'c("--no-manual", "--as-cran")' 40 | 41 | - name: Test coverage 42 | if: github.event_name == 'push' && github.ref == 'refs/heads/rc' 43 | env: 44 | CODECOV_TOKEN: ${{ secrets.CODECOV_TOKEN }} 45 | run: | 46 | options(covr.exclude_end="(?://|#)[[:space:]]*nocov[[:space:]]*end") 47 | options(covr.exclude_start="(?://|#)[[:space:]]*nocov[[:space:]]*start") 48 | options(covr.exclude_pattern="(?://|#)[[:space:]]*nocov") 49 | covr::codecov(token = Sys.getenv("CODECOV_TOKEN")) 50 | shell: Rscript {0} 51 | 52 | # Only run on push to rc 53 | R-CMD-check-extended: 54 | if: github.event_name == 'push' && github.ref == 'refs/heads/rc' 55 | runs-on: ubuntu-latest 56 | name: ubuntu-latest (${{ matrix.r }}) 57 | 58 | strategy: 59 | fail-fast: false 60 | matrix: 61 | r: ['devel', 'oldrel-1'] 62 | 63 | env: 64 | R_REMOTES_NO_ERRORS_FROM_WARNINGS: true 65 | _R_CHECK_FORCE_SUGGESTS_: false 66 | 67 | steps: 68 | - uses: actions/checkout@v4 69 | - uses: r-lib/actions/setup-pandoc@v2 70 | - uses: r-lib/actions/setup-r@v2 71 | with: 72 | r-version: ${{ matrix.r }} 73 | use-public-rspm: true 74 | - uses: r-lib/actions/setup-r-dependencies@v2 75 | with: 76 | extra-packages: any::rcmdcheck 77 | needs: check 78 | - name: Check 79 | uses: r-lib/actions/check-r-package@v2 80 | with: 81 | args: 'c("--no-manual", "--as-cran")' 82 | -------------------------------------------------------------------------------- /tests/unitizer/helper/UTF-8-critical.R: -------------------------------------------------------------------------------- 1 | # In own file due to Solaris issues preventing direct inclusion in unitizer 2 | # 3 | # Well-Formed UTF-8 Byte Sequences 4 | # 5 | # Code Points | Byte 1 | Byte 2 | Byte 3 | Byte 4 6 | # U+0000..U+007F | 00..7F | 7 | # U+0080..U+07FF | C2..DF | 80..BF 8 | # U+0800..U+0FFF | E0 | A0..BF | 80..BF 9 | # U+1000..U+CFFF | E1..EC | 80..BF | 80..BF 10 | # U+D000..U+D7FF | ED | 80..9F | 80..BF 11 | # U+E000..U+FFFF | EE..EF | 80..BF | 80..BF 12 | # U+10000..U+3FFFF | F0 | 90..BF | 80..BF | 80..BF 13 | # U+40000..U+FFFFF | F1..F3 | 80..BF | 80..BF | 80..BF 14 | # U+100000..U+10FFFF | F4 | 80..8F | 80..BF | 80..BF 15 | 16 | # Check all the critical cases where we transition from legal to illegal 17 | # sequences 18 | 19 | crit.1 <- c( 20 | n.0="\x7F", 21 | y.1="\x80" 22 | ) 23 | Encoding(crit.1) <- "UTF-8" 24 | crit.2 <- c( 25 | n.0="\xC1\x91", 26 | n.1="\xC2\x79", 27 | y.2="\xC2\x80", 28 | y.3="\xDF\xBF", 29 | n.4="\xDF\xC0" 30 | ) 31 | Encoding(crit.2) <- "UTF-8" 32 | crit.3 <- c( 33 | n.00="\xE0\x9F\x91", 34 | n.01="\xE0\xA0\x79", 35 | y.02="\xE0\xA0\x80", 36 | y.03="\xE0\xBF\xBF", 37 | n.04="\xE0\xBF\xC0", 38 | n.05="\xE1\x79\x91", 39 | y.06="\xE1\x80\x80", 40 | y.07="\xEC\xBF\xBF", 41 | n.08="\xEC\xBF\xC0", 42 | n.10="\xEC\xC0\xBF", 43 | n.11="\xED\x79\x80", 44 | n.12="\xED\x80\x79", 45 | y.13="\xED\x80\x80", 46 | y.14="\xED\x9F\xBF", 47 | n.16="\xED\x9F\xC0", 48 | n.17="\xED\xA0\xBF", 49 | n.18="\xEE\x80\x79", 50 | n.19="\xEE\x79\x80", 51 | y.20="\xEE\x80\x80", 52 | y.21="\xEF\xBF\xBF", 53 | n.22="\xEF\xBF\xC0", 54 | n.23="\xEF\xC0\xBF" 55 | ) 56 | Encoding(crit.3) <- "UTF-8" 57 | crit.4 <- c( 58 | n.00="\xF0\x89\x80\x80", 59 | n.01="\xF0\x90\x79\x80", 60 | n.02="\xF0\x90\x80\x79", 61 | y.03="\xF0\x90\x80\x80", 62 | y.04="\xF0\xBF\xBF\xBF", 63 | n.06="\xF0\xBF\xBF\xC0", 64 | n.07="\xF0\xBF\xC0\xBF", 65 | n.08="\xF0\xC0\xBF\xBF", 66 | n.09="\xF1\x80\x80\x79", 67 | n.10="\xF1\x80\x79\x80", 68 | n.11="\xF1\x79\x80\x80", 69 | y.12="\xF1\x80\x80\x80", 70 | y.13="\xF3\xBF\xBF\xBF", 71 | n.14="\xF3\xBF\xBF\xC0", 72 | n.15="\xF3\xBF\xC0\xBF", 73 | n.16="\xF3\xC0\xBF\xBF", 74 | n.17="\xF4\x80\x80\x79", 75 | n.18="\xF4\x80\x79\x80", 76 | n.19="\xF4\x79\x80\x80", 77 | y.20="\xF4\x80\x80\x80", 78 | y.21="\xF4\x8F\xBF\xBF", 79 | n.22="\xF4\x8F\xBF\xC0", 80 | n.23="\xF4\x8F\xC0\xBF", 81 | n.24="\xF4\x90\x01\x01", 82 | n.25="\xF5\x81\x81\x81" 83 | ) 84 | Encoding(crit.4) <- "UTF-8" 85 | -------------------------------------------------------------------------------- /R/type.R: -------------------------------------------------------------------------------- 1 | # Copyright (C) 2023 Brodie Gaslam 2 | # 3 | # This file is part of "vetr - Trust, but Verify" 4 | # 5 | # This program is free software: you can redistribute it and/or modify 6 | # it under the terms of the GNU General Public License as published by 7 | # the Free Software Foundation, either version 2 of the License, or 8 | # (at your option) any later version. 9 | # 10 | # This program is distributed in the hope that it will be useful, 11 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | # GNU General Public License for more details. 14 | # 15 | # Go to for a copy of the license. 16 | 17 | #' @export 18 | #' @rdname type_alike 19 | 20 | type_of <- function(object) 21 | .Call(VALC_typeof, object) 22 | 23 | #' Fuzzily Compare Types of Objects 24 | #' 25 | #' Type evaluation and comparison is carried out with special treatment for 26 | #' numerics, integers, and function types. Whole number NA-free numeric vectors 27 | #' of sufficiently short length (<100 by default) representable in the integer 28 | #' type are considered to be type integer. Closures, built-ins, and specials 29 | #' are all treated as type closure. 30 | #' 31 | #' Specific behavior can be tuned with the `type.mode` parameter to the 32 | #' [vetr_settings()] object passed as the `settings` parameter to this function. 33 | #' 34 | #' @seealso [alike()], [vetr_settings()], in particular the section about 35 | #' the `type.mode` parameter which affects how this function behaves. 36 | #' @param target the object to test type alikeness against 37 | #' @param current the object to test the type alikeness of 38 | #' @param settings NULL, or a list as produced by [vetr_settings()] 39 | #' @param object the object to check the type of 40 | #' @return For `type_of` character(1L) the type of the object, for `type_alike` 41 | #' either TRUE, or a string describing why the types are not alike. 42 | #' @export 43 | #' @examples 44 | #' type_of(1.0001) # numeric 45 | #' type_of(1.0) # integer (`typeof` returns numeric) 46 | #' type_of(1) # integer (`typeof` returns numeric) 47 | #' type_of(sum) # closure (`typeof` returns builtin) 48 | #' type_of(`$`) # closure (`typeof` returns special) 49 | #' 50 | #' type_alike(1L, 1) 51 | #' type_alike(1L, 1.1) 52 | #' type_alike(integer(), numeric(100)) 53 | #' type_alike(integer(), numeric(101)) # too long 54 | 55 | type_alike <- function(target, current, settings=NULL) 56 | .Call(VALC_type_alike, target, current, substitute(current), settings) 57 | -------------------------------------------------------------------------------- /vignettes/rmdhunks/declarative-checks.Rmd: -------------------------------------------------------------------------------- 1 | ## Declarative Checks with Templates 2 | 3 | ### Templates 4 | 5 | Declare a template that an object should conform to, and let `vetr` take care of 6 | the rest: 7 | 8 | ```{r} 9 | library(vetr) 10 | tpl <- numeric(1L) 11 | vet(tpl, 1:3) 12 | vet(tpl, "hello") 13 | vet(tpl, 42) 14 | ``` 15 | 16 | The template concept is based on `vapply`, but generalizes to all S3 objects and 17 | adds some special features to facilitate comparison. For example, zero length 18 | templates match any length: 19 | 20 | ```{r} 21 | tpl <- integer() 22 | vet(tpl, 1L:3L) 23 | vet(tpl, 1L) 24 | ``` 25 | 26 | And for convenience short (<= 100 length) integer-like numerics are considered 27 | integer: 28 | 29 | ```{r} 30 | tpl <- integer(1L) 31 | vet(tpl, 1) # this is a numeric, not an integer 32 | vet(tpl, 1.0001) 33 | ``` 34 | 35 | `vetr` can compare recursive objects such as lists, or data.frames: 36 | 37 | ```{r} 38 | tpl.iris <- iris[0, ] # 0 row DF matches any number of rows in object 39 | iris.fake <- iris 40 | levels(iris.fake$Species)[3] <- "sibirica" # tweak levels 41 | 42 | vet(tpl.iris, iris) 43 | vet(tpl.iris, iris.fake) 44 | ``` 45 | 46 | From our declared template `iris[0, ]`, `vetr` infers all the required checks. 47 | In this case, `vet(iris[0, ], iris.fake, stop=TRUE)` is equivalent to: 48 | 49 | ```{r} 50 | stopifnot_iris <- function(x) { 51 | stopifnot( 52 | is.data.frame(x), 53 | is.list(x), 54 | length(x) == length(iris), 55 | identical(lapply(x, class), lapply(iris, class)), 56 | is.integer(attr(x, 'row.names')), 57 | identical(names(x), names(iris)), 58 | identical(typeof(x$Species), "integer"), 59 | identical(levels(x$Species), levels(iris$Species)) 60 | ) 61 | } 62 | stopifnot_iris(iris.fake) 63 | ``` 64 | 65 | `vetr` saved us typing, and the time and thought needed to come up with what 66 | needs to be compared. 67 | 68 | You could just as easily have created templates for nested lists, or data frames 69 | in lists. Templates are compared to objects with the `alike` function. For a 70 | thorough description of templates and how they work see the [`alike` 71 | vignette][2]. For template examples see `example(alike)`. 72 | 73 | ### Auto-Generated Error Messages 74 | 75 | Let's revisit the error message: 76 | 77 | ```{r} 78 | vet(tpl.iris, iris.fake) 79 | ``` 80 | 81 | It tells us: 82 | 83 | * The reason for the failure 84 | * What structure would be acceptable instead 85 | * The location of failure `levels(iris.fake$Species)[3]` 86 | 87 | `vetr` does what it can to reduce the time from error to resolution. The 88 | location of failure is generated such that you can easily copy it in part or 89 | full to the R prompt for further examination. 90 | -------------------------------------------------------------------------------- /R/all-bw.R: -------------------------------------------------------------------------------- 1 | #' Verify Values in Vector are Between Two Others 2 | #' 3 | #' Similar to \code{isTRUE(all(x >= lo & x <= hi))} with default settings, 4 | #' except that it is substantially faster and returns a string describing the 5 | #' first encountered violation rather than FALSE on failure. 6 | #' 7 | #' You can modify the comparison to be strictly greater/less than via the 8 | #' `bounds` parameter, and the treatment of NAs with `na.rm`. Note that NAs are 9 | #' considered to be out of bounds by default. While technically incorrect 10 | #' since we cannot know whether an NA value is in or out of bounds, this 11 | #' assumption is both conservative and convenient. Zero length `x` will always 12 | #' succeed. 13 | #' 14 | #' If `x` and `lo`/`hi` are different types, `lo`/`hi` will be coerced to the 15 | #' type of `x`. When `lo`/`hi` are numeric and `x` is integer, if `lo`/`hi` 16 | #' values are outside of the integer range then that side will be treated as if 17 | #' you had used `-Inf`/`Inf`. `-Inf` and `Inf` mean `lo` and `hi` will be 18 | #' unbounded for all data types. 19 | #' 20 | #' @export 21 | #' @param x vector logical (treated as integer), integer, numeric, or character. 22 | #' Factors are treated as their underlying integer vectors. 23 | #' @param lo scalar vector of type coercible to the type of `x`, cannot be NA, 24 | #' use `-Inf` to indicate unbounded (default). 25 | #' @param hi scalar vector of type coercible to the type of `x`, cannot be NA, 26 | #' use `Inf` to indicate unbounded (default), must be greater than or equal to 27 | #' `lo`. 28 | #' @param na.rm TRUE, or FALSE (default), whether NAs are considered to be 29 | #' in bounds. Unlike with [all()], for `all_bw` `na.rm=FALSE` returns an 30 | #' error string if there are NAs instead of NA. Arguably NA, but not NaN, 31 | #' should be considered to be in `[-Inf,Inf]`, but since `NA < Inf` is NA we 32 | #' treat them as always being out of bounds. 33 | #' @param bounds `character(1L)` for values between `lo` and `hi`: 34 | #' * \dQuote{[]} include `lo` and `hi` 35 | #' * \dQuote{()} exclude `lo` and `hi` 36 | #' * \dQuote{(]} exclude `lo`, include `hi` 37 | #' * \dQuote{[)} include `lo`, exclude `hi` 38 | #' 39 | #' @return TRUE if all values in `x` conform to the specified bounds, a string 40 | #' describing the first position that fails otherwise 41 | #' @examples 42 | #' all_bw(runif(100), 0, 1) 43 | #' all_bw(runif(100) * 2, 0, 1) 44 | #' all_bw(NA, 0, 1) # This is does not return NA 45 | #' all_bw(NA, 0, 1, na.rm=TRUE) 46 | #' 47 | #' vec <- c(runif(100, 0, 1e12), Inf, 0) 48 | #' all_bw(vec, 0) # All +ve numbers 49 | #' all_bw(vec, hi=0) # All -ve numbers 50 | #' all_bw(vec, 0, bounds="(]") # All strictly +ve nums 51 | #' all_bw(vec, 0, bounds="[)") # All finite +ve nums 52 | 53 | all_bw <- function(x, lo=-Inf, hi=Inf, na.rm=FALSE, bounds="[]") 54 | .Call(VALC_all_bw, x, lo, hi, na.rm, bounds) 55 | 56 | 57 | -------------------------------------------------------------------------------- /tests/unitizer/type.R: -------------------------------------------------------------------------------- 1 | # Copyright (C) 2023 Brodie Gaslam 2 | # 3 | # This file is part of "vetr - Trust, but Verify" 4 | # 5 | # This program is free software: you can redistribute it and/or modify 6 | # it under the terms of the GNU General Public License as published by 7 | # the Free Software Foundation, either version 2 of the License, or 8 | # (at your option) any later version. 9 | # 10 | # This program is distributed in the hope that it will be useful, 11 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | # GNU General Public License for more details. 14 | # 15 | # Go to for a copy of the license. 16 | 17 | library(vetr) 18 | 19 | # Redefine names; necessary because we renamed functions when moving to C 20 | # versions 21 | 22 | unitizer_sect("type_of", { 23 | type_of(1:100) 24 | type_of(1.1) 25 | type_of(1:100 + 1.0) 26 | type_of(1:100 + 1/1e9) 27 | type_of(NA_real_) 28 | type_of(Inf) 29 | type_of(-Inf) 30 | } ) 31 | unitizer_sect("type_alike", { 32 | type_alike(1, 1.1) # TRUE, 1 is numeric 33 | type_alike(1L, 1.1) # FALSE 34 | type_alike(1L, 1.00000001) # FALSE 35 | type_alike(1L, 1.0) # TRUE 36 | 37 | type_alike(1, 1.1, vetr_settings(type.mode=1)) # TRUE, 1 is numeric 38 | type_alike(1L, 1.0, vetr_settings(type.mode=1)) # FALSE 39 | type_alike(1.0, 1L, vetr_settings(type.mode=1)) # TRUE 40 | type_alike(1.0, 1L, vetr_settings(type.mode=2)) # FALSE, must be num-num 41 | 42 | type_alike(1:100, 1:100 + 0.0) # TRUE 43 | type_alike(1:101, 1:101 + 0.0) # FALSE 44 | type_alike(1:101, 1:101 + 0.0, vetr_settings(fuzzy.int.max.len=200)) # TRUE 45 | 46 | type_alike(numeric(), c(1.1, 0.053, 41.8)) # TRUE 47 | type_alike(numeric(), list(1.1)) # FALSE 48 | type_alike(list(), integer()) # FALSE 49 | type_alike(1000000L, 1000000L + .1) # FALSE 50 | type_alike(1000000L, 1000000L + .0) # TRUE 51 | type_alike(data.frame(a=1:10), list()) # TRUE 52 | type_alike(NULL, NULL) 53 | type_alike(1/0, NA) 54 | 55 | # errors 56 | 57 | type_alike(1, 1.1, vetr_settings(type.mode=1:2)) 58 | type_alike(1, 1.1, vetr_settings(fuzzy.int.max.len=1:2)) 59 | } ) 60 | unitizer_sect("functions", { 61 | type_alike(sd, var) # clo-clo 62 | type_alike(`&&`, sd) # spe-clo 63 | type_alike(`&&`, sum) # spe-blt 64 | type_alike(sum, sd) # blt-clo 65 | type_alike(sum, c) # blt-blt 66 | type_alike(`&&`, `[`) # spe-spe 67 | 68 | type_alike(sd, 1:3) 69 | 70 | type_alike(sd, var, vetr_settings(type.mode=1)) # clo-clo 71 | type_alike(`&&`, sd, vetr_settings(type.mode=1)) # spe-clo 72 | type_alike(`&&`, sum, vetr_settings(type.mode=1)) # spe-blt 73 | type_alike(sum, sd, vetr_settings(type.mode=1)) # blt-clo 74 | type_alike(sum, c, vetr_settings(type.mode=1)) # blt-blt 75 | type_alike(`&&`, `[`, vetr_settings(type.mode=1)) # spe-spe 76 | } ) 77 | -------------------------------------------------------------------------------- /man/all_bw.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/all-bw.R 3 | \name{all_bw} 4 | \alias{all_bw} 5 | \title{Verify Values in Vector are Between Two Others} 6 | \usage{ 7 | all_bw(x, lo = -Inf, hi = Inf, na.rm = FALSE, bounds = "[]") 8 | } 9 | \arguments{ 10 | \item{x}{vector logical (treated as integer), integer, numeric, or character. 11 | Factors are treated as their underlying integer vectors.} 12 | 13 | \item{lo}{scalar vector of type coercible to the type of \code{x}, cannot be NA, 14 | use \code{-Inf} to indicate unbounded (default).} 15 | 16 | \item{hi}{scalar vector of type coercible to the type of \code{x}, cannot be NA, 17 | use \code{Inf} to indicate unbounded (default), must be greater than or equal to 18 | \code{lo}.} 19 | 20 | \item{na.rm}{TRUE, or FALSE (default), whether NAs are considered to be 21 | in bounds. Unlike with \code{\link[=all]{all()}}, for \code{all_bw} \code{na.rm=FALSE} returns an 22 | error string if there are NAs instead of NA. Arguably NA, but not NaN, 23 | should be considered to be in \verb{[-Inf,Inf]}, but since \code{NA < Inf} is NA we 24 | treat them as always being out of bounds.} 25 | 26 | \item{bounds}{\code{character(1L)} for values between \code{lo} and \code{hi}: 27 | \itemize{ 28 | \item \dQuote{[]} include \code{lo} and \code{hi} 29 | \item \dQuote{()} exclude \code{lo} and \code{hi} 30 | \item \dQuote{(]} exclude \code{lo}, include \code{hi} 31 | \item \dQuote{[)} include \code{lo}, exclude \code{hi} 32 | }} 33 | } 34 | \value{ 35 | TRUE if all values in \code{x} conform to the specified bounds, a string 36 | describing the first position that fails otherwise 37 | } 38 | \description{ 39 | Similar to \code{isTRUE(all(x >= lo & x <= hi))} with default settings, 40 | except that it is substantially faster and returns a string describing the 41 | first encountered violation rather than FALSE on failure. 42 | } 43 | \details{ 44 | You can modify the comparison to be strictly greater/less than via the 45 | \code{bounds} parameter, and the treatment of NAs with \code{na.rm}. Note that NAs are 46 | considered to be out of bounds by default. While technically incorrect 47 | since we cannot know whether an NA value is in or out of bounds, this 48 | assumption is both conservative and convenient. Zero length \code{x} will always 49 | succeed. 50 | 51 | If \code{x} and \code{lo}/\code{hi} are different types, \code{lo}/\code{hi} will be coerced to the 52 | type of \code{x}. When \code{lo}/\code{hi} are numeric and \code{x} is integer, if \code{lo}/\code{hi} 53 | values are outside of the integer range then that side will be treated as if 54 | you had used \code{-Inf}/\code{Inf}. \code{-Inf} and \code{Inf} mean \code{lo} and \code{hi} will be 55 | unbounded for all data types. 56 | } 57 | \examples{ 58 | all_bw(runif(100), 0, 1) 59 | all_bw(runif(100) * 2, 0, 1) 60 | all_bw(NA, 0, 1) # This is does not return NA 61 | all_bw(NA, 0, 1, na.rm=TRUE) 62 | 63 | vec <- c(runif(100, 0, 1e12), Inf, 0) 64 | all_bw(vec, 0) # All +ve numbers 65 | all_bw(vec, hi=0) # All -ve numbers 66 | all_bw(vec, 0, bounds="(]") # All strictly +ve nums 67 | all_bw(vec, 0, bounds="[)") # All finite +ve nums 68 | } 69 | -------------------------------------------------------------------------------- /man/abstract.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/abstract.R 3 | \name{abstract} 4 | \alias{abstract} 5 | \alias{abstract.data.frame} 6 | \alias{abstract.default} 7 | \alias{abstract.array} 8 | \alias{abstract.matrix} 9 | \alias{abstract.list} 10 | \alias{abstract.lm} 11 | \alias{abstract.environment} 12 | \alias{abstract.ts} 13 | \title{Turn S3 Objects Into Templates} 14 | \usage{ 15 | abstract(x, ...) 16 | 17 | \method{abstract}{data.frame}(x, ...) 18 | 19 | \method{abstract}{default}(x, ...) 20 | 21 | \method{abstract}{array}(x, ...) 22 | 23 | \method{abstract}{matrix}(x, ...) 24 | 25 | \method{abstract}{list}(x, ...) 26 | 27 | \method{abstract}{lm}(x, ...) 28 | 29 | \method{abstract}{environment}(x, ...) 30 | 31 | \method{abstract}{ts}(x, what = c("start", "end", "frequency"), ...) 32 | } 33 | \arguments{ 34 | \item{x}{the object to abstract} 35 | 36 | \item{...}{arguments for methods that require further arguments} 37 | 38 | \item{what, }{for time series which portion of the \code{ts} attribute to 39 | abstract, by default all three are abstracted, but you can select, any one, 40 | two, or all} 41 | } 42 | \value{ 43 | abstracted object 44 | } 45 | \description{ 46 | Create templates for use by \code{\link{alike}}. Currently somewhat 47 | experimental; behavior may change in future. 48 | } 49 | \details{ 50 | \code{abstract} is intended to create templates for use by 51 | \code{\link{alike}}. The result of abstraction is often a partially 52 | specified object. This type of object may not be suited for use in typical 53 | R computations and may cause errors (or worse) if you try to use them as 54 | normal R objects. 55 | 56 | There is no guarantee that the \code{abstract}ed object is suitable for use 57 | as a template to \code{alike} as is. You may need to modify it further so 58 | that it suits your purposes. 59 | 60 | \code{abstract} is an S3 generic. The default method will 61 | dispatch on implicit classes, so if you attempt to \code{abstract} an object 62 | without an explicit \code{abstract} method, it will get abstracted based on 63 | its implicit class. If you define your own \code{abstract} method and do not 64 | wish further abstraction based on implicit classes do not use 65 | \code{\link{NextMethod}}. 66 | 67 | S4 and RC objects are returned unchanged. 68 | } 69 | \section{Time Series}{ 70 | 71 | 72 | \code{\link{alike}} will treat time series parameter components with zero in 73 | them as wildcards. This function allows you to create these wild card time 74 | series attributes since R does not allow direct creation/modification of 75 | \code{ts} attributes with zero values. 76 | 77 | Make sure you do not try to use the templates you create with this for 78 | anything other than as \code{\link{alike}} templates since the result is 79 | likely undefined given R expects non zero values for the \code{ts} 80 | attribute and attempts to prevent such attributes. 81 | } 82 | 83 | \examples{ 84 | iris.tpl <- abstract(iris) 85 | alike(iris.tpl, iris[1:10, ]) 86 | alike(iris.tpl, transform(iris, Species=as.character(Species))) 87 | 88 | abstract(1:10) 89 | abstract(matrix(1:9, nrow=3)) 90 | abstract(list(1:9, runif(10))) 91 | } 92 | -------------------------------------------------------------------------------- /tests/unitizer/abstract.R: -------------------------------------------------------------------------------- 1 | # Copyright (C) 2023 Brodie Gaslam 2 | # 3 | # This file is part of "vetr - Trust, but Verify" 4 | # 5 | # This program is free software: you can redistribute it and/or modify 6 | # it under the terms of the GNU General Public License as published by 7 | # the Free Software Foundation, either version 2 of the License, or 8 | # (at your option) any later version. 9 | # 10 | # This program is distributed in the hope that it will be useful, 11 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | # GNU General Public License for more details. 14 | # 15 | # Go to for a copy of the license. 16 | 17 | library(vetr) 18 | 19 | unitizer_sect("Standard Methods", { 20 | abstract(1:10) 21 | abstract(list(a=1:10, b=runif(10))) 22 | abstract(matrix(1:9, nrow=3)) 23 | abstract( 24 | array(1:8, c(2, 2, 2), dimnames=list(letters[1:2], LETTERS[1:2], NULL)) 25 | ) 26 | # non atomic 27 | list.arr <- replicate(8, list(1), simplify=FALSE) 28 | dim(list.arr) <- rep(2, 3) 29 | abstract(list.arr) 30 | abstract(list(1, NULL)) 31 | 32 | # df 33 | alike(abstract(iris), iris[1:10, ]) 34 | alike(abstract(iris), iris[1:10, 1:3]) 35 | alike(abstract(iris), transform(iris, Species=as.character(Species))) 36 | 37 | my.env <- new.env() 38 | identical(my.env, abstract(my.env)) 39 | }) 40 | unitizer_sect("Time Series", { 41 | y <- ts(runif(12), start=1970, frequency=12) 42 | attr(abstract(y), "tsp") 43 | attr(abstract(y, "start"), "tsp") 44 | attr(abstract(y, "end"), "tsp") 45 | attr(abstract(y, "frequency"), "tsp") 46 | attr(abstract(y, c("start", "frequency")), "tsp") 47 | 48 | # Errors 49 | 50 | abstract(y, "boom") 51 | vetr:::abstract.ts(1:12) 52 | }) 53 | unitizer_sect("s4", { 54 | ## s4 objects are unaffected 55 | obj <- new("unitizerGlobalState") 56 | abstract(obj) 57 | nullify(obj, 1) 58 | }) 59 | unitizer_sect("lm", { 60 | set.seed(1) 61 | df1 <- data.frame(x = runif(10), y=runif(10), z=runif(10)) 62 | df2 <- data.frame(a = runif(5), b=runif(5), c=runif(5)) 63 | mdl <- lm(y ~ x + poly(z, 2), df1) 64 | 65 | alike(abstract(mdl), mdl) 66 | 67 | mdl2 <- lm(x ~ y + poly(z, 2), df1) 68 | 69 | alike(abstract(mdl), mdl2) 70 | 71 | mdl3 <- lm(a ~ b + log(c), df2) 72 | 73 | alike(abstract(mdl), mdl3) 74 | 75 | mdl4 <- lm(a ~ b, df2) 76 | 77 | alike(abstract(mdl), mdl4) 78 | }) 79 | unitizer_sect("nullify", { 80 | nullify(list(1, 2, 3), 2) 81 | nullify(list(1, 2, 3), -2) 82 | nullify(list(1, 2, 3, 4), c(TRUE, FALSE)) 83 | nullify(list(1, 2, 3, 4), c(TRUE, FALSE, FALSE)) 84 | nullify(list(1, 2, 3, 4), c(rep(FALSE, 4), TRUE)) 85 | nullify(list(a=1, b=2, 3, 4), c("a", "b")) 86 | nullify(list(1, 2, 3, 4), "hello") 87 | 88 | nullify(list(1, 2, 3), 4) 89 | 90 | ## can't print the data frame because the concomitant warning changes in 91 | ## r75024 (see issue#96), and limitations of unitizer (unitizer:issue249) 92 | 93 | iris.null <- nullify(iris[1:10, ], 4) 94 | as.list(iris.null) 95 | class(iris.null) 96 | 97 | nullify(letters, 5) 98 | 99 | nullify(structure(letters[1:2], class='xqwer892jahaksdf'), 2) 100 | }) 101 | -------------------------------------------------------------------------------- /tests/unitizer/classes.R: -------------------------------------------------------------------------------- 1 | # Copyright (C) 2023 Brodie Gaslam 2 | # 3 | # This file is part of "vetr - Trust, but Verify" 4 | # 5 | # This program is free software: you can redistribute it and/or modify 6 | # it under the terms of the GNU General Public License as published by 7 | # the Free Software Foundation, either version 2 of the License, or 8 | # (at your option) any later version. 9 | # 10 | # This program is distributed in the hope that it will be useful, 11 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | # GNU General Public License for more details. 14 | # 15 | # Go to for a copy of the license. 16 | 17 | library(vetr) 18 | 19 | unitizer_sect("Class Matching", { 20 | obj2 <- structure(numeric()) 21 | obj1 <- structure(numeric(), class="hello") 22 | alike(obj1, obj2) 23 | obj2 <- structure(numeric(), class=c(letters[10:12], letters[1:3], letters[8:9])) 24 | obj1 <- structure(numeric(), class=letters[1:3]) 25 | alike(obj1, obj2) 26 | alike(obj2, obj1) 27 | obj2 <- structure(numeric(), class=c("b", "a", "c")) 28 | alike(obj1, obj2) 29 | obj2 <- structure(numeric(), class=c("a", "b", "x", "c")) 30 | alike(obj1, obj2) 31 | obj2 <- structure(numeric(), class=c("a", "b", "c")) 32 | alike(obj1, obj2) # TRUE 33 | obj2 <- structure(numeric(), class=c("x", "a", "b", "c")) 34 | alike(obj1, obj2) # TRUE 35 | alike(obj1, obj2, settings=vetr_settings(attr.mode=1)) # FALSE 36 | } ) 37 | unitizer_sect("S4", { 38 | # We used to define classes here, but under unitizer by virtue of vetr being 39 | # the first package on the search path, that is where the class definitions 40 | # ended up due to logic in topenv(). That seemed fragile so we switched to 41 | # defining in package. 42 | 43 | x <- new("vetr_foo") 44 | y <- new("vetr_foo") 45 | z <- new("vetr_bar") 46 | v <- new("vetr_baz") 47 | w <- structure(list(a=character(), b=numeric()), class="vetr_foo") 48 | 49 | alike(x, y) # TRUE 50 | alike(x, z) # FALSE 51 | alike(x, w) # FALSE 52 | alike(w, x) # FALSE 53 | alike(x, v) # TRUE, because v contains x 54 | alike(v, x) # FALSE 55 | 56 | # S4 nested in list 57 | 58 | lst.2 <- list(list(11, 21), list(31, list(41, list(51, list(61))))) 59 | lst.5 <- lst.6 <- lst.2 60 | lst.5[[2]][[2]][[1]] <- x 61 | lst.6[[2]][[2]][[1]] <- v 62 | 63 | alike(lst.5, lst.6) # TRUE 64 | alike(lst.6, lst.5) # FALSE, child class is target, so parent can't match 65 | 66 | # Borked S4 67 | v2 <- v 68 | class(v2) <- c("vetr_baz", "vetr_foo") 69 | alike(x, v2) 70 | 71 | # Stress test installation of `inherits`; right now the inherits command is 72 | # evaluated in the base environment, which seems to work since the arguments 73 | # are already evaluated, but it suggests `inherits` can look up S4 definitions 74 | # irrespective of where they are defined... 75 | 76 | inherits <- function(x, y) stop("pwned!!!") 77 | alike(y, v) # TRUE 78 | } ) 79 | unitizer_sect("R5", { 80 | Foo.1 <- vetr:::Foo$new() 81 | Foo.2 <- vetr:::Foo$new() 82 | Bar.1 <- vetr:::Bar$new() 83 | 84 | alike(Foo.1, Foo.2) 85 | alike(Foo.1, Bar.1) 86 | 87 | } ) 88 | unitizer_sect("Non-Standard Class", { 89 | # Basically ensure that stuff still recurses even if they are lists/calls 90 | # but have another class 91 | 92 | var.1 <- list(1, 2, 3) 93 | var.2 <- list("hello", list(1, 2, 3), 5) 94 | class(var.1) <- "marbles" 95 | class(var.2) <- "marbles" 96 | # "mis-match at index [[1]]: should be integer instead of character" 97 | alike(var.1, var.2) 98 | } ) 99 | -------------------------------------------------------------------------------- /tests/unitizer/parse.R: -------------------------------------------------------------------------------- 1 | # Copyright (C) 2023 Brodie Gaslam 2 | # 3 | # This file is part of "vetr - Trust, but Verify" 4 | # 5 | # This program is free software: you can redistribute it and/or modify 6 | # it under the terms of the GNU General Public License as published by 7 | # the Free Software Foundation, either version 2 of the License, or 8 | # (at your option) any later version. 9 | # 10 | # This program is distributed in the hope that it will be useful, 11 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | # GNU General Public License for more details. 14 | # 15 | # Go to for a copy of the license. 16 | 17 | library(vetr) 18 | 19 | unitizer_sect("remove parens", { 20 | vetr:::remove_parens(quote((a))) 21 | vetr:::remove_parens(quote(.(a))) 22 | vetr:::remove_parens(quote((((a))))) 23 | vetr:::remove_parens(quote((.((.(a)))))) 24 | vetr:::remove_parens(quote((a) && .(a))) # Nothing should be removed 25 | }) 26 | unitizer_sect("parse", { 27 | x <- quote(.(.) && ((a))) 28 | vetr:::parse_validator(x, quote(arg_to_validate)) 29 | x # make sure unchanged from previous assignment 30 | 31 | vetr:::parse_validator(quote(FALSE), quote(arg_to_validate)) 32 | vetr:::parse_validator(quote(((FALSE))), quote(arg_to_validate)) 33 | vetr:::parse_validator(quote(((FALSE && ((TRUE))))), quote(arg_to_validate)) 34 | vetr:::parse_validator(quote(.(FALSE)), quote(arg_to_validate)) 35 | vetr:::parse_validator(quote(.), quote(arg_to_validate)) 36 | vetr:::parse_validator(quote(. && a), quote(arg_to_validate)) 37 | vetr:::parse_validator(quote(.(.)), quote(arg_to_validate)) 38 | vetr:::parse_validator(quote(((a && b) || .(.))), quote(arg_to_validate)) 39 | vetr:::parse_validator(quote(matrix(nrow=3)), quote(arg_to_validate)) 40 | vetr:::parse_validator(quote(matrix(nrow=3) && .(.)), quote(arg_to_validate)) 41 | vetr:::parse_validator(quote((a || ((b && c))) && .(a + .)), quote(arg_to_validate)) 42 | vetr:::parse_validator(quote((a || ((b && .(c)))) && (a + .(.))), quote(arg_to_validate)) 43 | 44 | vetr:::parse_validator(quote(a && (b + .(c))), quote(arg_to_validate)) # uninterpretable? 45 | vetr:::parse_validator(quote(a && .), "hello") # uninterpretable? 46 | } ) 47 | unitizer_sect("token sub", { 48 | vetr:::symb_sub(INT.1) 49 | vetr:::symb_sub(NO.NA) 50 | 51 | # Dot unescaping 52 | `..` <- quote(yes) 53 | `.zzz` <- `zzz.` <- quote(yup) 54 | `.` <- quote(...) 55 | vetr:::symb_sub(quote(..)) 56 | vetr:::symb_sub(quote(...)) 57 | vetr:::symb_sub(quote(.zzz)) 58 | vetr:::symb_sub(quote(zzz.)) 59 | 60 | # Errors 61 | `.` <- quote(..) 62 | vetr:::symb_sub(quote(..)) 63 | vetr:::symb_sub(quote(.)) 64 | 65 | # Identity operations on non-symbols 66 | vetr:::symb_sub(quote(.(zzz))) 67 | vetr:::symb_sub("hello") 68 | }) 69 | 70 | unitizer_sect("preset tokens", { 71 | x <- quote(integer(1L)) 72 | y <- quote(integer(1L) || NULL) 73 | z <- quote(integer(1L) && .(!any(is.na(.)))) 74 | vetr:::parse_validator(quote(x), quote(w)) 75 | vetr:::parse_validator(quote(y), quote(w)) 76 | vetr:::parse_validator(quote(z), quote(w)) 77 | vetr:::parse_validator(quote(z || NULL), quote(w)) 78 | } ) 79 | unitizer_sect("validators", { 80 | vetr:::parse_validator(INT.1, quote(w)) 81 | vetr:::parse_validator(INT, quote(w)) 82 | vetr:::parse_validator(CHR.1, quote(w)) 83 | vetr:::parse_validator(CHR, quote(w)) 84 | vetr:::parse_validator(NUM.1, quote(w)) 85 | vetr:::parse_validator(NUM, quote(w)) 86 | vetr:::parse_validator(LGL.1, quote(w)) 87 | vetr:::parse_validator(LGL, quote(w)) 88 | vetr:::parse_validator(CPX.1, quote(w)) 89 | vetr:::parse_validator(CPX, quote(w)) 90 | } ) 91 | -------------------------------------------------------------------------------- /man/vetr.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/validate.R 3 | \name{vetr} 4 | \alias{vetr} 5 | \title{Verify Function Arguments Meet Structural Requirements} 6 | \usage{ 7 | vetr(..., .VETR_SETTINGS = NULL) 8 | } 9 | \arguments{ 10 | \item{...}{vetting expressions, each will be matched to the enclosing 11 | function formals as with \code{\link[=match.call]{match.call()}} and will be used to validate the 12 | value of the matching formal.} 13 | 14 | \item{.VETR_SETTINGS}{a settings list as produced by \code{\link[=vetr_settings]{vetr_settings()}}, or 15 | NULL to use the default settings. Note that this means you cannot use 16 | \code{vetr} with a function that takes a \code{.VETR_SETTINGS} argument} 17 | } 18 | \value{ 19 | TRUE if validation succeeds, otherwise \code{stop} with error message 20 | detailing nature of failure. 21 | } 22 | \description{ 23 | Use vetting expressions to enforce structural requirements for function 24 | arguments. Works just like \code{\link[=vet]{vet()}}, except that the formals of the 25 | enclosing function automatically matched to the vetting expressions provided 26 | in \code{...}. 27 | } 28 | \details{ 29 | Only named arguments may be vetted; in other words it is not possible to vet 30 | arguments passed via \code{...}. 31 | } 32 | \note{ 33 | \code{vetr} will force evaluation of any arguments that are being 34 | checked (you may omit arguments that should not be evaluate from 35 | \code{vetr}) 36 | } 37 | \section{Vetting Expressions}{ 38 | 39 | 40 | Vetting expressions can be template tokens, standard tokens, or any 41 | expression built with them, \code{||}, \code{&&}, and parentheses. Template tokens 42 | are R objects that define the required structure, much like the \code{FUN.VALUE} 43 | argument to \code{\link[=vapply]{vapply()}}. Standard tokens are R expressions evaluated and 44 | checked for being \code{all(TRUE)}. 45 | 46 | Standard tokens are distinguished from templates by whether they reference 47 | the \code{.} symbol or not. If you have a need to reference an object bound to 48 | \code{.} in a vetting expression, you can escape the \code{.} with an extra dot (i.e. 49 | use \code{..}, and \code{...} for \code{..}, and so forth for symbols comprising only 50 | dots). If you use standard tokens in your packages you will need to include 51 | \code{utils::globalVariables(".")} as a top-level call to avoid the "no visible 52 | binding for global variable '.'"' R CMD check NOTE. Standard tokens that 53 | return a string like e.g. \code{all.equal(x, .)} will result in that string being 54 | incorporated into the error message. 55 | 56 | See \code{vignette('vetr', package='vetr')} and examples for details on how 57 | to craft vetting expressions. 58 | } 59 | 60 | \examples{ 61 | ## Look at `?vet` examples for more details on how to craft 62 | ## vetting expressions. 63 | 64 | fun1 <- function(x, y) { 65 | vetr(integer(), LGL.1) 66 | TRUE # do some work 67 | } 68 | fun1(1:10, TRUE) 69 | try(fun1(1:10, 1:10)) 70 | 71 | ## only vet the second argument 72 | fun2 <- function(x, y) { 73 | vetr(y=LGL.1) 74 | TRUE # do some work 75 | } 76 | try(fun2(letters, 1:10)) 77 | 78 | ## Nested templates; note, in packages you should consider 79 | ## defining templates outside of `vet` or `vetr` so that 80 | ## they are computed on load rather that at runtime 81 | tpl <- list(numeric(1L), matrix(integer(), 3)) 82 | val.1 <- list(runif(1), rbind(1:10, 1:10, 1:10)) 83 | val.2 <- list(runif(1), cbind(1:10, 1:10, 1:10)) 84 | fun3 <- function(x, y) { 85 | vetr(x=tpl, y=tpl && ncol(.[[2]]) == ncol(x[[2]])) 86 | TRUE # do some work 87 | } 88 | fun3(val.1, val.1) 89 | try(fun3(val.1, val.2)) 90 | val.1.a <- val.1 91 | val.1.a[[2]] <- val.1.a[[2]][, 1:8] 92 | try(fun3(val.1, val.1.a)) 93 | } 94 | \seealso{ 95 | \code{\link[=vet]{vet()}}, in particular \code{example(vet)}. 96 | } 97 | -------------------------------------------------------------------------------- /src/misc.c: -------------------------------------------------------------------------------- 1 | /* 2 | Copyright (C) 2023 Brodie Gaslam 3 | 4 | This file is part of "vetr - Trust, but Verify" 5 | 6 | This program is free software: you can redistribute it and/or modify 7 | it under the terms of the GNU General Public License as published by 8 | the Free Software Foundation, either version 2 of the License, or 9 | (at your option) any later version. 10 | 11 | This program is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | GNU General Public License for more details. 15 | 16 | Go to for a copy of the license. 17 | */ 18 | 19 | #include "validate.h" 20 | 21 | /* testing funs 22 | SEXP VALC_test1(SEXP a) { 23 | return ScalarReal(REAL(a)[0] + REAL(a)[0] + REAL(a)[0]); 24 | } 25 | SEXP VALC_test2(SEXP a, SEXP b) { 26 | return ScalarReal(REAL(a)[0] + REAL(b)[0] + REAL(a)[0]); 27 | } 28 | SEXP VALC_test3(SEXP a, SEXP b, SEXP c) { 29 | return ScalarReal(REAL(a)[0] + REAL(b)[0] + REAL(b)[0]); 30 | } 31 | */ 32 | 33 | // - Helper Functions ---------------------------------------------------------- 34 | 35 | /* 36 | Fake `stop` 37 | 38 | Main benefit is that it allows us to control the call that gets displayed. 39 | */ 40 | void VALC_stop(SEXP call, const char * msg) { 41 | SEXP quot_call = PROTECT(Rf_lang2(VALC_SYM_quote, call)); 42 | SEXP msg_string = PROTECT(ScalarString(mkChar(msg))); 43 | SEXP cond_call = PROTECT( 44 | Rf_lang3(install("simpleError"), msg_string, quot_call) 45 | ); 46 | SEXP cond = PROTECT(eval(cond_call, R_GlobalEnv)); 47 | SEXP err_call = PROTECT(Rf_lang2(install("stop"), cond)); 48 | UNPROTECT(5); 49 | eval(err_call, R_GlobalEnv); 50 | // nocov start 51 | error("Internal Error: 3423; contact maintainer."); 52 | } // nocov end 53 | 54 | /* 55 | Create simple error for a tag 56 | */ 57 | void VALC_arg_error(SEXP tag, SEXP fun_call, const char * err_base) { 58 | if(TYPEOF(tag) != SYMSXP) { 59 | // nocov start 60 | error( 61 | "Internal Error:" 62 | "non symbol arg names are not currently supported; " 63 | "contact maintainer." 64 | ); 65 | // nocov end 66 | } 67 | const char * err_tag = CHAR(PRINTNAME(tag)); 68 | char * err_msg = CSR_smprintf1(10001, err_base, err_tag); 69 | VALC_stop(fun_call, err_msg); 70 | // nocov start 71 | error("Internal Error: shouldn't get here 181; contact maintainer.");// nocov 72 | } // nocov end 73 | /* 74 | return 75 | * 3 if zero length, and hence true in the way all(logical()) is TRUE 76 | * 2 if isTRUE, 77 | * 1 if every element is TRUE, 78 | * 0 if there is at least one FALSE, 79 | * -1 if identical to FALSE, 80 | * -2 if not logical, 81 | * -3 if a single NA, 82 | * -4 if contains NAs, 83 | * -6 if the result is a string and has at least one element 84 | */ 85 | 86 | int VALC_all(SEXP vec) { 87 | if(TYPEOF(vec) == STRSXP && xlength(vec)) return -6; 88 | if(TYPEOF(vec) != LGLSXP) return -2; 89 | int * vec_c = LOGICAL(vec); 90 | R_xlen_t i, i_end = XLENGTH(vec); 91 | 92 | if(!i_end) return 3; 93 | for(i = 0; i < i_end; i++) { 94 | if(vec_c[i] == NA_INTEGER) 95 | return i_end == 1 ? -3 : -4; 96 | if(vec_c[i] != 1) return i_end == 1 ? -1 : 0; 97 | } 98 | if(i_end == 1) return 2; 99 | return 1; 100 | } 101 | /* 102 | ext interface for testing 103 | */ 104 | SEXP VALC_all_ext(SEXP vec) { 105 | return ScalarInteger(VALC_all(vec)); 106 | } 107 | 108 | /* 109 | print current PROTECT stack height; used for debugging 110 | */ 111 | // nocov start 112 | void psh(const char * lab) { 113 | PROTECT_INDEX i; 114 | PROTECT_WITH_INDEX(R_NilValue, &i); 115 | UNPROTECT(1); 116 | Rprintf("Protect Stack %s: %d\n", lab, i); 117 | } 118 | // nocov end 119 | -------------------------------------------------------------------------------- /src/cstringr.h: -------------------------------------------------------------------------------- 1 | /* 2 | Copyright (C) 2023 Brodie Gaslam 3 | 4 | This file is part of "vetr - Trust, but Verify" 5 | 6 | This program is free software: you can redistribute it and/or modify 7 | it under the terms of the GNU General Public License as published by 8 | the Free Software Foundation, either version 2 of the License, or 9 | (at your option) any later version. 10 | 11 | This program is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | GNU General Public License for more details. 15 | 16 | Go to for a copy of the license. 17 | */ 18 | 19 | #include 20 | #include 21 | #include 22 | #include 23 | 24 | #ifndef _CSTRINGR_H 25 | #define _CSTRINGR_H 26 | 27 | // Constants 28 | 29 | #define CSR_MAX_CHAR 50000 30 | 31 | // Testing Functions 32 | 33 | SEXP CSR_len_chr_len_ext(SEXP a); 34 | SEXP CSR_len_as_chr_ext(SEXP a); 35 | SEXP CSR_strmlen_ext(SEXP str, SEXP maxlen); 36 | SEXP CSR_strmcpy_ext(SEXP str, SEXP maxlen); 37 | SEXP CSR_smprintf2_ext(SEXP maxlen, SEXP format, SEXP a, SEXP b); 38 | SEXP CSR_smprintf6_ext( 39 | SEXP maxlen, SEXP format, SEXP a, SEXP b, SEXP c, SEXP d, SEXP e, SEXP f 40 | ); 41 | SEXP CSR_ucfirst_ext(SEXP str, SEXP maxlen); 42 | SEXP CSR_lcfirst_ext(SEXP str, SEXP maxlen); 43 | SEXP CSR_bullet_ext(SEXP str, SEXP bullet, SEXP ctd, SEXP maxlen); 44 | SEXP CSR_collapse_ext(SEXP str, SEXP sep, SEXP maxlen); 45 | 46 | SEXP CSR_strsub(SEXP string, SEXP chars, SEXP mark_trunc); 47 | SEXP CSR_nchar_u(SEXP string); 48 | SEXP CSR_char_offsets(SEXP string); 49 | 50 | SEXP CSR_test_strmcpy(void); 51 | SEXP CSR_test_strappend(void); 52 | SEXP CSR_test_strappend2(void); 53 | SEXP CSR_test_add_szt(void); 54 | SEXP CSR_test_smprintfx(void); 55 | 56 | // Internal Functions 57 | 58 | size_t CSR_len_chr_len(R_xlen_t a); 59 | char * CSR_len_as_chr(R_xlen_t a); 60 | char * CSR_num_as_chr(double a, int as_int); 61 | SEXP CSR_num_as_chr_ext(SEXP a, SEXP as_int); 62 | size_t CSR_strmlen_x(const char * str, size_t maxlen); 63 | size_t CSR_strmlen(const char * str, size_t maxlen); 64 | char * CSR_strmcpy(const char * str, size_t maxlen); 65 | char * CSR_strmcpy_int(const char * str, size_t maxlen, int warn); 66 | char * CSR_smprintf6( 67 | size_t maxlen, const char * format, const char * a, const char * b, 68 | const char * c, const char * d, const char * e, const char * f 69 | ); 70 | char * CSR_smprintf5( 71 | size_t maxlen, const char * format, const char * a, const char * b, 72 | const char * c, const char * d, const char * e 73 | ); 74 | char * CSR_smprintf4( 75 | size_t maxlen, const char * format, const char * a, const char * b, 76 | const char * c, const char * d 77 | ); 78 | char * CSR_smprintf3( 79 | size_t maxlen, const char * format, const char * a, const char * b, 80 | const char * c 81 | ); 82 | char * CSR_smprintf2( 83 | size_t maxlen, const char * format, const char * a, const char * b 84 | ); 85 | char * CSR_smprintf1(size_t maxlen, const char * format, const char * a); 86 | const char * CSR_bullet(SEXP string, SEXP bullet, SEXP ctd, size_t max_len); 87 | 88 | char * CSR_ucfirst(const char * str, size_t maxlen); 89 | char * CSR_lcfirst(const char * str, size_t maxlen); 90 | 91 | char * CSR_collapse(SEXP str, const char *, size_t maxlen); 92 | 93 | void CSR_strappend(char * target, const char * str, size_t maxlen); 94 | 95 | size_t CSR_add_szt(size_t a, size_t b); 96 | 97 | // macros, offset is expected to be a pointer to a character 98 | 99 | #define UTF8_IS_CONT(offset) UTF8_BW(offset, 0x80, 0xBF) 100 | #define UTF8_BW(offset, a, b) ((*(offset) >= (a)) && (*(offset) <= (b))) 101 | 102 | #endif 103 | -------------------------------------------------------------------------------- /R/benchmark.R: -------------------------------------------------------------------------------- 1 | # Copyright (C) 2023 Brodie Gaslam 2 | # 3 | # This file is part of "vetr - Trust, but Verify" 4 | # 5 | # This program is free software: you can redistribute it and/or modify 6 | # it under the terms of the GNU General Public License as published by 7 | # the Free Software Foundation, either version 2 of the License, or 8 | # (at your option) any later version. 9 | # 10 | # This program is distributed in the hope that it will be useful, 11 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | # GNU General Public License for more details. 14 | # 15 | # Go to for a copy of the license. 16 | 17 | #' Lightweight Benchmarking Function 18 | #' 19 | #' Evaluates provided expression in a loop and reports mean evaluation time. 20 | #' This is inferior to `microbenchmark` and other benchmarking tools in many 21 | #' ways except that it has zero dependencies or suggests which helps with 22 | #' package build and test times. Used in vignettes. 23 | #' 24 | #' Runs [gc()] before each expression is evaluated. Expressions are evaluated 25 | #' in the order provided. Attempts to estimate the overhead of the loop by 26 | #' running a loop that evaluates `NULL` the `times` times. 27 | #' 28 | #' Unfortunately because this computes the average of all iterations it is very 29 | #' susceptible to outliers in small sample runs, particularly with fast running 30 | #' code. For that reason the default number of iterations is one thousand. 31 | #' 32 | #' @importFrom stats median 33 | #' @export 34 | #' @param ... expressions to benchmark, are captured unevaluated 35 | #' @param times how many times to loop, defaults to 1000 36 | #' @param deparse.width how many characters to deparse for labels 37 | #' @return NULL, invisibly, reports timings as a side effect as screen output 38 | #' @examples 39 | #' bench_mark(runif(1000), Sys.sleep(0.001), times=10) 40 | 41 | bench_mark <- function(..., times=1000L, deparse.width=40) { 42 | stopifnot( 43 | is.integer(times) || is.numeric(times), length(times) == 1, times > 0 44 | ) 45 | times <- as.integer(times) 46 | dots <- as.list(match.call(expand.dots=FALSE)[["..."]]) 47 | p.f <- parent.frame() 48 | 49 | timings <- vapply( 50 | dots, function(x) { 51 | call.q <- bquote({ 52 | gc() 53 | start <- proc.time() 54 | for(i in 1:.(times)) .(x) 55 | stop <- proc.time() 56 | stop[['elapsed']] - start[['elapsed']] 57 | }) 58 | eval(call.q, p.f) 59 | }, 60 | numeric(1L) 61 | ) 62 | # try to compute overhead 63 | 64 | o.h.times <- 10 65 | gc() 66 | overhead <- vapply( 67 | seq.int(o.h.times), function(x) { 68 | call.q.baseline <- bquote({ 69 | start <- proc.time() 70 | for(j in 1:.(times)) NULL 71 | stop <- proc.time() 72 | stop[['elapsed']] - start[['elapsed']] 73 | }) 74 | eval(call.q.baseline, p.f) 75 | }, 76 | numeric(1L) 77 | ) 78 | overhead.act <- median(overhead) 79 | timings.fin <- (timings - overhead.act) / times 80 | exps <- vapply( 81 | dots, 82 | function(x) dep_oneline(x, max.chars=deparse.width), 83 | character(1L) 84 | ) 85 | timings.clean <- timings.fin[timings.fin >= 0] 86 | 87 | unit <- "seconds" 88 | mult <- 0 89 | 90 | if(length(timings.clean)) { 91 | min.time <- min(log(timings.clean, base=10)) 92 | if(min.time <= -3) { 93 | unit <- "microseconds" 94 | mult <- 6 95 | } else if(min.time <= 0) { 96 | unit <- "milliseconds" 97 | mult <- 3 98 | } 99 | } 100 | timings.disp <- timings.fin * 10 ^ mult 101 | 102 | cat( 103 | sprintf( 104 | "Mean eval time from %d iteration%s, in %s:\n", times, 105 | if(times > 1) "s" else "", unit 106 | ) ) 107 | cat( 108 | paste0( 109 | " ", 110 | format(exps), " ~ ", 111 | format(signif(timings.disp, 4), justify='right'), "\n" 112 | ), 113 | sep="" 114 | ) 115 | invisible(data.frame(call=exps, mean.time=timings.fin)) 116 | } 117 | -------------------------------------------------------------------------------- /src/cstringr-ext.c: -------------------------------------------------------------------------------- 1 | /* 2 | Copyright (C) 2023 Brodie Gaslam 3 | 4 | This file is part of "vetr - Trust, but Verify" 5 | 6 | This program is free software: you can redistribute it and/or modify 7 | it under the terms of the GNU General Public License as published by 8 | the Free Software Foundation, either version 2 of the License, or 9 | (at your option) any later version. 10 | 11 | This program is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | GNU General Public License for more details. 15 | 16 | Go to for a copy of the license. 17 | */ 18 | 19 | #include "cstringr.h" 20 | 21 | /* 22 | External interface to internal string functions, mostly for testing, note these 23 | aren't very careful about potential overflows from input so user should ensure 24 | inputs don't overflow int 25 | */ 26 | 27 | void is_scalar_pos_int(SEXP obj) { 28 | if(TYPEOF(obj) != INTSXP || XLENGTH(obj) != 1L || asInteger(obj) < 0) 29 | error("Argument `maxlen` must be a positive scalar integer"); 30 | } 31 | void is_scalar_chr(SEXP obj) { 32 | if(TYPEOF(obj) != STRSXP || XLENGTH(obj) != 1L) 33 | error("Argument `str` must be a scalar character"); 34 | } 35 | SEXP CSR_len_chr_len_ext(SEXP a) { 36 | is_scalar_pos_int(a); 37 | return ScalarInteger(CSR_len_chr_len((R_xlen_t) asInteger(a))); 38 | } 39 | SEXP CSR_len_as_chr_ext(SEXP a) { 40 | is_scalar_pos_int(a); 41 | return mkString(CSR_len_as_chr((R_xlen_t) asInteger(a))); 42 | } 43 | SEXP CSR_strmlen_ext(SEXP str, SEXP maxlen) { 44 | is_scalar_chr(str); 45 | is_scalar_pos_int(maxlen); 46 | return(ScalarInteger(CSR_strmlen(CHAR(asChar(str)), asInteger(maxlen)))); 47 | } 48 | SEXP CSR_strmcpy_ext(SEXP str, SEXP maxlen) { 49 | is_scalar_chr(str); 50 | is_scalar_pos_int(maxlen); 51 | return(mkString(CSR_strmcpy(CHAR(asChar(str)), asInteger(maxlen)))); 52 | } 53 | SEXP CSR_smprintf2_ext(SEXP maxlen, SEXP format, SEXP a, SEXP b) { 54 | is_scalar_chr(format); 55 | is_scalar_chr(a); 56 | is_scalar_chr(b); 57 | is_scalar_pos_int(maxlen); 58 | char * res = CSR_smprintf2( 59 | asInteger(maxlen), CHAR(asChar(format)), CHAR(asChar(a)), CHAR(asChar(b)) 60 | ); 61 | return mkString(res); 62 | } 63 | SEXP CSR_smprintf6_ext( 64 | SEXP maxlen, SEXP format, SEXP a, SEXP b, SEXP c, SEXP d, SEXP e, SEXP f 65 | ) { 66 | is_scalar_chr(format); 67 | is_scalar_chr(a); 68 | is_scalar_chr(b); 69 | is_scalar_chr(c); 70 | is_scalar_chr(d); 71 | is_scalar_chr(e); 72 | is_scalar_chr(f); 73 | is_scalar_pos_int(maxlen); 74 | char * res = CSR_smprintf6( 75 | asInteger(maxlen), CHAR(asChar(format)), CHAR(asChar(a)), CHAR(asChar(b)), 76 | CHAR(asChar(c)), CHAR(asChar(d)), CHAR(asChar(e)), CHAR(asChar(f)) 77 | ); 78 | return mkString(res); 79 | } 80 | SEXP CSR_ucfirst_ext(SEXP str, SEXP maxlen) { 81 | is_scalar_chr(str); 82 | is_scalar_pos_int(maxlen); 83 | return(mkString(CSR_ucfirst(CHAR(asChar(str)), asInteger(maxlen)))); 84 | } 85 | SEXP CSR_lcfirst_ext(SEXP str, SEXP maxlen) { 86 | is_scalar_chr(str); 87 | is_scalar_pos_int(maxlen); 88 | return(mkString(CSR_lcfirst(CHAR(asChar(str)), asInteger(maxlen)))); 89 | } 90 | SEXP CSR_bullet_ext(SEXP str, SEXP bullet, SEXP ctd, SEXP maxlen) { 91 | if(TYPEOF(str) != STRSXP || TYPEOF(bullet) != STRSXP || TYPEOF(ctd) != STRSXP) 92 | error("First three arguments must be string"); 93 | if(TYPEOF(maxlen) != INTSXP) error("Argument `maxlen` must be integer"); 94 | if(XLENGTH(bullet) != 1) error("Argument `bullet` must be length 1"); 95 | if(XLENGTH(ctd) != 1) error("Argument `ctd` must be length 1"); 96 | 97 | R_xlen_t i, str_len = XLENGTH(str); 98 | SEXP res = PROTECT(allocVector(STRSXP, str_len)); 99 | 100 | size_t st_ml = INTEGER(maxlen)[0]; 101 | 102 | if(str_len) { 103 | for(i = 0; i < str_len; ++i) { 104 | const char * char_new = CSR_bullet( 105 | STRING_ELT(str, i), 106 | STRING_ELT(bullet, 0), 107 | STRING_ELT(ctd, 0), 108 | st_ml 109 | ); 110 | SET_STRING_ELT(res, i, mkChar(char_new)); 111 | } } 112 | UNPROTECT(1); 113 | return res; 114 | } 115 | 116 | -------------------------------------------------------------------------------- /tests/unitizer/eval.R: -------------------------------------------------------------------------------- 1 | # Copyright (C) 2023 Brodie Gaslam 2 | # 3 | # This file is part of "vetr - Trust, but Verify" 4 | # 5 | # This program is free software: you can redistribute it and/or modify 6 | # it under the terms of the GNU General Public License as published by 7 | # the Free Software Foundation, either version 2 of the License, or 8 | # (at your option) any later version. 9 | # 10 | # This program is distributed in the hope that it will be useful, 11 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | # GNU General Public License for more details. 14 | # 15 | # Go to for a copy of the license. 16 | 17 | # Runs the tests without attempting to fully compose the result message 18 | 19 | library(vetr) 20 | 21 | unitizer_sect("evaluate", { 22 | vetr:::eval_check(quote(logical(2L)), quote(xyz), 1:2) 23 | vetr:::eval_check(quote(logical(2L)), quote(xyz), c(TRUE, FALSE)) 24 | vetr:::eval_check(quote(logical(2L)), quote(xyz), c(TRUE, FALSE, TRUE)) 25 | 26 | vetr:::eval_check(quote(logical(2L) || NULL), quote(xyz), 1:2) 27 | vetr:::eval_check(quote(logical(2L) || NULL), quote(xyz), NULL) 28 | vetr:::eval_check(quote(logical(2L) || NULL), quote(xyz), c(TRUE, TRUE)) 29 | 30 | vetr:::eval_check( 31 | quote(matrix(integer(), nrow=3) || NULL), quote(xyz), matrix(1:21, ncol=7) 32 | ) 33 | vetr:::eval_check(quote(matrix(integer(), nrow=3) || NULL), quote(xyz), 1:21) 34 | vetr:::eval_check( 35 | quote(matrix(integer(), nrow=3) || vector("list", 2L)), 36 | quote(xyz), list("hello") 37 | ) 38 | vetr:::eval_check( 39 | quote(matrix(integer(), nrow=3) || vector("list", 2L)), 40 | quote(xyz), list("hello", "goodbye") 41 | ) 42 | vetr:::eval_check( 43 | quote(matrix(integer(), nrow=3) || list(character(1L), 1L)), 44 | quote(xyz), list("hello", "goodbye")) 45 | }) 46 | unitizer_sect("evaluate with sub", { 47 | xyz <- c(TRUE, TRUE) 48 | vetr:::eval_check(quote(logical(2L) && .(all(xyz))), quote(xyz), xyz) 49 | vetr:::eval_check(quote(logical(2L) && .(all(.))), quote(xyz), xyz) 50 | vetr:::eval_check(quote(logical(2L) && .(!any(is.na(.)))), quote(xyz), xyz) 51 | xyz <- c(TRUE, NA) 52 | vetr:::eval_check(quote(logical(2L) && .(!any(is.na(.)))), quote(xyz), xyz) 53 | xyz <- c(TRUE, FALSE, TRUE) 54 | vetr:::eval_check(quote(logical(2L) && .(!any(is.na(.)))), quote(xyz), xyz) 55 | 56 | abc1 <- letters[1:5] 57 | vetr:::eval_check( 58 | quote(character(5L) && .(all(. %in% letters[1:3]))), quote(abc1), abc1 59 | ) 60 | abc2 <- rep("a", 5) 61 | vetr:::eval_check( 62 | quote(character(5L) && .(all(. %in% letters[1:3]))), quote(abc2), abc2 63 | ) 64 | 65 | mat1 <- matrix(1:30, ncol=3) 66 | vetr:::eval_check( 67 | quote( 68 | ( 69 | matrix(numeric(), ncol=3) || matrix(integer(), nrow=10) || 70 | character(10L) 71 | ) && .(length(.) < 100) 72 | ), 73 | quote(mat1), mat1 74 | ) 75 | mat2 <- matrix(1:120, ncol=3) 76 | vetr:::eval_check( 77 | quote( 78 | ( 79 | matrix(numeric(), ncol=3) || matrix(integer(), nrow=10) || 80 | character(10L) 81 | ) && 82 | .(length(.) < 100) 83 | ), 84 | quote(mat2), mat2 85 | ) 86 | mat3 <- LETTERS[1:9] 87 | vetr:::eval_check( # Fail all 88 | quote( 89 | ( 90 | matrix(numeric(), ncol=3) || matrix(integer(), nrow=10) || 91 | character(10L) 92 | ) && .(length(.) < 100) 93 | ), 94 | quote(mat3), mat3 95 | ) 96 | vetr:::eval_check( # Fail all 97 | quote( 98 | matrix(numeric(), ncol=3) || matrix(integer(), nrow=10) || 99 | character(10L) || .(length(.) > 20) 100 | ), 101 | quote(mat3), mat3 102 | ) 103 | }) 104 | unitizer_sect("custom expressions", { 105 | x <- -1:1 106 | y <- 1 107 | z <- -1 108 | w <- NA_integer_ 109 | u <- integer() 110 | t <- 1:3 111 | vetr:::eval_check(quote(. > 0), quote(x), x) 112 | vetr:::eval_check(quote(. > 0), quote(y), y) 113 | vetr:::eval_check(quote(. > 0), quote(z), z) 114 | vetr:::eval_check(quote(. > 0), quote(t), t) 115 | vetr:::eval_check(quote(. > 0), quote(w), w) 116 | vetr:::eval_check(quote(. > 0), quote(u), u) 117 | }) 118 | unitizer_sect("Errors", { 119 | vetr:::eval_check(1:3, 1:3, TRUE, env=list(1:3)) 120 | vetr:::eval_check(quote(y), quote(x), TRUE, env=list(1:3)) 121 | }) 122 | -------------------------------------------------------------------------------- /src/assumptions.c: -------------------------------------------------------------------------------- 1 | /* 2 | Copyright (C) 2023 Brodie Gaslam 3 | 4 | This file is part of "vetr - Trust, but Verify" 5 | 6 | This program is free software: you can redistribute it and/or modify 7 | it under the terms of the GNU General Public License as published by 8 | the Free Software Foundation, either version 2 of the License, or 9 | (at your option) any later version. 10 | 11 | This program is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | GNU General Public License for more details. 15 | 16 | Go to for a copy of the license. 17 | */ 18 | 19 | #include 20 | #include 21 | #include 22 | #include 23 | 24 | /* 25 | * Check all the assumptions we're making 26 | * 27 | * Intended to be run onload to make sure there isn't some weird system where 28 | * our baseline assumptions are not met 29 | * 30 | * returns TRUE on success, errors on failure 31 | */ 32 | // nocov start by definition none of the errors should be thrown, so no sense in 33 | // covering this 34 | SEXP VALC_check_assumptions(void) { 35 | const char * err_base = "Failed system assumption: %s%s"; 36 | if(sizeof(R_len_t) < sizeof(int)) 37 | warningcall(R_NilValue, err_base, "R_len_t is not gte to int", ""); 38 | 39 | // Otherwise bit twiddling assumptions may not work as expected? 40 | 41 | if(CHAR_BIT != 8) 42 | warningcall(R_NilValue, err_base, "CHAR_BIT is not 8", ""); 43 | 44 | // This is supposedly enforced by R 45 | 46 | if(sizeof(int) < 4) 47 | warningcall(R_NilValue, err_base, "ints are not at least 32 bits", ""); 48 | 49 | // If this is not TRUE, there could be alignment issues for some of our 50 | // structs that use size_t elements given that R_alloc only guarantees double 51 | // alignment. 52 | // 53 | // This will likely cause problems on systems other than 32 and 64 bits, 54 | // particularly those with larger register sizes, probably the easiest 55 | // solution is to not use size_t in the structs if this becomes a problem 56 | 57 | if(sizeof(size_t) > sizeof(double)) 58 | warningcall( 59 | R_NilValue, err_base, "size_t larger than double not same size", "" 60 | ); 61 | 62 | // Important for some our boundary condition assumptions, in particular that 63 | // NA_INTEGER < int x. 64 | 65 | if(INT_MIN != NA_INTEGER) { 66 | warningcall( 67 | R_NilValue, err_base, "INT_MIN != NA_INTEGER but the code in this ", 68 | "package assumes that they are equal; please contact maintainer." 69 | ); 70 | } 71 | #ifndef IEEE_754 72 | warningcall( 73 | R_NilValue, err_base, "This package assumes IEEE-754 real implementation ", 74 | "but that does not appear to be the case; please contact maintainer." 75 | ); 76 | #else 77 | // If these checks fail they would be UB anyway because promotion rules are to 78 | // convert the integer to double (6.3.1.8), which would be UB. 79 | // if(INT_MIN < -DBL_MAX) { 80 | // warningcall( 81 | // R_NilValue, err_base, "INT_MIN < -DBL_MAX but the code in this ", 82 | // "package assumes the opposite; please contact maintainer." 83 | // ); 84 | // } 85 | // if(INT_MAX > DBL_MAX) { 86 | // warningcall( 87 | // R_NilValue, err_base, "INT_MAX > DBL_MAX but the code in this ", 88 | // "package assumes the opposite; please contact maintainer." 89 | // ); 90 | // } 91 | #endif 92 | 93 | // We would like to check because we try to represent R_xlen_t values with %.0f, 94 | // but for the same reason as above this would be UB. 95 | // if(R_XLEN_T_MAX >= DBL_MAX) 96 | // warningcall(R_NilValue, err_base, "R_XLEN_T_MAX is not less than DBL_MAX", ""); 97 | 98 | if(sizeof(R_len_t) != sizeof(int)) 99 | warningcall(R_NilValue, err_base, "R_len_t not same size as int", ""); 100 | 101 | // Because we check that strings are no longer than this, but then allocate 102 | // memory as INT_MAX + 1 with a size_t, so need to make sure that fits 103 | 104 | if(SIZE_MAX - 1 < INT_MAX) 105 | warningcall( 106 | R_NilValue, err_base, 107 | "SIZE_MAX not sufficiently larger than INT_MAX", "" 108 | ); 109 | // Because sometimes we use size_t to hold positive R_LEN_T_MAX values 110 | 111 | if(SIZE_MAX <= R_LEN_T_MAX) 112 | warningcall( 113 | R_NilValue, err_base, 114 | "SIZE_MAX smaller than or equal to R_LEN_T_MAX", "" 115 | ); 116 | return ScalarLogical(1); 117 | } 118 | // nocov end 119 | -------------------------------------------------------------------------------- /src/type.c: -------------------------------------------------------------------------------- 1 | /* 2 | Copyright (C) 2023 Brodie Gaslam 3 | 4 | This file is part of "vetr - Trust, but Verify" 5 | 6 | This program is free software: you can redistribute it and/or modify 7 | it under the terms of the GNU General Public License as published by 8 | the Free Software Foundation, either version 2 of the License, or 9 | (at your option) any later version. 10 | 11 | This program is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | GNU General Public License for more details. 15 | 16 | Go to for a copy of the license. 17 | */ 18 | 19 | #include "alike.h" 20 | 21 | /* 22 | compare types, accounting for "integer like" numerics; empty string means 23 | success, otherwise outputs an a character string explaining why the types are 24 | not alike 25 | 26 | call is substituted current, only used when this is called by type_alike directly otherwise doesn't do much 27 | */ 28 | struct ALIKEC_res ALIKEC_type_alike_internal( 29 | SEXP target, SEXP current, struct VALC_settings set 30 | ) { 31 | SEXPTYPE tar_type, cur_type, tar_type_raw, cur_type_raw; 32 | int int_like = 0; 33 | tar_type_raw = TYPEOF(target); 34 | cur_type_raw = TYPEOF(current); 35 | 36 | struct ALIKEC_res res = ALIKEC_res_init(); 37 | 38 | if(tar_type_raw == cur_type_raw) return res; 39 | 40 | tar_type = tar_type_raw; 41 | cur_type = cur_type_raw; 42 | 43 | if(set.type_mode == 0) { 44 | if( 45 | tar_type_raw == INTSXP && ( 46 | set.fuzzy_int_max_len < 0 || 47 | ( 48 | xlength(target) <= set.fuzzy_int_max_len && 49 | xlength(current) <= set.fuzzy_int_max_len 50 | ) ) 51 | ) { 52 | int_like = 1; 53 | } 54 | if(int_like || ( 55 | tar_type_raw == CLOSXP || tar_type_raw == SPECIALSXP || 56 | tar_type_raw == BUILTINSXP 57 | ) 58 | ) { 59 | tar_type = ALIKEC_typeof_internal(target); 60 | cur_type = ALIKEC_typeof_internal(current); 61 | } 62 | } 63 | if(tar_type == cur_type) return res; 64 | if( 65 | cur_type == INTSXP && set.type_mode < 2 && 66 | (tar_type == INTSXP || tar_type == REALSXP) 67 | ) { 68 | return res; 69 | } 70 | const char * what; 71 | 72 | if(set.type_mode == 0 && int_like) { 73 | what = "integer-like"; 74 | } else if (set.type_mode < 2 && tar_type == REALSXP) { 75 | what = "numeric"; 76 | } else if (set.type_mode == 0 && tar_type == CLOSXP) { 77 | what = "function"; 78 | } else { 79 | what = type2char(tar_type); 80 | } 81 | struct ALIKEC_res res_fin = res; 82 | 83 | res_fin.success = 0; 84 | res_fin.dat.strings.target[0]= "type \"%s\""; 85 | res_fin.dat.strings.target[1]= what; 86 | res_fin.dat.strings.current[0] = "\"%s\""; 87 | res_fin.dat.strings.current[1] = type2char(cur_type); 88 | res_fin.wrap = allocVector(VECSXP, 2); // note not PROTECTing b/c return 89 | return res_fin; 90 | } 91 | SEXP ALIKEC_type_alike( 92 | SEXP target, SEXP current, SEXP call, SEXP settings 93 | ) { 94 | struct ALIKEC_res res; 95 | struct VALC_settings set = VALC_settings_vet(settings, R_BaseEnv); 96 | 97 | res = ALIKEC_type_alike_internal(target, current, set); 98 | PROTECT(res.wrap); 99 | SEXP res_sexp; 100 | if(!res.success) { 101 | res_sexp = PROTECT(ALIKEC_res_as_string(res, call, set)); 102 | } else { 103 | res_sexp = PROTECT(ScalarLogical(1)); 104 | } 105 | UNPROTECT(2); 106 | return(res_sexp); 107 | } 108 | 109 | /* - typeof ----------------------------------------------------------------- */ 110 | 111 | SEXPTYPE ALIKEC_typeof_internal(SEXP object) { 112 | double * obj_real; 113 | SEXPTYPE obj_type = TYPEOF(object); 114 | 115 | switch(obj_type) { 116 | case REALSXP: 117 | { 118 | R_xlen_t obj_len = XLENGTH(object), i; 119 | obj_real = REAL(object); 120 | /* 121 | could optimize this more by using the magic number tricks or bit 122 | fiddling, but at end of day this still wouldn't be fast enough to 123 | realistically use on a very large vector, so it doesn't really matter 124 | */ 125 | for(i = 0; i < obj_len; i++) { 126 | if( 127 | ( 128 | isnan(obj_real[i]) || 129 | obj_real[i] > INT_MAX || obj_real[i] <= INT_MIN || 130 | obj_real[i] != (int)obj_real[i] 131 | ) 132 | ) 133 | return REALSXP; 134 | } 135 | return INTSXP; 136 | } 137 | break; 138 | case CLOSXP: 139 | case BUILTINSXP: 140 | case SPECIALSXP: 141 | return CLOSXP; 142 | } 143 | return(obj_type); 144 | } 145 | /* 146 | External interface for typeof, here mostly so we don't have to deal with the 147 | SEXP return in the internal use case 148 | */ 149 | 150 | SEXP ALIKEC_typeof(SEXP object) { 151 | return mkString(type2char(ALIKEC_typeof_internal(object))); 152 | } 153 | -------------------------------------------------------------------------------- /extra/PUBLISH.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "vetR - Trust, but Verify" 3 | output: 4 | rmarkdown::html_vignette: 5 | toc: true 6 | css: vignettes/styles.css 7 | --- 8 | 9 | ```{r, echo=FALSE} 10 | knitr::opts_chunk$set(error=TRUE) 11 | library(vetr) 12 | ``` 13 | 14 | # Tweets 15 | 16 | ## Tweet #2 17 | 18 | Fast #rstats bounds checks with `vetr::all_bw` https://github.com/brodieG/vetr; 19 | 10x improvement over primitives (1/3): 20 | 21 | ~30% of speedup is avoiding 3x1e6 temp logical vecs, rest is dedicated loops for 22 | input permutations (num/int/char, nas, infs, etc.) (2/3). 23 | 24 | Peeling back abstraction layer is eye-opening. Massive complexity to implement something seemingly so simple in optimized manner (3/3). 25 | 26 | 27 | ~1/3 of speedup is avoiding 3 28 | logical(1e6) intermediate vectors, rest is stripping inner loops to bare 29 | minimum: 30 | 31 | 32 | ## Tweet #1 33 | 34 | Declarative structural guarantees for #rstats S3 objects via templates with new 35 | pkg #vetr https://github.com/brodieG/vetr (1/4) 36 | 37 | ### Like vapply 38 | 39 | Declarative checks via templates, much like `vapply`: 40 | 41 | ```{r} 42 | vet(numeric(1L), 1:3) 43 | vet(numeric(1L), "hello") 44 | vet(numeric(1L), 42) 45 | ``` 46 | 47 | ### Handles Complex Objects 48 | 49 | ```{r} 50 | vet(matrix(integer(), ncol=3), matrix(1:12, 4)) 51 | vet(matrix(integer(), ncol=3), matrix(1:12, 3)) 52 | ``` 53 | 54 | Even recursive ones: 55 | 56 | ```{r} 57 | iris.template <- abstract(iris) 58 | levels(iris$Species)[3] <- 'Sibirica' # corrupt iris 59 | ``` 60 | ```{r} 61 | vet(iris.template, iris[1:10,]) 62 | ``` 63 | 64 | Note the useful error messages. 65 | 66 | ## Tweet #2 67 | 68 | We made `vetr` fast to mitigate overhead concerns. There is a 69 | dedicated mode for fun param vetting (2/4) 70 | 71 | ### Fast 72 | 73 | Comparable in performance to `stopifnot` for simple checks, and faster for 74 | complex ones: 75 | 76 | ```{r} 77 | mx.3.col.num <- matrix(numeric(), ncol=3) 78 | mx1 <- matrix(1:12, 4) 79 | 80 | bench_mark(times=1e4, 81 | vet(mx.3.col.num, mx1), 82 | stopifnot(is.matrix(mx1), is.numeric(mx1), ncol(mx1) == 3) 83 | ) 84 | ``` 85 | 86 | ### In Functions 87 | 88 | `vetr()` streamlines function parameter vetting: 89 | 90 | ```{r} 91 | fun <- function(x, y) { 92 | vetr(integer(), character(1L) || NULL) 93 | } 94 | fun(1, 'hello') 95 | fun(1, NULL) 96 | fun(1, 2) 97 | ``` 98 | 99 | ## Tweet #3 100 | 101 | Create complex vetting expressions with intuitively programmable 102 | non-standard-evaluation (3/4) 103 | 104 | ### Programmable NSE 105 | 106 | `vetr` implements programmable NSE via recursive substitution of language 107 | objects. This allows you to construct complex vetting expressions from simple 108 | ones: 109 | 110 | ```{r} 111 | a <- quote(integer() && . > 0) 112 | b <- quote(logical(1L) && !is.na(.)) 113 | ``` 114 | ```{r} 115 | vet(a || b, 1:3) 116 | vet(a || b, -1) 117 | ``` 118 | ```{r} 119 | c <- quote(a || b) # equivalently 120 | ``` 121 | ```{r} 122 | vet(c, -1) 123 | ``` 124 | 125 | ## Tweet #4 126 | 127 | On CRAN, 100% coverage with #covr https://github.com/jimhester/covr 128 | and #unitizer https://github.com/brodieG/unitizer, but under dev so feedback 129 | welcome (4/4) 130 | 131 | # R Package Announce 132 | 133 | Announcing New Package vetr on CRAN 134 | 135 | `vetr` implements a declarative template-based approach to verify that objects 136 | meet structural requirements, and auto-compose error messages when they do not. 137 | This package is intended to simplify a more formal use of S3 objects. 138 | 139 | The template concept is borrowed from `vapply`: 140 | 141 | >> vet(numeric(1L), 1:3) 142 | > [1] "`1:3` should be length 1 (is 3)" 143 | >> vet(numeric(1L), "hello") 144 | > [1] "`\"hello\"` should be type \"numeric\" (is \"character\")" 145 | >> vet(numeric(1L), 42) 146 | > [1] TRUE 147 | 148 | There is no limit on template complexity: 149 | 150 | >> vet(matrix(integer(), ncol=3), matrix(1:12, 3)) 151 | > [1] "`matrix(1:12, 3)` should have 3 columns (has 4)" 152 | > 153 | >> iris.template <- abstract(iris) 154 | >> levels(iris$Species)[3] <- 'sibirica' 155 | >> vet(iris.template, iris[1:10,]) 156 | > [1] "`levels((iris[1:10, ])$Species)[3]` should be \"virginica\" 157 | > (is \"sibirica\")" 158 | 159 | `vetr` implements programmable non-standard evaluation via recursive 160 | substitution of language objects: 161 | 162 | >> a <- quote(integer() && . > 0) 163 | >> b <- quote(logical(1L) && !is.na(.)) 164 | >> c <- quote(a || b) 165 | >> vet(c, -1) 166 | > [1] "At least one of these should pass:" 167 | > [2] " - `-1 > 0` is not TRUE (FALSE)" 168 | > [3] " - `-1` should be type \"logical\" (is \"double\")" 169 | 170 | Performance is comparable to `stopifnot` for simple checks, and is faster for 171 | complex (template based) ones. There is a mode that further streamlines 172 | parameter vetting in functions. 173 | 174 | The package is still under development, but the features should be mostly 175 | stable. Feedback welcome (https://github.com/brodieG/vetr). 176 | 177 | Best regards, 178 | 179 | 180 | Brodie. 181 | -------------------------------------------------------------------------------- /R/misc.R: -------------------------------------------------------------------------------- 1 | # Copyright (C) 2023 Brodie Gaslam 2 | # 3 | # This file is part of "vetr - Trust, but Verify" 4 | # 5 | # This program is free software: you can redistribute it and/or modify 6 | # it under the terms of the GNU General Public License as published by 7 | # the Free Software Foundation, either version 2 of the License, or 8 | # (at your option) any later version. 9 | # 10 | # This program is distributed in the hope that it will be useful, 11 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | # GNU General Public License for more details. 14 | # 15 | # Go to for a copy of the license. 16 | 17 | ## Internal Funs 18 | ## 19 | ## R interface for an internal C functions used by \code{alike}. Provided 20 | ## primarily for unit testing purposes 21 | ## 22 | ## @aliases name_compare class_compare dimname_compare dim_compare ts_compare 23 | ## lang_alike fun_alike dep_alike match_call_alike env_track 24 | ## @keywords internal 25 | ## @param int_mode 26 | 27 | attr_compare <- function(target, current, attr.mode=0L) 28 | .Call(VALC_compare_attributes, target, current, attr.mode) 29 | 30 | name_compare <- function(target, current) 31 | .Call(VALC_compare_names, target, current) 32 | 33 | class_compare <- function(target, current, rev=0) # `rev` is unused; here for legacy 34 | .Call(VALC_compare_class, target, current) 35 | 36 | dimname_compare <- function(target, current) 37 | .Call(VALC_compare_dimnames, target, current) 38 | 39 | dim_compare <- function( 40 | target, current, tar_obj=integer(), cur_obj=integer(), rev=0L 41 | ) 42 | .Call(VALC_compare_dims, target, current, tar_obj, cur_obj, rev); 43 | 44 | ts_compare <- function(target, current) 45 | .Call(VALC_compare_ts, target, current) 46 | 47 | lang_alike <- function(target, current, match.call.env=parent.frame()) 48 | .Call(VALC_lang_alike, target, current, match.call.env) 49 | 50 | lang_alike_chr <- function(target, current, match.call.env=parent.frame()) 51 | .Call(VALC_lang_alike_chr, target, current, match.call.env) 52 | 53 | fun_alike <- function(target, current) 54 | .Call(VALC_fun_alike, target, current) 55 | 56 | dep_alike <- function(obj, width.cutoff=60L) 57 | .Call(VALC_deparse, obj, width.cutoff) 58 | 59 | dep_oneline <- function(obj, max.chars=20L, keep.at.end=0L) 60 | .Call(VALC_deparse_oneline, obj, max.chars, keep.at.end) 61 | 62 | pad <- function(obj, lines=-1, pad=-1) 63 | .Call(VALC_pad, obj, lines, pad) 64 | 65 | pad_or_quote <- function(obj, width=-1L, syntactic=-1L) 66 | .Call(VALC_pad_or_quote, obj, width, syntactic) 67 | 68 | match_call_alike <- function(call, env) 69 | .Call(VALC_match_call, call, quote(match.call(NULL, quote(NULL))), env) 70 | 71 | env_track <- function(env, size_init = 32, env_limit=65536L) 72 | .Call(VALC_env_track, env, size_init, env_limit) 73 | 74 | is_valid_name <- function(name) 75 | .Call(VALC_is_valid_name_ext, name) 76 | 77 | is_dfish <- function(obj) 78 | .Call(VALC_is_dfish, obj) 79 | 80 | alike_mode <- function(obj) 81 | .Call(VALC_mode, obj) 82 | 83 | syntactic_names <- function(lang) .Call(VALC_syntactic_names, lang) 84 | 85 | msg_sort <- function(messages) 86 | .Call(VALC_msg_sort, messages) 87 | 88 | msg_merge <- function(messages) 89 | .Call(VALC_msg_merge, messages) 90 | 91 | msg_merge_2 <- function(messages) 92 | .Call(VALC_msg_merge_2, messages) 93 | 94 | find_fun <- function(fun.name, env) 95 | .Call(VALC_find_fun, fun.name, env) 96 | 97 | hash_test <- function(values, keys) .Call(VALC_hash_test, values, keys); 98 | 99 | hash_test2 <- function(keys, add) .Call(VALC_hash_test2, keys, add); 100 | 101 | track_hash <- function(keys, size) .Call(VALC_track_hash, keys, size); 102 | 103 | hash_fun <- function(x) .Call(VALC_default_hash_fun, x) 104 | 105 | check_assumptions <- function() .Call(VALC_check_assumptions) # nocov 106 | 107 | list_as_sorted_vec <- function(x) .Call(VALC_list_as_sorted_vec, x) 108 | 109 | ### Testing C stuff; should be deleted eventually 110 | ## 111 | ## @export 112 | ##test1 <- function(a) .Call(VALC_test1, a) 113 | ## @export 114 | ##test2 <- function(a, b) .Call(VALC_test2, a, b) 115 | ## @export 116 | ##test3 <- function(a, b, c) .Call(VALC_test3, a, b, c) 117 | 118 | # Used for tests. We can't really create them test time as `where` is not 119 | # allowed, and even if it where, it only works becaue it seems topenv doesn't 120 | # anticipate the possibility globalenv will not be on the search path. 121 | 122 | #' Test Objects 123 | #' 124 | #' Objects used for testing purposes only. 125 | #' 126 | #' @rdname vetr-internal 127 | #' @name vetr-interal 128 | #' @keywords internal 129 | 130 | setClass("vetr_foo", representation(a = "character", b = "numeric")) 131 | 132 | #' @rdname vetr-internal 133 | 134 | setClass("vetr_bar", representation(d = "numeric", c = "numeric")) 135 | 136 | #' @rdname vetr-internal 137 | 138 | setClass("vetr_baz", contains="vetr_foo", list(c="character")) 139 | 140 | Foo <- setRefClass("Foo") 141 | Bar <- setRefClass("Bar") 142 | 143 | -------------------------------------------------------------------------------- /src/validate.h: -------------------------------------------------------------------------------- 1 | /* 2 | Copyright (C) 2023 Brodie Gaslam 3 | 4 | This file is part of "vetr - Trust, but Verify" 5 | 6 | This program is free software: you can redistribute it and/or modify 7 | it under the terms of the GNU General Public License as published by 8 | the Free Software Foundation, either version 2 of the License, or 9 | (at your option) any later version. 10 | 11 | This program is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | GNU General Public License for more details. 15 | 16 | Go to for a copy of the license. 17 | */ 18 | 19 | #include 20 | #include 21 | #include 22 | #include "trackinghash.h" 23 | #include "alike.h" 24 | 25 | // - Objects We Install Once --------------------------------------------------- 26 | 27 | // One question: are static objects not garbage collected? The examples from 28 | // "Writing R Extensions" don't seem to require the protection of these 29 | 30 | #ifndef _VETR_H 31 | #define _VETR_H 32 | 33 | // Our result holds the C and R data in separate structures mostly because it 34 | // would be slow to translate the C stuff into R so we defer that until we're 35 | // actually positive we have to make the conversion (i.e. all branches of OR 36 | // statements fail). We are quite wastefull of space here, but it is easier 37 | // this way and there shouldn't be that many objects 38 | 39 | struct VALC_res_dat { 40 | struct ALIKEC_res_dat tpl_dat; // Data from template token 41 | 42 | // The SEXP data, which can either be: 43 | // 44 | // * wrap data from template token, or: 45 | // * Standard token result, a 2 long VECSXP with the standard token 46 | // language in position 0, and the result of evaluating it in position 1 47 | 48 | SEXP sxp_dat; 49 | }; 50 | // Holds all the template or standard token data 51 | 52 | struct VALC_res { 53 | struct VALC_res_dat dat; 54 | int tpl; // template or standard token res? 55 | int success; 56 | }; 57 | // Holds all the template or standard token data, except for the SEXP data 58 | // which is kept separately. This is intended explicitly as a member of the 59 | // VALC_res_list array. 60 | 61 | struct VALC_res_node { 62 | struct ALIKEC_res_dat tpl_dat; 63 | int tpl; // template or standard token res? 64 | int success; 65 | }; 66 | // Used to track the results of multiple tokens 67 | 68 | struct VALC_res_list { 69 | struct VALC_res_node * list_tpl; 70 | SEXP list_sxp; // this is a pairlist 71 | SEXP list_sxp_tail; // end of pairlist 72 | 73 | // index of free slot (and count of how many we have), note this means that 74 | // the last recorded result is at .list[.idx - 1], not .list[.idx] 75 | int idx; 76 | int idx_alloc; // how many we've allocated memory for 77 | int idx_alloc_max;// max we are allowed to allocate 78 | }; 79 | 80 | extern SEXP VALC_SYM_one_dot; 81 | extern SEXP VALC_SYM_deparse; 82 | extern SEXP VALC_SYM_paren; 83 | extern SEXP VALC_SYM_quote; 84 | extern SEXP VALC_SYM_current; 85 | extern SEXP VALC_TRUE; 86 | extern SEXP VALC_SYM_errmsg; 87 | 88 | SEXP VALC_test1(SEXP a); 89 | SEXP VALC_test2(SEXP a, SEXP b); 90 | SEXP VALC_test3(SEXP a, SEXP b, SEXP c); 91 | 92 | SEXP VALC_check_assumptions(void); 93 | 94 | SEXP VALC_res_init(void); 95 | struct VALC_res_list VALC_res_add( 96 | struct VALC_res_list list, struct VALC_res res 97 | ); 98 | struct VALC_res_list VALC_res_list_init(struct VALC_settings set); 99 | 100 | SEXP VALC_validate( 101 | SEXP target, SEXP current, SEXP cur_sub, SEXP par_call, SEXP rho, 102 | SEXP ret_mode_sxp, SEXP stop, SEXP settings 103 | ); 104 | SEXP VALC_validate_args( 105 | SEXP fun, SEXP fun_call, SEXP val_call, SEXP fun_frame, SEXP settings 106 | ); 107 | SEXP VALC_remove_parens(SEXP lang); 108 | SEXP VALC_name_sub_ext(SEXP symb, SEXP arg_lang); 109 | void VALC_stop(SEXP call, const char * msg); 110 | void VALC_stop2(SEXP call, const char * msg, SEXP rho); 111 | SEXP VALC_all_ext(SEXP vec); 112 | int VALC_all(SEXP vec); 113 | int IS_TRUE(SEXP x); 114 | int IS_LANG(SEXP x); 115 | SEXP VALC_parse( 116 | SEXP lang, SEXP arg_lang, struct VALC_settings settings, SEXP arg_tag 117 | ); 118 | SEXP VALC_parse_ext(SEXP lang, SEXP arg_lang, SEXP rho); 119 | int VALC_parse_recurse( 120 | SEXP lang, SEXP lang2, SEXP lang_track, SEXP arg_lang, 121 | int token, struct VALC_settings set, 122 | struct track_hash * track_hash, struct track_hash * track_hash2, 123 | SEXP arg_tag 124 | ); 125 | SEXP VALC_sub_symbol( 126 | SEXP lang, struct VALC_settings set, struct track_hash * track_hash, 127 | SEXP arg_tag 128 | ); 129 | SEXP VALC_sub_symbol_ext(SEXP lang, SEXP rho); 130 | void VALC_install_objs(void); 131 | SEXP VALC_evaluate( 132 | SEXP lang, SEXP arg_lang, SEXP arg_tag, SEXP arg_value, SEXP lang_full, 133 | struct VALC_settings set, int use_lang_raw 134 | ); 135 | SEXP VALC_evaluate_ext( 136 | SEXP lang, SEXP arg_lang, SEXP arg_tag, SEXP arg_value, SEXP lang_full, 137 | SEXP rho 138 | ); 139 | void VALC_arg_error(SEXP tag, SEXP fun_call, const char * err_base); 140 | void psh(const char * lab); 141 | #endif 142 | -------------------------------------------------------------------------------- /man/alike.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/alike.R 3 | \name{alike} 4 | \alias{alike} 5 | \title{Compare Object Structure} 6 | \usage{ 7 | alike(target, current, env = parent.frame(), settings = NULL) 8 | } 9 | \arguments{ 10 | \item{target}{the template to compare the object to} 11 | 12 | \item{current}{the object to determine alikeness of to the template} 13 | 14 | \item{env}{environment used internally when evaluating expressions; currently 15 | used only when looking up functions to \code{\link{match.call}} when 16 | testing language objects, note that this will be overridden by the 17 | environment specified in \code{settings} if any, defaults to the parent 18 | frame.} 19 | 20 | \item{settings}{a list of settings generated using \code{vetr_settings}, NULL 21 | for default} 22 | } 23 | \value{ 24 | TRUE if target and current are alike, character(1L) describing why 25 | they are not if they are not 26 | } 27 | \description{ 28 | Similar to \code{\link{all.equal}}, but compares object structure rather than 29 | value. The \code{target} argument defines a template that the \code{current} 30 | argument must match. 31 | } 32 | \note{ 33 | The semantics of alikeness for language objects, formulas, and 34 | functions may change in the future. 35 | } 36 | \section{alikeness}{ 37 | 38 | 39 | Generally speaking two objects are alike if they are of the same type (as 40 | determined by \code{\link{type_alike}}) and length. \code{\link{type_alike}} 41 | has special treatment for integer-like numerics and function-like objects. 42 | 43 | Attributes on the objects are required to be recursively \code{alike}, though 44 | the following attributes are treated specially: \code{class}, \code{dim}, 45 | \code{dimnames}, \code{names}, \code{row.names}, \code{levels}, \code{tsp}, 46 | and \code{srcref}. 47 | 48 | Exactly what makes two objects \code{alike} is complex, but should be 49 | intuitive. The best way to understand "alikeness" is to review the examples. 50 | For a thorough exposition see \href{../doc/alike.html}{the vignette}. 51 | } 52 | 53 | \examples{ 54 | ## Type comparison 55 | alike(1L, 1.0) # TRUE, because 1.0 is integer-like 56 | alike(1L, 1.1) # FALSE, 1.1 is not integer-like 57 | alike(1.1, 1L) # TRUE, by default, integers are always considered real 58 | 59 | alike(1:100, 1:100 + 0.0) # TRUE 60 | 61 | ## We do not check numerics for integerness if longer than 100 62 | alike(1:101, 1:101 + 0.0) 63 | 64 | ## Scalarness can now be checked at same time as type 65 | alike(integer(1L), 1) # integer-like and length 1? 66 | alike(logical(1L), TRUE) # logical and length 1? 67 | alike(integer(1L), 1:3) 68 | alike(logical(1L), c(TRUE, TRUE)) 69 | 70 | ## Zero length match any length of same type 71 | alike(integer(), 1:10) 72 | alike(1:10, integer()) # but not the other way around 73 | 74 | ## Recursive objects compared recursively 75 | alike( 76 | list(integer(), list(character(), logical(1L))), 77 | list(1:10, list(letters, TRUE)) 78 | ) 79 | alike( 80 | list(integer(), list(character(), logical(1L))), 81 | list(1:10, list(letters, c(TRUE, FALSE))) 82 | ) 83 | 84 | ## `NULL` is a wild card when nested within recursive objects 85 | alike(list(NULL, NULL), list(iris, mtcars)) 86 | alike(NULL, mtcars) # but not at top level 87 | 88 | ## Since `data.frame` are lists, we can compare them recursively: 89 | iris.fake <- transform(iris, Species=as.character(Species)) 90 | alike(iris, iris.fake) 91 | 92 | ## we even check attributes (factor levels must match)! 93 | iris.fake2 <- iris 94 | levels(iris.fake2$Species) <- c("setosa", "versicolor", "africana") 95 | alike(iris, iris.fake2) 96 | 97 | ## We can use partially specified objects as templates 98 | iris.tpl <- abstract(iris) 99 | str(iris.tpl) 100 | alike(iris.tpl, iris) 101 | ## any row sample of iris matches our iris template 102 | alike(iris.tpl, iris[sample(1:nrow(iris), 10), ]) 103 | ## but column order matters 104 | alike(iris.tpl, iris[c(2, 1, 3, 4, 5)]) 105 | 106 | ## 3 x 3 integer 107 | alike(matrix(integer(), 3, 3), matrix(1:9, nrow=3)) 108 | ## 3 x 3, but not integer! 109 | alike(matrix(integer(), 3, 3), matrix(runif(9), nrow=3)) 110 | ## partial spec, any 3 row integer matrix 111 | alike(matrix(integer(), 3), matrix(1:12, nrow=3)) 112 | alike(matrix(integer(), 3), matrix(1:12, nrow=4)) 113 | ## Any logical matrix (but not arrays) 114 | alike(matrix(logical()), array(rep(TRUE, 8), rep(2, 3))) 115 | 116 | ## In order for objects to be alike, they must share a family 117 | ## tree, not just a common class 118 | obj.tpl <- structure(TRUE, class=letters[1:3]) 119 | obj.cur.1 <- structure(TRUE, class=c("x", letters[1:3])) 120 | obj.cur.2 <- structure(TRUE, class=c(letters[1:3], "x")) 121 | 122 | alike(obj.tpl, obj.cur.1) 123 | alike(obj.tpl, obj.cur.2) 124 | 125 | ## You can compare language objects; these are alike if they are self 126 | ## consistent; we don't care what the symbols are, so long as they are used 127 | ## consistently across target and current: 128 | 129 | ## TRUE, symbols are consistent (adding two different symbols) 130 | alike(quote(x + y), quote(a + b)) 131 | ## FALSE, different function 132 | alike(quote(x + y), quote(a - b)) 133 | ## FALSE, inconsistent symbols 134 | alike(quote(x + y), quote(a + a)) 135 | } 136 | \seealso{ 137 | \code{\link{type_alike}}, \code{\link{type_of}}, 138 | \code{\link{abstract}}, \code{\link{vetr_settings}} for more control of 139 | settings 140 | } 141 | -------------------------------------------------------------------------------- /src/r-copied.c: -------------------------------------------------------------------------------- 1 | /* 2 | Copyright (C) 2023 Brodie Gaslam 3 | 4 | This file is part of "vetr - Trust, but Verify" 5 | 6 | This program is free software: you can redistribute it and/or modify 7 | it under the terms of the GNU General Public License as published by 8 | the Free Software Foundation, either version 2 of the License, or 9 | (at your option) any later version. 10 | 11 | This program is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | GNU General Public License for more details. 15 | 16 | Go to for a copy of the license. 17 | 18 | This file contains modified versions of functions copied from the R sources. 19 | Original copyright notices follow. 20 | */ 21 | 22 | /* 23 | * R : A Computer Language for Statistical Data Analysis 24 | * Copyright (C) 1999--2022 The R Core Team. 25 | * Copyright (C) 1995, 1996 Robert Gentleman and Ross Ihaka 26 | * 27 | * This program is free software; you can redistribute it and/or modify 28 | * it under the terms of the GNU General Public License as published by 29 | * the Free Software Foundation; either version 2 of the License, or 30 | * (at your option) any later version. 31 | * 32 | * This program is distributed in the hope that it will be useful, 33 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 34 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 35 | * GNU General Public License for more details. 36 | * 37 | * You should have received a copy of the GNU General Public License 38 | * along with this program; if not, a copy is available at 39 | * https://www.R-project.org/Licenses/ 40 | */ 41 | 42 | /* 43 | Simplified version of R's internal findFun 44 | 45 | Doesn't do quick lookups for special symbols, or use the global cache if it is 46 | available. 47 | 48 | Most importantly, instead of failing if function is not found, returns 49 | R_UnboundValue. 50 | 51 | The code is copied almost verbatim from src/main/envir.c:findFun() 52 | */ 53 | 54 | #include 55 | #include 56 | #include 57 | #include "alike.h" 58 | #include "backports.h" // For R_ParentEnv 59 | 60 | SEXP ALIKEC_findFun(SEXP symbol, SEXP rho) { 61 | if(TYPEOF(symbol) != SYMSXP) 62 | error("Internal Error: `symbol` must be symbol"); // nocov 63 | if(TYPEOF(rho) != ENVSXP) 64 | error("Internal Error: `rho` must be environment");// nocov 65 | SEXP vl; 66 | while (rho != R_EmptyEnv) { 67 | vl = findVarInFrame(rho, symbol); 68 | if (vl != R_UnboundValue) { 69 | if (TYPEOF(vl) == PROMSXP) { 70 | PROTECT(vl); 71 | vl = eval(vl, rho); 72 | UNPROTECT(1); 73 | } 74 | if ( 75 | TYPEOF(vl) == CLOSXP || TYPEOF(vl) == BUILTINSXP || 76 | TYPEOF(vl) == SPECIALSXP 77 | ) 78 | return (vl); 79 | if (vl == R_MissingArg) { 80 | return R_UnboundValue; 81 | } } // nocov 82 | rho = R_ParentEnv(rho); 83 | } 84 | return R_UnboundValue; 85 | } 86 | SEXP ALIKEC_findFun_ext(SEXP symbol, SEXP rho) { 87 | SEXP res = ALIKEC_findFun(symbol, rho); 88 | if(res == R_UnboundValue) return R_NilValue; 89 | return res; 90 | } 91 | 92 | extern Rboolean mbcslocale; 93 | /* A version that reports failure as an error */ 94 | /* 95 | * Taken and adapted from R 3.2.2 src/main/util.c@1324 96 | */ 97 | size_t Mbrtowc(wchar_t *wc, const char *s, size_t n, mbstate_t *ps) 98 | { 99 | size_t used; 100 | 101 | if(n <= 0 || !*s) return (size_t)0; 102 | used = mbrtowc(wc, s, n, ps); 103 | if((int) used < 0) { 104 | /* This gets called from the menu setup in RGui */ 105 | // if (!R_Is_Running) return (size_t)-1; 106 | /* let's try to print out a readable version */ 107 | error("Internal Error: invalid multibyte string at"); // nocov 108 | } 109 | return used; 110 | } 111 | int ALIKEC_is_keyword(const char *name) { 112 | const char * keywords[19] = { 113 | "NULL", "NA", "TRUE", "FALSE", "Inf", "NaN", "NA_integer_", "NA_real_", 114 | "NA_character_", "NA_complex_", "function", "while", "repeat", "for", 115 | "if", "in", "else", "next", "break" 116 | }; 117 | for (int i = 0; i < 19; i++) 118 | if (strcmp(keywords[i], name) == 0) return 1; 119 | 120 | return 0; 121 | } 122 | /* 123 | * Taken and adapted from R 3.2.2 src/main/gram.c@4915 124 | */ 125 | int ALIKEC_is_valid_name(const char *name) 126 | { 127 | const char *p = name; 128 | 129 | if(mbcslocale) { 130 | /* the only way to establish which chars are alpha etc is to 131 | use the wchar variants */ 132 | size_t n = strlen(name), used; 133 | wchar_t wc; 134 | used = Mbrtowc(&wc, p, n, NULL); 135 | if((int) used <= 0) return 0; 136 | p += used; n -= used; 137 | if (wc != L'.' && !iswalpha(wc) ) return 0; 138 | if (wc == L'.') { 139 | /* We don't care about other than ASCII digits */ 140 | if(isdigit(0xff & (int)*p)) return 0; 141 | /* Mbrtowc(&wc, p, n, NULL); if(iswdigit(wc)) return 0; */ 142 | } 143 | while((int)(used = Mbrtowc(&wc, p, n, NULL)) > 0) { 144 | if (!(iswalnum(wc) || wc == L'.' || wc == L'_')) break; 145 | p += used; n -= used; 146 | } 147 | if (*p != '\0') return 0; 148 | } else { 149 | // nocov start current local has MB_CUR_MAX > 1, so this never runs 150 | int c = 0xff & *p++; 151 | if (c != '.' && !isalpha(c) ) return 0; 152 | if (c == '.' && isdigit(0xff & (int)*p)) return 0; 153 | while ( c = 0xff & *p++, (isalnum(c) || c == '.' || c == '_') ) ; 154 | if (c != '\0') return 0; 155 | // nocov end 156 | } 157 | if (strcmp(name, "...") == 0) return 1; 158 | return !ALIKEC_is_keyword(name); 159 | } 160 | -------------------------------------------------------------------------------- /vignettes/styles.css: -------------------------------------------------------------------------------- 1 | /* 2 | Styles primarily borrowed from rmarkdown/templates/html_vignette/resources/vignette.css 3 | at a time 12/2/2014 when rmarkdown was (and probably still is) under the GPL-3 4 | license 5 | */ 6 | 7 | body { 8 | background-color: #fff; 9 | margin: 1em auto; 10 | max-width: 700px; 11 | overflow: visible; 12 | padding-left: 2em; 13 | padding-right: 2em; 14 | font-family: "Open Sans", "Helvetica Neue", Helvetica, Arial, sans-serif; 15 | font-size: 14px; 16 | line-height: 1.5; 17 | } 18 | 19 | #header { 20 | text-align: center; 21 | } 22 | 23 | #TOC { 24 | clear: both; 25 | /*margin: 0 0 10px 10px;*/ 26 | padding: 4px; 27 | width: 100%; 28 | border: 1px solid #CCCCCC; 29 | border-radius: 5px; 30 | 31 | background-color: #f6f6f6; 32 | font-size: 13px; 33 | line-height: 1.3; 34 | } 35 | #TOC .toctitle { 36 | font-weight: bold; 37 | font-size: 15px; 38 | margin-left: 5px; 39 | } 40 | 41 | #TOC ul { 42 | padding-left: 40px; 43 | margin-left: -1.5em; 44 | margin-top: 5px; 45 | margin-bottom: 5px; 46 | } 47 | #TOC ul ul { 48 | margin-left: -2em; 49 | } 50 | #TOC li { 51 | line-height: 16px; 52 | } 53 | 54 | table { 55 | margin: 1em auto; 56 | border-width: 1px; 57 | border-color: #DDDDDD; 58 | border-style: outset; 59 | border-collapse: collapse; 60 | } 61 | table th { 62 | border-width: 2px; 63 | padding: 5px; 64 | border-style: inset; 65 | } 66 | table td { 67 | border-width: 1px; 68 | border-style: inset; 69 | line-height: 18px; 70 | padding: 5px 5px; 71 | } 72 | table, table th, table td { 73 | border-left-style: none; 74 | border-right-style: none; 75 | } 76 | table thead, table tr.even { 77 | background-color: #f7f7f7; 78 | } 79 | 80 | p { 81 | margin: .5em 0; 82 | } 83 | 84 | blockquote { 85 | background-color: #f6f6f6; 86 | padding: 0.25em 0.75em; 87 | } 88 | 89 | hr { 90 | border-style: solid; 91 | border: none; 92 | border-top: 1px solid #777; 93 | margin: 28px 0; 94 | } 95 | 96 | dl { 97 | margin-left: 0; 98 | } 99 | dl dd { 100 | margin-bottom: 13px; 101 | margin-left: 13px; 102 | } 103 | dl dt { 104 | font-weight: bold; 105 | } 106 | 107 | ul { 108 | margin-top: 0; 109 | } 110 | ul li { 111 | list-style: circle outside; 112 | } 113 | ul ul { 114 | margin-bottom: 0; 115 | } 116 | 117 | h3.subtitle { 118 | margin-top: -23px; 119 | } 120 | pre, code { 121 | background-color: #EEE; 122 | color: #333; 123 | white-space: pre-wrap; /* Wrap long lines */ 124 | /*border-radius: 3px;*/ 125 | } 126 | code {font-size: 85%;} 127 | pre { 128 | border: 2px solid #EEE; 129 | overflow: auto; 130 | /* 131 | border-radius: 3px; 132 | */ 133 | margin: 5px 0px; 134 | padding: 5px 10px; 135 | } 136 | pre:not([class]) { 137 | color: #353; 138 | /*border-radius: 0px 0px 3px 3px;*/ 139 | } 140 | div.sourceCode pre, div.sourceCode code { 141 | background-color: #FAFAFA; 142 | } 143 | div.sourceCode pre{ 144 | /*border-radius: 3px 3px 0px 0px;*/ 145 | } 146 | div.sourceCode + pre, 147 | div.sourceCode + div.diffobj_container { 148 | margin-top: -14px; 149 | } 150 | div.diffobj_container pre{ 151 | line-height: 1.3; 152 | } 153 | /* 154 | pre:not([class]) { 155 | background-color: #eee; 156 | } 157 | */ 158 | 159 | code { 160 | font-family: Consolas, Monaco, 'Courier New', monospace; 161 | } 162 | p > code, li > code, h1 > code, h2 > code, h3 > code, 163 | h4 > code, h5 > code, h6 > code { 164 | padding: 2px 0px; 165 | line-height: 1; 166 | font-weight: bold; 167 | } 168 | div.figure { 169 | text-align: center; 170 | } 171 | img { 172 | background-color: #FFFFFF; 173 | padding: 2px; 174 | border: 1px solid #DDDDDD; 175 | border-radius: 3px; 176 | border: 1px solid #CCCCCC; 177 | margin: 0 5px; 178 | } 179 | 180 | h1 { 181 | margin-top: 0; 182 | padding-bottom: 3px; 183 | font-size: 35px; 184 | line-height: 40px; 185 | border-bottom: 1px solid #999; 186 | } 187 | 188 | h2 { 189 | border-bottom: 1px solid #999; 190 | padding-top: 5px; 191 | padding-bottom: 2px; 192 | font-size: 145%; 193 | } 194 | 195 | h3 { 196 | padding-top: 5px; 197 | font-size: 120%; 198 | } 199 | 200 | h4 { 201 | /*border-bottom: 1px solid #f7f7f7;*/ 202 | color: #777; 203 | font-size: 105%; 204 | } 205 | h4.author {display: none;} 206 | h4.date {margin-top: -20px;} 207 | 208 | h5, h6 { 209 | /*border-bottom: 1px solid #ccc;*/ 210 | font-size: 105%; 211 | } 212 | 213 | a { 214 | color: #2255dd; 215 | font-weight: bold; 216 | text-decoration: none; 217 | } 218 | a:hover { 219 | color: #6666ff; } 220 | a:visited { 221 | color: #800080; } 222 | a:visited:hover { 223 | color: #BB00BB; } 224 | a[href^="http:"] { 225 | text-decoration: underline; } 226 | a[href^="https:"] { 227 | text-decoration: underline; } 228 | 229 | /* Class described in https://benjeffrey.com/posts/pandoc-syntax-highlighting-css 230 | Colours from https://gist.github.com/robsimmons/1172277 */ 231 | 232 | code > span.kw { color: #555; font-weight: bold; } /* Keyword */ 233 | code > span.dt { color: #902000; } /* DataType */ 234 | code > span.dv { color: #40a070; } /* DecVal (decimal values) */ 235 | code > span.bn { color: #555; } /* BaseN */ 236 | code > span.fl { color: #555; } /* Float */ 237 | code > span.ch { color: #555; } /* Char */ 238 | code > span.st { color: #40a070; } /* String */ 239 | code > span.co { color: #888888; font-style: italic; } /* Comment */ 240 | code > span.ot { color: #007020; } /* OtherToken */ 241 | code > span.al { color: #ff0000; font-weight: bold; } /* AlertToken */ 242 | code > span.fu { color: #900; font-weight: bold; } /* Function calls */ 243 | code > span.er { color: #a61717; background-color: #e3d2d2; } /* ErrorTok */ 244 | -------------------------------------------------------------------------------- /src/recurse.c: -------------------------------------------------------------------------------- 1 | /* 2 | Copyright (C) 2023 Brodie Gaslam 3 | 4 | This file is part of "vetr - Trust, but Verify" 5 | 6 | This program is free software: you can redistribute it and/or modify 7 | it under the terms of the GNU General Public License as published by 8 | the Free Software Foundation, either version 2 of the License, or 9 | (at your option) any later version. 10 | 11 | This program is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | GNU General Public License for more details. 15 | 16 | Go to for a copy of the license. 17 | */ 18 | 19 | #include "alike.h" 20 | /* 21 | Functions used to manage tracking recursion into list like objects 22 | 23 | To track recursion you must: 24 | - initalize the rec track object first, 25 | - increment each time you recurse, 26 | - decrement each time you recurse, 27 | - mark lvl_max when you hit an error 28 | */ 29 | /*-----------------------------------------------------------------------------\ 30 | \-----------------------------------------------------------------------------*/ 31 | /* 32 | Allocate the storage for the indices; should be done at first error, then 33 | as we unwind recursion we record the values of the indices for each level 34 | prior to the error 35 | 36 | By design the rec.lvl should be 0 if there is no recursion. 37 | */ 38 | struct ALIKEC_rec_track ALIKEC_rec_ind_init(struct ALIKEC_rec_track rec) { 39 | if(rec.lvl) { 40 | rec.indices = (struct ALIKEC_index *) 41 | R_alloc(rec.lvl, sizeof(struct ALIKEC_index)); 42 | } 43 | return rec; 44 | } 45 | /* 46 | After error has been found, populate the last value in our index tracking 47 | structure, AND decrement the index level. 48 | 49 | See ALIKEC_rec_ind_init for details on index structure 50 | */ 51 | struct ALIKEC_rec_track ALIKEC_rec_ind_set( 52 | struct ALIKEC_rec_track rec, struct ALIKEC_index ind 53 | ) { 54 | // Initialize indices if not initialized 55 | 56 | if(!rec.indices) { 57 | rec = ALIKEC_rec_ind_init(rec); 58 | rec.lvl_max = rec.lvl; 59 | } 60 | // Find correct spot in previously allocated indices spaces, clearly relies on 61 | // lvl being exactly correct... 62 | 63 | struct ALIKEC_index * cur_ind = rec.indices + rec.lvl - 1; 64 | *cur_ind = ind; 65 | return rec; 66 | } 67 | /* 68 | Record character or numeric index values 69 | */ 70 | struct ALIKEC_rec_track ALIKEC_rec_ind_chr( 71 | struct ALIKEC_rec_track res, const char * ind 72 | ) { 73 | union ALIKEC_index_raw ind_u = {.chr = ind}; 74 | return ALIKEC_rec_ind_set(res, (struct ALIKEC_index) {ind_u, 1}); 75 | } 76 | struct ALIKEC_rec_track ALIKEC_rec_ind_num( 77 | struct ALIKEC_rec_track res, R_xlen_t ind 78 | ) { 79 | union ALIKEC_index_raw ind_u = {.num = ind}; 80 | return ALIKEC_rec_ind_set(res, (struct ALIKEC_index) {ind_u, 0}); 81 | } 82 | struct ALIKEC_rec_track ALIKEC_rec_track_init(void) { 83 | return (struct ALIKEC_rec_track) { 84 | .lvl = 0, 85 | .lvl_max = 0, 86 | .indices = 0, // NULL pointer 87 | .envs = 0, // NULL pointer 88 | .gp = 0 89 | }; 90 | } 91 | /* 92 | increment recursion 93 | 94 | decrementing happens via ALIKEC_rec_ind_set 95 | */ 96 | struct ALIKEC_rec_track ALIKEC_rec_inc(struct ALIKEC_rec_track rec) { 97 | size_t lvl_old = rec.lvl; 98 | rec.lvl++; 99 | if(rec.lvl < lvl_old) { 100 | // nocov start 101 | error( 102 | "Internal Error: %s; contact maintainer.", 103 | "max recursion depth exceeded, this really shouldn't happen" 104 | ); 105 | // nocov end 106 | } 107 | return rec; 108 | } 109 | struct ALIKEC_rec_track ALIKEC_rec_dec(struct ALIKEC_rec_track rec) { 110 | if(!rec.lvl) { 111 | // nocov start 112 | error( 113 | "Internal Error: %s; contact maintainer.", 114 | "tried to decrement rec counter below zero" 115 | ); 116 | // nocov end 117 | } 118 | rec.lvl--; 119 | return rec; 120 | } 121 | /* 122 | Closely related to ALIKEC_rec_ind_as_chr except that it return a list (vector) 123 | with the language call with all the indices subset, and the pointer to the 124 | location in the language call that needs to be substituted. 125 | */ 126 | SEXP ALIKEC_rec_ind_as_lang(struct ALIKEC_rec_track rec) { 127 | SEXP res = PROTECT(allocVector(VECSXP, 2)); 128 | setAttrib(res, ALIKEC_SYM_syntacticnames, ScalarLogical(1)); 129 | SEXP lang = PROTECT(list1(R_NilValue)); 130 | SEXP lang_cpy = lang; 131 | 132 | if(rec.lvl_max) { // Recursion occurred 133 | // Make call to `[[` or `$`. CAR is the `[[` or `$`, CADDR is the index 134 | // value, and CADR is the spot that will be filled in with what is being 135 | // subsetted: CADR$CADDR or CADR[[CADDR]] 136 | 137 | for(size_t i = rec.lvl_max; i > 0; i--) { 138 | size_t j = i - 1; 139 | SEXP index_call = PROTECT(lang3(R_NilValue, R_NilValue, R_NilValue)); 140 | switch(rec.indices[j].type) { 141 | case 0: 142 | SETCAR(index_call, R_Bracket2Symbol); 143 | SETCADDR(index_call, ScalarReal(rec.indices[j].ind.num)); 144 | break; 145 | case 1: 146 | SETCAR(index_call, R_DollarSymbol); 147 | SETCADDR(index_call, install(rec.indices[j].ind.chr)); 148 | if(!ALIKEC_is_valid_name(rec.indices[j].ind.chr)) 149 | setAttrib(res, ALIKEC_SYM_syntacticnames, ScalarLogical(0)); 150 | break; 151 | // nocov start 152 | default: { 153 | error( 154 | "Internal Error: unexpected index type %d; contact maintainer.", 155 | rec.indices[j].type 156 | ); 157 | // nocov end 158 | } } 159 | SETCAR(lang, index_call); 160 | UNPROTECT(1); 161 | lang = CDR(index_call); 162 | } 163 | SET_VECTOR_ELT(res, 0, CAR(lang_cpy)); 164 | SET_VECTOR_ELT(res, 1, lang); 165 | } 166 | UNPROTECT(2); 167 | return res; 168 | } 169 | -------------------------------------------------------------------------------- /tests/unitizer/validate.args.R: -------------------------------------------------------------------------------- 1 | # Copyright (C) 2023 Brodie Gaslam 2 | # 3 | # This file is part of "vetr - Trust, but Verify" 4 | # 5 | # This program is free software: you can redistribute it and/or modify 6 | # it under the terms of the GNU General Public License as published by 7 | # the Free Software Foundation, either version 2 of the License, or 8 | # (at your option) any later version. 9 | # 10 | # This program is distributed in the hope that it will be useful, 11 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | # GNU General Public License for more details. 14 | # 15 | # Go to for a copy of the license. 16 | 17 | library(vetr) 18 | 19 | unitizer_sect("Single template validation", { 20 | fun0 <- function(x, y, z) 21 | vetr(x=matrix(integer(), ncol=3), y=integer(2L), z=logical(1L)) 22 | fun0(1, 2, 3) 23 | fun0(matrix(1), 2, 3) 24 | fun0(matrix(1:3, nrow=1), 2, 3) 25 | fun0(matrix(1:3, nrow=1), 2:3, 3) 26 | fun0(matrix(1:3, nrow=1), c(2.0, 3.0), 3) # integer like 27 | fun0(matrix(1:3, nrow=1), c(2.0, 3.0), TRUE) 28 | }) 29 | unitizer_sect("Multi-template validation", { 30 | fun1 <- function(x, y, z) 31 | vetr( 32 | x=matrix(integer(), ncol=3) || integer(3L), 33 | y=integer(2L) || NULL || logical(1L), 34 | z=logical(1L) 35 | ) 36 | fun1(1:3, "fail", "fail") # x passes 37 | fun1(matrix(1:9, ncol=3), "fail", "fail") # x passes 38 | fun1(letters[1:3], "fail", "fail") # x fails 39 | 40 | fun1(1:3, 1:2, "fail") # x,y pass 41 | fun1(1:3, NULL, "fail") # x,y pass 42 | fun1(1:3, FALSE, "fail") # x,y pass 43 | 44 | fun1(1:3, FALSE, FALSE) # all pass 45 | }) 46 | unitizer_sect("Template and Straight Eval", { 47 | fun2 <- function(x, y, z) 48 | vetr( 49 | x=(matrix(integer(), ncol=3) || integer(3L)) && .(!any(is.na(.))), 50 | y=integer(3L) && .(all(. > 0)), 51 | z=logical(1L) && .(!is.na(.)) 52 | ) 53 | fun2(matrix(c(1:8, NA), nrow=3), NULL, NULL) 54 | fun2(matrix(c(1:9), nrow=3), -1:1, NULL) 55 | fun2(matrix(c(1:9), nrow=3), 1:3, NA) 56 | fun2(matrix(c(1:9), nrow=3), 1:3, TRUE) 57 | }) 58 | unitizer_sect("Complex OR outcomes", { 59 | fun2a <- function(x) 60 | vetr( 61 | x=setNames(character(3L), letters[1:3]) || matrix("", 3, 1) || 62 | list(character(), x=integer()) 63 | ) 64 | fun2a(letters[1:3]) 65 | }) 66 | unitizer_sect("Errors in Arguments", { 67 | fun3 <- function(x, y) 68 | vetr(x=logical(1L), y=integer(3L)) 69 | fun3(stop("boom")) 70 | fun3(TRUE, stop("boomBOOM")) 71 | fun3(1:3, stop("boomBOOM")) 72 | 73 | fun4 <- function(x, y) 74 | vetr(x=stop("BOOM"), y=integer(3L)) 75 | fun4(NULL, 1:3) 76 | 77 | fun5 <- function(x, y) 78 | vetr(x=integer(3L), y=NULL || .(stop("hah"))) 79 | fun5(1:3, NULL) 80 | fun5(1:2, NULL) 81 | 82 | fun6 <- function(x, y) 83 | vetr(x=integer(3L), y=NULL && .(stop("hah"))) 84 | fun6(1:3, NULL) 85 | }) 86 | unitizer_sect("Args evaled in correct env?", { 87 | fun7 <- function(x, y=z + 2) { z <- "boom"; vetr(x=TRUE, y=1L) } 88 | fun7a <- function(x, y=z + 2) { z <- 40; vetr(x=TRUE, y=1L) } 89 | z <- 1 90 | fun7(TRUE) # fail because z in fun is character 91 | fun7a(TRUE) # works 92 | fun8 <- function(x, y=z + 2) { a <- b <- TRUE; vetr(x=TRUE, y=1L) } 93 | fun8a <- function(x, y=z + 2) { a <- b <- NULL; vetr(x=TRUE, y=1L) } 94 | a <- NULL 95 | b <- TRUE 96 | fun8(a && b) # fail because a in parent is NULL 97 | a <- TRUE 98 | fun8a(a && b) # works despite NULLs in function 99 | 100 | # Make sure we can access defined templates in lexical parents 101 | 102 | fun_make <- function() { 103 | a <- matrix(1:9, 3) 104 | tpl <- matrix(numeric(), 3) 105 | 106 | function(x) { 107 | vetr(tpl) 108 | TRUE 109 | } 110 | } 111 | fun <- fun_make() 112 | a <- b <- 1:9 113 | local({ 114 | NULL 115 | a <- character() 116 | fun(a) 117 | }) 118 | local({ 119 | b <- character() 120 | fun(b) 121 | }) 122 | # make sure we can access variables that are not in fun lexical scope 123 | 124 | fun8b <- function(x) vetr(x=length(.) > 0 && integer()) 125 | get("zfqwefkj") # should fail 126 | local({ 127 | zfqwefkj <- 200L 128 | fun8b(zfqwefkj) 129 | }) 130 | }) 131 | unitizer_sect("Compound Expression Scope Issues", { 132 | a <- quote(!anyNA(.)) 133 | fun <- function(x) { 134 | a <- quote(all(. > 0)) 135 | b <- quote(is.vector(.)) 136 | vetr(a && b) 137 | TRUE 138 | } 139 | fun(-(1:3)) 140 | }) 141 | unitizer_sect("Non-equal args and validation exps", { 142 | fun8 <- function(x="hello", y=TRUE, z) 143 | vetr(x=integer(), z=integer(2L)) 144 | 145 | fun8(1L, NULL, 1:2) 146 | fun8(1L, 1:2, NULL) 147 | 148 | fun8(1L, 1:2) 149 | fun8(1L) 150 | 151 | # default argument fails validation 152 | 153 | fun8(z=1:2) 154 | 155 | }) 156 | unitizer_sect("Referencing argument in vet exp error", { 157 | fun1 <- function(x, y) vetr(x > 0, . < 3) 158 | fun1(1:10, 1:10) 159 | fun2 <- function(x, y) vetr(. > 0 && all(y > 0), y < 3) 160 | fun2(TRUE, 1:10) 161 | 162 | # also check with vet, although not as important 163 | 164 | x <- 1:10 165 | vet(x > 0, x) 166 | vet((x + 1) > 0, x + 1) # this doesn't cause error, but maybe should? 167 | }) 168 | unitizer_sect("Default arg mix-up", { 169 | fun10a <- function(x, y=TRUE, z=999) vetr(INT, LGL.1, INT.1) 170 | fun10a(1, z=1:3) 171 | 172 | fun10b <- function(x, y=TRUE, z=999) vetr(INT, z=INT.1) 173 | fun10b(1, z=1:3) 174 | }) 175 | unitizer_sect("Dots", { 176 | f <- function(x, y=1L, z=1L, ...) vetr(1L, 1L, 1L) 177 | f(2L, w=3L) 178 | 179 | f <- function(x, y=1L, ...) vetr(1L, 1L, 1L) 180 | f(2L, z=3L) 181 | }) 182 | unitizer_sect("Don't access promises in environments", { 183 | fenv <- function(env) vetr(environment()) 184 | env <- FALSE 185 | fenv(environment()) 186 | }) 187 | unitizer_sect("Invocation via `do.call` (#109)", { 188 | f <- function(x) vetr(is.function(.)) 189 | do.call(f, list(mean)) 190 | }) 191 | -------------------------------------------------------------------------------- /tests/unitizer/language.R: -------------------------------------------------------------------------------- 1 | # Copyright (C) 2023 Brodie Gaslam 2 | # 3 | # This file is part of "vetr - Trust, but Verify" 4 | # 5 | # This program is free software: you can redistribute it and/or modify 6 | # it under the terms of the GNU General Public License as published by 7 | # the Free Software Foundation, either version 2 of the License, or 8 | # (at your option) any later version. 9 | # 10 | # This program is distributed in the hope that it will be useful, 11 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | # GNU General Public License for more details. 14 | # 15 | # Go to for a copy of the license. 16 | 17 | # redefine funs to give us flexibility if we change packages without having 18 | # to export the internal functions 19 | 20 | library(vetr) 21 | 22 | unitizer_sect("Match Calls", { 23 | vetr:::match_call_alike(quote(var(y=1:10, runif(10))), baseenv()) 24 | env0 <- new.env() 25 | env0$var <- function(yollo, zambia) NULL 26 | vetr:::match_call_alike(quote(var(y=1:10, runif(10))), env0) 27 | }) 28 | unitizer_sect("Calls", { 29 | c0 <- quote(fun(a, b, a, 25)) 30 | c1 <- quote(fun(x, y, x, "hello")) 31 | c2 <- quote(fun(x, y, z, "hello")) 32 | c3 <- quote(FUN(x, y, x, 1.01)) 33 | c4 <- quote(fun(x, y, x, z)) 34 | c5 <- quote(fun(a + b + a, FUN(z, a + 1))) 35 | c6 <- quote(fun(x + y + x, FUN(w, x + 2))) 36 | c7 <- quote(fun(x + y + x, FUN(w, y + 2))) 37 | c8 <- quote(fun(x + y + x, FUN(w, x - 2))) 38 | c9 <- quote(fun(x + y + x, FUN(w, x + "hello"))) 39 | c10 <- quote(fun(1)) 40 | c11 <- quote(fun(1, 2)) 41 | 42 | c12 <- quote(a + b + c) 43 | c13 <- quote((a + b) + c) 44 | c14 <- quote(a + (b + c)) 45 | 46 | vetr:::lang_alike(c0, c1, NULL) # TRUE 47 | vetr:::lang_alike(c0, c2, NULL) # no, inconsistent 48 | vetr:::lang_alike(c0, c3, NULL) # no, wrong fun name 49 | vetr:::lang_alike(c0, c4, NULL) # extra symbol 50 | vetr:::lang_alike(c5, c6, NULL) # TRUE 51 | vetr:::lang_alike(c5, c7, NULL) # inconsistent 52 | vetr:::lang_alike(c5, c8, NULL) # wrong call `-` 53 | vetr:::lang_alike(c5, c9, NULL) # TRUE 54 | vetr:::lang_alike(c11, c10, NULL)# Length mismatch 55 | 56 | # Parens 57 | 58 | vetr:::lang_alike(c12, c13) # equivalent 59 | vetr:::lang_alike(c12, c14) # not equivalent 60 | vetr:::lang_alike(c13, c14) # not equivalent 61 | 62 | vetr:::lang_alike(c14, c13) # not equivalent 63 | 64 | # with defined fun 65 | 66 | fun <- function(abc, bcd, efg) NULL 67 | 68 | ca <- quote(fun(a, b, a)) 69 | cb <- quote(fun(x, e=x, y)) 70 | 71 | vetr:::lang_alike(ca, cb, NULL) # shouldn't match without match.call 72 | vetr:::lang_alike(cb, ca, NULL) # false, different error 73 | vetr:::lang_alike(ca, cb) # TRUE, should match 74 | 75 | # Actually use a function (and not just name of fun) 76 | 77 | ca.1 <- ca 78 | cb.1 <- cb 79 | 80 | ca.1[[1]] <- fun 81 | cb.1[[1]] <- fun 82 | 83 | vetr:::lang_alike(ca.1, cb.1) # TRUE, should match 84 | 85 | # test nested match.call 86 | 87 | cc <- quote(fun(a, b, fun(b=1))) 88 | cd <- quote(fun(a, b, fun(c=1))) 89 | 90 | vetr:::lang_alike(cc, cd) 91 | 92 | # NULL in target matches anything 93 | 94 | ce <- quote(fun(a, b, NULL)) 95 | 96 | vetr:::lang_alike(cc, ce) # FALSE 97 | vetr:::lang_alike(ce, cc) # TRUE 98 | 99 | # mismatched functions 100 | 101 | da <- quote(ff(a=1, b=2, c=3)) 102 | db <- quote(ff(a=1, d=2, c=3)) 103 | 104 | vetr:::lang_alike(da, db) 105 | 106 | # Errors 107 | 108 | vetr:::lang_alike(cc, 1:10) 109 | vetr:::lang_alike(ce, cc, match.call.env=1:10) 110 | }) 111 | unitizer_sect("Calls as char", { 112 | vetr:::lang_alike_chr(c0, c1, NULL) # TRUE 113 | vetr:::lang_alike_chr(c0, c2, NULL) # no, inconsistent 114 | vetr:::lang_alike_chr(c0, c3, NULL) # no, wrong fun name 115 | vetr:::lang_alike_chr(c0, c4, NULL) # extra symbol 116 | vetr:::lang_alike_chr(c5, c6, NULL) # TRUE 117 | vetr:::lang_alike_chr(c5, c7, NULL) # inconsistent 118 | vetr:::lang_alike_chr(c5, c8, NULL) # wrong call `-` 119 | vetr:::lang_alike_chr(c5, c9, NULL) # TRUE 120 | 121 | vetr:::lang_alike_chr(ca, cb, NULL) # shouldn't match without match.call 122 | vetr:::lang_alike_chr(cb, ca, NULL) # false, different error 123 | vetr:::lang_alike_chr(ca, cb) # TRUE, should match 124 | 125 | # test nested match.call 126 | 127 | vetr:::lang_alike_chr(cc, cd) 128 | 129 | # NULL in target matches anything 130 | 131 | vetr:::lang_alike_chr(cc, ce) # FALSE 132 | vetr:::lang_alike_chr(ce, cc) # TRUE 133 | }) 134 | unitizer_sect("Formulas", { 135 | f0 <- y ~ x + 1 136 | f1 <- a ~ b + 1 137 | f2 <- a ~ b + 2 138 | f3 <- y ~ x + log(x) + z - 1 139 | f4 <- a ~ b + log(b) + c - 1 140 | f5 <- a ~ b + log(c) + b - 1 141 | f6 <- a ~ b + ln(b) + c - 1 142 | f7 <- a ~ b + log(b) + c + 1 143 | 144 | vetr:::lang_alike(f0, f1, NULL) # TRUE 145 | vetr:::lang_alike(f0, f2, NULL) # FALSE 146 | vetr:::lang_alike(f3, f4, NULL) # TRUE 147 | vetr:::lang_alike(f3, f5, NULL) # FALSE 148 | vetr:::lang_alike(f3, f6, NULL) # FALSE 149 | vetr:::lang_alike(f3, f7, NULL) # FALSE 150 | }) 151 | unitizer_sect("Deparse", { 152 | l0 <- quote( 153 | a + b + fun(x + funz( 154 | matrix_over[25, 32]) + transform(iris, x = Sepal.Width * 3) / 155 | the_donkey_ate_a_carrot %in% { 156 | paste0( 157 | match(letter, LETTERS), 158 | c("hello there") 159 | ) } ) ) 160 | # simple deparse 161 | 162 | (dep.txt <- vetr:::dep_alike(l0)) 163 | vetr:::dep_alike(l0, 30) 164 | 165 | # manip the deparse 166 | 167 | vetr:::pad(dep.txt) 168 | old.opt <- options(prompt=">>", continue=" |") 169 | vetr:::pad(dep.txt) 170 | options(old.opt) 171 | vetr:::pad(dep.txt, pad=4) 172 | vetr:::pad(dep.txt, pad=4, lines=2) 173 | 174 | # oneline 175 | 176 | vetr:::dep_oneline(quote(1 + 1 + 3 + 944254235), 10) 177 | vetr:::dep_oneline(quote(1 + 1 + 3), 10) 178 | vetr:::dep_oneline(quote(1 + 1 + 3), "hello") 179 | vetr:::dep_oneline(quote(1 + 1 + 3 - (mean(1:10) + 3)), 15, 1L) 180 | }) 181 | -------------------------------------------------------------------------------- /man/vetr_settings.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/settings.R 3 | \name{vetr_settings} 4 | \alias{vetr_settings} 5 | \title{Generate Control Settings For vetr and alike} 6 | \usage{ 7 | vetr_settings( 8 | type.mode = 0L, 9 | attr.mode = 0L, 10 | lang.mode = 0L, 11 | fun.mode = 0L, 12 | rec.mode = 0L, 13 | suppress.warnings = FALSE, 14 | fuzzy.int.max.len = 100L, 15 | width = -1L, 16 | env.depth.max = 65535L, 17 | symb.sub.depth.max = 65535L, 18 | symb.size.max = 15000L, 19 | nchar.max = 65535L, 20 | track.hash.content.size = 63L, 21 | env = NULL, 22 | result.list.size.init = 64L, 23 | result.list.size.max = 1024L 24 | ) 25 | } 26 | \arguments{ 27 | \item{type.mode}{integer(1L) in 0:2, defaults to 0, determines how object 28 | types (as in \code{typeof}) are compared: \itemize{ 29 | \item 0: integer like numerics (e.g. \code{1.0}) can match against 30 | integer templates, and integers always match real templates; all 31 | function types are considered of the same type 32 | \item 1: integers always match against numeric templates, but not vice 33 | versa, and integer-like numerics are treated only as numerics; 34 | functions only match same function type (i.e. closures only match 35 | closures, builtins builtins, and specials specials) 36 | \item 2: types must be equal for all objects types (for functions, this 37 | is unchanged from 1) 38 | }} 39 | 40 | \item{attr.mode}{integer(1L) in 0:2, defaults to 0, determines strictness of 41 | attribute comparison: \itemize{ 42 | \item \code{0} only checks attributes that are present in target, and 43 | uses special comparisons for the special attributes (\code{class}, 44 | \code{dim}, \code{dimnames}, \code{names}, \code{row.names}, 45 | \code{levels}, \code{srcref}, and \code{tsp}) while requiring other 46 | attributes to be \code{alike} 47 | \item \code{1} is like \code{0}, except all atributes must be 48 | \code{alike} 49 | \item \code{2} requires all attributes to be present in \code{target} and 50 | \code{current} and to be alike 51 | }} 52 | 53 | \item{lang.mode}{integer(1L) in 0:1, defaults to 0, controls language 54 | matching, set to \code{1} to turn off use of \code{\link[=match.call]{match.call()}}} 55 | 56 | \item{fun.mode}{NOT IMPLEMENTED, controls how functions are compared} 57 | 58 | \item{rec.mode}{integer(1L) \code{0} currently unused, intended to control how 59 | recursive structures (other than language objects) are compared} 60 | 61 | \item{suppress.warnings}{logical(1L) suppress warnings if TRUE} 62 | 63 | \item{fuzzy.int.max.len}{max length of numeric vectors to consider for 64 | integer likeness (e.g. \code{c(1, 2)} can be considered "integer", even 65 | though it is numeric); currently we limit this check to vectors 66 | shorter than 100 to avoid a potentially expensive computation on large 67 | vectors, set to -1 to apply to all vectors irrespective of length} 68 | 69 | \item{width}{to use when deparsing expressions; default \code{-1} 70 | equivalent to \code{getOption("width")}} 71 | 72 | \item{env.depth.max}{integer(1L) maximum number of nested environments to 73 | recurse through, defaults to 65535L; these are tracked to make sure we do 74 | not get into an infinite recursion loop, but because they are tracked we 75 | keep a limit on how many we will go through, set to -1 to allow unlimited 76 | recursion depth. You should not need to change this unless you are running 77 | into the recursion limit.} 78 | 79 | \item{symb.sub.depth.max}{integer(1L) maximum recursion depth when 80 | recursively substituting symbols in vetting expression, defaults to 65535L} 81 | 82 | \item{symb.size.max}{integer(1L) maximum number of characters that a symbol 83 | is allowed to have in vetting expressions, defaults to 15000L.} 84 | 85 | \item{nchar.max}{integer(1L) defaults to 65535L, threshold after which 86 | strings encountered in C code are truncated. This is the read limit. In 87 | theory \code{vetr} can produce strings longer than that by combining multiple 88 | shorter pieces.} 89 | 90 | \item{track.hash.content.size}{integer(1L) (advanced) used to set the initial 91 | size of the symbol tracking vector used with the hash table that detects 92 | recursive symbol substitution. If the tracking vector fills up it will be 93 | grown by 2x. This parameter is exposed mostly for developer use.} 94 | 95 | \item{env}{what environment to use to match calls and evaluate vetting 96 | expressions, although typically you would specify this with the \code{env} 97 | argument to \code{vet}; if NULL will use the calling frame to 98 | \code{vet/vetr/alike}.} 99 | 100 | \item{result.list.size.init}{initial value for token tracking. This will be 101 | grown by a factor of two each time it fills up until we reach 102 | \code{result.list.size.max}.} 103 | 104 | \item{result.list.size.max}{maximum number of tokens we keep track of, 105 | intended mostly as a safeguard in case a logic error causes us to keep 106 | allocating memory. Set to 1024 as a default value since it should be 107 | exceedingly rare to have vetting expressions with such a large number of 108 | tokens, enough so that if we reach that number it is more likely something 109 | went wrong.} 110 | } 111 | \value{ 112 | list with all the setting values 113 | } 114 | \description{ 115 | Utility function to generate setting values. We strongly recommend 116 | that you generate the settings outside of function calls so that setting 117 | generation does not become part of the \code{vet/vetr/alike} evaluation as 118 | that could add noticeable overhead to the function evaluation. 119 | } 120 | \details{ 121 | Settings after \code{fuzzy.int.max.len} are fairly low level and exposed mostly 122 | for testing purposes. You should generally not need to use them. 123 | 124 | Note that a successful evaluation of this function does not guarantee a 125 | correct settings list. Those checks are carried out internally by 126 | \code{vet/vetr/alike}. 127 | } 128 | \examples{ 129 | type_alike(1L, 1.0, settings=vetr_settings(type.mode=2)) 130 | ## better if you are going to re-use settings to reduce overhead 131 | set <- vetr_settings(type.mode=2) 132 | type_alike(1L, 1.0, settings=set) 133 | } 134 | \seealso{ 135 | \code{\link{type_alike}}, \code{\link{alike}}, \code{\link{vetr}} 136 | } 137 | -------------------------------------------------------------------------------- /src/envtrack.c: -------------------------------------------------------------------------------- 1 | /* 2 | Copyright (C) 2023 Brodie Gaslam 3 | 4 | This file is part of "vetr - Trust, but Verify" 5 | 6 | This program is free software: you can redistribute it and/or modify 7 | it under the terms of the GNU General Public License as published by 8 | the Free Software Foundation, either version 2 of the License, or 9 | (at your option) any later version. 10 | 11 | This program is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | GNU General Public License for more details. 15 | 16 | Go to for a copy of the license. 17 | */ 18 | 19 | #include "alike.h" 20 | 21 | /* 22 | We need environment stack tracking that will not persist across .Call calls 23 | */ 24 | 25 | /* 26 | Allocated and re-allocate our env stack tracking object 27 | 28 | Return 0 for failure, 1 for normal success, 2 for success requiring 29 | re-allocation, 3 for success requiring re-allocation and copying 30 | 31 | We need stack size to be strictly greater than stack_ind as next time we write 32 | we will write to stack_ind 33 | */ 34 | 35 | int ALIKEC_env_stack_alloc( 36 | struct ALIKEC_env_track * envs, int env_limit 37 | ) { 38 | int success = 1; 39 | int stack_size = envs->stack_size; 40 | if(stack_size <= envs->stack_ind) { 41 | int stack_size_old = stack_size; 42 | if(stack_size > INT_MAX - stack_size) { 43 | // nocov start 44 | error( 45 | "%s%s", 46 | "Internal Error: cannot increase env stack size past INT_MAX; ", 47 | "contact maintainer" 48 | ); 49 | // nocov end 50 | } 51 | stack_size += stack_size ? stack_size : envs->stack_size_init; 52 | 53 | if(stack_size <= envs->stack_ind) { 54 | // nocov start 55 | error( 56 | "%s%s", 57 | "Internal Error: env stack size increase is insufficient; ", 58 | "contact maintainer" 59 | ); 60 | // nocov end 61 | } 62 | if(stack_size > env_limit) return 0; 63 | 64 | SEXP * env_stack_tmp = (SEXP *) R_alloc(stack_size, sizeof(SEXP)); 65 | envs->stack_size = stack_size; 66 | 67 | success = 2; 68 | if(envs->env_stack == 0) { 69 | envs->env_stack = env_stack_tmp; 70 | } else if(envs->stack_size > stack_size_old) { 71 | // Prev allocation happened, need to copy pointers 72 | for(int i = 0; i < stack_size_old; i++) 73 | env_stack_tmp[i] = envs->env_stack[i]; 74 | // ideally would free env_stack before repointing... 75 | envs->env_stack = env_stack_tmp; 76 | success = 3; 77 | } 78 | } 79 | return success; 80 | } 81 | /* 82 | Initialize our stack tracking object 83 | */ 84 | struct ALIKEC_env_track * ALIKEC_env_set_create( 85 | int stack_size_init, int env_limit 86 | ) { 87 | if(stack_size_init < 1) { 88 | // nocov start 89 | error( 90 | "Internal Error: `alike` env stack size init should be greater than zero" 91 | ); 92 | // nocov end 93 | } 94 | struct ALIKEC_env_track * envs = 95 | (struct ALIKEC_env_track *) R_alloc(1, sizeof(struct ALIKEC_env_track)); 96 | envs->stack_size = envs->stack_ind = 0; 97 | envs->env_stack = 0; 98 | envs->no_rec = 0; 99 | envs->stack_size_init = stack_size_init; 100 | int res = ALIKEC_env_stack_alloc(envs, env_limit); 101 | if(!res) error("Unable to allocate `alike` environment stack"); 102 | return envs; 103 | } 104 | 105 | /* 106 | Track what environments we've checked already 107 | 108 | Not super efficient allocation here; we should really free previous allocation 109 | instead of just leaving it hanging until .Call ends. 110 | 111 | Also, this should really be a linked list so we don't have to re-copy all the 112 | pointers every time we expand the list. 113 | 114 | Really taking solace in the point that this part of the code should be rarely 115 | activated. 116 | 117 | Returns 118 | * > 1 if the environment has not been seen before (and adds it to stack), 119 | really it is the result of the allocation attempt 120 | * 0 if the environment is found 121 | * -1 if we are out of space in the env stack 122 | */ 123 | 124 | int ALIKEC_env_track( 125 | SEXP env, struct ALIKEC_env_track * envs, int env_limit 126 | ) { 127 | int alloc_res; 128 | if(!(alloc_res = ALIKEC_env_stack_alloc(envs, env_limit))) return -1; 129 | int env_found = 0; 130 | for(int i = 0; i < envs->stack_ind; i++) { 131 | if(env == envs->env_stack[i]) { 132 | env_found = 1; 133 | break; 134 | } 135 | } 136 | if(env_found) return 0; 137 | envs->env_stack[envs->stack_ind] = env; 138 | envs->stack_ind++; 139 | return alloc_res; 140 | } 141 | /* 142 | External interface purely for testing whether our environment hashing 143 | is working 144 | */ 145 | 146 | SEXP ALIKEC_env_track_test(SEXP env_list, SEXP stack_size_init, SEXP env_limit) { 147 | int stack_init_int = asInteger(stack_size_init); 148 | if(stack_init_int == NA_INTEGER || stack_init_int < 0) { 149 | // nocov start 150 | error("Internal Error: stack_size_init must be positive"); 151 | // nocov end 152 | } 153 | if(TYPEOF(env_list) != VECSXP) { 154 | // nocov start 155 | error("Internal Error: expected a list for argument `env_list`"); 156 | // nocov end 157 | } 158 | if(TYPEOF(env_limit) != INTSXP) { 159 | // nocov start 160 | error("Internal Error: expected an integer for argument `env_limit`"); 161 | // nocov end 162 | } 163 | int env_limit_int = asInteger(env_limit); 164 | struct ALIKEC_env_track * envs = 165 | ALIKEC_env_set_create(stack_init_int, env_limit_int); 166 | 167 | R_xlen_t len = XLENGTH(env_list); 168 | SEXP res = PROTECT(allocVector(INTSXP, len)); 169 | int * res_int = INTEGER(res); 170 | R_xlen_t i; 171 | 172 | for(i = 0; i < len; i++) { 173 | SEXP env = VECTOR_ELT(env_list, i); 174 | if(TYPEOF(env) != ENVSXP) 175 | error( 176 | "All contents of `env` %s at item %jd\n", 177 | "should be environments; error ", 178 | i == INTMAX_MAX ? - 1 : (intmax_t) i + 1 179 | ); 180 | res_int[i] = ALIKEC_env_track(env, envs, env_limit_int); 181 | } 182 | UNPROTECT(1); 183 | return res; 184 | } 185 | -------------------------------------------------------------------------------- /R/alike.R: -------------------------------------------------------------------------------- 1 | # Copyright (C) 2023 Brodie Gaslam 2 | # 3 | # This file is part of "vetr - Trust, but Verify" 4 | # 5 | # This program is free software: you can redistribute it and/or modify 6 | # it under the terms of the GNU General Public License as published by 7 | # the Free Software Foundation, either version 2 of the License, or 8 | # (at your option) any later version. 9 | # 10 | # This program is distributed in the hope that it will be useful, 11 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | # GNU General Public License for more details. 14 | # 15 | # Go to for a copy of the license. 16 | 17 | #' Compare Object Structure 18 | #' 19 | #' Similar to \code{\link{all.equal}}, but compares object structure rather than 20 | #' value. The \code{target} argument defines a template that the \code{current} 21 | #' argument must match. 22 | #' 23 | #' @section alikeness: 24 | #' 25 | #' Generally speaking two objects are alike if they are of the same type (as 26 | #' determined by \code{\link{type_alike}}) and length. \code{\link{type_alike}} 27 | #' has special treatment for integer-like numerics and function-like objects. 28 | #' 29 | #' Attributes on the objects are required to be recursively \code{alike}, though 30 | #' the following attributes are treated specially: \code{class}, \code{dim}, 31 | #' \code{dimnames}, \code{names}, \code{row.names}, \code{levels}, \code{tsp}, 32 | #' and \code{srcref}. 33 | #' 34 | #' Exactly what makes two objects \code{alike} is complex, but should be 35 | #' intuitive. The best way to understand "alikeness" is to review the examples. 36 | #' For a thorough exposition see \href{../doc/alike.html}{the vignette}. 37 | #' 38 | #' @note The semantics of alikeness for language objects, formulas, and 39 | #' functions may change in the future. 40 | #' 41 | #' @export 42 | #' @seealso \code{\link{type_alike}}, \code{\link{type_of}}, 43 | #' \code{\link{abstract}}, \code{\link{vetr_settings}} for more control of 44 | #' settings 45 | #' @param target the template to compare the object to 46 | #' @param current the object to determine alikeness of to the template 47 | #' @param settings a list of settings generated using \code{vetr_settings}, NULL 48 | #' for default 49 | #' @param env environment used internally when evaluating expressions; currently 50 | #' used only when looking up functions to \code{\link{match.call}} when 51 | #' testing language objects, note that this will be overridden by the 52 | #' environment specified in \code{settings} if any, defaults to the parent 53 | #' frame. 54 | #' @return TRUE if target and current are alike, character(1L) describing why 55 | #' they are not if they are not 56 | #' @examples 57 | #' ## Type comparison 58 | #' alike(1L, 1.0) # TRUE, because 1.0 is integer-like 59 | #' alike(1L, 1.1) # FALSE, 1.1 is not integer-like 60 | #' alike(1.1, 1L) # TRUE, by default, integers are always considered real 61 | #' 62 | #' alike(1:100, 1:100 + 0.0) # TRUE 63 | #' 64 | #' ## We do not check numerics for integerness if longer than 100 65 | #' alike(1:101, 1:101 + 0.0) 66 | #' 67 | #' ## Scalarness can now be checked at same time as type 68 | #' alike(integer(1L), 1) # integer-like and length 1? 69 | #' alike(logical(1L), TRUE) # logical and length 1? 70 | #' alike(integer(1L), 1:3) 71 | #' alike(logical(1L), c(TRUE, TRUE)) 72 | #' 73 | #' ## Zero length match any length of same type 74 | #' alike(integer(), 1:10) 75 | #' alike(1:10, integer()) # but not the other way around 76 | #' 77 | #' ## Recursive objects compared recursively 78 | #' alike( 79 | #' list(integer(), list(character(), logical(1L))), 80 | #' list(1:10, list(letters, TRUE)) 81 | #' ) 82 | #' alike( 83 | #' list(integer(), list(character(), logical(1L))), 84 | #' list(1:10, list(letters, c(TRUE, FALSE))) 85 | #' ) 86 | #' 87 | #' ## `NULL` is a wild card when nested within recursive objects 88 | #' alike(list(NULL, NULL), list(iris, mtcars)) 89 | #' alike(NULL, mtcars) # but not at top level 90 | #' 91 | #' ## Since `data.frame` are lists, we can compare them recursively: 92 | #' iris.fake <- transform(iris, Species=as.character(Species)) 93 | #' alike(iris, iris.fake) 94 | #' 95 | #' ## we even check attributes (factor levels must match)! 96 | #' iris.fake2 <- iris 97 | #' levels(iris.fake2$Species) <- c("setosa", "versicolor", "africana") 98 | #' alike(iris, iris.fake2) 99 | #' 100 | #' ## We can use partially specified objects as templates 101 | #' iris.tpl <- abstract(iris) 102 | #' str(iris.tpl) 103 | #' alike(iris.tpl, iris) 104 | #' ## any row sample of iris matches our iris template 105 | #' alike(iris.tpl, iris[sample(1:nrow(iris), 10), ]) 106 | #' ## but column order matters 107 | #' alike(iris.tpl, iris[c(2, 1, 3, 4, 5)]) 108 | #' 109 | #' ## 3 x 3 integer 110 | #' alike(matrix(integer(), 3, 3), matrix(1:9, nrow=3)) 111 | #' ## 3 x 3, but not integer! 112 | #' alike(matrix(integer(), 3, 3), matrix(runif(9), nrow=3)) 113 | #' ## partial spec, any 3 row integer matrix 114 | #' alike(matrix(integer(), 3), matrix(1:12, nrow=3)) 115 | #' alike(matrix(integer(), 3), matrix(1:12, nrow=4)) 116 | #' ## Any logical matrix (but not arrays) 117 | #' alike(matrix(logical()), array(rep(TRUE, 8), rep(2, 3))) 118 | #' 119 | #' ## In order for objects to be alike, they must share a family 120 | #' ## tree, not just a common class 121 | #' obj.tpl <- structure(TRUE, class=letters[1:3]) 122 | #' obj.cur.1 <- structure(TRUE, class=c("x", letters[1:3])) 123 | #' obj.cur.2 <- structure(TRUE, class=c(letters[1:3], "x")) 124 | #' 125 | #' alike(obj.tpl, obj.cur.1) 126 | #' alike(obj.tpl, obj.cur.2) 127 | #' 128 | #' ## You can compare language objects; these are alike if they are self 129 | #' ## consistent; we don't care what the symbols are, so long as they are used 130 | #' ## consistently across target and current: 131 | #' 132 | #' ## TRUE, symbols are consistent (adding two different symbols) 133 | #' alike(quote(x + y), quote(a + b)) 134 | #' ## FALSE, different function 135 | #' alike(quote(x + y), quote(a - b)) 136 | #' ## FALSE, inconsistent symbols 137 | #' alike(quote(x + y), quote(a + a)) 138 | 139 | alike <- function(target, current, env=parent.frame(), settings=NULL) 140 | .Call(VALC_alike_ext, target, current, substitute(current), env, settings) 141 | 142 | -------------------------------------------------------------------------------- /man/vet_token.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/validators.R 3 | \docType{data} 4 | \name{vet_token} 5 | \alias{vet_token} 6 | \alias{NO.NA} 7 | \alias{NO.INF} 8 | \alias{GTE.0} 9 | \alias{LTE.0} 10 | \alias{GT.0} 11 | \alias{LT.0} 12 | \alias{INT.1} 13 | \alias{INT.1.POS} 14 | \alias{INT.1.NEG} 15 | \alias{INT.1.POS.STR} 16 | \alias{INT.1.NEG.STR} 17 | \alias{INT} 18 | \alias{INT.POS} 19 | \alias{INT.NEG} 20 | \alias{INT.POS.STR} 21 | \alias{INT.NEG.STR} 22 | \alias{NUM.1} 23 | \alias{NUM.1.POS} 24 | \alias{NUM.1.NEG} 25 | \alias{NUM} 26 | \alias{NUM.POS} 27 | \alias{NUM.NEG} 28 | \alias{CHR.1} 29 | \alias{CHR} 30 | \alias{CPX} 31 | \alias{CPX.1} 32 | \alias{LGL} 33 | \alias{LGL.1} 34 | \title{Vetting Tokens With Custom Error Messages} 35 | \format{ 36 | An object of class \code{call} of length 2. 37 | 38 | An object of class \code{call} of length 2. 39 | 40 | An object of class \code{call} of length 3. 41 | 42 | An object of class \code{call} of length 3. 43 | 44 | An object of class \code{call} of length 3. 45 | 46 | An object of class \code{call} of length 3. 47 | 48 | An object of class \code{call} of length 3. 49 | 50 | An object of class \code{call} of length 3. 51 | 52 | An object of class \code{call} of length 3. 53 | 54 | An object of class \code{call} of length 3. 55 | 56 | An object of class \code{call} of length 3. 57 | 58 | An object of class \code{call} of length 3. 59 | 60 | An object of class \code{call} of length 3. 61 | 62 | An object of class \code{call} of length 3. 63 | 64 | An object of class \code{call} of length 3. 65 | 66 | An object of class \code{call} of length 3. 67 | 68 | An object of class \code{call} of length 3. 69 | 70 | An object of class \code{call} of length 3. 71 | 72 | An object of class \code{call} of length 3. 73 | 74 | An object of class \code{call} of length 3. 75 | 76 | An object of class \code{call} of length 3. 77 | 78 | An object of class \code{call} of length 3. 79 | 80 | An object of class \code{call} of length 3. 81 | 82 | An object of class \code{call} of length 3. 83 | 84 | An object of class \code{call} of length 3. 85 | 86 | An object of class \code{call} of length 3. 87 | 88 | An object of class \code{call} of length 3. 89 | 90 | An object of class \code{call} of length 3. 91 | } 92 | \usage{ 93 | vet_token(exp, err.msg = "\%s") 94 | 95 | NO.NA 96 | 97 | NO.INF 98 | 99 | GTE.0 100 | 101 | LTE.0 102 | 103 | GT.0 104 | 105 | LT.0 106 | 107 | INT.1 108 | 109 | INT.1.POS 110 | 111 | INT.1.NEG 112 | 113 | INT.1.POS.STR 114 | 115 | INT.1.NEG.STR 116 | 117 | INT 118 | 119 | INT.POS 120 | 121 | INT.NEG 122 | 123 | INT.POS.STR 124 | 125 | INT.NEG.STR 126 | 127 | NUM.1 128 | 129 | NUM.1.POS 130 | 131 | NUM.1.NEG 132 | 133 | NUM 134 | 135 | NUM.POS 136 | 137 | NUM.NEG 138 | 139 | CHR.1 140 | 141 | CHR 142 | 143 | CPX 144 | 145 | CPX.1 146 | 147 | LGL 148 | 149 | LGL.1 150 | } 151 | \arguments{ 152 | \item{exp}{an expression which will be captured but not evaluated.} 153 | 154 | \item{err.msg}{character(1L) a message that tells the user what the 155 | expected value should be, should contain a "\%s" for \code{sprintf} 156 | to use (e.g. "\%s should be greater than 2").} 157 | } 158 | \value{ 159 | a quoted expressions with \code{err.msg} attribute set 160 | } 161 | \description{ 162 | Utility function to generate vetting tokens with attached error messages. 163 | You should only need to use this if the error message produced naturally by 164 | \code{vetr} is unclear. Several predefined tokens created by this function 165 | are also documented here. 166 | } 167 | \details{ 168 | Allows you to supply error messages for vetting to use for each error 169 | token. Your token should not contain top level \code{&&} or \code{||}. If 170 | it does your error message will not be reported because \code{vetr} looks for 171 | error messages attached to atomic tokens. If your token must involve 172 | top level \code{&&} or \code{||}, use \code{I(x && y)} to ensure that 173 | your error message is used by \code{vet}, but beware than in doing so you do 174 | not use templates within the \code{I} call as everything therein will be 175 | interpreted as a vetting expression rather than a template. 176 | 177 | Error messages are typically of the form "\%s should be XXX". 178 | 179 | This package ships with many predefined tokens for common use cases. They 180 | are listed in the \code{Usage} section of this documentation. The tokens 181 | are named in format \code{TYPE[.LENGTH][.OTHER]}. For example 182 | \code{INT} will vet an integer vector, \code{INT.1} will vet a scalar integer 183 | vector, and \code{INT.1.POS.STR} will vet a strictly positive integer vector. 184 | At this time tokens are predefined for the basic types as scalars or 185 | any-length vectors. Some additional checks are available (e.g. positive only 186 | values). 187 | 188 | Every one of the predefined vetting tokens documented here implicitly 189 | disallows NAs. Numeric tokens also disallow infinite values. If you wish 190 | to allow NAs or infinite values just use a template object (e.g. 191 | \code{integer(1L)}). 192 | } 193 | \note{ 194 | \strong{This will only work with standard tokens containing \code{.}}. Anything 195 | else will be interpreted as a template token. 196 | } 197 | \examples{ 198 | ## Predefined tokens: 199 | vet(INT.1, 1:2) 200 | vet(INT.1 || LGL, 1:2) 201 | vet(INT.1 || LGL, c(TRUE, FALSE)) 202 | 203 | ## Check squareness 204 | mx <- matrix(1:3) 205 | SQR <- vet_token(nrow(.) == ncol(.), "\%s should be square") 206 | vet(SQR, mx) 207 | 208 | ## Let `vetr` make up error message; note `quote` vs `vet_token` 209 | ## Often, `vetr` does fine without explictly specified err msg: 210 | SQR.V2 <- quote(nrow(.) == ncol(.)) 211 | vet(SQR.V2, mx) 212 | 213 | ## Combine some tokens, notice how we use `quote` at the combining 214 | ## step: 215 | NUM.MX <- vet_token(matrix(numeric(), 0, 0), "\%s should be numeric matrix") 216 | SQR.NUM.MX <- quote(NUM.MX && SQR) 217 | vet(SQR.NUM.MX, mx) 218 | 219 | ## If instead we used `vet_token` the overall error message 220 | ## is not used; instead it falls back to the error message of 221 | ## the specific sub-token that fails: 222 | NUM.MX <- vet_token(matrix(numeric(), 0, 0), "\%s should be numeric matrix") 223 | SQR.NUM.MX.V2 <- 224 | vet_token(NUM.MX && SQR, "\%s should be a square numeric matrix") 225 | vet(SQR.NUM.MX.V2, mx) 226 | } 227 | \seealso{ 228 | \code{\link[=vet]{vet()}} 229 | } 230 | \keyword{datasets} 231 | -------------------------------------------------------------------------------- /tests/unitizer/_pre/lorem.R: -------------------------------------------------------------------------------- 1 | # we go through the trouble of saving stuff to RDS to quash valgrind errors 2 | # caused by heap alloc'ed strings that are strsplit with perl=TRUE 3 | 4 | lorem <- "Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat. Duis aute irure dolor in reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident, sunt in culpa qui officia deserunt mollit anim id est laborum." 5 | Encoding(lorem) <- "UTF-8" 6 | 7 | # lorem.phrases <- unlist(strsplit(lorem, "[.,]\\K ", perl=TRUE)) 8 | # saveRDS(lorem.phrases, 'unitizer/_pre/lorem.objs/lorem.RDS') 9 | lorem.phrases <- readRDS('unitizer/_pre/lorem.objs/lorem.RDS') 10 | 11 | # From the Stalin russian wiki page: 12 | # 13 | # 14 | # 15 | # Licensed under GNU Free Documentation License since it is from before 2009 16 | 17 | # lorem.ru <- "Родился 6 (18) декабря 1878 года (по записи в метрической книге Горийской Успенской соборной церкви[6]Это подлинная дата рождения Сталина. Позже она подтверждалась в уведомлении Санкт-Петербургского жандармского управления и самим Сталиным в ответе на анкету шведской газеты «Folkets Dagblad Politiken» в 1920 г.[7]) в Грузии в городе Гори, хотя начиная с 1929 года[источник?] днём его рождения официально считалось 9 (21) декабря 1879. Был третьим сыном в семье, первые двое умерли в младенчестве. Его родным языком был грузинский, русский язык Сталин выучил позже, но всегда говорил с заметным грузинским акцентом [8]. Согласно утверждениям дочери Светланы, Сталин, однако, пел по-русски практически без акцента." 18 | # Encoding(lorem.ru) <- "UTF-8" 19 | # lorem.ru.phrases <- unlist(strsplit(lorem.ru, "[.,]\\K ", perl=TRUE)) 20 | # saveRDS(lorem.ru.phrases, 'unitizer/_pre/lorem.objs/lorem.ru.RDS') 21 | lorem.ru.phrases <- readRDS('unitizer/_pre/lorem.objs/lorem.ru.RDS') 22 | 23 | # From the Stalin turkish wiki page: 24 | # 25 | # 26 | # 27 | # Licensed under GNU Free Documentation License since it is from before 2009 28 | 29 | # lorem.tr <- "Bu tartışmalı tarihsel dönemle ilgili olarak, Stalin'e düşman veya Stalin'den yana olan her iki tarafın da farklı tezleri vardır. Stalin karşıtlarının tezlerine göre, Hitlerle aralarındaki açıklanmayan gizli protokole bağlı olarak Finlandiya, Estonya, Letonya, Litvanya, Romanya ve Polonya'nin Naziler veya Sovyetler tarafından işgalinin yolu açılmıştır. Stalin'in doğru yaptığını savunanlara göre ise, 1937'deki Münih görüşmelerinde açıkça ortaya çıktığı gibi, İngiliz ve Fransız emperyalistleri ve dolaylı olarak da Amerikalılar, Nazileri kışkırtıyorlardı ve onların Sovyetler Birliği'ne saldırısının önünü açmaya çalışıyorlardı. Bu amaçla Avusturya'nın Almanya'ya katılmasına (Anschluss) ve Çekoslovakya'nın işgaline göz yummuş ve onaylamışlardı.Ne var ki, özellikle Çekoslovakya'nın işgalinden sonra Sovyetler Birliği'nin İngiltere ve Fransa ile ilişki kurma çabalarına rağmen bu iki ülke Nazi tehdidini birlikte ortadan kaldırma girişimini reddetti. Böylece Sovyetler Birliği, kendi sınırlarını güvence altına almak için bu protokolü imzaladı. Stalin'in amaçlarına göre, Polonya ve Baltık ülkelerinde oluşturulacak tampon bölgeler, Nazilerin Sovyetler Birliği'ne ulaşmasını engelleyecekti. Böylece 1939 yılında Nazi işgalinden sonra Sovyetler Polonya'nın kalan yarısını işgal edip Estonya, Litvanya ve Letonya'yı sınırlarına kattı. Finlandiya'ya saldırdı ve büyük kayıplar vermesine rağmen Mart 1940'da \"kış savaşı' olarak bilinen bu savaşı da kazandı. 1941'de Hitler'in Sovyetlere saldırması üzerine Stalin bu sefer müttefiklerin yanında yer aldı. II. Dünya Savaşı'nın en ağır bedeli ödeyen güç olarak (24 milyon ölü) müttefiklerin yanında Nazi Almanyası'na karşı kazandığı zafer uluslararası alanda gücünü artırdı." 30 | # Encoding(lorem.tr) <- "UTF-8" 31 | # lorem.tr.phrases <- unlist(strsplit(lorem.tr, "[.,]\\K ", perl=TRUE)) 32 | # saveRDS(lorem.tr.phrases, 'unitizer/_pre/lorem.objs/lorem.tr.RDS') 33 | lorem.tr.phrases <- readRDS('unitizer/_pre/lorem.objs/lorem.tr.RDS') 34 | 35 | # From the PRC chinese wiki page: 36 | # 37 | # 38 | # 39 | # Licensed under GNU Free Documentation License since it is from before 2009 40 | 41 | # lorem.cn <- "中華人民共和國是單一制的多民族國家。全國劃分為23個省（其中台灣省并沒有實際管辖）、5個自治區、4個直轄市和2個根據一國兩制設立的特別行政區，均直屬於中央人民政府。中华人民共和国跨越五个地理时区，但全国均使用北京时间（UTC+8，东八区）作为标准时间。中華人民共和國官方認定的民族現有56個，其中最大民族汉族佔總人口的91.59%，其餘55族統稱為少数民族，所有民族統稱為中華民族；除回族外，其他54個少数民族如壮族、维吾尔族、滿族、蒙古族、藏族、朝鲜族等也多使用自己的語言與文字。主要宗教有佛教、道教、基督教（多指新教）、天主教和伊斯兰教等，但過半人口無特定宗教信仰。中华人民共和国的通用语言是汉语普通話，當中在中國大陸通行的漢字為簡體字，而在港澳台地區通行的漢字則為繁體字。" 42 | # Encoding(lorem.cn) <- "UTF-8" 43 | # cn.split <- "[、。]\\K" 44 | # Encoding(cn.split) <- "UTF-8" 45 | # lorem.cn.phrases <- unlist(strsplit(lorem.cn, cn.split, perl=TRUE)) 46 | # 47 | # saveRDS(lorem.cn.phrases, 'unitizer/_pre/lorem.objs/lorem.cn.RDS') 48 | lorem.cn.phrases <- readRDS('unitizer/_pre/lorem.objs/lorem.cn.RDS') 49 | 50 | # Emoji from Unicode Site 51 | 52 | # emoji <- c( 53 | # "\U0001f600", "\U0001f619", "\U0001f61a", "\U0001f642", "\U0001f92f", 54 | # "\U0001f62c", "\U0001f630", "\U0001f631", "\U0001f633", "\U0001f92a", 55 | # "\U0001f635", "\U0001f637", "\U0001f912", "\U0001f915", "\U0001f922", 56 | # "\U0001f92e", "\U0001f927", "\U0001f607", "\U0001f920", "\U0001f921", 57 | # "\U0001f925", "\U0001f92b", "\U0001f92d", "\U0001f9d0", "\U0001f913", 58 | # "\U0001f608", "\U0001f4a9", "\U0001f63e", 59 | # "\U0001f469\U0001f3ff\U0000200d\U0001f3eb", 60 | # "\U0001f468\U0001f3fb\U0000200d\U00002696\U0000FE0F", "\U0001f46b", 61 | # "\U0001f469\U0000200D\U00002764\U0000200d\U0001f48b\U0000200d\U0001f468", 62 | # "\U0001f468\U0000200d\U0001f468\U0000200d\U0001f467", 63 | # "\U0001f468\U0000200d\U0001f468\U0000200d\U0001f467\U0000200d\U0001f466", 64 | # "\U0001f984", "\U0001f36b", "\U0001f1e6\U0001f1f7", "\U0001f1ed\U0001f1f0", 65 | # "\U0001f1ef\U0001f1f5", "\U0001f1f0\U0001f1f5", "\U0001f1fa\U0001f1f8", 66 | # "\U0001f3f4" 67 | # ) 68 | # Encoding(emoji) <- "UTF-8" 69 | # lorem.emo <- paste( 70 | # sample( 71 | # c(emoji, rep(", ", 3), rep(". ", 3), rep(" ", 40)), 450, replace=TRUE 72 | # ), 73 | # collapse="" 74 | # ) 75 | # lorem.emo.phrases <- unlist(strsplit(lorem.emo, "[,.]\\K", perl=TRUE)) 76 | 77 | -------------------------------------------------------------------------------- /man/vet.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/validate.R 3 | \name{vet} 4 | \alias{vet} 5 | \alias{tev} 6 | \title{Verify Objects Meet Structural Requirements} 7 | \usage{ 8 | vet( 9 | target, 10 | current, 11 | env = parent.frame(), 12 | format = "text", 13 | stop = FALSE, 14 | settings = NULL 15 | ) 16 | 17 | tev( 18 | current, 19 | target, 20 | env = parent.frame(), 21 | format = "text", 22 | stop = FALSE, 23 | settings = NULL 24 | ) 25 | } 26 | \arguments{ 27 | \item{target}{a template, a vetting expression, or a compound expression} 28 | 29 | \item{current}{an object to vet} 30 | 31 | \item{env}{the environment to match calls and evaluate vetting expressions 32 | in; will be ignored if an environment is also specified via 33 | \code{\link[=vetr_settings]{vetr_settings()}}. Defaults to calling frame.} 34 | 35 | \item{format}{character(1L), controls the format of the return value for 36 | \code{vet}, in case of failure. One of:\itemize{ 37 | \item "text": (default) character(1L) message for use elsewhere in code 38 | \item "full": character(1L) the full error message used in "stop" mode, 39 | but actually returned instead of thrown as an error 40 | \item "raw": character(N) least processed version of the error message 41 | with none of the formatting or surrounding verbiage 42 | }} 43 | 44 | \item{stop}{TRUE or FALSE whether to call \code{\link[=stop]{stop()}} on failure 45 | or not (default)} 46 | 47 | \item{settings}{a settings list as produced by \code{\link[=vetr_settings]{vetr_settings()}}, or NULL to 48 | use the default settings} 49 | } 50 | \value{ 51 | TRUE if validation succeeds, otherwise varies according to value 52 | chosen with parameter \code{stop} 53 | } 54 | \description{ 55 | Use vetting expressions to enforce structural requirements and/or evaluate 56 | test conditions for truth. \code{tev} is identical to \code{vet} except with reversed 57 | arguments for pipe based workflows. 58 | } 59 | \section{Vetting Expressions}{ 60 | 61 | 62 | Vetting expressions can be template tokens, standard tokens, or any 63 | expression built with them, \code{||}, \code{&&}, and parentheses. Template tokens 64 | are R objects that define the required structure, much like the \code{FUN.VALUE} 65 | argument to \code{\link[=vapply]{vapply()}}. Standard tokens are R expressions evaluated and 66 | checked for being \code{all(TRUE)}. 67 | 68 | Standard tokens are distinguished from templates by whether they reference 69 | the \code{.} symbol or not. If you have a need to reference an object bound to 70 | \code{.} in a vetting expression, you can escape the \code{.} with an extra dot (i.e. 71 | use \code{..}, and \code{...} for \code{..}, and so forth for symbols comprising only 72 | dots). If you use standard tokens in your packages you will need to include 73 | \code{utils::globalVariables(".")} as a top-level call to avoid the "no visible 74 | binding for global variable '.'"' R CMD check NOTE. Standard tokens that 75 | return a string like e.g. \code{all.equal(x, .)} will result in that string being 76 | incorporated into the error message. 77 | 78 | See \code{vignette('vetr', package='vetr')} and examples for details on how 79 | to craft vetting expressions. 80 | } 81 | 82 | \examples{ 83 | ## Template token vetting 84 | vet(numeric(2L), runif(2)) 85 | vet(numeric(2L), runif(3)) 86 | vet(numeric(2L), letters) 87 | try(vet(numeric(2L), letters, stop=TRUE)) 88 | 89 | ## Standard token vetting 90 | vet(. > 0, runif(2)) 91 | 92 | ## Expression made of standard and template tokens. 93 | vet(numeric(1) && . > 0, 1) 94 | try(vet(numeric(1) && . > 0, 1:2)) 95 | try(vet(numeric(1) && . > 0, -1)) 96 | 97 | ## `tev` just reverses target and current 98 | ## if(getRversion() >= "4.1.0") { # would be a parse error so commented 99 | ## runif(2) |> tev(numeric(2L)) 100 | ## runif(3) |> tev(numeric(2L)) 101 | ## } 102 | 103 | ## Zero length templates are wild cards 104 | vet(numeric(), runif(2)) 105 | vet(numeric(), runif(100)) 106 | vet(numeric(), letters) 107 | 108 | ## This extends to data.frames 109 | iris.tpl <- iris[0,] # zero row matches any # of rows 110 | iris.1 <- iris[1:10,] 111 | iris.2 <- iris[1:10, c(1,2,3,5,4)] # change col order 112 | vet(iris.tpl, iris.1) 113 | vet(iris.tpl, iris.2) 114 | 115 | ## Short (<100 length) integer-like numerics will 116 | ## pass for integer 117 | vet(integer(), c(1, 2, 3)) 118 | vet(integer(), c(1, 2, 3) + 0.1) 119 | 120 | ## Nested templates; note, in packages you should consider 121 | ## defining templates outside of `vet` or `vetr` so that 122 | ## they are computed on load rather that at runtime 123 | tpl <- list(numeric(1L), matrix(integer(), 3)) 124 | val.1 <- list(runif(1), rbind(1:10, 1:10, 1:10)) 125 | val.2 <- list(runif(1), cbind(1:10, 1:10, 1:10)) 126 | vet(tpl, val.1) 127 | vet(tpl, val.2) 128 | 129 | ## See `example(alike)` for more template examples 130 | 131 | ## Standard tokens allow you to check values 132 | vet(. > 0, runif(10)) 133 | vet(. > 0, -runif(10)) 134 | 135 | ## Zero length token results are considered TRUE, 136 | ## as is the case with `all(logical(0))` 137 | vet(. > 0, numeric()) 138 | 139 | ## `all_bw` is like `isTRUE(all(. >= x & . <= y))`, but 140 | ## ~10x faster for long vectors: 141 | vet(all_bw(., 0, 1), runif(1e6) + .1) 142 | 143 | ## You can combine templates and standard tokens with 144 | ## `&&` and/or `||` 145 | vet(numeric(2L) && . > 0, runif(2)) 146 | vet(numeric(2L) && . > 0, runif(10)) 147 | vet(numeric(2L) && . > 0, -runif(2)) 148 | 149 | ## Using pre-defined tokens (see `?vet_token`) 150 | vet(INT.1, 1) 151 | vet(INT.1, 1:2) 152 | vet(INT.1 && . \%in\% 0:1 || LGL.1, TRUE) 153 | vet(INT.1 && . \%in\% 0:1 || LGL.1, 1) 154 | vet(INT.1 && . \%in\% 0:1 || LGL.1, NA) 155 | 156 | ## Vetting expressions can be assembled from previously 157 | ## defined tokens 158 | scalar.num.pos <- quote(numeric(1L) && . > 0) 159 | foo.or.bar <- quote(character(1L) && . \%in\% c('foo', 'bar')) 160 | vet.exp <- quote(scalar.num.pos || foo.or.bar) 161 | 162 | vet(vet.exp, 42) 163 | vet(scalar.num.pos || foo.or.bar, 42) # equivalently 164 | vet(vet.exp, "foo") 165 | vet(vet.exp, "baz") 166 | 167 | ## Standard tokens that return strings see the string shown 168 | ## in the error message: 169 | vet(all.equal(., 2), 1) 170 | } 171 | \seealso{ 172 | \code{\link[=vetr]{vetr()}} for a version optimized to vet function arguments, 173 | \code{\link[=alike]{alike()}} for how templates are used, \code{\link[=vet_token]{vet_token()}} for how to specify 174 | custom error messages and also for predefined validation tokens for common 175 | use cases, \code{\link[=all_bw]{all_bw()}} for fast bounds checks. 176 | } 177 | -------------------------------------------------------------------------------- /src/trackinghash.c: -------------------------------------------------------------------------------- 1 | /* 2 | Copyright (C) 2023 Brodie Gaslam 3 | 4 | This file is part of "vetr - Trust, but Verify" 5 | 6 | This program is free software: you can redistribute it and/or modify 7 | it under the terms of the GNU General Public License as published by 8 | the Free Software Foundation, either version 2 of the License, or 9 | (at your option) any later version. 10 | 11 | This program is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | GNU General Public License for more details. 15 | 16 | Go to for a copy of the license. 17 | */ 18 | 19 | #include "pfhash.h" 20 | #include "cstringr.h" 21 | #include "trackinghash.h" 22 | 23 | /* 24 | * Implement a hash table with ancillary data that intended to allow checking 25 | * that a value exists in a hash table, and also quickly erase the last n values 26 | * that were written to the hash table 27 | * 28 | * size_init is the initial size of the content tracking character array, and 29 | * has no effect on the actual hash table. 30 | */ 31 | struct track_hash * VALC_create_track_hash(size_t size_init) { 32 | pfHashTable * hash = pfHashCreate(NULL); 33 | char ** contents = (char **) R_alloc(size_init, sizeof(char *)); 34 | struct track_hash * track_hash = 35 | (struct track_hash *) R_alloc(1, sizeof(struct track_hash)); 36 | 37 | track_hash->hash = hash; 38 | track_hash->contents = contents; 39 | track_hash->idx = 0; 40 | track_hash->idx_max = size_init; 41 | 42 | return track_hash; 43 | } 44 | 45 | /* 46 | * Restores hash to original state at index idx by removing all entries in 47 | * contents that were defined up to and including that point. 48 | * 49 | * reset_track_hash(x, 0) will remove all entries. 50 | * 51 | * Modifies the hash table by reference. 52 | */ 53 | 54 | void VALC_reset_track_hash( 55 | struct track_hash * track_hash, size_t idx 56 | ) { 57 | for(size_t i = track_hash->idx; i > idx; --i) { 58 | 59 | int del_res = pfHashDel(track_hash->hash, track_hash->contents[i - 1]); 60 | if(del_res) 61 | // nocov start 62 | error( 63 | "Internal Error: unable to delete key %s; contact maintainer.", 64 | track_hash->contents[i - 1] 65 | ); 66 | // nocov end 67 | } 68 | track_hash->idx = idx; 69 | } 70 | /* Add an item to the hash table 71 | * 72 | * If it already exists return 0, else if it doesn't exist 1, unless an 73 | * allocation is required in which case return the size of the allocation. 74 | * 75 | * Modifies track_hash by reference 76 | */ 77 | 78 | int VALC_add_to_track_hash( 79 | struct track_hash * track_hash, const char * key, const char * value, 80 | size_t max_nchar 81 | ) { 82 | int res = 1; 83 | int res_set = pfHashSet(track_hash->hash, key, value); 84 | 85 | if(res_set < 0) { 86 | // nocov start 87 | error( 88 | "Internal Error: failed setting value in hash table, contact maintainer." 89 | ); 90 | // nocov end 91 | } else if(res_set) { 92 | // Already existed, so no need to add 93 | res = 0; 94 | } else { 95 | // Need to add a value to the hash, first make sure that there is enough 96 | // room in the content tracking to hold it, and if not double the size of 97 | // the tracking list 98 | 99 | if(track_hash->idx == track_hash->idx_max) { 100 | 101 | // first, make sure no issues with size_t -> long 102 | 103 | size_t new_size = CSR_add_szt(track_hash->idx_max, track_hash->idx_max); 104 | size_t max_long = 1; 105 | max_long = (max_long << sizeof(long)) / 2; 106 | 107 | if(new_size > max_long) { 108 | // nocov start 109 | error( 110 | "Internal Error: attempted to allocate hash content vector bigger " 111 | "than int size." 112 | ); 113 | // nocov end 114 | } 115 | // re-allocate, note that we are re-allocating an array of pointers to 116 | // strings, but `S_realloc` is looking for a (char *) hence the coersion 117 | 118 | track_hash->contents = (char **) S_realloc( 119 | (char *) track_hash->contents, (long) new_size, 120 | (long) track_hash->idx_max, 121 | sizeof(char *) 122 | ); 123 | res = (int) new_size; 124 | track_hash->idx_max = new_size; 125 | } else if (track_hash->idx > track_hash->idx_max) { 126 | // nocov start 127 | error("Internal Error: hash index corrupted; contact maintainer."); 128 | // nocov end 129 | } 130 | // We incur some cost in duplicating string here which may not be strictly 131 | // necessary since it's most likely every string we use here should be 132 | // present for the duration of execution, but cost is probably reasonably 133 | // low. Should revisit if this turns out to be wrong. 134 | 135 | char * key_cpy = CSR_strmcpy(key, max_nchar); 136 | track_hash->contents[track_hash->idx] = key_cpy; 137 | track_hash->idx++; // shouldn't be overflowable 138 | } 139 | return res; 140 | } 141 | /* 142 | * External function for testing 143 | * 144 | * Any NA values in `keys` are taken to mean to take the `as.numeric` value 145 | * of the next element as the reset index. 146 | * 147 | 148 | hash tracking, uses a hash to detect potential collisions, 1 means a value 149 | is added, >1 means a value was added and tracking array had to be resized 150 | to that size, 0 means it existed already, NA is a reset instruction, value 151 | following a reset instruction is what the reset was to 152 | */ 153 | 154 | SEXP VALC_track_hash_test(SEXP keys, SEXP size) { 155 | if(TYPEOF(keys) != STRSXP) error("Arg keys must be character"); 156 | if(TYPEOF(size) != INTSXP) error("Arg size must be integer"); 157 | 158 | R_xlen_t i; 159 | R_xlen_t key_size = xlength(keys); 160 | SEXP res = PROTECT(allocVector(INTSXP, key_size)); 161 | 162 | struct track_hash * track_hash = VALC_create_track_hash(asInteger(size)); 163 | struct VALC_settings set = VALC_settings_init(); 164 | 165 | for(i = 0; i < key_size; ++i) { 166 | if(STRING_ELT(keys, i) == NA_STRING) { 167 | INTEGER(res)[i] = NA_INTEGER; 168 | if(++i < key_size) { 169 | int reset_int = atoi(CHAR(STRING_ELT(keys, i))); 170 | if(reset_int < 0) error("Internal Error: negative reset key."); 171 | VALC_reset_track_hash(track_hash, (size_t) reset_int); 172 | INTEGER(res)[i] = reset_int; 173 | } 174 | } else { 175 | int add_res = VALC_add_to_track_hash( 176 | track_hash, CHAR(STRING_ELT(keys, i)), "42", set.nchar_max 177 | ); 178 | INTEGER(res)[i] = add_res; 179 | } 180 | } 181 | UNPROTECT(1); 182 | return(res); 183 | } 184 | -------------------------------------------------------------------------------- /src/init.c: -------------------------------------------------------------------------------- 1 | /* 2 | Copyright (C) 2023 Brodie Gaslam 3 | 4 | This file is part of "vetr - Trust, but Verify" 5 | 6 | This program is free software: you can redistribute it and/or modify 7 | it under the terms of the GNU General Public License as published by 8 | the Free Software Foundation, either version 2 of the License, or 9 | (at your option) any later version. 10 | 11 | This program is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | GNU General Public License for more details. 15 | 16 | Go to for a copy of the license. 17 | */ 18 | 19 | #include "validate.h" 20 | #include "all-bw.h" 21 | #include 22 | 23 | static const 24 | R_CallMethodDef callMethods[] = { 25 | {"validate", (DL_FUNC) &VALC_validate, 8}, 26 | {"validate_args", (DL_FUNC) &VALC_validate_args, 5}, 27 | {"symb_sub", (DL_FUNC) &VALC_sub_symbol_ext, 2}, 28 | {"parse", (DL_FUNC) &VALC_parse_ext, 3}, 29 | {"remove_parens", (DL_FUNC) &VALC_remove_parens, 1}, 30 | {"eval_check", (DL_FUNC) &VALC_evaluate_ext, 6}, 31 | {"all", (DL_FUNC) &VALC_all_ext, 1}, 32 | {"track_hash", (DL_FUNC) &VALC_track_hash_test, 2}, 33 | {"default_hash_fun", (DL_FUNC) &VALC_default_hash_fun, 1}, 34 | {"all_bw", (DL_FUNC) &VALC_all_bw, 5}, 35 | {"check_assumptions", (DL_FUNC) &VALC_check_assumptions, 0}, 36 | 37 | /* 38 | {"test1", (DL_FUNC) &VALC_test1, 1}, 39 | {"test2", (DL_FUNC) &VALC_test2, 2}, 40 | {"test3", (DL_FUNC) &VALC_test3, 3}, 41 | */ 42 | {"alike_ext", (DL_FUNC) &ALIKEC_alike_ext, 5}, 43 | {"typeof", (DL_FUNC) &ALIKEC_typeof, 1}, 44 | {"mode", (DL_FUNC) &ALIKEC_mode, 1}, 45 | {"type_alike", (DL_FUNC) &ALIKEC_type_alike, 4}, 46 | {"syntactic_names", (DL_FUNC) &ALIKEC_syntactic_names_exp, 1}, 47 | {"compare_attributes", (DL_FUNC) &ALIKEC_compare_attributes, 3}, 48 | {"is_valid_name_ext", (DL_FUNC) &ALIKEC_is_valid_name_ext, 1}, 49 | {"is_dfish", (DL_FUNC) &ALIKEC_is_dfish_ext, 1}, 50 | {"compare_names", (DL_FUNC) &ALIKEC_compare_special_char_attrs, 2}, 51 | {"compare_dimnames", (DL_FUNC) &ALIKEC_compare_dimnames_ext, 2}, 52 | {"compare_class", (DL_FUNC) &ALIKEC_compare_class_ext, 2}, 53 | {"compare_dims", (DL_FUNC) &ALIKEC_compare_dim_ext, 5}, 54 | {"compare_ts", (DL_FUNC) &ALIKEC_compare_ts_ext, 2}, 55 | {"lang_alike", (DL_FUNC) &ALIKEC_lang_alike_ext, 3}, 56 | {"lang_alike_chr", (DL_FUNC) &ALIKEC_lang_alike_chr_ext, 3}, 57 | {"fun_alike", (DL_FUNC) &ALIKEC_fun_alike_ext, 2}, 58 | {"deparse", (DL_FUNC) &ALIKEC_deparse_ext, 2}, 59 | {"deparse_oneline", (DL_FUNC) &ALIKEC_deparse_oneline_ext, 3}, 60 | {"pad", (DL_FUNC) &ALIKEC_pad_ext, 3}, 61 | {"pad_or_quote", (DL_FUNC) &ALIKEC_pad_or_quote_ext, 3}, 62 | {"match_call", (DL_FUNC) &ALIKEC_match_call, 3}, 63 | {"abstract_ts", (DL_FUNC) &ALIKEC_abstract_ts, 2}, 64 | {"env_track", (DL_FUNC) &ALIKEC_env_track_test, 3}, 65 | {"msg_sort", (DL_FUNC) &ALIKEC_sort_msg_ext, 1}, 66 | {"msg_merge", (DL_FUNC) &ALIKEC_merge_msg_ext, 1}, 67 | {"msg_merge_2", (DL_FUNC) &ALIKEC_merge_msg_2_ext, 1}, 68 | {"hash_test", (DL_FUNC) &pfHashTest, 2}, 69 | {"hash_test2", (DL_FUNC) &pfHashTest2, 2}, 70 | {"find_fun", (DL_FUNC) &ALIKEC_findFun_ext, 2}, 71 | {"list_as_sorted_vec", (DL_FUNC) &ALIKEC_list_as_sorted_vec, 1}, 72 | 73 | {"len_chr_len_ext", (DL_FUNC) &CSR_len_chr_len_ext, 1}, 74 | {"len_as_chr_ext", (DL_FUNC) &CSR_len_as_chr_ext, 1}, 75 | {"num_as_chr", (DL_FUNC) &CSR_num_as_chr_ext, 2}, 76 | {"strmlen_ext", (DL_FUNC) &CSR_strmlen_ext, 2}, 77 | {"strmcpy_ext", (DL_FUNC) &CSR_strmcpy_ext, 2}, 78 | {"collapse_ext", (DL_FUNC) &CSR_collapse_ext, 3}, 79 | {"bullet_ext", (DL_FUNC) &CSR_bullet_ext, 4}, 80 | {"strsub", (DL_FUNC) &CSR_strsub, 3}, 81 | {"nchar_u", (DL_FUNC) &CSR_nchar_u, 1}, 82 | {"char_offsets", (DL_FUNC) &CSR_char_offsets, 1}, 83 | {"smprintf2_ext", (DL_FUNC) &CSR_smprintf2_ext, 4}, 84 | {"smprintf6_ext", (DL_FUNC) &CSR_smprintf6_ext, 8}, 85 | {"ucfirst_ext", (DL_FUNC) &CSR_ucfirst_ext, 2}, 86 | {"lcfirst_ext", (DL_FUNC) &CSR_lcfirst_ext, 2}, 87 | {"test_strmcpy", (DL_FUNC) &CSR_test_strmcpy, 0}, 88 | {"test_strappend", (DL_FUNC) &CSR_test_strappend, 0}, 89 | {"test_add_szt", (DL_FUNC) &CSR_test_add_szt, 0}, 90 | {"test_smprintfx", (DL_FUNC) &CSR_test_smprintfx, 0}, 91 | {"test_strappend2", (DL_FUNC) &CSR_test_strappend2, 0}, 92 | 93 | {NULL, NULL, 0} 94 | }; 95 | // Define global symbols (declarations in .h files) 96 | 97 | SEXP VALC_SYM_quote; 98 | SEXP VALC_SYM_deparse; 99 | SEXP VALC_SYM_one_dot; 100 | SEXP VALC_SYM_paren; 101 | SEXP VALC_SYM_current; 102 | SEXP VALC_SYM_errmsg; 103 | SEXP VALC_TRUE; 104 | SEXP ALIKEC_SYM_package; 105 | SEXP ALIKEC_SYM_inherits; 106 | SEXP ALIKEC_SYM_paren_open; 107 | SEXP ALIKEC_SYM_tilde; 108 | SEXP ALIKEC_SYM_args; 109 | SEXP ALIKEC_SYM_function; 110 | SEXP ALIKEC_SYM_deparse; 111 | SEXP ALIKEC_SYM_nlines; 112 | SEXP ALIKEC_SYM_widthcutoff; 113 | SEXP ALIKEC_SYM_getOption; 114 | SEXP ALIKEC_SYM_matchcall; 115 | SEXP ALIKEC_SYM_current; 116 | SEXP ALIKEC_SYM_attributes; 117 | SEXP ALIKEC_SYM_attr; 118 | SEXP ALIKEC_SYM_colnames; 119 | SEXP ALIKEC_SYM_length; 120 | SEXP ALIKEC_SYM_syntacticnames; 121 | 122 | void R_init_vetr(DllInfo *info) 123 | { 124 | /* Register the .C and .Call routines. 125 | No .Fortran() or .External() routines, 126 | so pass those arrays as NULL. 127 | */ 128 | R_registerRoutines(info, NULL, callMethods, NULL, NULL); 129 | R_useDynamicSymbols(info, FALSE); 130 | R_forceSymbols(info, FALSE); 131 | VALC_SYM_quote = install("quote"); 132 | VALC_SYM_deparse = install("deparse"); 133 | VALC_SYM_one_dot = install("."); 134 | VALC_SYM_paren = install("("); 135 | VALC_SYM_current = install("current"); 136 | VALC_SYM_errmsg = install("err.msg"); 137 | VALC_TRUE = ScalarLogical(1); 138 | 139 | // Some overlap with previous since these used to be separate packages... 140 | 141 | ALIKEC_SYM_package = install("package"); 142 | ALIKEC_SYM_inherits = install("inherits"); 143 | ALIKEC_SYM_paren_open = install("("); 144 | ALIKEC_SYM_tilde = install("~"); 145 | ALIKEC_SYM_args = install("args"); 146 | ALIKEC_SYM_function = install("function"); 147 | ALIKEC_SYM_deparse = install("deparse"); 148 | ALIKEC_SYM_nlines = install("nlines"); 149 | ALIKEC_SYM_widthcutoff = install("width.cutoff"); 150 | ALIKEC_SYM_getOption = install("getOption"); 151 | ALIKEC_SYM_matchcall = install("match.call"); 152 | ALIKEC_SYM_current = install("current"); 153 | ALIKEC_SYM_attributes = install("attributes"); 154 | ALIKEC_SYM_attr = install("attr"); 155 | ALIKEC_SYM_colnames = install("colnames"); 156 | ALIKEC_SYM_length = install("length"); 157 | ALIKEC_SYM_syntacticnames = install("syntacticnames"); 158 | } 159 | 160 | --------------------------------------------------------------------------------